diff --git a/src/LIB/RTTOV/README b/src/LIB/RTTOV/README
deleted file mode 100644
index 209bccb9211642fbe3a238e83d77df9f804694fb..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/README
+++ /dev/null
@@ -1 +0,0 @@
-rttov87
diff --git a/src/LIB/RTTOV/src/Makefile b/src/LIB/RTTOV/src/Makefile
deleted file mode 100644
index 1081397d35b907ef25dd25644b1939e8079ca06f..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/Makefile
+++ /dev/null
@@ -1,141 +0,0 @@
-#
-#
-# Script to compile all RTTOV-8.7 library and tests programs
-# You can either specifically give options in command line:
-# make FC=frt FFLAGS='-Ad -Am -O3 -M .'
-# or
-# remove the comment '#' from the definitions you want to use
-# on your machine below.
-# If this makefile is executed with options, like example above
-# they will be passed along to the other make files
-# You can run make like "make basic" to just compile
-# the part of the code for clear air RTTOV or
-# "make all" to compile all the code, options are:
-#
-# basic (default): classical RTTOV code
-# cld: for cloud cases with input cloud profile
-# scat: for scattering case
-# all: to make the code for all cases
-#
-# P. Brunel 12 March 2004
-#
-# Select options below by removing #
-#
-
-# Compiler
-#SUN and HP compilers
-#FC = f90
-#FC77 = f90
-
-#Fujitsu compiler
-#FC = frt -X9
-#FC77=frt -Fixed
-
-#IBM compiler
-#FC = f90
-#FC77 = f77
-
-#Intel compiler
-#FC = ifc
-#FC77 = ifc
-
-#Met Office HP compiler
-#FC = /opt/fortran90/bin/f90
-#FC77 = f77
-
-#NEC compiler (additionally uncomment section in Makefile_lib)
-#FC = sxf90
-#FC77 = sxf90
-
-#Compiler options
-#HP compiler HP
-#FFLAGS = -O2 +check=all -I. +cpp=yes
-
-#VPP compiler Fujitsu
-#FFLAGS= -Am -Ad -O3 -M .
-
-#SUN compiler Fujitsu
-#FFLAGS= -Am -O2 -M .
-#FFLAGS= -Am -M . -H aesu -O2
-#FFLAGS=-Am -O1 -M .
-
-#SUN compiler SUN
-#FFLAGS= -O3 -M.
-
-#NAG compiler
-FC= f95
-FC77= f95 -dusty
-#FFLAGS= -gline -C=all -nan
-FFLAGS=-gline -nan -kind=byte
-
-#SGI compiler
-#FFLAGS= -trapuv -g
-
-#IBM compiler
-#FFLAGS= -g -qmaxmem=8192 -qstrict \
-# -qdpc=e -qsuffix=cpp=F90 -qfree=F90 -qspillsize=860
-
-# Intel compiler
-#FFLAGS= -g -cm -w95
-
-# Portland compiler
-# FC= pgf90
-# FC77= pgf77
-
-#NEC compiler (additionally uncomment section in Makefile_lib)
-#FFLAGS= -ew -sx6 -Chopt -Wf,-pvctl loopcnt=200000 -Wf,-pvctl nomsg -Wf,-O nomove,-O nomsg
-
-# Main targets
-all: lib_basic lib_cld lib_scat
-basic: lib_basic main_basic
-cld: lib_basic lib_cld main_cld
-scat: lib_basic lib_scat main_scat
-#all: lib_basic lib_cld lib_scat main_basic main_cld main_scat
-
-# Make main programs
-main_basic:
-# @ ${MAKE} -f Makefile_main "FC=$(FC)" "FFLAGS=$(FFLAGS)" "PROG=rttov_ascii2bin_coef"
-# mv rttov_ascii2bin_coef.out ../scripts
-# @ ${MAKE} -f Makefile_main "FC=$(FC)" "FFLAGS=$(FFLAGS)" "PROG=test_2_coef"
-# mv test_2_coef.out ../scripts
-# @ ${MAKE} -f Makefile_main "FC=$(FC)" "FFLAGS=$(FFLAGS)" "PROG=test_coef"
-# mv test_coef.out ../scripts
- @ ${MAKE} -f Makefile_main "FC=$(FC)" "FFLAGS=$(FFLAGS)" "PROG=example_fwd"
- #mv example_fwd.out ../scripts
- @ ${MAKE} -f Makefile_main "FC=$(FC)" "FFLAGS=$(FFLAGS)" "PROG=tstrad"
- #mv tstrad.out ../scripts
-# @ ${MAKE} -f Makefile_main "FC=$(FC)" "FFLAGS=$(FFLAGS)" "PROG=tstrad_sx6"
-# mv tstrad_sx6.out scripts
- @ ${MAKE} -f Makefile_main "FC=$(FC)" "FFLAGS=$(FFLAGS)" "PROG=tstrad_rttov7"
- #mv tstrad_rttov7.out ../scripts
-# @ ${MAKE} -f Makefile_main "FC=$(FC)" "FFLAGS=$(FFLAGS)" "PROG=test_errorhandling"
-# mv test_errorhandling.out ../scripts/test_errorhandling.out
-# @ ${MAKE} -f Makefile_main "FC=$(FC)" "FFLAGS=$(FFLAGS)" "PROG=tstrad_indep"
-# mv tstrad_indep.out ../scripts
-
-main_cld:
- @ ${MAKE} -f Makefile_main "FC=$(FC)" "FFLAGS=$(FFLAGS)" "PROG=rttovcld_test"
- #mv rttovcld_test.out ../scripts
-
-main_scat:
- @ ${MAKE} -f Makefile_main "FC=$(FC)" "FFLAGS=$(FFLAGS)" "PROG=rttovscatt_test"
- #mv rttovscatt_test.out ../scripts
-
-
-
-# Make of RTTOV Library
-lib_basic:
- @ ${MAKE} -f Makefile_lib lib_basic "FC=${FC}" "FC77=$(FC77)" "FFLAGS=$(FFLAGS)"
-
-lib_cld:
- @ ${MAKE} -f Makefile_lib lib_cld "FC=${FC}" "FC77=$(FC77)" "FFLAGS=$(FFLAGS)"
-
-lib_scat:
- @ ${MAKE} -f Makefile_lib lib_scat "FC=${FC}" "FC77=$(FC77)" "FFLAGS=$(FFLAGS)"
-
-
-# Clean all
-clean:
- @ ${MAKE} -f Makefile_lib clean
- @ ${MAKE} -f Makefile_main clean
-#
diff --git a/src/LIB/RTTOV/src/Makefile_lib b/src/LIB/RTTOV/src/Makefile_lib
deleted file mode 100644
index 39de3e89239ce1773e9d54b523072ff62b1283b3..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/Makefile_lib
+++ /dev/null
@@ -1,336 +0,0 @@
-
-#
-# Makefile for RTTOV-8.7 library
-#
-# Usage: make -f Makefile_lib lib_basic FC=F90 FFLAGS=' -Am -O3 -M .'
-#
-# P. Brunel 26 October 2001
-#
-# split subroutines in 3 kinds (basic, cld, scat)
-# P. Brunel 12 March 2004
-
-LIBRARY=librttov8.8.a
-
-#Includes or modules are in the current directory
-INC=.
-
-LIST_MOD_F= \
-parkind1.F90 \
-rttov_const.F90 \
-rttov_types.F90 \
-rttov_global.F90 \
-mod_cparam.F90 \
-mod_tstrad.F90 \
-mod_rttov_scatt_test.F90
-
-LIST_MOD=$(LIST_MOD_F:.F90=.o)
-
-LIST_SUB_F= \
-rttov_cmpuc.F90 \
-rttov_deletecomment.F90 \
-rttov_dealloc_coef.F90 \
-rttov_errorreport.F90 \
-rttov_errorhandling.F90 \
-rttov_q2v.F90 \
-rttov_v2q.F90 \
-rttov_coeffname.F90 \
-rttov_findnextsection.F90 \
-rttov_intext_prof.F90 \
-rttov_opencoeff.F90 \
-rttov_readcoeffs.F90 \
-rttov_readcoeffs_ascii.F90 \
-rttov_readcoeffs_binary.F90 \
-rttov_setpressure.F90 \
-rttov_setup.F90 \
-rttov_setupchan.F90 \
-rttov_setupindex.F90 \
-rttov_scatt_setupindex.F90 \
-rttov_skipcommentline.F90 \
-rttov_writecoef.F90 \
-rttov_initcoeffs.F90 \
-rttov_distribcoeffs.F90 \
-rttvi.F90 \
-rttov.F90 \
-\
-rttov_direct.F90 \
-rttov_calcbt.F90 \
-rttov_calcpolarisation.F90 \
-rttov_calcemis_ir.F90 \
-rttov_calcemis_mw.F90 \
-rttov_calcrad.F90 \
-rttov_checkinput.F90 \
-rttov_integrate.F90 \
-rttov_profaux.F90 \
-rttov_setgeometry.F90 \
-rttov_setpredictors.F90 \
-rttov_transmit.F90 \
-\
-rttov_tl.F90 \
-rttov_calcbt_tl.F90 \
-rttov_calcpolarisation_tl.F90 \
-rttov_calcemis_mw_tl.F90 \
-rttov_calcrad_tl.F90 \
-rttov_integrate_tl.F90 \
-rttov_profaux_tl.F90 \
-rttov_setpredictors_tl.F90 \
-rttov_transmit_tl.F90 \
-tstrad_tl.F90 \
-\
-rttov_ad.F90 \
-rttov_calcbt_ad.F90 \
-rttov_calcpolarisation_ad.F90 \
-rttov_calcrad_ad.F90 \
-rttov_integrate_ad.F90 \
-rttov_profaux_ad.F90 \
-rttov_setpredictors_ad.F90 \
-rttov_calcemis_mw_ad.F90 \
-rttov_transmit_ad.F90 \
-tstrad_ad.F90 \
-\
-rttov_k.F90 \
-rttov_calcrad_k.F90 \
-rttov_profout_k.F90 \
-rttov_cld_profout_k.F90 \
-rttov_profaux_k.F90 \
-rttov_integrate_k.F90 \
-rttov_calcemis_mw_k.F90 \
-rttov_setpredictors_k.F90 \
-rttov_transmit_k.F90 \
-tstrad_k.F90 \
-\
-rttov_setpredictors_8.F90 \
-rttov_setpredictors_8_tl.F90 \
-rttov_setpredictors_8_ad.F90 \
-rttov_setpredictors_8_k.F90 \
-\
-rttov_intex.F90 \
-rttov_intex_tl.F90 \
-rttov_intex_ad.F90
-
-LIST_SUB_CLD_F= \
-rttov_cld.F90 \
-rttov_aitosu.F90 \
-rttov_emiscld.F90 \
-rttov_intex.F90 \
-rttovcld.F90 \
-\
-rttov_cld_tl.F90 \
-rttov_aitosu_tl.F90 \
-rttov_emiscld_tl.F90 \
-\
-rttov_cld_ad.F90 \
-rttov_aitosu_ad.F90 \
-rttov_emiscld_ad.F90 \
-\
-rttov_cld_k.F90
-
-LIST_SUB_SCAT_F= \
-rttov_boundaryconditions.F90 \
-rttov_eddington.F90 \
-rttov_iniedd.F90 \
-rttov_iniscatt.F90 \
-rttov_integratesource.F90 \
-rttov_interpcubic.F90 \
-rttov_polcoe.F90 \
-rttov_mieproc.F90 \
-rttov_readscattcoeffs.F90 \
-rttov_scatt.F90 \
-rttov_scatt_test.F90 \
-lapack.f \
-\
-rttov_boundaryconditions_tl.F90 \
-rttov_eddington_tl.F90 \
-rttov_iniedd_tl.F90 \
-rttov_iniscatt_tl.F90 \
-rttov_integratesource_tl.F90 \
-rttov_interpcubic_tl.F90 \
-rttov_mieproc_tl.F90 \
-rttov_scatt_tl.F90 \
-\
-rttov_boundaryconditions_ad.F90 \
-rttov_eddington_ad.F90 \
-rttov_iniedd_ad.F90 \
-rttov_iniscatt_ad.F90 \
-rttov_integratesource_ad.F90 \
-rttov_interpcubic_ad.F90 \
-rttov_mieproc_ad.F90 \
-rttov_scatt_ad.F90 \
-\
-rttov_boundaryconditions_k.F90 \
-rttov_eddington_k.F90 \
-rttov_iniedd_k.F90 \
-rttov_iniscatt_k.F90 \
-rttov_integratesource_k.F90 \
-rttov_mieproc_k.F90 \
-rttov_scatt_k.F90
-
-
-LIST_SUB=$(LIST_SUB_F:.F90=.o)
-LIST_SUB_CLD=$(LIST_SUB_CLD_F:.F90=.o)
-LIST_SUB_SCAT=$(LIST_SUB_SCAT_F:.F90=.o) $(LIST_SUB_SCAT_F:.f=.o)
-
-.SUFFIXES: .F90 .f
-
-.F90.o :
- $(FC) -c $(FFLAGS) $*.F90 -o $*.o
- ar rv $(LIBRARY) $*.o
-.f.o :
- $(FC77) -c $*.f -o $*.o
- ar rv $(LIBRARY) $*.o
-
-#.F90.mod :
-# $(FC) -c $(FFLAGS) $*.F90 -o $*.o
-# ar rv $(LIBRARY) $*.o
-
-## ----- Start of NEC Section -----
-##NEC compiler
-## These over-ride above settings.
-## Note the addition of FFLAGS to the F77 section
-#
-#.F90.o :
-# $(FC) -c $(FFLAGS) $*.F90 -o $*.o
-# sxar rv $(LIBRARY) $*.o
-#.f.o :
-# $(FC77) -c $(FFLAGS) $*.f -o $*.o
-# sxar rv $(LIBRARY) $*.o
-#
-## ------ End of NEC Section ------
-
-# default target
-all: $(LIST_MOD) $(LIST_SUB) $(LIST_SUB_CLD) $(LIST_SUB_SCAT)
- @echo "library $(LIBRARY) is build"
-
-lib_basic: $(LIST_MOD) $(LIST_SUB)
- @echo "library $(LIBRARY) basic routines is build"
-
-lib_cld: $(LIST_MOD) $(LIST_SUB) $(LIST_SUB_CLD)
- @echo "library $(LIBRARY) with cloud routines is build"
-
-lib_scat: $(LIST_MOD) $(LIST_SUB) $(LIST_SUB_SCAT)
- @echo "library $(LIBRARY) with scattering routines is build"
-
-# Clean library subroutines and modules
-clean:
- \rm -f $(LIBRARY) *.o *.mod *.MOD
-
-
-
-# Dependencies with modules and interfaces
-
-mod_cparam.o: mod_cparam.F90 rttov_types.o parkind1.o
-mod_tstrad.o: mod_tstrad.F90 parkind1.o
-parkind1.o: parkind1.F90
-rttov_const.o: rttov_const.F90 parkind1.o
-rttov_global.o: rttov_global.F90 rttov_const.o parkind1.o
-rttov_types.o: rttov_types.F90 rttov_const.o parkind1.o
-
-rttov.o: rttov.F90 rttov_const.o rttov_types.o mod_cparam.o parkind1.o rttov_errorreport.o rttov_direct.o
-rttov_ad.o: rttov_ad.F90 rttov_const.o rttov_types.o parkind1.o rttov_checkinput.o rttov_errorreport.o rttov_profaux.o rttov_setgeometry.o rttov_setpredictors.o rttov_setpredictors_8.o rttov_transmit.o rttov_calcemis_ir.o rttov_calcemis_mw.o rttov_integrate.o rttov_integrate_ad.o rttov_calcemis_mw_ad.o rttov_transmit_ad.o rttov_setpredictors_ad.o rttov_setpredictors_8_ad.o rttov_profaux_ad.o
-rttov_aitosu.o: rttov_aitosu.F90 rttov_types.o parkind1.o
-rttov_aitosu_ad.o: rttov_aitosu_ad.F90 rttov_types.o parkind1.o
-rttov_aitosu_tl.o: rttov_aitosu_tl.F90 rttov_types.o parkind1.o
-rttov_boundaryconditions.o: rttov_boundaryconditions.F90 rttov_types.o parkind1.o
-rttov_boundaryconditions_ad.o: rttov_boundaryconditions_ad.F90 rttov_types.o parkind1.o
-rttov_boundaryconditions_tl.o: rttov_boundaryconditions_tl.F90 rttov_types.o parkind1.o
-rttov_calcbt.o: rttov_calcbt.F90 rttov_types.o parkind1.o
-rttov_calcbt_ad.o: rttov_calcbt_ad.F90 rttov_types.o parkind1.o
-rttov_calcbt_tl.o: rttov_calcbt_tl.F90 rttov_types.o parkind1.o
-rttov_calcemis_ir.o: rttov_calcemis_ir.F90 rttov_const.o rttov_types.o parkind1.o
-rttov_calcemis_mw.o: rttov_calcemis_mw.F90 rttov_const.o rttov_types.o parkind1.o rttov_errorreport.o
-rttov_calcemis_mw_ad.o: rttov_calcemis_mw_ad.F90 rttov_const.o rttov_types.o parkind1.o
-rttov_calcemis_mw_k.o: rttov_calcemis_mw_k.F90 rttov_const.o rttov_types.o parkind1.o
-rttov_calcemis_mw_tl.o: rttov_calcemis_mw_tl.F90 rttov_const.o rttov_types.o parkind1.o
-rttov_calcpolarisation.o: rttov_calcpolarisation.F90 rttov_const.o rttov_types.o parkind1.o
-rttov_calcpolarisation_ad.o: rttov_calcpolarisation_ad.F90 rttov_const.o rttov_types.o parkind1.o
-rttov_calcpolarisation_tl.o: rttov_calcpolarisation_tl.F90 rttov_const.o rttov_types.o parkind1.o
-rttov_calcrad.o: rttov_calcrad.F90 rttov_const.o rttov_types.o parkind1.o
-rttov_calcrad_ad.o: rttov_calcrad_ad.F90 rttov_types.o parkind1.o
-rttov_calcrad_k.o: rttov_calcrad_k.F90 rttov_types.o parkind1.o
-rttov_calcrad_tl.o: rttov_calcrad_tl.F90 rttov_types.o parkind1.o
-rttov_checkinput.o: rttov_checkinput.F90 rttov_const.o rttov_types.o parkind1.o rttov_errorreport.o
-rttov_cld.o: rttov_cld.F90 rttov_const.o rttov_types.o parkind1.o rttov_errorreport.o rttov_direct.o rttov_intex.o rttov_emiscld.o rttov_aitosu.o rttov_calcbt.o rttov_setgeometry.o rttov_calcpolarisation.o
-rttov_cld_ad.o: rttov_cld_ad.F90 rttov_const.o rttov_types.o parkind1.o rttov_errorreport.o rttov_direct.o rttov_intex.o rttov_emiscld.o rttov_aitosu.o rttov_calcbt.o rttov_setgeometry.o rttov_calcpolarisation.o rttov_calcpolarisation_ad.o rttov_calcbt_ad.o rttov_aitosu_ad.o rttov_emiscld_ad.o rttov_intex_ad.o rttov_ad.o
-rttov_cld_k.o: rttov_cld_k.F90 rttov_const.o rttov_types.o parkind1.o rttov_cld_ad.o rttov_errorreport.o
-rttov_cld_tl.o: rttov_cld_tl.F90 rttov_const.o rttov_types.o parkind1.o rttov_errorreport.o rttov_tl.o rttov_intex_tl.o rttov_emiscld_tl.o rttov_aitosu_tl.o rttov_calcbt.o rttov_calcbt_tl.o rttov_setgeometry.o rttov_calcpolarisation.o rttov_calcpolarisation_tl.o
-rttov_cmpuc.o: rttov_cmpuc.F90 parkind1.o
-rttov_coeffname.o: rttov_coeffname.F90 rttov_const.o parkind1.o rttov_errorreport.o
-rttov_dealloc_coef.o: rttov_dealloc_coef.F90 rttov_const.o rttov_types.o parkind1.o rttov_errorreport.o
-rttov_deletecomment.o: rttov_deletecomment.F90 parkind1.o
-rttov_direct.o: rttov_direct.F90 rttov_const.o rttov_types.o parkind1.o rttov_checkinput.o rttov_errorreport.o rttov_profaux.o rttov_setgeometry.o rttov_setpredictors.o rttov_setpredictors_8.o rttov_transmit.o rttov_calcemis_ir.o rttov_calcemis_mw.o rttov_integrate.o
-rttov_distribcoeffs.o: rttov_distribcoeffs.F90 rttov_const.o rttov_types.o parkind1.o
-rttov_eddington.o: rttov_eddington.F90 rttov_types.o rttov_const.o parkind1.o rttov_boundaryconditions.o rttov_integratesource.o
-rttov_eddington_ad.o: rttov_eddington_ad.F90 rttov_types.o rttov_const.o parkind1.o rttov_boundaryconditions.o rttov_integratesource.o rttov_integratesource_ad.o rttov_boundaryconditions_ad.o
-rttov_eddington_tl.o: rttov_eddington_tl.F90 rttov_types.o rttov_const.o parkind1.o rttov_boundaryconditions_tl.o rttov_integratesource_tl.o
-rttov_emiscld.o: rttov_emiscld.F90 rttov_const.o rttov_types.o parkind1.o
-rttov_emiscld_ad.o: rttov_emiscld_ad.F90 rttov_const.o rttov_types.o parkind1.o
-rttov_emiscld_tl.o: rttov_emiscld_tl.F90 rttov_const.o rttov_types.o parkind1.o
-rttov_errorhandling.o: rttov_errorhandling.F90 rttov_const.o rttov_global.o parkind1.o
-rttov_errorreport.o: rttov_errorreport.F90 rttov_const.o rttov_global.o parkind1.o rttov_errorhandling.o
-rttov_findnextsection.o: rttov_findnextsection.F90 rttov_const.o parkind1.o
-rttov_iniedd.o: rttov_iniedd.F90 rttov_types.o parkind1.o
-rttov_iniedd_ad.o: rttov_iniedd_ad.F90 rttov_types.o parkind1.o
-rttov_iniedd_tl.o: rttov_iniedd_tl.F90 rttov_types.o parkind1.o
-rttov_iniscatt.o: rttov_iniscatt.F90 rttov_types.o rttov_const.o parkind1.o rttov_errorreport.o rttov_setgeometry.o rttov_intex.o rttov_mieproc.o rttov_iniedd.o rttov_calcemis_mw.o
-rttov_iniscatt_ad.o: rttov_iniscatt_ad.F90 rttov_types.o rttov_const.o parkind1.o rttov_errorreport.o rttov_setgeometry.o rttov_intex.o rttov_mieproc.o rttov_iniedd.o rttov_calcemis_mw.o rttov_calcemis_mw_ad.o rttov_iniedd_ad.o rttov_mieproc_ad.o rttov_intex_ad.o
-rttov_iniscatt_tl.o: rttov_iniscatt_tl.F90 rttov_types.o rttov_const.o parkind1.o rttov_errorreport.o rttov_setgeometry.o rttov_intex_tl.o rttov_mieproc_tl.o rttov_iniedd_tl.o rttov_calcemis_mw.o rttov_calcemis_mw_tl.o
-rttov_initcoeffs.o: rttov_initcoeffs.F90 rttov_const.o rttov_types.o parkind1.o rttov_distribcoeffs.o rttov_errorreport.o rttov_q2v.o
-rttov_integrate.o: rttov_integrate.F90 rttov_const.o rttov_types.o parkind1.o rttov_calcrad.o rttov_calcbt.o rttov_calcpolarisation.o
-rttov_integrate_ad.o: rttov_integrate_ad.F90 rttov_const.o rttov_types.o parkind1.o rttov_calcpolarisation_ad.o rttov_calcbt_ad.o rttov_calcrad_ad.o
-rttov_integrate_k.o: rttov_integrate_k.F90 rttov_const.o rttov_types.o parkind1.o rttov_calcpolarisation_ad.o rttov_calcbt_ad.o rttov_calcrad_k.o
-rttov_integrate_tl.o: rttov_integrate_tl.F90 rttov_const.o rttov_types.o parkind1.o rttov_calcrad_tl.o rttov_calcbt_tl.o rttov_calcpolarisation_tl.o
-rttov_integratesource.o: rttov_integratesource.F90 rttov_types.o parkind1.o
-rttov_integratesource_ad.o: rttov_integratesource_ad.F90 rttov_types.o parkind1.o
-rttov_integratesource_tl.o: rttov_integratesource_tl.F90 rttov_types.o parkind1.o
-rttov_interpcubic.o: rttov_interpcubic.F90 rttov_types.o parkind1.o rttov_polcoe.o
-rttov_interpcubic_ad.o: rttov_interpcubic_ad.F90 rttov_types.o parkind1.o rttov_polcoe.o
-rttov_interpcubic_tl.o: rttov_interpcubic_tl.F90 rttov_types.o parkind1.o rttov_polcoe.o
-rttov_intex.o: rttov_intex.F90 parkind1.o
-rttov_intex_ad.o: rttov_intex_ad.F90 parkind1.o
-rttov_intex_tl.o: rttov_intex_tl.F90 parkind1.o
-rttov_intext_prof.o: rttov_intext_prof.F90 rttov_types.o parkind1.o
-rttov_k.o: rttov_k.F90 rttov_const.o rttov_types.o parkind1.o rttov_checkinput.o rttov_errorreport.o rttov_profaux.o rttov_setgeometry.o rttov_setpredictors.o rttov_setpredictors_8.o rttov_transmit.o rttov_calcemis_ir.o rttov_calcemis_mw.o rttov_integrate.o rttov_integrate_k.o rttov_calcemis_mw_k.o rttov_transmit_k.o rttov_setpredictors_k.o rttov_setpredictors_8_k.o rttov_profaux_k.o rttov_profout_k.o
-rttov_mieproc.o: rttov_mieproc.F90 parkind1.o rttov_types.o
-rttov_mieproc_ad.o: rttov_mieproc_ad.F90 parkind1.o rttov_types.o
-rttov_mieproc_tl.o: rttov_mieproc_tl.F90 rttov_types.o parkind1.o
-rttov_opencoeff.o: rttov_opencoeff.F90 rttov_const.o parkind1.o rttov_errorreport.o
-rttov_polcoe.o: rttov_polcoe.F90 parkind1.o
-rttov_profaux.o: rttov_profaux.F90 rttov_const.o rttov_types.o parkind1.o
-rttov_profaux_ad.o: rttov_profaux_ad.F90 rttov_const.o rttov_types.o parkind1.o
-rttov_profaux_k.o: rttov_profaux_k.F90 rttov_const.o rttov_types.o parkind1.o
-rttov_profaux_tl.o: rttov_profaux_tl.F90 rttov_const.o rttov_types.o parkind1.o
-rttov_profout_k.o: rttov_profout_k.F90 rttov_const.o rttov_types.o parkind1.o
-rttov_q2v.o: rttov_q2v.F90 rttov_const.o parkind1.o
-rttov_readcoeffs.o: rttov_readcoeffs.F90 rttov_const.o rttov_types.o parkind1.o rttov_errorreport.o rttov_coeffname.o rttov_opencoeff.o rttov_readcoeffs_binary.o rttov_readcoeffs_ascii.o
-rttov_readcoeffs_ascii.o: rttov_readcoeffs_ascii.F90 rttov_const.o rttov_types.o parkind1.o rttov_findnextsection.o rttov_skipcommentline.o rttov_errorreport.o rttov_deletecomment.o rttov_cmpuc.o rttov_opencoeff.o
-rttov_readcoeffs_binary.o: rttov_readcoeffs_binary.F90 rttov_const.o rttov_types.o parkind1.o rttov_errorreport.o
-rttov_readscattcoeffs.o: rttov_readscattcoeffs.F90 rttov_types.o rttov_const.o parkind1.o rttov_errorreport.o rttov_opencoeff.o rttov_findnextsection.o rttov_skipcommentline.o
-rttov_scatt.o: rttov_scatt.F90 rttov_const.o rttov_types.o parkind1.o rttov_errorreport.o rttov_direct.o rttov_iniscatt.o rttov_eddington.o rttov_setgeometry.o rttov_calcpolarisation.o
-rttov_scatt_ad.o: rttov_scatt_ad.F90 rttov_const.o rttov_types.o parkind1.o rttov_errorreport.o rttov_direct.o rttov_iniscatt.o rttov_eddington.o rttov_setgeometry.o rttov_calcpolarisation_ad.o rttov_eddington_ad.o rttov_iniscatt_ad.o rttov_ad.o
-rttov_scatt_k.o: rttov_scatt_k.F90 rttov_const.o rttov_types.o parkind1.o rttov_scatt_ad.o rttov_errorreport.o
-rttov_scatt_tl.o: rttov_scatt_tl.F90 rttov_const.o rttov_types.o parkind1.o rttov_errorreport.o rttov_tl.o rttov_iniscatt_tl.o rttov_eddington_tl.o rttov_setgeometry.o rttov_calcpolarisation.o rttov_calcpolarisation_tl.o
-rttov_setgeometry.o: rttov_setgeometry.F90 rttov_const.o rttov_types.o parkind1.o
-rttov_setpredictors.o: rttov_setpredictors.F90 rttov_const.o rttov_types.o parkind1.o
-rttov_setpredictors_8.o: rttov_setpredictors_8.F90 rttov_const.o rttov_types.o parkind1.o
-rttov_setpredictors_8_ad.o: rttov_setpredictors_8_ad.F90 rttov_const.o rttov_types.o parkind1.o
-rttov_setpredictors_8_k.o: rttov_setpredictors_8_k.F90 rttov_const.o rttov_types.o parkind1.o
-rttov_setpredictors_8_tl.o: rttov_setpredictors_8_tl.F90 rttov_const.o rttov_types.o parkind1.o
-rttov_setpredictors_ad.o: rttov_setpredictors_ad.F90 rttov_const.o rttov_types.o parkind1.o
-rttov_setpredictors_k.o: rttov_setpredictors_k.F90 rttov_const.o rttov_types.o parkind1.o
-rttov_setpredictors_tl.o: rttov_setpredictors_tl.F90 rttov_const.o rttov_types.o parkind1.o
-rttov_setpressure.o: rttov_setpressure.F90 rttov_const.o rttov_types.o
-rttov_setup.o: rttov_setup.F90 rttov_const.o rttov_types.o parkind1.o rttov_errorhandling.o rttov_errorreport.o rttov_readcoeffs.o rttov_initcoeffs.o
-rttov_setupchan.o: rttov_setupchan.F90 rttov_types.o rttov_const.o parkind1.o
-rttov_setupindex.o: rttov_setupindex.F90 rttov_types.o rttov_const.o parkind1.o
-rttov_skipcommentline.o: rttov_skipcommentline.F90 parkind1.o
-rttov_tl.o: rttov_tl.F90 rttov_const.o rttov_types.o parkind1.o rttov_checkinput.o rttov_errorreport.o rttov_profaux.o rttov_setgeometry.o rttov_setpredictors.o rttov_setpredictors_8.o rttov_transmit.o rttov_calcemis_ir.o rttov_calcemis_mw.o rttov_integrate.o rttov_profaux_tl.o rttov_setpredictors_tl.o rttov_setpredictors_8_tl.o rttov_transmit_tl.o rttov_calcemis_mw_tl.o rttov_integrate_tl.o
-rttov_transmit.o: rttov_transmit.F90 rttov_const.o rttov_types.o parkind1.o
-rttov_transmit_ad.o: rttov_transmit_ad.F90 rttov_const.o rttov_types.o parkind1.o
-rttov_transmit_k.o: rttov_transmit_k.F90 rttov_const.o rttov_types.o parkind1.o
-rttov_transmit_tl.o: rttov_transmit_tl.F90 rttov_const.o rttov_types.o parkind1.o
-rttov_v2q.o: rttov_v2q.F90 rttov_const.o parkind1.o
-rttov_writecoef.o: rttov_writecoef.F90 rttov_const.o rttov_types.o parkind1.o rttov_errorreport.o
-rttovcld.o: rttovcld.F90 rttov_const.o rttov_types.o mod_cparam.o parkind1.o rttov_errorreport.o rttov_setupindex.o rttov_cld.o
-rttvi.o: rttvi.F90 mod_cparam.o rttov_const.o parkind1.o rttov_readcoeffs.o rttov_initcoeffs.o
-tstrad_ad.o: tstrad_ad.F90 rttov_const.o rttov_types.o mod_tstrad.o parkind1.o rttov_errorreport.o rttov_ad.o rttov_tl.o
-tstrad_k.o: tstrad_k.F90 rttov_const.o rttov_types.o mod_tstrad.o parkind1.o rttov_errorreport.o rttov_k.o
-tstrad_tl.o: tstrad_tl.F90 rttov_const.o rttov_types.o mod_tstrad.o parkind1.o rttov_errorreport.o rttov_tl.o rttov_direct.o
diff --git a/src/LIB/RTTOV/src/example_fwd.F90 b/src/LIB/RTTOV/src/example_fwd.F90
deleted file mode 100644
index 621bcd45032f6300923f192ae9f08fe1dc0649e1..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/example_fwd.F90
+++ /dev/null
@@ -1,554 +0,0 @@
-Program example_fwd
- !
- ! This software was developed within the context of
- ! the EUMETSAT Satellite Application Facility on
- ! Numerical Weather Prediction (NWP SAF), under the
- ! Cooperation Agreement dated 25 November 1998, between
- ! EUMETSAT and the Met Office, UK, by one or more partners
- ! within the NWP SAF. The partners in the NWP SAF are
- ! the Met Office, ECMWF, KNMI and MeteoFrance.
- !
- ! Copyright 2004, EUMETSAT, All Rights Reserved.
- !
- ! *************************************************************
- !
- ! TEST PROGRAM FOR RTTOV SUITE FORWARD MODEL ONLY
- ! RTTOV VERSION 8
- ! To run this program you must have the following files
- ! either resident in the same directory or set up as a
- ! symbolic link:
- ! prof.dat -- input profile
- ! rtcoef_platform_id_sensor.dat -- coefficient file to match
- ! the sensor you request in the input dialogue
- ! There are unix scripts available to set up the files above and
- ! run this program (e.g. tstrad_full.scr)
- ! The output is generated in a file called print.dat.
- !
- !
- ! If the user wants to use this example to create his own
- ! program he will have to modify the code between
- ! comment lines of that kind:
- ! !================================
- ! !======Read =====start===========
- ! code to be modified
- ! !======Read ===== end ===========
- ! !================================
- !
- ! Current Code Owner: SAF NWP
- !
- ! History:
- ! Version Date Comment
- ! ------- ---- -------
- ! 1.0 27/04/2004 orginal (based on tstrad) P. Brunel
- ! 1.1 09/08/2004 modified to allow for variable no. channels/per profile
- ! R. Saunders
- ! Code Description:
- ! Language: Fortran 90.
- ! Software Standards: "European Standards for Writing and
- ! Documenting Exchangeable Fortran 90 Code".
- !
- !
- Use rttov_const, Only : &
- errorstatus_success,&
- errorstatus_warning,&
- errorstatus_fatal
-
- Use rttov_types, Only : &
- rttov_coef ,&
- profile_Type ,&
- transmission_Type ,&
- radiance_Type
-
- Use parkind1, Only : jpim ,jprb
- !
- Implicit None
- !
-#include "rttov_direct.interface"
-#include "rttov_readcoeffs.interface"
-#include "rttov_initcoeffs.interface"
-#include "rttov_setupchan.interface"
-#include "rttov_setupindex.interface"
-#include "rttov_errorhandling.interface"
-#include "rttov_dealloc_coef.interface"
-#include "rttov_errorreport.interface"
- ! Commons
- !
- ! Functions
-
-
- !--------------------------
- !
- Integer(Kind=jpim) :: iup=20 ! unit for profile file
- Integer(Kind=jpim) :: ioout=21 ! unit for output
-
- ! One profile per run
- Integer (Kind=jpim) :: nprof = 1
-
- ! RTTOV_errorhandling interface
- !====================
- Integer :: Err_Unit ! Logical error unit (<0 for default)
- Integer :: verbosity_level ! (<0 for default)
-
- ! RTTOV_readcoeffs interface
- !====================
- Integer(Kind=jpim) :: errorstatus
- Integer(Kind=jpim) :: instrument(3)
- Type( rttov_coef ) :: coef ! coefficients
- Integer(Kind=jpim), Allocatable :: lchan(:)
-
- ! RTTOV interface
- !====================
- Integer(Kind=jpim), Allocatable :: rttov_errorstatus(:) ! rttov error return code
- Integer(Kind=jpim) :: nfrequencies
- Integer(Kind=jpim) :: nchannels
- Integer(Kind=jpim) :: nbtout
- Integer(Kind=jpim), Allocatable :: channels (:)
- Integer(Kind=jpim), Allocatable :: polarisations (:,:)
- Integer(Kind=jpim), Allocatable :: lprofiles (:)
- Type(profile_Type) :: profiles(1)! ONE profile but need array
- !Logical :: addcloud = .True.
- Logical :: addcloud = .False.
- Logical, Allocatable :: calcemis(:)
- Real(Kind=jprb), Allocatable :: emissivity (:)
- Type(transmission_Type) :: transmission ! transmittances and layer optical depths
- Type(radiance_Type) :: radiance
-
- Real(Kind=jprb), Allocatable :: input_emissivity (:)
- Character (len=80) :: errMessage
- Character (len=6) :: NameOfRoutine = 'tstrad'
-
-
- ! variables for input
- !====================
- ! Parameter for WV conversion used in all tstrad suite
- Real(Kind=jprb), Parameter :: q_mixratio_to_ppmv = 1.60771704e+6_JPRB
-
- Integer(Kind=jpim), Parameter :: mxchn = 9000 ! max number of channels
- Integer(Kind=jpim) :: input_chan(mxchn)
- Real(Kind=jprb) :: input_ems(mxchn)
- Real(Kind=jprb), Allocatable :: ems(:)
- Real(Kind=jprb) :: zenith
- Real(Kind=jprb) :: azimut
- Integer(Kind=jpim) :: ivch, ich
- Real(Kind=jprb) :: ems_val
- Integer(Kind=jpim), Allocatable :: nchan(:) ! number of channels per profile
- Integer(Kind=jpim) :: isurf
-
-
- ! printing arrays
- Real(Kind=jprb), Allocatable :: pr_radcld(:)
- Real(Kind=jprb), Allocatable :: pr_trans(:)
- Real(Kind=jprb), Allocatable :: pr_emis(:)
- Real(Kind=jprb), Allocatable :: pr_trans_lev(:,:)
- Real(Kind=jprb), Allocatable :: pr_upclr(:)
- Real(Kind=jprb), Allocatable :: pr_dncld(:,:)
- Real(Kind=jprb), Allocatable :: pr_refclr(:)
- Real(Kind=jprb), Allocatable :: pr_ovcst(:,:)
-
- ! loop variables
- Integer :: j, jpol
- Integer :: np
- Integer :: ilev, nprint
- Integer :: ios
-
- Integer(Kind=jpim) :: alloc_status(40)
-
- !- End of header --------------------------------------------------------
-
- errorstatus = 0
- alloc_status(:) = 0
-
- !=====================================================
- !========== Interactive inputs == start ==============
- Write(0,*) 'enter platform number'
- Read(*,*) instrument(1)
- Write(0,*) 'enter satellite number '
- Read(*,*) instrument(2)
- Write(0,*) 'enter instrument number'
- Read(*,*) instrument(3)
- Write(0,*) 'enter surface type (0=land, 1=sea, 2=ice/snow)'
- Read(*,*) isurf
- Write(0,*) 'enter zenith angle in degrees'
- Read(*,*) zenith
- Write(0,*) 'enter azimut angle in degrees'
- Read(*,*) azimut
- !
- Allocate (nchan(nprof))
- nchan(:) = 0
- Read(*,*,iostat=ios) ich, ivch, ems_val ! channel number, validity, emissivity
- Do While (ios == 0 )
- If( ivch /= 0 ) Then
- nchan(nprof) = nchan(nprof) +1
- input_chan(nchan(nprof)) = ich
- input_ems(nchan(nprof)) = ems_val
- Endif
- Read(*,*,iostat=ios) ich, ivch, ems_val
- End Do
-
- !Pack channels and emmissivity arrays
- Allocate(lchan(nchan(nprof))) ! Note these array sizes nchan can vary per profile
- Allocate(ems(nchan(nprof))) ! but for this example assume 1 profile/call with same channels
- lchan(:) = input_chan(1:nchan(nprof))
- ems(:) = input_ems(1:nchan(nprof))
- !
- !========== Interactive inputs == end ==============
- !===================================================
-
-
- !Initialise error management with default value for
- ! the error unit number and
- ! Fatal error message output
- Err_unit = -1
- !verbosity_level = 1
- ! All error message output
- verbosity_level = 3
- Call rttov_errorhandling(Err_unit, verbosity_level)
-
- !Read and initialise coefficients
- !---------------------------------------------------------
- Call rttov_readcoeffs (errorstatus, coef, instrument, channels = lchan(:))
- If(errorstatus /= 0) Then
- Write(*,*) 'error rttov_readcoeffs :',errorstatus
- Stop "error rttov_readcoeffs"
- Else
- Write(*,*) 'rttov_readcoeffs OK:'
- Endif
- Call rttov_initcoeffs (errorstatus,coef)
- If(errorstatus /= 0) Then
- Write(*,*) 'error rttov_initcoeffs :',errorstatus
- Stop "error rttov_initcoeffs"
- Else
- Write(*,*) 'rttov_initcoeffs OK:'
- Endif
-
- ! security if input number of channels is higher than number
- ! stored in coeffs
- If( nchan(nprof) > coef % fmv_chn ) Then
- nchan(nprof) = coef % fmv_chn
- Endif
-
- !Open output file
- Open(IOOUT,file='print.dat',status='unknown',form='formatted',iostat=ios)
- If( ios /= 0 ) Then
- Write(*,*) 'error opening the output file ios= ',ios
- Stop
- Endif
-
- !===============================================
- !========== Read profile == start ==============
- Open(iup, file='prof.dat',status='old',iostat=ios)
- If( ios /= 0 ) Then
- Write(*,*) 'error opening profile file ios= ',ios
- Stop
- Endif
-
- ! Do allocation of profile arrays with the number of levels.
- ! Take care that the number and pressure levels should be
- ! the same as the ones of the coefficient file.
- profiles(1) % nlevels = coef % nlevels
- Allocate(profiles(1) % p(coef % nlevels) ,stat= alloc_status(1))
- Allocate(profiles(1) % t(coef % nlevels) ,stat= alloc_status(2))
- Allocate(profiles(1) % q(coef % nlevels) ,stat= alloc_status(3))
- Allocate(profiles(1) % o3(coef % nlevels) ,stat= alloc_status(4))
- Allocate(profiles(1) % clw(coef % nlevels),stat= alloc_status(5))
- If( Any(alloc_status /= 0) ) Then
- errorstatus = errorstatus_fatal
- Write( errMessage, '( "mem allocation error for profile")' )
- Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine)
- Stop
- End If
-
- ! Presures are from reference profile
- profiles(1) % p(:) = coef % ref_prfl_p(:)
-
- ! read pressure, temp (K), WV (lnq), O3 (ppmv)
- ! take care of doing the unit conversions to
- ! hPa, K and ppmv
- Read(iup,*) profiles(1) % t(:)
- Read(iup,*) profiles(1) % q(:)
- Read(iup,*) profiles(1) % o3(:)
- Read(iup,*) profiles(1) % clw(:)
- ! 2 meter air variables
- Read(iup,*) profiles(1) % s2m % t ,&
- & profiles(1) % s2m % q ,&
- & profiles(1) % s2m % p ,&
- & profiles(1) % s2m % u ,&
- & profiles(1) % s2m % v
-
- ! Convert lnq to q in ppmv for profile
- profiles(1) % q(:) = (Exp(profiles(1) % q(:)) / 1000._JPRB) * q_mixratio_to_ppmv
- profiles(1) % s2m % q = (Exp(profiles(1) % s2m % q) / 1000._JPRB) * q_mixratio_to_ppmv
-
- ! Skin variables
- Read(iup,*) profiles(1) % skin % t ,&
- & profiles(1) % skin % fastem
-
- ! Cloud variables
- Read(iup,*) profiles(1) % ctp,&
- & profiles(1) % cfraction
-
- ! we have an ozone profile
- profiles(1) % ozone_Data =.True.
- ! we do not have CO2 profile
- profiles(1) % co2_Data =.False.
- ! check Cloud liquid water profile
- profiles(1) % clw_Data = profiles(1) % clw(1) >= 0.0_JPRB
-
-
- ! Other variables from interactive inputs
- profiles(1) % skin % surftype = isurf
- profiles(1) % zenangle = zenith
- profiles(1) % azangle = azimut
-
- !========== Read profile == end ==============
- !=============================================
-
-
- ! Setup default number of frequencies, channels , output BTs
- ! for the coeff file. These are then used by rttov_setupindex
- ! to set up channel and polarisation indices.
- ! Take care that this routine is only valid if
- ! the user has selected a list of channels (channels = )
- ! for the rttov_readcoeffs or rttov_setup routine
- Call rttov_setupchan(nprof,nchan,coef,nfrequencies, &
- & nchannels,nbtout)
-
- Allocate( rttov_errorstatus(1) ,stat= alloc_status(1))
- Allocate( channels ( nfrequencies ) ,stat= alloc_status(2))
- Allocate( lprofiles ( nfrequencies ) ,stat= alloc_status(3))
- Allocate( emissivity ( nchannels ) ,stat= alloc_status(4))
- Allocate( input_emissivity ( nchannels ) ,stat= alloc_status(5))
- Allocate( calcemis ( nchannels ) ,stat= alloc_status(6))
- Allocate( polarisations(nchannels,3) ,stat= alloc_status(7))
-
- ! allocate transmittance structure
- Allocate( transmission % tau_surf ( nchannels ) ,stat= alloc_status(8))
- Allocate( transmission % tau_layer ( coef % nlevels, nchannels ) ,stat= alloc_status(9))
- Allocate( transmission % od_singlelayer( coef % nlevels, nchannels ),stat= alloc_status(10))
-
- ! allocate radiance results arrays with number of channels
- Allocate( radiance % clear ( nchannels ) ,stat= alloc_status(11))
- Allocate( radiance % cloudy ( nchannels ) ,stat= alloc_status(12))
- Allocate( radiance % total ( nchannels ) ,stat= alloc_status(13))
- Allocate( radiance % bt ( nchannels ) ,stat= alloc_status(14))
- Allocate( radiance % bt_clear ( nchannels ) ,stat= alloc_status(15))
- Allocate( radiance % upclear ( nchannels ) ,stat= alloc_status(16))
- Allocate( radiance % dnclear ( nchannels ) ,stat= alloc_status(17))
- Allocate( radiance % reflclear( nchannels ) ,stat= alloc_status(18))
- Allocate( radiance % overcast ( coef % nlevels, nchannels ) ,stat= alloc_status(19))
- ! allocate the cloudy radiances with full size even
- ! if not used
- Allocate( radiance % downcld ( coef % nlevels, nchannels ) ,stat= alloc_status(20))
-
- Allocate( radiance % out ( nbtout ) ,stat= alloc_status(21))
- Allocate( radiance % out_clear( nbtout ) ,stat= alloc_status(22))
- Allocate( radiance % total_out( nbtout ) ,stat= alloc_status(23))
- Allocate( radiance % clear_out( nbtout ) ,stat= alloc_status(24))
-
- If( Any(alloc_status /= 0) ) Then
- errorstatus = errorstatus_fatal
- Write( errMessage, '( "mem allocation error prior to rttov_direct")' )
- Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine)
- Stop
- End If
-
-
-
- ! Build the list of channels/profiles indices
- ! outputs are lprofiles,channels,polarisations,emissivity
- ! Take care that this routine is only valid if
- ! the user has selected a list of channels
- ! for the rttov_readcoeffs or rttov_setup routine (channels = )
- Call rttov_setupindex (nchan,nprof,nfrequencies,nchannels,nbtout,coef,&
- & ems,lprofiles,channels,polarisations,emissivity)
-
-
- ! save input values of emissivities for all calculations
- ! calculate emissivity where the input emissivity value is less than 0.01
- input_emissivity(:) = emissivity(:)
- calcemis(:) = emissivity(:) < 0.01_JPRB
-
- ! Call RTTOV forward model
- Call rttov_direct( &
- rttov_errorstatus, & ! out
- nfrequencies, & ! in
- nchannels, & ! in
- nbtout, & ! in
- nprof, & ! in
- channels, & ! in
- polarisations, & ! in
- lprofiles, & ! in
- profiles, & ! in
- coef, & ! in
- addcloud, & ! in
- calcemis, & ! in
- emissivity, & ! inout
- transmission, & ! out
- radiance ) ! inout
-
- If ( Any( rttov_errorstatus(:) == errorstatus_warning ) ) Then
- Write ( ioout, * ) 'rttov_direct warning'
- End If
-
- If ( Any( rttov_errorstatus(:) == errorstatus_fatal ) ) Then
- Write ( 0, * ) 'rttov_direct error'
- Stop
- End If
-
- ! transfer data to printing arrays
- Allocate(pr_radcld(nbtout) ,stat= alloc_status(1))
- Allocate(pr_trans(nbtout) ,stat= alloc_status(2))
- Allocate(pr_emis(nbtout) ,stat= alloc_status(3))
- Allocate(pr_trans_lev(coef % nlevels,nbtout) ,stat= alloc_status(4))
- Allocate(pr_upclr(nbtout) ,stat= alloc_status(5))
- Allocate(pr_dncld(coef % nlevels,nbtout) ,stat= alloc_status(6))
- Allocate(pr_refclr(nbtout) ,stat= alloc_status(7))
- Allocate(pr_ovcst(coef % nlevels,nbtout) ,stat= alloc_status(8))
- If( Any(alloc_status /= 0) ) Then
- errorstatus = errorstatus_fatal
- Write( errMessage, '( "mem allocation error for printing arrays")' )
- Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine)
- Stop
- End If
-
- pr_radcld(:) = 0.0_JPRB
- pr_trans(:) = 0.0_JPRB
- pr_emis(:) = 0.0_JPRB
- pr_trans_lev(:,:) = 0.0_JPRB
- pr_upclr(:) = 0.0_JPRB
- pr_dncld(:,:) = 0.0_JPRB
- pr_refclr(:) = 0.0_JPRB
- pr_ovcst(:,:) = 0.0_JPRB
- !
- Do j = 1 , nchannels
- jpol = polarisations(j,2)
- pr_radcld(jpol) = radiance % cloudy(j)
- pr_trans(jpol) = Transmission % tau_surf(J)
- pr_emis(jpol) = emissivity(j)
- pr_upclr(jpol) = radiance % upclear(J)
- pr_refclr(jpol) = radiance % reflclear(J)
- Do ilev = 1 , coef % nlevels
- pr_trans_lev(ilev,jpol) = Transmission % tau_layer(ilev,J)
- pr_dncld(ilev,jpol) = radiance % downcld(ILEV,J)
- pr_ovcst(ilev,jpol) = radiance % overcast(ILEV,J)
- Enddo
- Enddo
-
-
-
- ! OUTPUT RESULTS
- !
- NPRINT = 1+ Int((nbtout-1)/10)
- Write(IOOUT,*)' -----------------'
- Write(IOOUT,*)' Instrument ', instrument(3)
- Write(IOOUT,*)' -----------------'
- Write(IOOUT,*)' '
-
- Write(IOOUT,777)instrument(2), profiles(1)%zenangle,profiles(1)%azangle,profiles(1)%skin%surftype
- Write(IOOUT,222) radiance % out(:)
- Write(IOOUT,*)' '
- Write(IOOUT,*)'CALCULATED RADIANCES: SAT =', instrument(2)
- Write(IOOUT,222) radiance % total_out(:)
- Write(IOOUT,*)' '
- Write(IOOUT,*)'CALCULATED OVERCAST RADIANCES: SAT =', instrument(2)
- Write(IOOUT,222) pr_radcld(:)
- Write (IOOUT,*)' '
- Write(IOOUT,*)'CALCULATED SURFACE TO SPACE TRANSMITTANCE: S'&
- & ,'AT =',instrument(2)
- Write(IOOUT,4444) pr_trans(:)
- Write (IOOUT,*)' '
- Write(IOOUT,*)'CALCULATED SURFACE EMISSIVITIES '&
- & ,'SAT =',instrument(2)
- Write(IOOUT,444) pr_emis(:)
- !
- !
- If(nchan(nprof) <= 20)Then
- Do NP = 1 , NPRINT
- Write (IOOUT,*)' '
- Write (IOOUT,*)'Level to space transmittances for channels'
- Write(IOOUT,1115) (LCHAN(J),&
- & J = 1+(NP-1)*10,Min(10+(NP-1)*10,nbtout))
- Do ILEV = 1 , coef % NLEVELS
- Write(IOOUT,4445)ILEV,(pr_trans_lev(ilev,J),&
- & J = 1+(NP-1)*10,Min(10+(NP-1)*10,nbtout))
- End Do
- Write(IOOUT,1115) (LCHAN(J),&
- & J = 1+(NP-1)*10,Min(10+(NP-1)*10,nbtout))
- End Do
- Endif
- !
- ! deallocate model profiles atmospheric arrays
- Deallocate( profiles(1) % p ,stat=alloc_status(1))
- Deallocate( profiles(1) % t ,stat=alloc_status(2))
- Deallocate( profiles(1) % q ,stat=alloc_status(3))
- Deallocate( profiles(1) % o3 ,stat=alloc_status(4))
- Deallocate( profiles(1) % clw ,stat=alloc_status(5))
- If( Any(alloc_status /= 0) ) Then
- errorstatus = errorstatus_fatal
- Write( errMessage, '( "mem deallocation error")' )
- Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine)
- Stop
- End If
-
- ! number of channels per RTTOV call is only nchannels
- Deallocate( channels ,stat=alloc_status(2))
- Deallocate( lprofiles ,stat=alloc_status(3))
- Deallocate( emissivity ,stat=alloc_status(4))
- Deallocate( calcemis ,stat=alloc_status(5))
-
- ! allocate transmittance structure
- Deallocate( transmission % tau_surf ,stat= alloc_status(6))
- Deallocate( transmission % tau_layer ,stat= alloc_status(7))
- Deallocate( transmission % od_singlelayer,stat= alloc_status(8))
-
- ! allocate radiance results arrays with number of channels
- Deallocate( radiance % clear ,stat=alloc_status(9))
- Deallocate( radiance % cloudy ,stat=alloc_status(10))
- Deallocate( radiance % total ,stat=alloc_status(11))
- Deallocate( radiance % bt ,stat=alloc_status(12))
- Deallocate( radiance % bt_clear ,stat=alloc_status(13))
- Deallocate( radiance % upclear ,stat=alloc_status(14))
- Deallocate( radiance % dnclear ,stat=alloc_status(15))
- Deallocate( radiance % reflclear,stat=alloc_status(16))
- Deallocate( radiance % overcast ,stat=alloc_status(17))
- Deallocate( radiance % downcld ,stat=alloc_status(18))
- Deallocate( radiance % out ,stat= alloc_status(19))
- Deallocate( radiance % out_clear ,stat= alloc_status(20))
- Deallocate( radiance % total_out ,stat= alloc_status(21))
- Deallocate( radiance % clear_out ,stat= alloc_status(22))
- Deallocate(pr_radcld ,stat= alloc_status(31))
- Deallocate(pr_trans ,stat= alloc_status(32))
- Deallocate(pr_emis ,stat= alloc_status(33))
- Deallocate(pr_trans_lev ,stat= alloc_status(34))
- If( Any(alloc_status /= 0) ) Then
- errorstatus = errorstatus_fatal
- Write( errMessage, '( "mem deallocation error")' )
- Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine)
- Stop
- End If
-
- Call rttov_dealloc_coef (errorstatus, coef)
- If(errorstatus /= errorstatus_success) Then
- Write( errMessage, '( "deallocation error")' )
- Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine)
- Endif
-
- !Close output file
- Close(IOOUT,iostat=ios)
- If( ios /= 0 ) Then
- Write(*,*) 'error closing the output file ios= ',ios
- Stop
- Endif
-
-1115 Format(3X,10I8)
-222 Format(1X,10F8.2)
-444 Format(1X,10F8.3)
-4444 Format(1X,10F8.4)
-4445 Format(1X,I2,10F8.4)
-777 Format(1X,'CALCULATED BRIGHTNESS TEMPERATURES: SAT =',I2,&
- &' ZENITH ANGLE=',F6.2, &
- &' AZIMUTH ANGLE=',F7.2,' SURFACE TYPE=',I2)
-
-
-
-End Program example_fwd
diff --git a/src/LIB/RTTOV/src/lapack.f b/src/LIB/RTTOV/src/lapack.f
deleted file mode 100644
index 462af93a69ccdb80557859e5807a5ec9b503545d..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/lapack.f
+++ /dev/null
@@ -1,9783 +0,0 @@
- SUBROUTINE SMESSG(NUNIT,IP,NMESS)
-C DEFINE THE TEXT OF ERROR MESSAGES.
-C THIS IS A TEST SUBPROGRAM FOR THE LEVEL TWO BLAS.
-C REVISED 860623
-C REVISED YYMMDD
-C AUTH=R. J. HANSON, SANDIA NATIONAL LABS.
- LOGICAL EX,OP,INQ
- INTEGER NUNIT(3)
- CHARACTER *256 MESS(09)
- CHARACTER *256 M
- DATA MESS(01)/
- .' THE COMPILER IS GENERATING BAD CODE FOR IN-LINE DOT PRODUCTS OR
- .IS INCORRECTLY EVALUATING THE ARITHMETIC EXPRESSIONS J*((J+1)*J)/2
- . - (J+1)*J*(J-1)/3, J=1 THRU 32.'/
- DATA MESS(02)/
- .' ABNORMAL OR EARLY END-OF-FILE WHILE READING NAME OF FILE THAT CO
- .NTAINS THE NAMES OF THE SUBPROGRAMS AND THE SUMMARY FILES.'/
- DATA MESS(03)/
- .' THE ABOVE FILE NAME MUST BE PRESENT ON THE SYSTEM. IT IS NOT.
- .THIS FILE CONTAINS THE NAMES OF THE SUBPROGRAMS AND THE SUMMARY FI
- .LES.'/
- DATA MESS(04)/
- .' ABNORMAL OR EARLY END-OF-FILE WHILE READING NAMES OF SUBPROGRAMS
- . FROM THE ABOVE FILE NAME.'/
- DATA MESS(05)/
- .' ABNORNAL OR EARLY END-OF-FILE WHILE READING NAMES OF FILES FOR S
- .UMMARY OUTPUT.'/
- DATA MESS(06)/
- .' ENTER NAME AND UNIT NUMBER OF FILE CONTAINING NAMES OF SUBPROGRA
- .MS AND SUMMARY FILES. ONE ITEM PER LINE, PLEASE.'/
- DATA MESS(07)/
- .' THE SNAP-SHOT FILE OF ACTIVE TESTS CANNOT BE OPENED WITH ''NEW''
- . STATUS OR IT CANNOT BE DELETED. THIS FILE SHOULD NOT BE PRESENT
- .ON THE SYSTEM.'/
- DATA MESS(08)/
- .' THE SUMMARY FILE OF ACTIVE TESTS CANNOT BE OPENED WITH ''UNKOWN'
- .' STATUS. THIS FILE SHOULD NOT BE PRESENT ON THE SYSTEM.'/
- M = MESS(NMESS)
- NL = 256
- NS = 72
- INQ = .TRUE.
- DO 10 I = NL,1,-1
- IF (ICHAR(M(I:I)).NE.ICHAR(' ')) GO TO 20
- 10 CONTINUE
- NL = 0
- GO TO 30
-*
- 20 NL = I
-C FOUND NS = POINTER TO LAST NONBLANK IN MESSAGE.
- 30 CONTINUE
-C NOW OUTPUT THE MESSAGE. PARSE IT SO THAT UP TO NS CHARS. PER LINE
-C PRINT, BUT DO NOT BREAK WORDS ACCROSS LINES.
- IS = 1
- 40 CONTINUE
- IE = MIN(NL,IS+NS)
- IF (IS.GE.IE) GO TO 70
- 50 CONTINUE
- IF (ICHAR(M(IE:IE)).EQ.ICHAR(' ') .OR. NL-IS.LT.NS) GO TO 60
- IE = IE - 1
- IF (IE.GT.IS) GO TO 50
- 60 CONTINUE
- IF (INQ) THEN
- INQUIRE (UNIT=NUNIT(IP),EXIST=EX,OPENED=OP)
- END IF
-C IF THE INTENDED UNIT IS NOT OPENED, SEND OUTPUT TO
-C STANDARD OUTPUT SO IT WILL BE SEEN.
- IF ( .NOT. OP .OR. .NOT. EX .OR. NUNIT(IP).EQ.0) THEN
- IF (IE.EQ.NL) THEN
- WRITE (*,'(A,/)') M(IS:IE)
-*
- ELSE
- WRITE (*,'(A)') M(IS:IE)
- END IF
-*
- INQ = .FALSE.
-*
- ELSE
- LUNIT = NUNIT(IP)
- WRITE (LUNIT,'(A)') M(IS:IE)
- END IF
-*
- IS = IE
- GO TO 40
-*
- 70 CONTINUE
- RETURN
- END
-*
- SUBROUTINE SCHCK1(ISNUM,SNAME,IG,DOPE,NUNIT,AVIGR,FATAL)
-C THIS IS A TEST SUBPROGRAM FOR THE LEVEL TWO BLAS.
-C REVISED 860623
-C REVISED YYMMDD
-C AUTH=R. J. HANSON, SANDIA NATIONAL LABS.
-C THIS PROGRAM HAS TWO PARTS. THE FIRST PART CHECKS TO SEE
-C IF ANY DATA GETS CHANGED WHEN NONE SHOULD. FOR EXAMPLE WHEN
-C USING AN INVALID OPTION OR NONPOSITVE PROBLEM DIMENSIONS.
-C THE SECOND PART CHECKS THAT THE RESULTS ARE REASONABLY ACCURATE.
-C DIMENSION AND PROBLEM SIZE DATA..
- INTEGER INC(04),IDIM(08),NUNIT(2)
- REAL ALF(04),BET(04),SDIFF
- LOGICAL ISAME(13),LSE,FATAL,SAME,NCHNG,RESET
- CHARACTER *128 DOPE(2)
- CHARACTER *6 SNAME
- CHARACTER *3 ICH
- CHARACTER *1 ICHS,ICI
- INTEGER LA,LV
- PARAMETER (LA=4096,LV=4096,LMN=2048)
- REAL A(LA),AS(LA),X(LV),XS(LV)
- REAL Y(LV),YS(LV),YT(LMN),XT(LMN)
- REAL ALPHA,ALS,BETA,BLS,T,TRANSL,XN
- PARAMETER (ZERO=0.E0,HALF=.5E0,ONE=1.E0)
- COMMON /ARRAYS/AR,AS,X,XS,Y,YS,YT,XT
- EXTERNAL SDIFF
-*
- DATA ALF/-1.E0,2.E0,.3E0,1.E0/
- DATA BET/-1.E0,0.E0,.3E0,1.E0/
- DATA INC/-2,-1,1,2/
- DATA IDIM/1,2,4,8,64,128,2048,0/
- DATA ICH/'NT/'/
- FATAL = .FALSE.
-C CHECK GENERAL MATRIX-VECTOR PRODUCT, Y = ALPHA*A*X+BETA*Y, NO.1-2.
- IF (ISNUM.LT.0) GO TO 220
- NC = 0
- RESET = .TRUE.
- AVIGR = ZERO
- IX = 0
- 10 IX = IX + 1
- IF (IX.GT.4) GO TO 200
- INCX = INC(IX)
- ALPHA = ALF(IX)
- IY = 0
- 20 IY = IY + 1
- IF (IY.GT.4) GO TO 190
- INCY = INC(IY)
- BETA = BET(IY)
- MM = 0
- 30 MM = MM + 1
- IF (MM.GT.8) GO TO 180
- M = IDIM(MM)
- NN = 0
- 40 NN = NN + 1
- IF (NN.GT.8) GO TO 170
- N = IDIM(NN)
- IC = 0
- 50 IC = IC + 1
- IF (IC.GT.3) GO TO 160
- IF (FATAL) GO TO 210
-C SET DEFAULT BANDWIDTH SO PRINTING WILL BE OK.
- KL = MAX(0,M-1)
- KU = MAX(0,N-1)
-C DEFINE THE NUMBER OF ARGUMENTS AND THE Y ARGUMENT NUMBER.
- IF (ISNUM.EQ.1) THEN
- LDA = MAX(M,1)
- NARGS = 11
- IYARG = 10
-*
- ELSE IF (ISNUM.EQ.2) THEN
- NARGS = 13
- IYARG = 12
-C DEFINE BANDWIDTH OF MATRIX FOR TEST OF SGBMV.
- KL = MAX(0,MIN(M-1,M/2))
- KU = MAX(0,MIN(N-1,N/2))
- LDA = MAX(KL+KU+1,M)
- END IF
-*
- ICI = ICH(IC:IC)
- IF (ICHAR(ICI).EQ.ICHAR('T')) THEN
- ML = N
- NL = M
- INCCA = 1
- INCRA = LDA
-*
- ELSE
- ML = M
- NL = N
- INCCA = LDA
- INCRA = 1
- END IF
-*
-C IF NOT ENOUGH STORAGE, SKIP THIS CASE. (AVOID EXPLICT LDA*N).
- IF (SQRT(REAL(N))*SQRT(REAL(LDA)).GT.SQRT(REAL(LA))) GO TO 50
-C DO (PREPARE NOTES FOR THIS TEST)
-C
-C PRINT A MESSAGE THAT GIVES DEBUGGING INFORMATION. THIS
-C MESSAGE SAYS..
-C IN SUBPROGRAM XXXXX TESTS WERE ACTIVE WITH
-C OPTION = 'A'
-C M = IIII, N = IIII,
-C INCX = IIII, INCY = IIII,
-C KL = IIII, KU = IIII.
-C THE MAIN IDEA HERE IS THAT A SERIOUS BUG THAT OCCURS DURING THE
-C TESTING OF THESE SUBPROGRAMS MAY LOSE PROGRAM CONTROL. THIS
-C AUXILLIARY FILE CONTAINS THE DIMENSIONS THAT RESULTED IN THE LOSS
-C OF CONTROL. HENCE IT PROVIDES THE IMPLEMENTOR WITH MORE COMPLETE
-C INFORMATION ABOUT WHERE TO START TRACKING DOWN THE BUG.
- IF (NUNIT(1).GT.0) THEN
-C IF UNIT IS NOT AVAILABLE WITH 'NEW' STATUS, OPEN WITH
-C 'OLD' AND THEN DELETE IT.
- ISTAT = 1
- CALL SOPEN(NUNIT(1),DOPE(1),ISTAT,IERROR)
- IF (IERROR.EQ.1) GO TO 60
-C GET RID OF ANY OLD FILE.
- CLOSE (UNIT=NUNIT(1),STATUS='DELETE',ERR=60)
- 60 CONTINUE
- ISTAT = 2
-C CREATE A NEW FILE FOR THE NEXT TEST.
- CALL SOPEN(NUNIT(1),DOPE(1),ISTAT,IERROR)
- IF (IERROR.EQ.0) GO TO 80
- NMESS = 7
-C DO (PRINT A MESSAGE)
-C PRINT AN ERROR MESSAGE ABOUT OPENING THE NAME FILE.
- CALL SMESSG(0,1,NMESS)
- FATAL = .TRUE.
- GO TO 210
-*
- 80 CONTINUE
- WRITE (NUNIT(1),9001) SNAME,ICI,M,N,INCX,INCY,KL,KU
-C CLOSE THE FILE SO USEFUL STATUS INFORMATION IS SEALED.
- CLOSE (UNIT=NUNIT(1))
- END IF
-C DO (DEFINE A SET OF PROBLEM DATA)
- ASSIGN 90 TO IGO3
- GO TO 340
-*
- 90 CONTINUE
-C DO (CALL SUBROUTINE)
- ASSIGN 100 TO IGO1
- GO TO 280
-*
- 100 CONTINUE
- IF (M.LE.0 .OR. N.LE.0 .OR. ICHAR(ICI).EQ.ICHAR('/')) THEN
-C DO (SEE WHAT DATA CHANGED INSIDE SUBROUTINES)
- ASSIGN 110 TO IGO2
- GO TO 240
-*
- 110 CONTINUE
-C IF DATA WAS INCORRECTLY CHANGED, MAKE NOTES AND RETURN.
- SAME = .TRUE.
- DO 120 I = 1,NARGS
- SAME = SAME .AND. ISAME(I)
- IF ( .NOT. ISAME(I)) THEN
- WRITE (NUNIT(2),9011) SNAME,I,ICI,M,N,INCX,INCY,KL,KU
- END IF
-*
- 120 CONTINUE
- IF ( .NOT. SAME) THEN
- FATAL = .TRUE.
- GO TO 210
-*
- END IF
-*
- ELSE
-C DO (SEE WHAT DATA CHANGED INSIDE SUBROUTINES)
- ASSIGN 130 TO IGO2
- GO TO 240
-*
- 130 CONTINUE
-C IF DATA WAS INCORRECTLY CHANGED, MAKE NOTES AND RETURN.
- SAME = .TRUE.
- DO 140 I = 1,NARGS
- NCHNG = (I.EQ.IYARG .OR. ISAME(I))
- SAME = SAME .AND. NCHNG
- IF ( .NOT. NCHNG) THEN
- WRITE (NUNIT(2),9021) SNAME,I,ICI,M,N,INCX,INCY,KL,KU
- END IF
-*
- 140 CONTINUE
- IF ( .NOT. SAME) THEN
- FATAL = .TRUE.
- GO TO 210
-*
- END IF
-*
- NC = NC + 1
-C DO (COMPUTE A CORRECT RESULT)
- ASSIGN 150 TO IGO4
- GO TO 370
-*
- 150 CONTINUE
-C IF GOT REALLY BAD ANSWER, PRINT NOTE AND GO BACK.
- IF (FATAL) GO TO 200
-*
- END IF
-*
- GO TO 50
-*
- 160 CONTINUE
- GO TO 40
-*
- 170 CONTINUE
- GO TO 30
-*
- 180 CONTINUE
- GO TO 20
-*
- 190 CONTINUE
- GO TO 10
-*
- 200 CONTINUE
-C REPORT ON ACCURACY OF DATA.
- WRITE (NUNIT(2),9031) ISNUM,SNAME,AVIGR,IG
- GO TO 230
-*
- 210 CONTINUE
- WRITE (NUNIT(2),9041) ISNUM,SNAME
- GO TO 230
-*
- 220 CONTINUE
- WRITE (NUNIT(2),9051) - ISNUM,SNAME
- 230 CONTINUE
- RETURN
-*
- 240 CONTINUE
-C PROCEDURE (SEE WHAT DATA CHANGED INSIDE SUBROUTINES)
- IF (ISNUM.EQ.1) THEN
- ISAME(1) = ICHAR(ICI) .EQ. ICHAR(ICHS)
- ISAME(2) = MS .EQ. M
- ISAME(3) = NS .EQ. N
- ISAME(4) = ALS .EQ. ALPHA
- ISAME(5) = .TRUE.
- IF (M.GT.0 .AND. N.GT.0) ISAME(5) = LSE(AS,A,M,N,LDA)
- ISAME(6) = LDAS .EQ. LDA
- ISAME(7) = .TRUE.
- IF (NL.GT.0 .AND. INCX.NE.0) ISAME(7) = LSE(XS,X,1,NL,
- . ABS(INCX))
- ISAME(8) = INCXS .EQ. INCX
- ISAME(9) = BLS .EQ. BETA
- ISAME(10) = .TRUE.
- IF (ML.GT.0 .AND. INCY.NE.0) ISAME(10) = LSE(YS,Y,1,ML,
- . ABS(INCY))
- ISAME(11) = INCYS .EQ. INCY
-*
- ELSE IF (ISNUM.EQ.2) THEN
-C COMPARE THE MATRIX IN THE SGBMV DATA STRUCTURE WITH
-C THE SAVED COPY.
- ISAME(1) = ICHAR(ICI) .EQ. ICHAR(ICHS)
- ISAME(2) = MS .EQ. M
- ISAME(3) = NS .EQ. N
- ISAME(4) = KLS .EQ. KL
- ISAME(5) = KUS .EQ. KU
- ISAME(6) = ALS .EQ. ALPHA
- ISAME(7) = .TRUE.
- IF (N.GT.0 .AND. M.GT.0) THEN
- DO 260 J = 1,N
- DO 250 I = MAX(1,J-KU),MIN(M,J+KL)
- IF (AS(1+ (I-1)+ (J-1)*LDA).NE.
- . A(1+ (KU+I-J)+ (J-1)*LDA)) THEN
- ISAME(7) = .FALSE.
- GO TO 270
-*
- END IF
-*
- 250 CONTINUE
- 260 CONTINUE
- 270 CONTINUE
- END IF
-*
- ISAME(8) = LDAS .EQ. LDA
- ISAME(9) = .TRUE.
- IF (NL.GT.0 .AND. INCX.NE.0) ISAME(9) = LSE(XS,X,1,NL,
- . ABS(INCX))
- ISAME(10) = INCXS .EQ. INCX
- ISAME(11) = BLS .EQ. BETA
- ISAME(12) = .TRUE.
- IF (ML.GT.0 .AND. INCY.NE.0) ISAME(12) = LSE(YS,Y,1,ML,
- . ABS(INCY))
- ISAME(13) = INCYS .EQ. INCY
- END IF
-*
- GO TO IGO2
-*
- 280 CONTINUE
-C PROCEDURE (CALL SUBROUTINE)
-C SAVE EVERY DATUM BEFORE THE CALL.
- ICHS = ICI
- MS = M
- NS = N
- KLS = KL
- KUS = KU
- ALS = ALPHA
- DO 290 I = 1,LDA*N
- AS(I) = A(I)
- 290 CONTINUE
- LDAS = LDA
-C SAVE COPY OF THE X AND Y VECTORS.
- IBX = 1
- IF (INCX.LT.0) IBX = 1 + (1-NL)*INCX
- DO 300 J = 1,NL
- XS(IBX+ (J-1)*INCX) = X(IBX+ (J-1)*INCX)
- 300 CONTINUE
- INCXS = INCX
- BLS = BETA
- IBY = 1
- IF (INCY.LT.0) IBY = 1 + (1-ML)*INCY
- DO 310 I = 1,ML
- YS(IBY+ (I-1)*INCY) = Y(IBY+ (I-1)*INCY)
- 310 CONTINUE
- INCYS = INCY
- IF (ISNUM.EQ.1) THEN
- CALL SGEMV(ICI,M,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY)
-*
- ELSE IF (ISNUM.EQ.2) THEN
-C TRANSFER THE MATRIX TO THE DATA STRUCTURE USED WITH SGBMV.
- DO 330 J = 1,N
- DO 320 I = MAX(1,J-KU),MIN(M,J+KL)
- A(1+ (KU+I-J)+ (J-1)*LDA) = AS(1+ (I-1)+ (J-1)*LDA)
- 320 CONTINUE
- 330 CONTINUE
- CALL SGBMV(ICI,M,N,KL,KU,ALPHA,A,LDA,X,INCX,BETA,Y,INCY)
- END IF
-*
- GO TO IGO1
-*
- 340 CONTINUE
-C PROCEDURE (DEFINE A SET OF PROBLEM DATA)
-C DO NOTHING IF BOTH DIMENSIONS ARE NOT POSITIVE.
- IF (M.LE.0 .OR. N.LE.0) GO TO IGO3
- TRANSL = ZERO
- CALL SMAKE(A,M,N,LDA,RESET,TRANSL)
-C TRIM AWAY ELEMENTS OUTSIDE THE BANDWIDTH FOR SGBMV.
- IF (ISNUM.EQ.2) THEN
- DO 360 J = 1,N
- DO 350 I = 1,M
- T = A(1+ (I-1)+ (J-1)*LDA)
- IF (J.GT.I .AND. J-I.GT.KU) T = ZERO
- IF (I.GT.J .AND. I-J.GT.KL) T = ZERO
- A(1+ (I-1)+ (J-1)*LDA) = T
- 350 CONTINUE
- 360 CONTINUE
- END IF
-*
- TRANSL = 500.E0
- RESET = .FALSE.
- CALL SMAKE(X,1,NL,MAX(1,ABS(INCX)),RESET,TRANSL)
- IF (NL.GT.1 .AND. INCX.EQ.1) X(NL/2) = ZERO
- TRANSL = ZERO
- CALL SMAKE(Y,1,ML,MAX(1,ABS(INCY)),RESET,TRANSL)
- GO TO IGO3
-*
- 370 CONTINUE
-C PROCEDURE (COMPUTE A CORRECT RESULT)
-C COMPUTE THE CONDITION NUMBER TO USE AS GAUGE FOR ACCURATE RESULTS.
-C THIS IS RETURNED IN XT(*).
-C COMPUTE THE APPROXIMATE CORRECT RESULT.
-C THIS IS RETURNED IN YT(*).
- IF (INCY.LT.0) THEN
- IBY = (1-ML)*INCY + 1
-*
- ELSE
- IBY = 1
- END IF
-*
- DO 390 I = 1,ML
- YT(I) = BETA*YS(IBY+ (I-1)*INCY)
- XT(I) = YS(IBY+ (I-1)*INCY)**2
- IF (INCX.LT.0) THEN
- IBX = (1-NL)*INCX + 1
-*
- ELSE
- IBX = 1
- END IF
-*
- DO 380 J = 1,NL
- YT(I) = YT(I) + AS(1+ (I-1)*INCRA+ (J-1)*INCCA)*ALPHA*
- . XS(IBX+ (J-1)*INCX)
- XT(I) = XT(I) + AS(1+ (I-1)*INCRA+ (J-1)*INCCA)**2
- 380 CONTINUE
- XT(I) = SQRT(XT(I))
- 390 CONTINUE
- XN = BETA**2
- DO 400 J = 1,NL
- XN = XN + XS(IBX+ (J-1)*INCX)**2
- 400 CONTINUE
- XN = SQRT(XN)
-C COMPUTE THE GAUGES FOR THE RESULTS.
- DO 410 I = 1,ML
- XT(I) = XT(I)*XN
- 410 CONTINUE
-C COMPUTE THE DIFFERENCES. THEY SHOULD BE SMALL FOR CORRECT RESULTS.
- DO 420 I = 1,ML
- YT(I) = YT(I) - Y(IBY+ (I-1)*INCY)
- 420 CONTINUE
-C COMPUTE THE GRADE OF THIS RESULT.
- IGR = 0
- T = ONE
- 430 CONTINUE
-C THIS TEST ALLOWS UP TO A LOSS OF FULL PRECISION BEFORE QUITTING.
- IF (IGR.GE.IG) GO TO 460
- DO 440 I = 1,ML
- IF (SDIFF(T*ABS(YT(I))+XT(I),XT(I)).EQ.ZERO) GO TO 440
- T = T*HALF
- IGR = IGR + 1
- GO TO 430
-*
- 440 CONTINUE
-C IF THE LOOP COMPLETES, ALL VALUES ARE 'SMALL.' THE VALUE IGR/IG
-C IS THE GRADE ASSIGNED. THE VALUE OF IGR IS MAXIMIZED OVER ALL THE
-C PROBLEMS.
- 450 CONTINUE
- AVIGR = MAX(AVIGR,REAL(IGR))
- GO TO IGO4
-*
- 460 CONTINUE
- FATAL = .TRUE.
- GO TO 450
-*
-* LAST EXECUTABLE LINE OF SCHCK1
- 9001 FORMAT (' IN SUBPROGRAM ',A,/,' TESTS ACTIVE WITH OPTION = ',A,/,
- . ' M =',I4,', N = ',I4,/,' INCX = ',I2,', INCY = ',I2,/,' KL =',
- . I4,', KU =',I4)
- 9011 FORMAT (' IN SUBPROGRAM ',A,/,' ARGUMENT ',I2,
- . ' WAS CHANGED WITH INVALID INPUT.',/,' OPTION = ',A,', M =',I4,
- . ', N = ',I4,/,' INCX = ',I2,', INCY = ',I2,/,' KL =',I4,
- . ', KU =',I4)
- 9021 FORMAT (' IN SUBPROGRAM ',A,/,' ARGUMENT ',I2,
- . ' WAS CHANGED WHILE COMPUTING',/,' OPTION = ',A,', M =',I4,
- . ', N = ',I4,/,' INCX = ',I2,', INCY = ',I2,/,' KL =',I4,
- . ', KU =',I4)
- 9031 FORMAT (1X,I2,' SUBPROGRAM ',A,T24,'RECEIVED A LOSS GRADE OF ',
- . F5.2,' OUT OF ',I3)
- 9041 FORMAT (1X,I2,' SUBPROGRAM ',A,T24,'FAILED.')
- 9051 FORMAT (1X,I2,' SUBPROGRAM ',A,T24,'NOT TESTED.')
- END
- SUBROUTINE SCHCK2(ISNUM,SNAME,IG,DOPE,NUNIT,AVIGR,FATAL)
-C THIS IS A TEST SUBPROGRAM FOR THE LEVEL TWO BLAS.
-C TEST SSYMV, 03, SSBMV, 04, AND SSPMV, 05.
-C REVISED 860623
-C REVISED YYMMDD
-C AUTH=R. J. HANSON, SANDIA NATIONAL LABS.
-C THIS PROGRAM HAS TWO PARTS. THE FIRST PART CHECKS TO SEE
-C IF ANY DATA GETS CHANGED WHEN NONE SHOULD. FOR EXAMPLE WHEN
-C USING AN INVALID OPTION OR NONPOSITVE PROBLEM DIMENSIONS.
-C THE SECOND PART CHECKS THAT THE RESULTS ARE REASONABLY ACCURATE.
-C DIMENSION AND PROBLEM SIZE DATA..
- INTEGER INC(04),IDIM(06),NUNIT(2)
- REAL ALF(04),BET(04)
- LOGICAL ISAME(13),LSE,FATAL,SAME,NCHNG,RESET
- CHARACTER *128 DOPE(2)
- CHARACTER *6 SNAME
- CHARACTER *3 ICH
- CHARACTER *1 ICHS,ICI
- INTEGER LA,LV
- PARAMETER (LA=4096,LV=4096,LMN=2048)
- REAL ALPHA,ALS,BETA,BLS,T,TRANSL,XN
- REAL A(LA),AS(LA),X(LV),XS(LV)
- REAL Y(LV),YS(LV),YT(LMN),XT(LMN)
- PARAMETER (ZERO=0.E0,HALF=.5E0,ONE=1.E0)
- COMMON /ARRAYS/AR,AS,X,XS,Y,YS,YT,XT
- EXTERNAL SDIFF
-*
- DATA ALF/-1.E0,2.E0,.3E0,1.E0/
- DATA BET/-1.E0,0.E0,.3E0,1.E0/
- DATA INC/-2,-1,1,2/
- DATA IDIM/1,2,4,8,64,0/
- DATA ICH/'LU/'/
- FATAL = .FALSE.
-C CHECK SYMMETRIC MATRIX-VECTOR PRODUCT, Y = ALPHA*A*X+BETA*Y, 3-5.
- IF (ISNUM.LT.0) GO TO 200
- NC = 0
- RESET = .TRUE.
- AVIGR = ZERO
- IX = 0
- 10 IX = IX + 1
- IF (IX.GT.4) GO TO 180
- INCX = INC(IX)
- ALPHA = ALF(IX)
- IY = 0
- 20 IY = IY + 1
- IF (IY.GT.4) GO TO 170
- INCY = INC(IY)
- BETA = BET(IY)
- NN = 0
- 30 NN = NN + 1
- IF (NN.GT.6) GO TO 160
- N = IDIM(NN)
- IC = 0
- 40 IC = IC + 1
- IF (IC.GT.3) GO TO 150
- IF (FATAL) GO TO 190
- ICI = ICH(IC:IC)
-C DEFINE DEFAULT VALUE OF K SO PRINTING IS OK.
- K = MAX(0,N-1)
-C DEFINE THE NUMBER OF ARGUMENTS AND THE Y ARGUMENT NUMBER.
- LDA = MAX(N,1)
- IF (ISNUM.EQ.3) THEN
- NARGS = 10
- IYARG = 09
-*
- ELSE IF (ISNUM.EQ.4) THEN
- NARGS = 11
- IYARG = 10
-C DEFINE BANDWIDTH OF MATRIX FOR TEST OF SSBMV.
- K = INT(SQRT(REAL(N))+HALF) - 1
-*
- ELSE IF (ISNUM.EQ.5) THEN
- NARGS = 9
- IYARG = 8
- END IF
-C DO (PREPARE NOTES FOR THIS TEST)
-C
-C PRINT A MESSAGE THAT GIVES DEBUGGING INFORMATION. THIS
-C MESSAGE SAYS..
-C IN SUBPROGRAM XXXXX TESTS WERE ACTIVE WITH
-C OPTION = 'A'
-C N = IIII,
-C INCX = IIII, INCY = IIII,
-C K = IIII.
-C THE MAIN IDEA HERE IS THAT A SERIOUS BUG THAT OCCURS DURING THE
-C TESTING OF THESE SUBPROGRAMS MAY LOSE PROGRAM CONTROL. THIS
-C AUXILLIARY FILE CONTAINS THE DIMENSIONS THAT RESULTED IN THE LOSS
-C OF CONTROL. HENCE IT PROVIDES THE IMPLEMENTOR WITH MORE COMPLETE
-C INFORMATION ABOUT WHERE TO START TRACKING DOWN THE BUG.
- IF (NUNIT(1).GT.0) THEN
-C IF UNIT IS NOT AVAILABLE WITH 'NEW' STATUS, OPEN WITH
-C 'OLD' AND THEN DELETE IT.
- ISTAT = 1
- CALL SOPEN(NUNIT(1),DOPE(1),ISTAT,IERROR)
- IF (IERROR.EQ.1) GO TO 50
-C GET RID OF ANY OLD FILE.
- CLOSE (UNIT=NUNIT(1),STATUS='DELETE',ERR=50)
- 50 CONTINUE
- ISTAT = 2
-C CREATE A NEW FILE FOR THE NEXT TEST.
- CALL SOPEN(NUNIT(1),DOPE(1),ISTAT,IERROR)
- IF (IERROR.EQ.0) GO TO 70
- 60 CONTINUE
- NMESS = 7
-C DO (PRINT A MESSAGE)
-C PRINT AN ERROR MESSAGE ABOUT OPENING THE NAME FILE.
- CALL SMESSG(0,1,NMESS)
- FATAL = .TRUE.
- GO TO 190
-*
- 70 CONTINUE
- WRITE (NUNIT(1),9001) SNAME,ICI,N,INCX,INCY,K
-C CLOSE THE FILE SO USEFUL STATUS INFORMATION IS SEALED.
- CLOSE (UNIT=NUNIT(1))
- END IF
-C DO (DEFINE A SET OF PROBLEM DATA)
- ASSIGN 80 TO IGO3
- GO TO 370
-*
- 80 CONTINUE
-C DO (CALL SUBROUTINE)
- ASSIGN 90 TO IGO1
- GO TO 290
-*
- 90 CONTINUE
- IF (N.LE.0 .OR. ICHAR(ICI).EQ.ICHAR('/')) THEN
-C DO (SEE WHAT DATA CHANGED INSIDE SUBROUTINES)
- ASSIGN 100 TO IGO2
- GO TO 220
-*
- 100 CONTINUE
-C IF DATA WAS INCORRECTLY CHANGED, MAKE NOTES AND RETURN.
- SAME = .TRUE.
- DO 110 I = 1,NARGS
- SAME = SAME .AND. ISAME(I)
- IF ( .NOT. ISAME(I)) THEN
- WRITE (NUNIT(2),9011) SNAME,I,ICI,N,INCX,INCY,K
- END IF
-*
- 110 CONTINUE
- IF ( .NOT. SAME) THEN
- FATAL = .TRUE.
- GO TO 190
-*
- END IF
-*
- ELSE
-C DO (SEE WHAT DATA CHANGED INSIDE SUBROUTINES)
- ASSIGN 120 TO IGO2
- GO TO 220
-*
- 120 CONTINUE
-C IF DATA WAS INCORRECTLY CHANGED, MAKE NOTES AND RETURN.
- SAME = .TRUE.
- DO 130 I = 1,NARGS
- NCHNG = (I.EQ.IYARG .OR. ISAME(I))
- SAME = SAME .AND. NCHNG
- IF ( .NOT. NCHNG) THEN
- WRITE (NUNIT(2),9021) SNAME,I,ICI,N,INCX,INCY,K
- END IF
-*
- 130 CONTINUE
- IF ( .NOT. SAME) THEN
- FATAL = .TRUE.
- GO TO 190
-*
- END IF
-*
- NC = NC + 1
-C DO (COMPUTE A CORRECT RESULT)
- ASSIGN 140 TO IGO4
- GO TO 420
-*
- 140 CONTINUE
-C IF GOT REALLY BAD ANSWER, PRINT NOTE AND GO BACK.
- IF (FATAL) GO TO 180
-*
- END IF
-*
- GO TO 40
-*
- 150 CONTINUE
- GO TO 30
-*
- 160 CONTINUE
- GO TO 20
-*
- 170 CONTINUE
- GO TO 10
-*
- 180 CONTINUE
-C REPORT ON ACCURACY OF DATA.
- WRITE (NUNIT(2),9031) ISNUM,SNAME,AVIGR,IG
- GO TO 210
-*
- 190 CONTINUE
- WRITE (NUNIT(2),9041) ISNUM,SNAME
- GO TO 210
-*
- 200 CONTINUE
- WRITE (NUNIT(2),9051) - ISNUM,SNAME
- 210 CONTINUE
- RETURN
-*
- 220 CONTINUE
-C PROCEDURE (SEE WHAT DATA CHANGED INSIDE SUBROUTINES)
- IF (ISNUM.EQ.3) THEN
- ISAME(1) = ICHAR(ICI) .EQ. ICHAR(ICHS)
- ISAME(2) = NS .EQ. N
- ISAME(3) = ALS .EQ. ALPHA
- ISAME(4) = .TRUE.
- IF (N.GT.0) ISAME(4) = LSE(AS,A,N,N,LDA)
- ISAME(5) = LDAS .EQ. LDA
- ISAME(6) = .TRUE.
- IF (N.GT.0 .AND. INCX.NE.0) ISAME(6) = LSE(XS,X,1,N,ABS(INCX))
- ISAME(7) = INCXS .EQ. INCX
- ISAME(8) = BLS .EQ. BETA
- ISAME(9) = .TRUE.
- IF (N.GT.0 .AND. INCY.NE.0) ISAME(9) = LSE(YS,Y,1,N,ABS(INCY))
- ISAME(10) = INCYS .EQ. INCY
-*
- ELSE IF (ISNUM.EQ.4) THEN
-C COMPARE THE MATRIX IN THE SSBMV AND SSPMV DATA STRUCTURES WITH
-C THE SAVED COPY.
- ISAME(1) = ICHAR(ICI) .EQ. ICHAR(ICHS)
- ISAME(2) = NS .EQ. N
- ISAME(3) = KS .EQ. K
- ISAME(4) = ALS .EQ. ALPHA
- ISAME(5) = .TRUE.
-C TEST THE MATRIX IN THE DATA STRUCTURE USED WITH SSBMV.
- IF (ICHAR(ICI).EQ.ICHAR('U')) THEN
- KOFF = K
-*
- ELSE
- KOFF = 0
- END IF
-*
- IF (N.GT.0) THEN
- DO 240 J = 1,N
- DO 230 I = MAX(1,J-K),MIN(N,J+K)
- IF (AS(1+ (I-1)+ (J-1)*LDA).NE.
- . A(1+ (KOFF+I-J)+ (J-1)*LDA)) THEN
- ISAME(5) = .FALSE.
- GO TO 250
-*
- END IF
-*
- 230 CONTINUE
- 240 CONTINUE
- 250 CONTINUE
- END IF
-*
- ISAME(6) = LDAS .EQ. LDA
- ISAME(7) = .TRUE.
- IF (N.GT.0 .AND. INCX.NE.0) ISAME(7) = LSE(XS,X,1,N,ABS(INCX))
- ISAME(8) = INCXS .EQ. INCX
- ISAME(9) = BLS .EQ. BETA
- ISAME(10) = .TRUE.
- IF (N.GT.0 .AND. INCY.NE.0) ISAME(10) = LSE(YS,Y,1,N,
- . ABS(INCY))
- ISAME(11) = INCYS .EQ. INCY
-*
- ELSE IF (ISNUM.EQ.5) THEN
- ISAME(1) = ICHAR(ICI) .EQ. ICHAR(ICHS)
- ISAME(2) = NS .EQ. N
- ISAME(3) = ALS .EQ. ALPHA
- ISAME(4) = .TRUE.
-C TEST THE MATRIX USING THE DATA STRUCTURE USED WITH SSPMV.
- IOFF = 0
- DO 270 J = 1,N
- IF (ICHAR(ICI).EQ.ICHAR('U')) THEN
- ISTRT = 1
- IEND = J
-*
- ELSE
- ISTRT = J
- IEND = N
- END IF
-*
- DO 260 I = ISTRT,IEND
- IOFF = IOFF + 1
- IF (A(IOFF).NE.AS(1+ (I-1)+ (J-1)*LDA)) THEN
- ISAME(4) = .FALSE.
- GO TO 280
-*
- END IF
-*
- 260 CONTINUE
-*
- 270 CONTINUE
- 280 CONTINUE
- ISAME(5) = .TRUE.
- IF (N.GT.0 .AND. INCX.NE.0) ISAME(5) = LSE(XS,X,1,N,ABS(INCX))
- ISAME(6) = INCXS .EQ. INCX
- ISAME(7) = BLS .EQ. BETA
- ISAME(8) = .TRUE.
- IF (N.GT.0 .AND. INCY.NE.0) ISAME(8) = LSE(YS,Y,1,N,ABS(INCY))
- ISAME(9) = INCYS .EQ. INCY
- END IF
-*
- GO TO IGO2
-*
- 290 CONTINUE
-C PROCEDURE (CALL SUBROUTINE)
-C SAVE EVERY DATUM BEFORE THE CALL.
- ICHS = ICI
- NS = N
- KS = K
- ALS = ALPHA
- DO 300 I = 1,N*N
- AS(I) = A(I)
- 300 CONTINUE
- LDAS = LDA
-C SAVE COPY OF THE X AND Y VECTORS.
- IBX = 1
- IF (INCX.LT.0) IBX = 1 + (1-N)*INCX
- DO 310 J = 1,N
- XS(IBX+ (J-1)*INCX) = X(IBX+ (J-1)*INCX)
- 310 CONTINUE
- INCXS = INCX
- BLS = BETA
- IBY = 1
- IF (INCY.LT.0) IBY = 1 + (1-N)*INCY
- DO 320 I = 1,N
- YS(IBY+ (I-1)*INCY) = Y(IBY+ (I-1)*INCY)
- 320 CONTINUE
- INCYS = INCY
- IF (ISNUM.EQ.3) THEN
- CALL SSYMV(ICI,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY)
-*
- ELSE IF (ISNUM.EQ.4) THEN
-C TRANSFER THE MATRIX TO THE DATA STRUCTURE USED WITH SSBMV.
- IF (ICHAR(ICI).EQ.ICHAR('U')) THEN
- KOFF = K
-*
- ELSE
- KOFF = 0
- END IF
-*
- DO 340 J = 1,N
- DO 330 I = MAX(1,J-K),MIN(N,J+K)
- A(1+ (KOFF+I-J)+ (J-1)*LDA) = AS(1+ (I-1)+ (J-1)*LDA)
- 330 CONTINUE
- 340 CONTINUE
- CALL SSBMV(ICI,N,K,ALPHA,A,LDA,X,INCX,BETA,Y,INCY)
-*
- ELSE IF (ISNUM.EQ.5) THEN
-C TRANSFER THE MATRIX TO THE DATA STRUCTURE USED WITH SSPMV.
- IOFF = 0
- DO 360 J = 1,N
- IF (ICHAR(ICI).EQ.ICHAR('U')) THEN
- ISTRT = 1
- IEND = J
-*
- ELSE
- ISTRT = J
- IEND = N
- END IF
-*
- DO 350 I = ISTRT,IEND
- IOFF = IOFF + 1
- A(IOFF) = AS(1+ (I-1)+ (J-1)*LDA)
- 350 CONTINUE
-*
- 360 CONTINUE
- CALL SSPMV(ICI,N,ALPHA,A,X,INCX,BETA,Y,INCY)
- END IF
-*
- GO TO IGO1
-*
- 370 CONTINUE
-C PROCEDURE (DEFINE A SET OF PROBLEM DATA)
-C DO NOTHING IF DIMENSIONS ARE NOT POSITIVE.
- IF (N.LE.0) GO TO IGO3
- TRANSL = ZERO
- CALL SMAKE(A,N,N,LDA,RESET,TRANSL)
-C MAKE THE DATA MATRIX SYMMETRIC.
- DO 390 I = 1,N
- DO 380 J = I,N
- T = (A(1+ (I-1)+ (J-1)*LDA)+A(1+ (J-1)+ (I-1)*LDA))*HALF
- A(1+ (I-1)+ (J-1)*LDA) = T
- A(1+ (J-1)+ (I-1)*LDA) = T
- 380 CONTINUE
- 390 CONTINUE
-C TRIM AWAY ELEMENTS OUTSIDE THE BANDWIDTH FOR SSBMV.
- IF (ISNUM.EQ.4) THEN
- DO 410 J = 1,N
- DO 400 I = 1,N
- T = A(1+ (I-1)+ (J-1)*LDA)
- IF (J.GT.I .AND. J-I.GT.K) T = ZERO
- IF (I.GT.J .AND. I-J.GT.K) T = ZERO
- A(1+ (I-1)+ (J-1)*LDA) = T
- 400 CONTINUE
- 410 CONTINUE
- END IF
-*
- TRANSL = 500.E0
- RESET = .FALSE.
- CALL SMAKE(X,1,N,MAX(1,ABS(INCX)),RESET,TRANSL)
- IF (N.GT.1 .AND. INCX.EQ.1) X(N/2) = ZERO
- TRANSL = ZERO
- CALL SMAKE(Y,1,N,MAX(1,ABS(INCY)),RESET,TRANSL)
- GO TO IGO3
-*
- 420 CONTINUE
-C PROCEDURE (COMPUTE A CORRECT RESULT)
-C COMPUTE THE CONDITION NUMBER TO USE AS GAUGE FOR ACCURATE RESULTS.
-C THIS IS RETURNED IN XT(*).
-C COMPUTE THE APPROXIMATE CORRECT RESULT.
-C THIS IS RETURNED IN YT(*).
- IF (INCY.LT.0) THEN
- IBY = (1-N)*INCY + 1
-*
- ELSE
- IBY = 1
- END IF
-*
- DO 440 I = 1,N
- YT(I) = BETA*YS(IBY+ (I-1)*INCY)
- XT(I) = YS(IBY+ (I-1)*INCY)**2
- IF (INCX.LT.0) THEN
- IBX = (1-N)*INCX + 1
-*
- ELSE
- IBX = 1
- END IF
-*
- DO 430 J = 1,N
- YT(I) = YT(I) + AS(1+ (I-1)+ (J-1)*LDA)*ALPHA*
- . XS(IBX+ (J-1)*INCX)
- XT(I) = XT(I) + AS(1+ (I-1)+ (J-1)*LDA)**2
- 430 CONTINUE
- XT(I) = SQRT(XT(I))
- 440 CONTINUE
- XN = BETA**2
- DO 450 J = 1,N
- XN = XN + XS(IBX+ (J-1)*INCX)**2
- 450 CONTINUE
- XN = SQRT(XN)
-C COMPUTE THE GAUGES FOR THE RESULTS.
- DO 460 I = 1,N
- XT(I) = XT(I)*XN
- 460 CONTINUE
-C COMPUTE THE DIFFERENCES. THEY SHOULD BE SMALL FOR CORRECT RESULTS.
- DO 470 I = 1,N
- YT(I) = YT(I) - Y(IBY+ (I-1)*INCY)
- 470 CONTINUE
-C COMPUTE THE GRADE OF THIS RESULT.
- IGR = 0
- T = ONE
- 480 CONTINUE
-C THIS TEST ALLOWS UP TO A LOSS OF FULL PRECISION BEFORE QUITTING.
- IF (IGR.GT.IG) GO TO 510
- DO 490 I = 1,N
- IF (SDIFF(T*ABS(YT(I))+XT(I),XT(I)).EQ.ZERO) GO TO 490
- T = T*HALF
- IGR = IGR + 1
- GO TO 480
-*
- 490 CONTINUE
-C IF THE LOOP COMPLETES, ALL VALUES ARE 'SMALL.' THE VALUE IGR/IG
-C IS THE GRADE ASSIGNED. THE VALUE OF IGR IS MAXIMIZED OVER ALL THE
-C PROBLEMS.
- 500 CONTINUE
- AVIGR = MAX(AVIGR,REAL(IGR))
- GO TO IGO4
-*
- 510 CONTINUE
- FATAL = .TRUE.
- GO TO 500
-*
-* LAST EXECUTABLE LINE OF SCHCK2
- 9001 FORMAT (' IN SUBPROGRAM ',A,/,' TESTS ACTIVE WITH OPTION = ',A,/,
- . ' N = ',I4,/,' INCX = ',I2,', INCY = ',I2,/,' K =',I4)
- 9011 FORMAT (' IN SUBPROGRAM ',A,/,' ARGUMENT ',I2,
- . ' WAS CHANGED WITH INVALID INPUT.',/,' OPTION = ',A,/,' N = ',
- . I4,/,' INCX = ',I2,', INCY = ',I2,/,' K = ',I4)
- 9021 FORMAT (' IN SUBPROGRAM ',A,/,' ARGUMENT ',I2,
- . ' WAS CHANGED WHILE COMPUTING',/,' OPTION = ',A,/,' N = ',I4,/,
- . ' INCX = ',I2,', INCY = ',I2,/,' K = ',I4)
- 9031 FORMAT (1X,I2,' SUBPROGRAM ',A,T24,'RECEIVED A LOSS GRADE OF ',
- . F5.2,' OUT OF ',I3)
- 9041 FORMAT (1X,I2,' SUBPROGRAM ',A,T24,'FAILED.')
- 9051 FORMAT (1X,I2,' SUBPROGRAM ',A,T24,'NOT TESTED.')
- END
- SUBROUTINE SCHCK3(ISNUM,SNAME,IG,DOPE,NUNIT,AVIGR,FATAL)
-C THIS IS A TEST SUBPROGRAM FOR THE LEVEL TWO BLAS.
-C TEST STRMV, 06, STBMV, 07, STPMV, 08,
-C STRSV, 09, STBSV, 10, AND STPSV, 11.
-C REVISED 860623
-C REVISED YYMMDD
-C AUTH=R. J. HANSON, SANDIA NATIONAL LABS.
-C THIS PROGRAM HAS TWO PARTS. THE FIRST PART CHECKS TO SEE
-C IF ANY DATA GETS CHANGED WHEN NONE SHOULD. FOR EXAMPLE WHEN
-C USING AN INVALID OPTION OR NONPOSITVE PROBLEM DIMENSIONS.
-C THE SECOND PART CHECKS THAT THE RESULTS ARE REASONABLY ACCURATE.
-C DIMENSION AND PROBLEM SIZE DATA..
- INTEGER INC(04),IDIM(06),NUNIT(2)
- LOGICAL ISAME(13),LSE,FATAL,SAME,NCHNG,RESET
- CHARACTER *128 DOPE(2)
- CHARACTER *6 SNAME
- CHARACTER *3 ICHI,ICHJ,ICHK
- CHARACTER *1 ICIU,ICIT,ICID
- CHARACTER *1 ICIUS,ICITS,ICIDS
- INTEGER LA,LV
- PARAMETER (LA=4096,LV=4096,LMN=2048)
- REAL A(LA),AS(LA),X(LV),XS(LV)
- REAL Y(LV),YS(LV),YT(LMN),XT(LMN)
- PARAMETER (ZERO=0.E0,HALF=.5E0,ONE=1.E0)
- COMMON /ARRAYS/AR,AS,X,XS,Y,YS,XT,YT
- EXTERNAL SDIFF
-*
- DATA INC/-2,-1,1,2/
- DATA IDIM/1,2,4,8,64,0/
- DATA ICHI/'LU/'/,ICHJ/'NT/'/,ICHK/'NU/'/
- FATAL = .FALSE.
-C CHECK TRIANGULAR MATRIX-VECTOR PRODUCT, X = A*X, 6-8,
-C AND TRIANGULAR SOLVERS, 9-11.
- IF (ISNUM.LT.0) GO TO 180
- NC = 0
- RESET = .TRUE.
- AVIGR = ZERO
- IX = 0
- 10 IX = IX + 1
- IF (IX.GT.4) GO TO 160
- INCX = INC(IX)
- NN = 0
- 20 NN = NN + 1
- IF (NN.GT.6) GO TO 150
- N = IDIM(NN)
- IC = 0
- 30 IC = IC + 1
- IF (IC.GT.3) GO TO 140
- IF (FATAL) GO TO 170
- ICIU = ICHI(IC:IC)
- ICIT = ICHJ(IC:IC)
- ICID = ICHK(IC:IC)
-C DEFINE DEFAULT VALUE OF K SO PRINTING IS OK.
- K = MAX(0,N-1)
-C DEFINE THE NUMBER OF ARGUMENTS AND THE X ARGUMENT NUMBER.
- LDA = MAX(N,1)
- IF (ICHAR(ICIT).EQ.ICHAR('T')) THEN
- INCRA = LDA
- INCCA = 1
-*
- ELSE
- INCRA = 1
- INCCA = LDA
- END IF
-*
- IF (ISNUM.EQ.6 .OR. ISNUM.EQ.9) THEN
- NARGS = 08
- IXARG = 07
-*
- ELSE IF (ISNUM.EQ.7 .OR. ISNUM.EQ.10) THEN
- NARGS = 09
- IXARG = 08
-C DEFINE BANDWIDTH OF MATRIX FOR TEST OF STBMV.
- K = INT(SQRT(REAL(N))+HALF) - 1
-*
- ELSE IF (ISNUM.EQ.8 .OR. ISNUM.EQ.11) THEN
- NARGS = 07
- IXARG = 06
- END IF
-C DO (PREPARE NOTES FOR THIS TEST)
-C
-C PRINT A MESSAGE THAT GIVES DEBUGGING INFORMATION. THIS
-C MESSAGE SAYS..
-C IN SUBPROGRAM XXXXX TESTS WERE ACTIVE WITH
-C OPTIONS = 'A' 'A' 'A'
-C N = IIII,
-C INCX = IIII C K = IIII.
-C THE MAIN IDEA HERE IS THAT A SERIOUS BUG THAT OCCURS DURING THE
-C TESTING OF THESE SUBPROGRAMS MAY LOSE PROGRAM CONTROL. THIS
-C AUXILLIARY FILE CONTAINS THE DIMENSIONS THAT RESULTED IN THE LOSS
-C OF CONTROL. HENCE IT PROVIDES THE IMPLEMENTOR WITH MORE COMPLETE
-C INFORMATION ABOUT WHERE TO START TRACKING DOWN THE BUG.
- IF (NUNIT(1).GT.0) THEN
-C IF UNIT IS NOT AVAILABLE WITH 'NEW' STATUS, OPEN WITH
-C 'OLD' AND THEN DELETE IT.
- ISTAT = 1
- CALL SOPEN(NUNIT(1),DOPE(1),ISTAT,IERROR)
- IF (IERROR.EQ.1) GO TO 40
-C GET RID OF ANY OLD FILE.
- CLOSE (UNIT=NUNIT(1),STATUS='DELETE',ERR=40)
- 40 CONTINUE
- ISTAT = 2
-C CREATE A NEW FILE FOR THE NEXT TEST.
- CALL SOPEN(NUNIT(1),DOPE(1),ISTAT,IERROR)
- IF (IERROR.EQ.0) GO TO 60
- 50 CONTINUE
- NMESS = 7
-C DO (PRINT A MESSAGE)
-C PRINT AN ERROR MESSAGE ABOUT OPENING THE NAME FILE.
- CALL SMESSG(0,1,NMESS)
- FATAL = .TRUE.
- GO TO 170
-*
- 60 CONTINUE
- WRITE (NUNIT(1),9001) SNAME,ICIU,ICIT,ICID,N,INCX,K
-C CLOSE THE FILE SO USEFUL STATUS INFORMATION IS SEALED.
- CLOSE (UNIT=NUNIT(1))
- END IF
-C DO (DEFINE A SET OF PROBLEM DATA)
- ASSIGN 70 TO IGO3
- GO TO 330
-*
- 70 CONTINUE
-C DO (CALL SUBROUTINE)
- ASSIGN 80 TO IGO1
- GO TO 260
-*
- 80 CONTINUE
- IF (N.LE.0 .OR. ICHAR(ICIU).EQ.ICHAR('/') .OR. ICHAR(ICIT).EQ.
- . ICHAR('/') .OR. ICHAR(ICID).EQ.ICHAR('/')) THEN
-C DO (SEE WHAT DATA CHANGED INSIDE SUBROUTINES)
- ASSIGN 90 TO IGO2
- GO TO 200
-*
- 90 CONTINUE
-C IF DATA WAS INCORRECTLY CHANGED, MAKE NOTES AND RETURN.
- SAME = .TRUE.
- DO 100 I = 1,NARGS
- SAME = SAME .AND. ISAME(I)
- IF ( .NOT. ISAME(I)) THEN
- WRITE (NUNIT(2),9011) SNAME,I,ICIU,ICIT,ICID,N,INCX,K
- END IF
-*
- 100 CONTINUE
- IF ( .NOT. SAME) THEN
- FATAL = .TRUE.
- GO TO 170
-*
- END IF
-*
- ELSE
-C DO (SEE WHAT DATA CHANGED INSIDE SUBROUTINES)
- ASSIGN 110 TO IGO2
- GO TO 200
-*
- 110 CONTINUE
-C IF DATA WAS INCORRECTLY CHANGED, MAKE NOTES AND RETURN.
- SAME = .TRUE.
- DO 120 I = 1,NARGS
- NCHNG = (I.EQ.IXARG .OR. ISAME(I))
- SAME = SAME .AND. NCHNG
- IF ( .NOT. NCHNG) THEN
- WRITE (NUNIT(2),9021) SNAME,I,ICIU,ICIT,ICID,N,INCX,K
- END IF
-*
- 120 CONTINUE
- IF ( .NOT. SAME) THEN
- FATAL = .TRUE.
- GO TO 170
-*
- END IF
-*
- NC = NC + 1
-C DO (COMPUTE A CORRECT RESULT)
- ASSIGN 130 TO IGO4
- GO TO 380
-*
- 130 CONTINUE
-C IF GOT REALLY BAD ANSWER, PRINT NOTE AND GO BACK.
- IF (FATAL) GO TO 160
-*
- END IF
-*
- GO TO 30
-*
- 140 CONTINUE
- GO TO 20
-*
- 150 CONTINUE
- GO TO 10
-*
- 160 CONTINUE
-C REPORT ON ACCURACY OF DATA.
- WRITE (NUNIT(2),9031) ISNUM,SNAME,AVIGR,IG
- GO TO 190
-*
- 170 CONTINUE
- WRITE (NUNIT(2),9041) ISNUM,SNAME
- GO TO 190
-*
- 180 CONTINUE
- WRITE (NUNIT(2),9051) - ISNUM,SNAME
- 190 CONTINUE
- RETURN
-*
- 200 CONTINUE
-C PROCEDURE (SEE WHAT DATA CHANGED INSIDE SUBROUTINES)
- ISAME(1) = ICHAR(ICIU) .EQ. ICHAR(ICIUS)
- ISAME(2) = ICHAR(ICIT) .EQ. ICHAR(ICITS)
- ISAME(3) = ICHAR(ICID) .EQ. ICHAR(ICIDS)
- ISAME(4) = NS .EQ. N
- IF (ISNUM.EQ.6 .OR. ISNUM.EQ.9) THEN
- ISAME(5) = .TRUE.
- IF (N.GT.0) ISAME(5) = LSE(AS,A,N,N,LDA)
- ISAME(6) = LDAS .EQ. LDA
- ISAME(7) = .TRUE.
- IF (N.GT.0) ISAME(7) = LSE(XS,X,1,N,ABS(INCX))
- ISAME(8) = INCXS .EQ. INCX
-*
- ELSE IF (ISNUM.EQ.7 .OR. ISNUM.EQ.10) THEN
-C COMPARE THE MATRIX IN THE STBMV AND STPMV DATA STRUCTURES WITH
-C THE SAVED COPY.
- ISAME(5) = KS .EQ. K
- ISAME(6) = .TRUE.
- IF (N.GT.0) THEN
- DO 220 J = 1,N
- IF (ICHAR(ICIU).EQ.ICHAR('U')) THEN
- ISTRT = MAX(1,J-K)
- IEND = J
-*
- ELSE
- ISTRT = J
- IEND = MIN(N,J+K)
- END IF
-*
- DO 210 I = ISTRT,IEND
- IF (AS(1+ (I-1)+ (J-1)*LDA).NE.
- . A(1+ (KOFF+I-J)+ (J-1)*LDA)) THEN
- ISAME(6) = .FALSE.
- GO TO 230
-*
- END IF
-*
- 210 CONTINUE
- 220 CONTINUE
- 230 CONTINUE
- END IF
-*
- ISAME(7) = LDAS .EQ. LDA
- ISAME(8) = .TRUE.
- IF (N.GT.0) ISAME(8) = LSE(XS,X,1,N,ABS(INCX))
- ISAME(9) = INCXS .EQ. INCX
-*
- ELSE IF (ISNUM.EQ.8 .OR. ISNUM.EQ.11) THEN
- ISAME(5) = .TRUE.
- IOFF = 0
- DO 250 J = 1,N
- IF (ICHAR(ICIU).EQ.ICHAR('U')) THEN
- ISTRT = 1
- IEND = J
-*
- ELSE
- ISTRT = J
- IEND = N
- END IF
-*
- DO 240 I = ISTRT,IEND
- IOFF = IOFF + 1
- IF (A(IOFF).NE.AS(1+ (I-1)+ (J-1)*
- . LDA)) ISAME(5) = .FALSE.
- 240 CONTINUE
-*
- 250 CONTINUE
- ISAME(6) = .TRUE.
- IF (N.GT.0) ISAME(6) = LSE(XS,X,1,N,ABS(INCX))
- ISAME(7) = INCXS .EQ. INCX
- END IF
-*
- GO TO IGO2
-*
- 260 CONTINUE
-C PROCEDURE (CALL SUBROUTINE)
-C SAVE EVERY DATUM BEFORE THE CALL.
- ICIUS = ICIU
- ICITS = ICIT
- ICIDS = ICID
- NS = N
- KS = K
- DO 270 I = 1,N*N
- AS(I) = A(I)
- 270 CONTINUE
- LDAS = LDA
-C SAVE COPY OF THE X VECTOR.
- IBX = 1
- IF (INCX.LT.0) IBX = 1 + (1-N)*INCX
- DO 280 J = 1,N
- XS(IBX+ (J-1)*INCX) = X(IBX+ (J-1)*INCX)
- 280 CONTINUE
- INCXS = INCX
- IF (ISNUM.EQ.6) THEN
- CALL STRMV(ICIU,ICIT,ICID,N,A,LDA,X,INCX)
-*
- ELSE IF (ISNUM.EQ.9) THEN
- CALL STRSV(ICIU,ICIT,ICID,N,A,LDA,X,INCX)
-*
- ELSE IF (ISNUM.EQ.7 .OR. ISNUM.EQ.10) THEN
-C TRANSFER THE MATRIX TO THE DATA STRUCTURE USED WITH STBMV.
- IF (ICHAR(ICIU).EQ.ICHAR('U')) THEN
- KOFF = K
-*
- ELSE
- KOFF = 0
- END IF
-*
- DO 300 J = 1,N
- IF (ICHAR(ICIU).EQ.ICHAR('U')) THEN
- ISTRT = MAX(1,J-K)
- IEND = J
-*
- ELSE
- ISTRT = J
- IEND = MIN(N,J+K)
- END IF
-*
- DO 290 I = ISTRT,IEND
- A(1+ (KOFF+I-J)+ (J-1)*LDA) = AS(1+ (I-1)+ (J-1)*LDA)
- 290 CONTINUE
- 300 CONTINUE
- IF (ISNUM.EQ.7) CALL STBMV(ICIU,ICIT,ICID,N,K,A,LDA,X,INCX)
- IF (ISNUM.EQ.10) CALL STBSV(ICIU,ICIT,ICID,N,K,A,LDA,X,INCX)
-*
- ELSE IF (ISNUM.EQ.8 .OR. ISNUM.EQ.11) THEN
-C TRANSFER THE MATRIX TO THE DATA STRUCTURE USED WITH STPMV.
- IOFF = 0
- DO 320 J = 1,N
- IF (ICHAR(ICIU).EQ.ICHAR('U')) THEN
- ISTRT = 1
- IEND = J
-*
- ELSE
- ISTRT = J
- IEND = N
- END IF
-*
- DO 310 I = ISTRT,IEND
- IOFF = IOFF + 1
- A(IOFF) = AS(1+ (I-1)+ (J-1)*LDA)
- 310 CONTINUE
-*
- 320 CONTINUE
- IF (ISNUM.EQ.8) CALL STPMV(ICIU,ICIT,ICID,N,A,X,INCX)
- IF (ISNUM.EQ.11) CALL STPSV(ICIU,ICIT,ICID,N,A,X,INCX)
- END IF
-*
- GO TO IGO1
-*
- 330 CONTINUE
-C PROCEDURE (DEFINE A SET OF PROBLEM DATA)
-C DO NOTHING IF DIMENSIONS ARE NOT POSITIVE.
- IF (N.LE.0) GO TO IGO3
- TRANSL = ZERO
- CALL SMAKE(A,N,N,LDA,RESET,TRANSL)
-C MAKE THE DATA MATRIX TRIANGULAR.
- DO 350 I = 1,N
- DO 340 J = 1,N
- T = A(1+INCRA* (I-1)+ (J-1)*INCCA)
- S = A(1+INCRA* (J-1)+ (I-1)*INCCA)
-C SCALE TERMS SO THAT UNIT MATRICES ARE WELL-CONDITIONED.
- S = S/1000.E0
- T = T/1000.E0
- IF (ICHAR(ICIU).EQ.ICHAR('L') .AND. I.LT.J) T = ZERO
- IF (ICHAR(ICIU).EQ.ICHAR('U') .AND. I.GT.J) S = ZERO
- IF (ICHAR(ICID).EQ.ICHAR('U') .AND. I.EQ.J) THEN
- S = ONE
- T = ONE
- END IF
-*
- A(1+INCRA* (I-1)+ (J-1)*INCCA) = T
- A(1+INCRA* (J-1)+ (I-1)*INCCA) = S
- 340 CONTINUE
- 350 CONTINUE
-C TRIM AWAY ELEMENTS OUTSIDE THE BANDWIDTH FOR STBMV.
- IF (ISNUM.EQ.7 .OR. ISNUM.EQ.10) THEN
- DO 370 I = 1,N
- DO 360 J = 1,N
- T = A(1+INCRA* (I-1)+ (J-1)*INCCA)
- IF (J.GT.I .AND. J-I.GT.K) T = ZERO
- IF (I.GT.J .AND. I-J.GT.K) T = ZERO
- A(1+INCRA* (I-1)+ (J-1)*INCCA) = T
- 360 CONTINUE
- 370 CONTINUE
- END IF
-*
- TRANSL = 500.E0
- RESET = .FALSE.
- CALL SMAKE(X,1,N,MAX(1,ABS(INCX)),RESET,TRANSL)
- IF (N.GT.1 .AND. INCX.EQ.1) X(N/2) = ZERO
- GO TO IGO3
-*
- 380 CONTINUE
-C PROCEDURE (COMPUTE A CORRECT RESULT)
-C COMPUTE THE CONDITION NUMBER TO USE AS GAUGE FOR ACCURATE RESULTS.
-C THIS IS RETURNED IN XT(*).
-C COMPUTE THE APPROXIMATE CORRECT RESULT.
-C THIS IS RETURNED IN YT(*).
- DO 400 I = 1,N
- YT(I) = ZERO
- XT(I) = ZERO
- IF (INCX.LT.0) THEN
- IBX = (1-N)*INCX + 1
-*
- ELSE
- IBX = 1
- END IF
-*
- DO 390 J = 1,N
- T = XS(IBX+ (J-1)*INCX)
- IF (ISNUM.GE.9) T = X(IBX+ (J-1)*INCX)
- YT(I) = YT(I) + AS(1+ (I-1)*INCRA+ (J-1)*INCCA)*T
- XT(I) = XT(I) + AS(1+ (I-1)*INCRA+ (J-1)*INCCA)**2
- 390 CONTINUE
- XT(I) = SQRT(XT(I))
- 400 CONTINUE
- XN = ZERO
- DO 410 J = 1,N
- T = XS(IBX+ (J-1)*INCX)
- IF (ISNUM.GE.9) T = X(IBX+ (J-1)*INCX)
- XN = XN + T**2
- 410 CONTINUE
- XN = SQRT(XN)
-C COMPUTE THE GAUGES FOR THE RESULTS.
- DO 420 I = 1,N
- XT(I) = XT(I)*XN
- 420 CONTINUE
-C COMPUTE THE DIFFERENCES. THEY SHOULD BE SMALL FOR CORRECT RESULTS.
- DO 430 I = 1,N
- T = X(IBX+ (I-1)*INCX)
- IF (ISNUM.GE.9) T = XS(IBX+ (I-1)*INCX)
- YT(I) = YT(I) - T
- 430 CONTINUE
-C COMPUTE THE GRADE OF THIS RESULT.
- IGR = 0
- T = ONE
- 440 CONTINUE
-C THIS TEST ALLOWS UP TO A LOSS OF FULL PRECISION BEFORE QUITTING.
- IF (IGR.GE.IG) GO TO 470
- DO 450 I = 1,N
- IF (SDIFF(T*ABS(YT(I))+XT(I),XT(I)).EQ.ZERO) GO TO 450
- T = T*HALF
- IGR = IGR + 1
- GO TO 440
-*
- 450 CONTINUE
-C IF THE LOOP COMPLETES, ALL VALUES ARE 'SMALL.' THE VALUE IGR/IG
-C IS THE GRADE ASSIGNED. THE VALUE OF IGR IS MAXIMIZED OVER ALL THE
-C PROBLEMS.
- 460 CONTINUE
- AVIGR = MAX(AVIGR,REAL(IGR))
- GO TO IGO4
-*
- 470 CONTINUE
- FATAL = .TRUE.
- GO TO 460
-*
-* LAST EXECUTABLE LINE OF SCHCK3
- 9001 FORMAT (' IN SUBPROGRAM ',A,/,' TESTS ACTIVE WITH OPTIONS = ',
- . 3 (A,2X),/,' N = ',I4,/,' INCX = ',I2,/,' K =',I4)
- 9011 FORMAT (' IN SUBPROGRAM ',A,/,' ARGUMENT ',I2,
- . ' WAS CHANGED WITH INVALID INPUT.',/,' OPTIONS = ',3 (A,2X),/,
- . ' N = ',I4,/,' INCX = ',I2,/,' K = ',I4)
- 9021 FORMAT (' IN SUBPROGRAM ',A,/,' ARGUMENT ',I2,
- . ' WAS CHANGED WHILE COMPUTING',/,' OPTIONS = ',3 (A,2X),/,
- . ' N = ',I4,/,' INCX = ',I2,/,' K = ',I4)
- 9031 FORMAT (1X,I2,' SUBPROGRAM ',A,T24,'RECEIVED A LOSS GRADE OF ',
- . F5.2,' OUT OF ',I3)
- 9041 FORMAT (1X,I2,' SUBPROGRAM ',A,T24,'FAILED.')
- 9051 FORMAT (1X,I2,' SUBPROGRAM ',A,T24,'NOT TESTED.')
- END
- SUBROUTINE SCHCK4(ISNUM,SNAME,IG,DOPE,NUNIT,AVIGR,FATAL)
-C THIS IS A TEST SUBPROGRAM FOR THE LEVEL TWO BLAS.
-C TEST SGER, 12.
-C REVISED 860623
-C REVISED YYMMDD
-C AUTH=R. J. HANSON, SANDIA NATIONAL LABS.
-C THIS PROGRAM HAS TWO PARTS. THE FIRST PART CHECKS TO SEE
-C IF ANY DATA GETS CHANGED WHEN NONE SHOULD. FOR EXAMPLE WHEN
-C USING AN INVALID OPTION OR NONPOSITVE PROBLEM DIMENSIONS.
-C THE SECOND PART CHECKS THAT THE RESULTS ARE REASONABLY ACCURATE.
-C DIMENSION AND PROBLEM SIZE DATA..
- INTEGER INC(04),IDIM(08),NUNIT(2)
- REAL ALF(04),SDIFF
- LOGICAL ISAME(13),LSE,FATAL,SAME,NCHNG,RESET
- CHARACTER *128 DOPE(2)
- CHARACTER *6 SNAME
- INTEGER LA,LV
- PARAMETER (LA=4096,LV=4096,LMN=2048)
- REAL A(LA),AS(LA),X(LV),XS(LV)
- REAL Y(LV),YS(LV),YT(LMN),XT(LMN)
- PARAMETER (ZERO=0.E0,HALF=.5E0,ONE=1.E0)
- COMMON /ARRAYS/AR,AS,X,XS,Y,YS,YT,XT
- EXTERNAL SDIFF
-*
- DATA ALF/-1.E0,2.E0,.3E0,1.E0/
- DATA INC/-2,-1,1,2/
- DATA IDIM/1,2,4,8,64,128,2048,0/
- FATAL = .FALSE.
-C CHECK GENERAL RANK 1 UPDATE, 12.
- IF (ISNUM.LT.0) GO TO 200
- NC = 0
- RESET = .TRUE.
- AVIGR = ZERO
- IX = 0
- 10 IX = IX + 1
- IF (IX.GT.4) GO TO 180
- INCX = INC(IX)
- ALPHA = ALF(IX)
- IY = 0
- 20 IY = IY + 1
- IF (IY.GT.4) GO TO 170
- INCY = INC(IY)
- MM = 0
- 30 MM = MM + 1
- IF (MM.GT.8) GO TO 160
- M = IDIM(MM)
- NN = 0
- 40 NN = NN + 1
- IF (NN.GT.8) GO TO 150
- N = IDIM(NN)
- IF (FATAL) GO TO 190
- ML = N
- NL = M
- INCCA = M
- INCRA = 1
-C DEFINE THE NUMBER OF ARGUMENTS AND THE A ARGUMENT NUMBER.
- LDA = MAX(M,1)
- NARGS = 09
- IAARG = 08
-C IF NOT ENOUGH STORAGE, SKIP THIS CASE. (AVOID EXPLICT M*N).
- IF (SQRT(REAL(N))*SQRT(REAL(M)).GT.SQRT(REAL(LA))) GO TO 40
-C DO (PREPARE NOTES FOR THIS TEST)
-C
-C PRINT A MESSAGE THAT GIVES DEBUGGING INFORMATION. THIS
-C MESSAGE SAYS..
-C IN SUBPROGRAM XXXXX TESTS WERE ACTIVE WITH
-C M = IIII, N = IIII,
-C INCX = IIII, INCY = IIII,
-C THE MAIN IDEA HERE IS THAT A SERIOUS BUG THAT OCCURS DURING THE
-C TESTING OF THESE SUBPROGRAMS MAY LOSE PROGRAM CONTROL. THIS
-C AUXILLIARY FILE CONTAINS THE DIMENSIONS THAT RESULTED IN THE LOSS
-C OF CONTROL. HENCE IT PROVIDES THE IMPLEMENTOR WITH MORE COMPLETE
-C INFORMATION ABOUT WHERE TO START TRACKING DOWN THE BUG.
- IF (NUNIT(1).GT.0) THEN
-C IF UNIT IS NOT AVAILABLE WITH 'NEW' STATUS, OPEN WITH
-C 'OLD' AND THEN DELETE IT.
- ISTAT = 1
- CALL SOPEN(NUNIT(1),DOPE(1),ISTAT,IERROR)
- IF (IERROR.EQ.1) GO TO 50
-C GET RID OF ANY OLD FILE.
- CLOSE (UNIT=NUNIT(1),STATUS='DELETE',ERR=50)
- 50 CONTINUE
- ISTAT = 2
-C CREATE A NEW FILE FOR THE NEXT TEST.
- CALL SOPEN(NUNIT(1),DOPE(1),ISTAT,IERROR)
- IF (IERROR.EQ.0) GO TO 70
- 60 CONTINUE
- NMESS = 7
-C DO (PRINT A MESSAGE)
-C PRINT AN ERROR MESSAGE ABOUT OPENING THE NAME FILE.
- CALL SMESSG(0,1,NMESS)
- FATAL = .TRUE.
- GO TO 190
-*
- 70 CONTINUE
- WRITE (NUNIT(1),9001) SNAME,M,N,INCX,INCY
-C CLOSE THE FILE SO USEFUL STATUS INFORMATION IS SEALED.
- CLOSE (UNIT=NUNIT(1))
- END IF
-C DO (DEFINE A SET OF PROBLEM DATA)
- ASSIGN 80 TO IGO3
- GO TO 270
-*
- 80 CONTINUE
-C DO (CALL SUBROUTINE)
- ASSIGN 90 TO IGO1
- GO TO 230
-*
- 90 CONTINUE
- IF (M.LE.0 .OR. N.LE.0) THEN
-C DO (SEE WHAT DATA CHANGED INSIDE SUBROUTINES)
- ASSIGN 100 TO IGO2
- GO TO 220
-*
- 100 CONTINUE
-C IF DATA WAS INCORRECTLY CHANGED, MAKE NOTES AND RETURN.
- SAME = .TRUE.
- DO 110 I = 1,NARGS
- SAME = SAME .AND. ISAME(I)
- IF ( .NOT. ISAME(I)) THEN
- WRITE (NUNIT(2),9011) SNAME,I,M,N,INCX,INCY
- END IF
-*
- 110 CONTINUE
- IF ( .NOT. SAME) THEN
- FATAL = .TRUE.
- GO TO 190
-*
- END IF
-*
- ELSE
-C DO (SEE WHAT DATA CHANGED INSIDE SUBROUTINES)
- ASSIGN 120 TO IGO2
- GO TO 220
-*
- 120 CONTINUE
-C IF DATA WAS INCORRECTLY CHANGED, MAKE NOTES AND RETURN.
- SAME = .TRUE.
- DO 130 I = 1,NARGS
- NCHNG = (I.EQ.IAARG .OR. ISAME(I))
- SAME = SAME .AND. NCHNG
- IF ( .NOT. NCHNG) THEN
- WRITE (NUNIT(2),9021) SNAME,I,M,N,INCX,INCY
- END IF
-*
- 130 CONTINUE
- IF ( .NOT. SAME) THEN
- FATAL = .TRUE.
- GO TO 190
-*
- END IF
-*
- NC = NC + 1
-C DO (COMPUTE A CORRECT RESULT)
- ASSIGN 140 TO IGO4
- GO TO 280
-*
- 140 CONTINUE
-C IF GOT REALLY BAD ANSWER, PRINT NOTE AND GO BACK.
- IF (FATAL) GO TO 180
-*
- END IF
-*
- GO TO 40
-*
- 150 CONTINUE
- GO TO 30
-*
- 160 CONTINUE
- GO TO 20
-*
- 170 CONTINUE
- GO TO 10
-*
- 180 CONTINUE
-C REPORT ON ACCURACY OF DATA.
- WRITE (NUNIT(2),9031) ISNUM,SNAME,AVIGR,IG
- GO TO 210
-*
- 190 CONTINUE
- WRITE (NUNIT(2),9041) ISNUM,SNAME
- GO TO 210
-*
- 200 CONTINUE
- WRITE (NUNIT(2),9051) - ISNUM,SNAME
- 210 CONTINUE
- RETURN
-*
- 220 CONTINUE
-C PROCEDURE (SEE WHAT DATA CHANGED INSIDE SUBROUTINES)
- ISAME(1) = MS .EQ. M
- ISAME(2) = NS .EQ. N
- ISAME(3) = ALS .EQ. ALPHA
- ISAME(4) = .TRUE.
- IF (NL.GT.0 .AND. INCX.NE.0) ISAME(4) = LSE(XS,X,1,NL,ABS(INCX))
- ISAME(5) = INCXS .EQ. INCX
- ISAME(6) = .TRUE.
- IF (ML.GT.0 .AND. INCY.NE.0) ISAME(6) = LSE(YS,Y,1,ML,ABS(INCY))
- ISAME(7) = INCYS .EQ. INCY
- ISAME(8) = .TRUE.
- IF (M.GT.0 .AND. N.GT.0) ISAME(8) = LSE(AS,A,M,N,LDA)
- ISAME(9) = LDAS .EQ. LDA
-*
- GO TO IGO2
-*
- 230 CONTINUE
-C PROCEDURE (CALL SUBROUTINE)
-C SAVE EVERY DATUM BEFORE THE CALL.
- MS = M
- NS = N
- ALS = ALPHA
- DO 240 I = 1,M*N
- AS(I) = A(I)
- 240 CONTINUE
- LDAS = LDA
-C SAVE COPY OF THE X AND Y VECTORS.
- IBX = 1
- IF (INCX.LT.0) IBX = 1 + (1-NL)*INCX
- DO 250 J = 1,NL
- XS(IBX+ (J-1)*INCX) = X(IBX+ (J-1)*INCX)
- 250 CONTINUE
- INCXS = INCX
- IBY = 1
- IF (INCY.LT.0) IBY = 1 + (1-ML)*INCY
- DO 260 I = 1,ML
- YS(IBY+ (I-1)*INCY) = Y(IBY+ (I-1)*INCY)
- 260 CONTINUE
- INCYS = INCY
- CALL SGER(M,N,ALPHA,X,INCX,Y,INCY,A,LDA)
-*
- GO TO IGO1
-*
- 270 CONTINUE
-C PROCEDURE (DEFINE A SET OF PROBLEM DATA)
-C DO NOTHING IF BOTH DIMENSIONS ARE NOT POSITIVE.
- IF (M.LE.0 .OR. N.LE.0) GO TO IGO3
- TRANSL = ZERO
- CALL SMAKE(A,M,N,LDA,RESET,TRANSL)
-*
- TRANSL = 500.E0
- RESET = .FALSE.
- CALL SMAKE(X,1,NL,MAX(1,ABS(INCX)),RESET,TRANSL)
- IF (NL.GT.1 .AND. INCX.EQ.1) X(NL/2) = ZERO
- TRANSL = ZERO
- CALL SMAKE(Y,1,ML,MAX(1,ABS(INCY)),RESET,TRANSL)
- GO TO IGO3
-*
- 280 CONTINUE
-C PROCEDURE (COMPUTE A CORRECT RESULT)
-C COMPUTE THE CONDITION NUMBER TO USE AS GAUGE FOR ACCURATE RESULTS.
-C THIS IS RETURNED IN XT(*).
-C COMPUTE THE APPROXIMATE CORRECT RESULT.
-C THIS IS RETURNED IN YT(*), COLUMN BY COLUMN.
- IF (INCY.LT.0) THEN
- IBY = (1-ML)*INCY + 1
-*
- ELSE
- IBY = 1
- END IF
-*
- DO 340 J = 1,N
- DO 290 I = 1,M
- IF (INCX.LT.0) THEN
- IBX = (1-NL)*INCX + 1
-*
- ELSE
- IBX = 1
- END IF
-*
- YT(I) = AS(1+ (I-1)*INCRA+ (J-1)*INCCA) +
- . ALPHA*XS(IBX+ (I-1)*INCX)*YS(IBY+ (J-1)*INCY)
- XT(I) = AS(1+ (I-1)*INCRA+ (J-1)*INCCA)**2 +
- . ALPHA**2*XS(IBX+ (I-1)*INCX)**2*
- . YS(IBY+ (J-1)*INCY)**2
-C COMPUTE THE GAUGES FOR THE RESULTS.
- XT(I) = SQRT(XT(I))
- 290 CONTINUE
-C COMPUTE THE DIFFERENCES. THEY SHOULD BE SMALL FOR CORRECT RESULTS.
- DO 300 I = 1,M
- YT(I) = YT(I) - A(1+ (I-1)*INCRA+ (J-1)*INCCA)
- 300 CONTINUE
-C COMPUTE THE GRADE OF THIS RESULT.
- IGR = 0
- T = ONE
- 310 CONTINUE
-C THIS TEST ALLOWS UP TO A LOSS OF FULL PRECISION BEFORE QUITTING.
- IF (IGR.GE.IG) GO TO 360
- DO 320 I = 1,M
- IF (SDIFF(T*ABS(YT(I))+XT(I),XT(I)).EQ.ZERO) GO TO 320
- T = T*HALF
- IGR = IGR + 1
- GO TO 310
-*
- 320 CONTINUE
-C IF THE LOOP COMPLETES, ALL VALUES ARE 'SMALL.' THE VALUE IGR/IG
-C IS THE GRADE ASSIGNED. THE VALUE OF IGR IS MAXIMIZED OVER ALL THE
-C PROBLEMS.
- 330 CONTINUE
- 340 CONTINUE
- 350 AVIGR = MAX(AVIGR,REAL(IGR))
- GO TO IGO4
-*
- 360 CONTINUE
- FATAL = .TRUE.
- GO TO 350
-*
-* LAST EXECUTABLE LINE OF SCHCK4
- 9001 FORMAT (' IN SUBPROGRAM ',A,/,' M =',I4,', N = ',I4,/,' INCX = ',
- . I2,', INCY = ',I2)
- 9011 FORMAT (' IN SUBPROGRAM ',A,/,' ARGUMENT ',I2,
- . ' WAS CHANGED WITH INVALID INPUT.',/,' M =',I4,', N = ',I4,/,
- . ' INCX = ',I2,', INCY = ',I2)
- 9021 FORMAT (' IN SUBPROGRAM ',A,/,' ARGUMENT ',I2,
- . ' WAS CHANGED WHILE COMPUTING',/,' M =',I4,', N = ',I4,/,
- . ' INCX = ',I2,', INCY = ',I2)
- 9031 FORMAT (1X,I2,' SUBPROGRAM ',A,T24,'RECEIVED A LOSS GRADE OF ',
- . F5.2,' OUT OF ',I3)
- 9041 FORMAT (1X,I2,' SUBPROGRAM ',A,T24,'FAILED.')
- 9051 FORMAT (1X,I2,' SUBPROGRAM ',A,T24,'NOT TESTED.')
- END
- SUBROUTINE SCHCK5(ISNUM,SNAME,IG,DOPE,NUNIT,AVIGR,FATAL)
-C THIS IS A TEST SUBPROGRAM FOR THE LEVEL TWO BLAS.
-C TEST SSYR, 13, SSPR, 14, SSYR2, 15, AND SSPR2,16.
-C REVISED 860623
-C REVISED YYMMDD
-C AUTH=R. J. HANSON, SANDIA NATIONAL LABS.
-C THIS PROGRAM HAS TWO PARTS. THE FIRST PART CHECKS TO SEE
-C IF ANY DATA GETS CHANGED WHEN NONE SHOULD. FOR EXAMPLE WHEN
-C USING AN INVALID OPTION OR NONPOSITVE PROBLEM DIMENSIONS.
-C THE SECOND PART CHECKS THAT THE RESULTS ARE REASONABLY ACCURATE.
-C DIMENSION AND PROBLEM SIZE DATA..
- INTEGER INC(04),IDIM(06),NUNIT(2)
- REAL ALF(04)
- LOGICAL ISAME(13),LSE,FATAL,SAME,NCHNG,RESET
- CHARACTER *128 DOPE(2)
- CHARACTER *6 SNAME
- CHARACTER *3 ICH
- CHARACTER *1 ICHS,ICI
- INTEGER LA,LV
- PARAMETER (LA=4096,LV=4096,LMN=2048)
- REAL A(LA),AS(LA),X(LV),XS(LV)
- REAL Y(LV),YS(LV),YT(LMN),XT(LMN)
- PARAMETER (ZERO=0.E0,HALF=.5E0,ONE=1.E0)
- COMMON /ARRAYS/AR,AS,X,XS,Y,YS,YT,XT
- EXTERNAL SDIFF
-*
- DATA ALF/-1.E0,2.E0,.3E0,1.E0/
- DATA INC/-2,-1,1,2/
- DATA IDIM/1,2,4,8,64,0/
- DATA ICH/'LU/'/
- FATAL = .FALSE.
-C CHECK SYMMETRIC MATRIX RANK 1 AND RANK 2 UPDATES.
- IF (ISNUM.LT.0) GO TO 200
- NC = 0
- RESET = .TRUE.
- AVIGR = ZERO
- IX = 0
- 10 IX = IX + 1
- IF (IX.GT.4) GO TO 180
- INCX = INC(IX)
- ALPHA = ALF(IX)
- IY = 0
- 20 IY = IY + 1
- IF (IY.GT.4) GO TO 170
- INCY = INC(IY)
- NN = 0
- 30 NN = NN + 1
- IF (NN.GT.6) GO TO 160
- N = IDIM(NN)
- IC = 0
- 40 IC = IC + 1
- IF (IC.GT.3) GO TO 150
- IF (FATAL) GO TO 190
- ICI = ICH(IC:IC)
-C DEFINE THE NUMBER OF ARGUMENTS AND THE Y ARGUMENT NUMBER.
- LDA = MAX(N,1)
- IF (ISNUM.EQ.13) THEN
- NARGS = 07
- IAARG = 06
-*
- ELSE IF (ISNUM.EQ.14) THEN
- NARGS = 06
- IAARG = 06
-*
- ELSE IF (ISNUM.EQ.15) THEN
- NARGS = 9
- IAARG = 8
-*
- ELSE IF (ISNUM.EQ.16) THEN
- NARGS = 8
- IAARG = 8
- END IF
-C DO (PREPARE NOTES FOR THIS TEST)
-C
-C PRINT A MESSAGE THAT GIVES DEBUGGING INFORMATION. THIS
-C MESSAGE SAYS..
-C IN SUBPROGRAM XXXXX TESTS WERE ACTIVE WITH
-C OPTION = 'A'
-C N = IIII,
-C INCX = IIII, INCY = IIII,
-C THE MAIN IDEA HERE IS THAT A SERIOUS BUG THAT OCCURS DURING THE
-C TESTING OF THESE SUBPROGRAMS MAY LOSE PROGRAM CONTROL. THIS
-C AUXILLIARY FILE CONTAINS THE DIMENSIONS THAT RESULTED IN THE LOSS
-C OF CONTROL. HENCE IT PROVIDES THE IMPLEMENTOR WITH MORE COMPLETE
-C INFORMATION ABOUT WHERE TO START TRACKING DOWN THE BUG.
- IF (NUNIT(1).GT.0) THEN
-C IF UNIT IS NOT AVAILABLE WITH 'NEW' STATUS, OPEN WITH
-C 'OLD' AND THEN DELETE IT.
- ISTAT = 1
- CALL SOPEN(NUNIT(1),DOPE(1),ISTAT,IERROR)
- IF (IERROR.EQ.1) GO TO 50
-C GET RID OF ANY OLD FILE.
- CLOSE (UNIT=NUNIT(1),STATUS='DELETE',ERR=50)
- 50 CONTINUE
- ISTAT = 2
-C CREATE A NEW FILE FOR THE NEXT TEST.
- CALL SOPEN(NUNIT(1),DOPE(1),ISTAT,IERROR)
- IF (IERROR.EQ.0) GO TO 70
- 60 CONTINUE
- NMESS = 7
-C DO (PRINT A MESSAGE)
-C PRINT AN ERROR MESSAGE ABOUT OPENING THE NAME FILE.
- CALL SMESSG(0,1,NMESS)
- FATAL = .TRUE.
- GO TO 190
-*
- 70 CONTINUE
- WRITE (NUNIT(1),9001) SNAME,ICI,N,INCX,INCY
-C CLOSE THE FILE SO USEFUL STATUS INFORMATION IS SEALED.
- CLOSE (UNIT=NUNIT(1))
- END IF
-C DO (DEFINE A SET OF PROBLEM DATA)
- ASSIGN 80 TO IGO3
- GO TO 370
-*
- 80 CONTINUE
-C DO (CALL SUBROUTINE)
- ASSIGN 90 TO IGO1
- GO TO 290
-*
- 90 CONTINUE
- IF (N.LE.0 .OR. ICHAR(ICI).EQ.ICHAR('/')) THEN
-C DO (SEE WHAT DATA CHANGED INSIDE SUBROUTINES)
- ASSIGN 100 TO IGO2
- GO TO 220
-*
- 100 CONTINUE
-C IF DATA WAS INCORRECTLY CHANGED, MAKE NOTES AND RETURN.
- SAME = .TRUE.
- DO 110 I = 1,NARGS
- SAME = SAME .AND. ISAME(I)
- IF ( .NOT. ISAME(I)) THEN
- WRITE (NUNIT(2),9011) SNAME,I,ICI,N,INCX,INCY
- END IF
-*
- 110 CONTINUE
- IF ( .NOT. SAME) THEN
- FATAL = .TRUE.
- GO TO 190
-*
- END IF
-*
- ELSE
-C DO (SEE WHAT DATA CHANGED INSIDE SUBROUTINES)
- ASSIGN 120 TO IGO2
- GO TO 220
-*
- 120 CONTINUE
-C IF DATA WAS INCORRECTLY CHANGED, MAKE NOTES AND RETURN.
- SAME = .TRUE.
- DO 130 I = 1,NARGS
- NCHNG = (I.EQ.IAARG .OR. ISAME(I))
- SAME = SAME .AND. NCHNG
- IF ( .NOT. NCHNG) THEN
- WRITE (NUNIT(2),9021) SNAME,I,ICI,N,INCX,INCY
- END IF
-*
- 130 CONTINUE
- IF ( .NOT. SAME) THEN
- FATAL = .TRUE.
- GO TO 190
-*
- END IF
-*
- NC = NC + 1
-C DO (COMPUTE A CORRECT RESULT)
- ASSIGN 140 TO IGO4
- GO TO 400
-*
- 140 CONTINUE
-C IF GOT REALLY BAD ANSWER, PRINT NOTE AND GO BACK.
- IF (FATAL) GO TO 180
-*
- END IF
-*
- GO TO 40
-*
- 150 CONTINUE
- GO TO 30
-*
- 160 CONTINUE
- IF (ISNUM.GE.15) GO TO 20
- GO TO 10
-*
- 170 CONTINUE
- GO TO 10
-*
- 180 CONTINUE
-C REPORT ON ACCURACY OF DATA.
- WRITE (NUNIT(2),9031) ISNUM,SNAME,AVIGR,IG
- GO TO 210
-*
- 190 CONTINUE
- WRITE (NUNIT(2),9041) ISNUM,SNAME
- GO TO 210
-*
- 200 CONTINUE
- WRITE (NUNIT(2),9051) - ISNUM,SNAME
- 210 CONTINUE
- RETURN
-*
- 220 CONTINUE
-C PROCEDURE (SEE WHAT DATA CHANGED INSIDE SUBROUTINES)
- IF (ISNUM.EQ.13) THEN
- ISAME(1) = ICHAR(ICI) .EQ. ICHAR(ICHS)
- ISAME(2) = NS .EQ. N
- ISAME(3) = ALS .EQ. ALPHA
- ISAME(4) = .TRUE.
- IF (N.GT.0 .AND. INCX.NE.0) ISAME(4) = LSE(XS,X,1,N,ABS(INCX))
- ISAME(5) = INCXS .EQ. INCX
- ISAME(6) = .TRUE.
- IF (N.GT.0) ISAME(6) = LSE(AS,A,N,N,LDA)
- ISAME(7) = LDAS .EQ. LDA
-*
- ELSE IF (ISNUM.EQ.14) THEN
-C COMPARE THE MATRIX IN THE DATA STRUCTURES WITH THE SAVED COPY.
- ISAME(1) = ICHAR(ICI) .EQ. ICHAR(ICHS)
- ISAME(2) = NS .EQ. N
- ISAME(3) = ALS .EQ. ALPHA
- ISAME(4) = .TRUE.
- IF (N.GT.0 .AND. INCX.NE.0) ISAME(4) = LSE(XS,X,1,N,ABS(INCX))
- ISAME(5) = INCXS .EQ. INCX
- ISAME(6) = .TRUE.
- IOFF = 0
- DO 240 J = 1,N
- IF (ICHAR(ICI).EQ.ICHAR('U')) THEN
- ISTRT = 1
- IEND = J
-*
- ELSE
- ISTRT = J
- IEND = N
- END IF
-*
- DO 230 I = ISTRT,IEND
- IOFF = IOFF + 1
- IF (A(IOFF).NE.AS(1+ (I-1)+ (J-1)*LDA)) THEN
- ISAME(6) = .FALSE.
- GO TO 250
-*
- END IF
-*
- 230 CONTINUE
- 240 CONTINUE
- 250 CONTINUE
-*
- ELSE IF (ISNUM.EQ.15) THEN
- ISAME(1) = ICHAR(ICI) .EQ. ICHAR(ICHS)
- ISAME(2) = NS .EQ. N
- ISAME(3) = ALS .EQ. ALPHA
- ISAME(4) = .TRUE.
- IF (N.GT.0 .AND. INCX.NE.0) ISAME(4) = LSE(XS,X,1,N,ABS(INCX))
- ISAME(5) = INCXS .EQ. INCX
- ISAME(6) = .TRUE.
- IF (N.GT.0 .AND. INCY.NE.0) ISAME(6) = LSE(YS,Y,1,N,ABS(INCY))
- ISAME(7) = INCYS .EQ. INCY
- ISAME(8) = .TRUE.
- IF (N.GT.0) ISAME(8) = LSE(AS,A,N,N,LDA)
- ISAME(9) = LDAS .EQ. LDA
-*
- ELSE IF (ISNUM.EQ.16) THEN
- ISAME(1) = ICHAR(ICI) .EQ. ICHAR(ICHS)
- ISAME(2) = NS .EQ. N
- ISAME(3) = ALS .EQ. ALPHA
- ISAME(4) = .TRUE.
- IF (N.GT.0 .AND. INCX.NE.0) ISAME(4) = LSE(XS,X,1,N,ABS(INCX))
- ISAME(5) = INCXS .EQ. INCX
- ISAME(6) = .TRUE.
- IF (N.GT.0 .AND. INCY.NE.0) ISAME(6) = LSE(YS,Y,1,N,ABS(INCY))
- ISAME(7) = INCYS .EQ. INCY
- ISAME(8) = .TRUE.
- IOFF = 0
- DO 270 J = 1,N
- IF (ICHAR(ICI).EQ.ICHAR('U')) THEN
- ISTRT = 1
- IEND = J
-*
- ELSE
- ISTRT = J
- IEND = N
- END IF
-*
- DO 260 I = ISTRT,IEND
- IOFF = IOFF + 1
- IF (A(IOFF).NE.AS(1+ (I-1)+ (J-1)*LDA)) THEN
- ISAME(8) = .FALSE.
- GO TO 280
-*
- END IF
-*
- 260 CONTINUE
- 270 CONTINUE
- 280 CONTINUE
- END IF
-*
- GO TO IGO2
-*
- 290 CONTINUE
-C PROCEDURE (CALL SUBROUTINE)
-C SAVE EVERY DATUM BEFORE THE CALL.
- ICHS = ICI
- NS = N
- ALS = ALPHA
- DO 300 I = 1,N*N
- AS(I) = A(I)
- 300 CONTINUE
- LDAS = LDA
-C SAVE COPY OF THE X AND Y VECTORS.
- IBX = 1
- IF (INCX.LT.0) IBX = 1 + (1-N)*INCX
- DO 310 J = 1,N
- XS(IBX+ (J-1)*INCX) = X(IBX+ (J-1)*INCX)
- 310 CONTINUE
- INCXS = INCX
- IBY = 1
- IF (INCY.LT.0) IBY = 1 + (1-N)*INCY
- DO 320 I = 1,N
- YS(IBY+ (I-1)*INCY) = Y(IBY+ (I-1)*INCY)
- 320 CONTINUE
- INCYS = INCY
- IF (ISNUM.EQ.13) THEN
- CALL SSYR(ICI,N,ALPHA,X,INCX,A,LDA)
-*
- ELSE IF (ISNUM.EQ.14) THEN
-C TRANSFER THE MATRIX TO THE DATA STRUCTURE USED WITH SSPR.
- IOFF = 0
- DO 340 J = 1,N
- IF (ICHAR(ICI).EQ.ICHAR('U')) THEN
- ISTRT = 1
- IEND = J
-*
- ELSE
- ISTRT = J
- IEND = N
- END IF
-*
- DO 330 I = ISTRT,IEND
- IOFF = IOFF + 1
- A(IOFF) = AS(1+ (I-1)+ (J-1)*LDA)
- 330 CONTINUE
-*
- 340 CONTINUE
- CALL SSPR(ICI,N,ALPHA,X,INCX,A)
-*
- ELSE IF (ISNUM.EQ.15) THEN
-*
- CALL SSYR2(ICI,N,ALPHA,X,INCX,Y,INCY,A,LDA)
-*
- ELSE IF (ISNUM.EQ.16) THEN
-C TRANSFER THE MATRIX TO THE DATA STRUCTURE USED WITH SSPR2.
- IOFF = 0
- DO 360 J = 1,N
- IF (ICHAR(ICI).EQ.ICHAR('U')) THEN
- ISTRT = 1
- IEND = J
-*
- ELSE
- ISTRT = J
- IEND = N
- END IF
-*
- DO 350 I = ISTRT,IEND
- IOFF = IOFF + 1
- A(IOFF) = AS(1+ (I-1)+ (J-1)*LDA)
- 350 CONTINUE
-*
- 360 CONTINUE
- CALL SSPR2(ICI,N,ALPHA,X,INCX,Y,INCY,A)
- END IF
-*
- GO TO IGO1
-*
- 370 CONTINUE
-C PROCEDURE (DEFINE A SET OF PROBLEM DATA)
-C DO NOTHING IF DIMENSIONS ARE NOT POSITIVE.
- IF (N.LE.0) GO TO IGO3
- TRANSL = ZERO
- CALL SMAKE(A,N,N,LDA,RESET,TRANSL)
-C MAKE THE DATA MATRIX SYMMETRIC.
- DO 390 I = 1,N
- DO 380 J = I,N
- T = (A(1+ (I-1)+ (J-1)*LDA)+A(1+ (J-1)+ (I-1)*LDA))*HALF
- A(1+ (I-1)+ (J-1)*LDA) = T
- A(1+ (J-1)+ (I-1)*LDA) = T
- 380 CONTINUE
- 390 CONTINUE
-*
- TRANSL = 500.E0
- RESET = .FALSE.
- CALL SMAKE(X,1,N,MAX(1,ABS(INCX)),RESET,TRANSL)
- IF (N.GT.1 .AND. INCX.EQ.1) X(N/2) = ZERO
- TRANSL = ZERO
- CALL SMAKE(Y,1,N,MAX(1,ABS(INCY)),RESET,TRANSL)
- GO TO IGO3
-*
- 400 CONTINUE
-C PROCEDURE (COMPUTE A CORRECT RESULT)
-C COMPUTE THE CONDITION NUMBER TO USE AS GAUGE FOR ACCURATE RESULTS.
-C THIS IS RETURNED IN XT(*).
-C COMPUTE THE APPROXIMATE CORRECT RESULT.
- IF (ISNUM.EQ.13 .OR. ISNUM.EQ.14) THEN
- IF (INCX.LT.0) THEN
- IBX = (1-N)*INCX + 1
-*
- ELSE
- IBX = 1
- END IF
-*
- IOFF = 0
- DO 450 J = 1,N
- IF (ICHAR(ICI).EQ.ICHAR('U')) THEN
- ISTRT = 1
- IEND = J
-*
- ELSE
- ISTRT = J
- IEND = N
- END IF
-*
- DO 410 I = ISTRT,IEND
- YT(I) = AS(1+ (I-1)+ (J-1)*LDA) +
- . ALPHA*XS(IBX+ (J-1)*INCX)*XS(IBX+ (I-1)*INCX)
- XT(I) = AS(1+ (I-1)+ (J-1)*LDA)**2 +
- . ALPHA**2*XS(IBX+ (I-1)*INCX)**2*
- . XS(IBX+ (J-1)*INCX)**2
- 410 CONTINUE
-C COMPUTE THE DIFFERENCES. THEY SHOULD BE SMALL FOR CORRECT RESULTS.
- DO 420 I = ISTRT,IEND
- XT(I) = SQRT(XT(I))
- IF (ISNUM.EQ.13) THEN
- YT(I) = YT(I) - A(1+ (I-1)+ (J-1)*LDA)
-*
- ELSE IF (ISNUM.EQ.14) THEN
- IOFF = IOFF + 1
- YT(I) = YT(I) - A(IOFF)
- END IF
-*
- 420 CONTINUE
-C COMPUTE THE GRADE OF THIS RESULT.
- IGR = 0
- T = ONE
- DO 440 I = ISTRT,IEND
- 430 CONTINUE
-C THIS TEST ALLOWS UP TO A LOSS OF FULL PRECISION BEFORE QUITTING.
- IF (IGR.GE.IG) GO TO 520
- IF (SDIFF(T*ABS(YT(I))+XT(I),XT(I)).EQ.ZERO) GO TO 440
- T = T*HALF
- IGR = IGR + 1
- GO TO 430
-*
-C IF THE LOOP COMPLETES, ALL VALUES ARE 'SMALL.' THE VALUE IGR/IG
-C IS THE GRADE ASSIGNED. THE VALUE OF IGR IS MAXIMIZED OVER ALL THE
-C PROBLEMS.
- 440 CONTINUE
- 450 CONTINUE
-*
- ELSE IF (ISNUM.EQ.15 .OR. ISNUM.EQ.16) THEN
- IF (INCX.LT.0) THEN
- IBX = (1-N)*INCX + 1
-*
- ELSE
- IBX = 1
- END IF
-*
- IF (INCY.LT.0) THEN
- IBY = (1-N)*INCY + 1
-*
- ELSE
- IBY = 1
- END IF
-*
- IOFF = 0
- DO 500 J = 1,N
- IF (ICHAR(ICI).EQ.ICHAR('U')) THEN
- ISTRT = 1
- IEND = J
-*
- ELSE
- ISTRT = J
- IEND = N
- END IF
-*
- DO 460 I = ISTRT,IEND
- YT(I) = AS(1+ (I-1)+ (J-1)*LDA) +
- . ALPHA*XS(IBX+ (J-1)*INCX)*YS(IBY+ (I-1)*INCY) +
- . ALPHA*XS(IBX+ (I-1)*INCX)*YS(IBY+ (J-1)*INCY)
- XT(I) = AS(1+ (I-1)+ (J-1)*LDA)**2 +
- . ALPHA**2*XS(IBX+ (I-1)*INCX)**2*
- . YS(IBY+ (J-1)*INCY)**2 +
- . ALPHA**2*XS(IBX+ (J-1)*INCX)**2*
- . YS(IBY+ (I-1)*INCY)**2
- 460 CONTINUE
-C COMPUTE THE DIFFERENCES. THEY SHOULD BE SMALL FOR CORRECT RESULTS.
- DO 470 I = ISTRT,IEND
- XT(I) = SQRT(XT(I))
- IF (ISNUM.EQ.15) THEN
- YT(I) = YT(I) - A(1+ (I-1)+ (J-1)*LDA)
-*
- ELSE IF (ISNUM.EQ.16) THEN
- IOFF = IOFF + 1
- YT(I) = YT(I) - A(IOFF)
- END IF
-*
- 470 CONTINUE
-C COMPUTE THE GRADE OF THIS RESULT.
- IGR = 0
- T = ONE
- DO 490 I = ISTRT,IEND
- 480 CONTINUE
-C THIS TEST ALLOWS UP TO A LOSS OF FULL PRECISION BEFORE QUITTING.
- IF (IGR.GE.IG) GO TO 520
- IF (SDIFF(T*ABS(YT(I))+XT(I),XT(I)).EQ.ZERO) GO TO 490
- T = T*HALF
- IGR = IGR + 1
- GO TO 480
-*
-C IF THE LOOP COMPLETES, ALL VALUES ARE 'SMALL.' THE VALUE IGR/IG
-C IS THE GRADE ASSIGNED. THE VALUE OF IGR IS MAXIMIZED OVER ALL THE
-C PROBLEMS.
- 490 CONTINUE
- 500 CONTINUE
- END IF
-*
- 510 CONTINUE
- AVIGR = MAX(AVIGR,REAL(IGR))
- GO TO IGO4
-*
- 520 CONTINUE
- FATAL = .TRUE.
- GO TO 510
-*
-* LAST EXECUTABLE LINE OF SCHCK5
- 9001 FORMAT (' IN SUBPROGRAM ',A,/,' TESTS ACTIVE WITH OPTION = ',A,/,
- . ' N = ',I4,/,' INCX = ',I2,', INCY = ',I2)
- 9011 FORMAT (' IN SUBPROGRAM ',A,/,' ARGUMENT ',I2,
- . ' WAS CHANGED WITH INVALID INPUT.',/,' OPTION = ',A,/,' N = ',
- . I4,/,' INCX = ',I2,', INCY = ',I2)
- 9021 FORMAT (' IN SUBPROGRAM ',A,/,' ARGUMENT ',I2,
- . ' WAS CHANGED WHILE COMPUTING',/,' OPTION = ',A,/,' N = ',I4,/,
- . ' INCX = ',I2,', INCY = ',I2)
- 9031 FORMAT (1X,I2,' SUBPROGRAM ',A,T24,'RECEIVED A LOSS GRADE OF ',
- . F5.2,' OUT OF ',I3)
- 9041 FORMAT (1X,I2,' SUBPROGRAM ',A,T24,'FAILED.')
- 9051 FORMAT (1X,I2,' SUBPROGRAM ',A,T24,'NOT TESTED.')
- END
- SUBROUTINE SMAKE(A,M,N,LDA,RESET,TRANS)
-C GENERATE VALUES FOR AN M BY N MATRIX A.
-C RESET THE GENERATOR IF FLAG RESET = .TRUE.
-C TRANSLATE THE VALUES WITH TRANS.
-C THIS IS A TEST SUBPROGRAM FOR THE LEVEL TWO BLAS.
-C REVISED 860623
-C REVISED YYMMDD
-C AUTH=R. J. HANSON, SANDIA NATIONAL LABS.
- REAL A(LDA,*),TRANS,ANOISE
- REAL ZERO,HALF,ONE
- PARAMETER (ZERO=0.E0,HALF=.5E0,ONE=1.E0,THREE=3.E0)
- LOGICAL RESET
- IF (RESET) THEN
- ANOISE = -ONE
- ANOISE = SBEG(ANOISE)
- ANOISE = ZERO
- END IF
-*
- IC = 0
- DO 20 I = 1,M
- DO 10 J = 1,N
- IC = IC + 1
-C BREAK UP PERIODICITIES THAT ARE MULTIPLES OF 5.
- IF (MOD(IC,5).EQ.0) A(I,J) = SBEG(ANOISE)
- A(I,J) = SBEG(ANOISE) - TRANS
-C HERE THE PERTURBATION IN THE LAST BIT POSITION IS MADE.
- A(I,J) = A(I,J) + ONE/THREE
- ANOISE = 0.E0
- 10 CONTINUE
- 20 CONTINUE
- RETURN
-* LAST EXECUTABLE LINE OF SMAKE
- END
- SUBROUTINE SOPEN(IUNIT,NAME,ISTAT,IERROR)
-C OPEN UNIT IUNIT WITH FILE NAMED NAME.
-C ISTAT=1 FOR 'OLD', =2 FOR 'NEW', =3 FOR 'UNKNOWN'.
-C THE RETURN FLAG IERROR=0 FOR SUCCESS, =1 FOR FAILURE.
-C A BAD VALUE OF ISTAT CAN ALSO INDICATE FAILURE.
-C THIS IS A TEST SUBPROGRAM FOR THE LEVEL TWO BLAS.
-C REVISED 860623
-C REVISED YYMMDD
-C AUTH=R. J. HANSON, SANDIA NATIONAL LABS.
- CHARACTER * (*) NAME
- IF (ISTAT.EQ.1) OPEN (UNIT=IUNIT,FILE=NAME,STATUS='OLD',ERR=10)
- IF (ISTAT.EQ.2) OPEN (UNIT=IUNIT,FILE=NAME,STATUS='NEW',ERR=10)
- IF (ISTAT.EQ.3) OPEN (UNIT=IUNIT,FILE=NAME,STATUS='UNKNOWN',
- . ERR=10)
- GO TO (20,20,20),ISTAT
-*
- 10 CONTINUE
- IERROR = 1
- GO TO 30
-*
- 20 CONTINUE
- IERROR = 0
- 30 CONTINUE
- RETURN
-* LAST EXECUTABLE LINE OF SOPEN
- END
- FUNCTION SDIFF(X,Y)
-C C.L.LAWSON AND R.J.HANSON, JET PROPULSION LABORATORY, 1973 JUNE 7
-C APPEARED IN 'SOLVING LEAST SQUARES PROBLEMS', PRENTICE-HALL, 1974
-C THIS IS USED AS A TEST SUBPROGRAM FOR THE LEVEL TWO BLAS.
-C REVISED 860623
-C REVISED YYMMDD
-C AUTH=R. J. HANSON, SANDIA NATIONAL LABS.
- SDIFF = X - Y
- RETURN
-* LAST EXECUTABLE LINE OF SDIFF
- END
-*
- FUNCTION SBEG(ANOISE)
-C THIS IS A TEST SUBPROGRAM FOR THE LEVEL TWO BLAS.
-C REVISED 860623
-C REVISED YYMMDD
-C AUTH=R. J. HANSON, SANDIA NATIONAL LABS.
- SAVE
-C GENERATE NUMBERS FOR CONSTRUCTION OF TEST CASES.
- IF (ANOISE) 10,30,20
- 10 MI = 891
- MJ = 457
- I = 7
- J = 7
- AJ = 0.
- SBEG = 0.
- RETURN
-*
- 20 J = J*MJ
- J = J - 997* (J/997)
- AJ = J - 498
-C THE SEQUENCE OF VALUES OF I IS BOUNDED BETWEEN 1 AND 999
-C IF INITIAL I = 1,2,3,6,7, OR 9, THE PERIOD WILL BE 50
-C IF INITIAL I = 4 OR 8 THE PERIOD WILL BE 25
-C IF INITIAL I = 5 THE PERIOD WILL BE 10
- 30 I = I*MI
- I = I - 1000* (I/1000)
- AI = I - 500
- SBEG = AI + AJ*ANOISE
- RETURN
-* LAST EXECUTABLE LINE OF SBEG
- END
-*
- LOGICAL FUNCTION LSE(RI,RJ,M,N,LDI)
-C TEST IF TWO REAL ARRAYS ARE IDENTICAL.
-C THE ARRAYS ARE M BY N.
-C THIS IS A TEST SUBPROGRAM FOR THE LEVEL TWO BLAS.
-C REVISED 860623
-C REVISED YYMMDD
-C AUTH=R. J. HANSON, SANDIA NATIONAL LABS.
- REAL RI(LDI,*),RJ(LDI,*)
- DO 20 I = 1,M
- DO 10 J = 1,N
- IF (RI(I,J).NE.RJ(I,J)) THEN
- LSE = .FALSE.
- GO TO 30
-*
- END IF
-*
- 10 CONTINUE
- 20 CONTINUE
- LSE = .TRUE.
- 30 CONTINUE
- RETURN
-* LAST EXECUTABLE LINE OF LSE
- END
-*
- LOGICAL FUNCTION LDE(DI,DJ,M,N,LDI)
-C TEST IF TWO REAL ARRAYS ARE IDENTICAL.
-C THE ARRAYS ARE M BY N.
-C THIS IS A TEST SUBPROGRAM FOR THE LEVEL TWO BLAS.
-C REVISED 860623
-C REVISED YYMMDD
-C AUTH=R. J. HANSON, SANDIA NATIONAL LABS.
- REAL DI(LDI,*),DJ(LDI,*)
- DO 20 I = 1,M
- DO 10 J = 1,N
- IF (DI(I,J).NE.DJ(I,J)) THEN
- LDE = .FALSE.
- GO TO 30
-*
- END IF
-*
- 10 CONTINUE
- 20 CONTINUE
- LDE = .TRUE.
- 30 CONTINUE
- RETURN
-* LAST EXECUTABLE LINE OF LDE
- END
-*
- LOGICAL FUNCTION LCE(CI,CJ,M,N,LDI)
-C TEST IF TWO COMPLEX ARRAYS ARE IDENTICAL.
-C THE ARRAYS ARE M BY N.
-C THIS IS A TEST SUBPROGRAM FOR THE LEVEL TWO BLAS.
-C REVISED 860623
-C REVISED YYMMDD
-C AUTH=R. J. HANSON, SANDIA NATIONAL LABS.
- COMPLEX CI(LDI,*),CJ(LDI,*)
- DO 20 I = 1,M
- DO 10 J = 1,N
- IF (REAL(CI(I,J)).NE.REAL(CJ(I,J)) .OR. AIMAG(CI(I,J)).NE.
- . AIMAG(CJ(I,J))) THEN
- LCE = .FALSE.
- GO TO 30
-*
- END IF
-*
- 10 CONTINUE
- 20 CONTINUE
- LCE = .TRUE.
- 30 CONTINUE
- RETURN
-* LAST EXECUTABLE LINE OF LCE
- END
-C
-C***********************************************************************
-C
-C File of the REAL Level 2 BLAS routines:
-C
-C SGEMV, SGBMV, SSYMV, SSBMV, SSPMV, STRMV, STBMV, STPMV,
-C SGER , SSYR , SSPR ,
-C SSYR2, SSPR2,
-C STRSV, STBSV, STPSV.
-C
-C See:
-C
-C Dongarra J. J., Du Croz J. J., Hammarling S. and Hanson R. J..
-C A proposal for an extended set of Fortran Basic Linear Algebra
-C Subprograms. Technical Memorandum No.41 (revision 1),
-C Mathematics and Computer Science Division, Argone National
-C Laboratory, 9700 South Cass Avenue, Argonne, Illinois 60439,
-C USA, or NAG Technical Report TR4/85, Numerical Algorithms Group
-C Inc., 1101 31st Street, Suite 100, Downers Grove, Illinois
-C 60606-1263, USA.
-C
-C***********************************************************************
-C
- SUBROUTINE SGEMV(TRANS,M,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY)
- CHARACTER *1 TRANS
- INTEGER M,N,LDA,INCX,INCY
- REAL ALPHA,A(LDA,*),X(*),BETA,Y(*)
-*
-* Purpose
-* =======
-*
-* SGEMV performs one of the matrix-vector operations
-*
-* y := alpha*A*x + beta*y, or y := alpha*A'*x + beta*y,
-*
-* where alpha and beta are scalars, x and y are vectors and A is an
-* m by n matrix.
-*
-* Parameters
-* ==========
-*
-* TRANS - CHARACTER*1.
-* On entry, TRANS specifies the operation to be performed as
-* follows:
-*
-* TRANS = 'N' y := alpha*A*x + beta*y.
-*
-* TRANS = 'T' y := alpha*A'*x + beta*y.
-*
-* TRANS = 'C' y := alpha*A'*x + beta*y
-*.
-* Unchanged on exit.
-*
-* M - INTEGER.
-* On entry, M specifies the number of rows of the matrix A.
-* M must be at least zero.
-* Unchanged on exit.
-*
-* N - INTEGER.
-* On entry, N specifies the number of columns of the matrix A.
-* N must be at least zero.
-* Unchanged on exit.
-*
-* ALPHA - REAL .
-* On entry, ALPHA specifies the scalar alpha.
-* Unchanged on exit.
-*
-* A - REAL array of DIMENSION ( LDA, n ).
-* Before entry, the leading m by n part of the array A must
-* contain the matrix of coefficients.
-* Unchanged on exit.
-*
-* LDA - INTEGER.
-* On entry, LDA specifies the leading dimension of A as
-* declared in the calling (sub) program. LDA must be at least
-* max(m,1).
-* Unchanged on exit.
-*
-* X - REAL array of DIMENSION at least
-* ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N'
-* and at least
-* ( 1 + ( m - 1 )*abs( INCX ) ) otherwise.
-* Before entry, the incremented array X must contain the
-* vector x.
-* Unchanged on exit.
-*
-* INCX - INTEGER.
-* On entry, INCX specifies the increment for the elements of
-* X.
-* Unchanged on exit.
-*
-* BETA - REAL
-* On entry, BETA specifies the scalar beta. When BETA is
-* supplied as zero then Y need not be set on input.
-* Unchanged on exit.
-*
-* Y - REAL array of DIMENSION at least
-* ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N'
-* and at least
-* ( 1 + ( n - 1 )*abs( INCY ) ) otherwise.
-* Before entry with BETA non-zero, the incremented array Y
-* must contain the vector y. On exit, Y is overwritten by the
-* updated vector y.
-*
-* INCY - INTEGER.
-* On entry, INCY specifies the increment for the elements of
-* Y.
-* Unchanged on exit.
-*
-*
-* Note that TRANS, M, N and LDA must be such that the value of the
-* LOGICAL variable OK in the following statement is true.
-*
-*
-*
-*
-* Level 2 Blas routine.
-*
-* -- Written on 30-August-1985.
-* Sven Hammarling, Nag Central Office.
-C REVISED 860623
-C REVISED YYMMDD
-C BY R. J. HANSON, SANDIA NATIONAL LABS.
-*
- INTEGER I,IX,IY,J,JX,JY
- INTEGER KX,KY,LENX,LENY
- REAL ONE,ZERO
- PARAMETER (ONE=1.0E+0,ZERO=0.0E+0)
- REAL TEMP
- LOGICAL OK,LSAME
- OK = (LSAME(TRANS,'N') .OR. LSAME(TRANS,'T') .OR.
- . LSAME(TRANS,'C')) .AND. ((M.GT.0) .AND. (N.GT.0) .AND.
- . (LDA.GE.M))
-*
-* Quick return if possible.
-*
- IF (((ALPHA.EQ.ZERO).AND. (BETA.EQ.ONE)) .OR. .NOT. OK) RETURN
-*
-* Set LENX and LENY, the lengths of the vectors x and y.
-*
- IF (LSAME(TRANS,'N')) THEN
- LENX = N
- LENY = M
-*
- ELSE
- LENX = M
- LENY = N
- END IF
-*
-* Start the operations. In this version the elements of A are
-* accessed sequentially with one pass through A.
-*
-* First form y := beta*y and set up the start points in X and Y if
-* the increments are not both unity.
-*
- IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
- IF (BETA.NE.ONE) THEN
- IF (BETA.EQ.ZERO) THEN
- DO 10,I = 1,LENY
- Y(I) = ZERO
- 10 CONTINUE
-*
- ELSE
- DO 20,I = 1,LENY
- Y(I) = BETA*Y(I)
- 20 CONTINUE
- END IF
-*
- END IF
-*
- ELSE
- IF (INCX.GT.0) THEN
- KX = 1
-*
- ELSE
- KX = 1 - (LENX-1)*INCX
- END IF
-*
- IF (INCY.GT.0) THEN
- KY = 1
-*
- ELSE
- KY = 1 - (LENY-1)*INCY
- END IF
-*
- IF (BETA.NE.ONE) THEN
- IY = KY
- IF (BETA.EQ.ZERO) THEN
- DO 30,I = 1,LENY
- Y(IY) = ZERO
- IY = IY + INCY
- 30 CONTINUE
-*
- ELSE
- DO 40,I = 1,LENY
- Y(IY) = BETA*Y(IY)
- IY = IY + INCY
- 40 CONTINUE
- END IF
-*
- END IF
-*
- END IF
-*
- IF (ALPHA.EQ.ZERO) RETURN
- IF (LSAME(TRANS,'N')) THEN
-*
-* Form y := alpha*A*x + y.
-*
- IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
- DO 60,J = 1,N
- IF (X(J).NE.ZERO) THEN
- TEMP = ALPHA*X(J)
- DO 50,I = 1,M
- Y(I) = Y(I) + TEMP*A(I,J)
- 50 CONTINUE
- END IF
-*
- 60 CONTINUE
-*
- ELSE
- JX = KX
- DO 80,J = 1,N
- IF (X(JX).NE.ZERO) THEN
- TEMP = ALPHA*X(JX)
- IY = KY
- DO 70,I = 1,M
- Y(IY) = Y(IY) + TEMP*A(I,J)
- IY = IY + INCY
- 70 CONTINUE
- END IF
-*
- JX = JX + INCX
- 80 CONTINUE
- END IF
-*
- ELSE
-*
-* Form y := alpha*A'*x + y.
-*
- IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
- DO 100,J = 1,N
- TEMP = ZERO
- DO 90,I = 1,M
- TEMP = TEMP + A(I,J)*X(I)
- 90 CONTINUE
- Y(J) = Y(J) + ALPHA*TEMP
- 100 CONTINUE
-*
- ELSE
- JY = KY
- DO 120,J = 1,N
- TEMP = ZERO
- IX = KX
- DO 110,I = 1,M
- TEMP = TEMP + A(I,J)*X(IX)
- IX = IX + INCX
- 110 CONTINUE
- Y(JY) = Y(JY) + ALPHA*TEMP
- JY = JY + INCY
- 120 CONTINUE
- END IF
-*
- END IF
-*
- RETURN
-*
-* End of SGEMV .
-*
- END
- SUBROUTINE SGBMV(TRANS,M,N,KL,KU,ALPHA,A,LDA,X,INCX,BETA,Y,INCY)
- CHARACTER *1 TRANS
- INTEGER M,N,KL,KU,LDA,INCX,INCY
- REAL ALPHA,A(LDA,*),X(*),BETA,Y(*)
-*
-* Purpose
-* =======
-*
-* SGBMV performs one of the matrix-vector operations
-*
-* y := alpha*A*x + beta*y, or y := alpha*A'*x + beta*y,
-*
-* where alpha and beta are scalars, x and y are vectors and A is an
-* m by n band matrix, with kl sub-diagonals and ku super-diagonals.
-*
-* Parameters
-* ==========
-*
-* TRANS - CHARACTER*1.
-* On entry, TRANS specifies the operation to be performed as
-* follows:
-*
-* TRANS = 'N' y := alpha*A*x + beta*y.
-*
-* TRANS = 'T' y := alpha*A'*x + beta*y.
-*
-* TRANS = 'C' y := alpha*A'*x + beta*y.
-*
-* Unchanged on exit.
-*
-* M - INTEGER.
-* On entry, M specifies the number of rows of the matrix A.
-* M must be at least zero.
-* Unchanged on exit.
-*
-* N - INTEGER.
-* On entry, N specifies the number of columns of the matrix A.
-* N must be at least zero.
-* Unchanged on exit.
-*
-* KL - INTEGER.
-* On entry, KL specifies the number of sub-diagonals of the
-* matrix A. KL must satisfy 0 .le. KL.
-* Unchanged on exit.
-*
-* KU - INTEGER.
-* On entry, KU specifies the number of super-diagonals of the
-* matrix A. KU must satisfy 0 .le. KU.
-* Unchanged on exit.
-*
-* Users may find that efficiency of their application is enhanced by
-* adjusting the values of m and n so that KL .ge. max(0,m-n) and
-* KU .ge. max(0,n-m) or KL and KU so that KL .lt. m and KU .lt. n.
-*
-* ALPHA - REAL .
-* On entry, ALPHA specifies the scalar alpha.
-* Unchanged on exit.
-*
-* A - REAL array of DIMENSION ( LDA, n ).
-* Before entry, the leading ( kl + ku + 1 ) by n part of the
-* array A must contain the matrix of coefficients, supplied
-* column by column, with the leading diagonal of the matrix in
-* row ( ku + 1 ) of the array, the first super-diagonal
-* starting at position 2 in row ku, the first sub-diagonal
-* starting at position 1 in row ( ku + 2 ), and so on.
-* This placement of the data can be realized with the
-* following loops:
-* DO 20 J =1,N
-* K=KU+1-J
-* DO 10 I =MAX(1,J-KU),MIN(M,J+KL)
-* A(K+I,J)=matrix entry of row I, column J.
-* 10 CONTINUE
-* 20 CONTINUE
-* Elements in the array A that do not correspond to elements
-* in the band matrix (such as the top left ku by ku triangle)
-* are not referenced.
-* Unchanged on exit.
-*
-* LDA - INTEGER.
-* On entry, LDA specifies the leading dimension of A as
-* declared in the calling (sub) program. LDA must be at least
-* ( kl + ku + 1 ).
-* Unchanged on exit.
-*
-* X - REAL array of DIMENSION at least
-* ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N'
-* and at least
-* ( 1 + ( m - 1 )*abs( INCX ) ) otherwise.
-* Before entry, the incremented array X must contain the
-* vector x.
-* Unchanged on exit.
-*
-* INCX - INTEGER.
-* On entry, INCX specifies the increment for the elements of
-* X.
-* Unchanged on exit.
-*
-* BETA - REAL .
-* On entry, BETA specifies the scalar beta. When BETA is
-* supplied as zero then Y need not be set on input.
-* Unchanged on exit.
-*
-* Y - REAL array of DIMENSION at least
-* ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N'
-* and at least
-* ( 1 + ( n - 1 )*abs( INCY ) ) otherwise.
-* Before entry, the incremented array Y must contain the
-* vector y. On exit, Y is overwritten by the updated vector y.
-*
-* INCY - INTEGER.
-* On entry, INCY specifies the increment for the elements of
-* Y.
-* Unchanged on exit.
-*
-*
-*
-*
-* Level 2 Blas routine.
-*
-* -- Written on 27-Sept-1985.
-* Sven Hammarling, Nag Central Office.
-C REVISED 860623
-C REVISED YYMMDD
-C BY R. J. HANSON, SANDIA NATIONAL LABS.
-*
- INTRINSIC MAX,MIN
- INTEGER I,IX,IY,J,JX,JY
- INTEGER K,KUP1,KX,KY,LENX,LENY
- REAL ONE,ZERO
- PARAMETER (ONE=1.0E+0,ZERO=0.0E+0)
- REAL TEMP
- LOGICAL OK,LSAME
- OK = (LSAME(TRANS,'N') .OR. LSAME(TRANS,'T') .OR.
- . LSAME(TRANS,'C')) .AND. (M.GT.0) .AND. (N.GT.0) .AND.
- . (KL.GE.0) .AND. (KU.GE.0) .AND.
- . (LDA.GE. (KL+KU+1))
-*
-* Quick return if possible.
-*
- IF ( .NOT. OK .OR. ((ALPHA.EQ.ZERO).AND. (BETA.EQ.ONE))) RETURN
-*
-* Set LENX and LENY, the lengths of the vectors x and y.
-*
- IF (LSAME(TRANS,'N')) THEN
- LENX = N
- LENY = M
-*
- ELSE
- LENX = M
- LENY = N
- END IF
-*
-* Start the operations. In this version the elements of A are
-* accessed sequentially with one pass through the band part of A.
-*
-* First form y := beta*y and set up the start points in X and Y
-* if the increments are not both unity.
-*
- IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
- IF (BETA.NE.ONE) THEN
- IF (BETA.EQ.ZERO) THEN
- DO 10,I = 1,LENY
- Y(I) = ZERO
- 10 CONTINUE
-*
- ELSE
- DO 20,I = 1,LENY
- Y(I) = BETA*Y(I)
- 20 CONTINUE
- END IF
-*
- END IF
-*
- ELSE
- IF (INCX.GT.0) THEN
- KX = 1
-*
- ELSE
- KX = 1 - (LENX-1)*INCX
- END IF
-*
- IF (INCY.GT.0) THEN
- KY = 1
-*
- ELSE
- KY = 1 - (LENY-1)*INCY
- END IF
-*
- IF (BETA.NE.ONE) THEN
- IY = KY
- IF (BETA.EQ.ZERO) THEN
- DO 30,I = 1,LENY
- Y(IY) = ZERO
- IY = IY + INCY
- 30 CONTINUE
-*
- ELSE
- DO 40,I = 1,LENY
- Y(IY) = BETA*Y(IY)
- IY = IY + INCY
- 40 CONTINUE
- END IF
-*
- END IF
-*
- END IF
-*
- IF (ALPHA.EQ.ZERO) RETURN
- KUP1 = KU + 1
- IF (LSAME(TRANS,'N')) THEN
-*
-* Form y := alpha*A*x + y.
-*
- IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
- DO 60,J = 1,N
- IF (X(J).NE.ZERO) THEN
- TEMP = ALPHA*X(J)
- K = KUP1 - J
- DO 50,I = MAX(1,J-KU),MIN(M,J+KL)
- Y(I) = Y(I) + TEMP*A(K+I,J)
- 50 CONTINUE
- END IF
-*
- 60 CONTINUE
-*
- ELSE
- JX = KX
- DO 80,J = 1,N
- IF (X(JX).NE.ZERO) THEN
- TEMP = ALPHA*X(JX)
- IY = KY
- K = KUP1 - J
- DO 70,I = MAX(1,J-KU),MIN(M,J+KL)
- Y(IY) = Y(IY) + TEMP*A(K+I,J)
- IY = IY + INCY
- 70 CONTINUE
- END IF
-*
- JX = JX + INCX
- IF (J.GT.KU) KY = KY + INCY
- 80 CONTINUE
- END IF
-*
- ELSE
-*
-* Form y := alpha*A'*x + y.
-*
- IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
- DO 100,J = 1,N
- TEMP = ZERO
- K = KUP1 - J
- DO 90,I = MAX(1,J-KU),MIN(M,J+KL)
- TEMP = TEMP + A(K+I,J)*X(I)
- 90 CONTINUE
- Y(J) = Y(J) + ALPHA*TEMP
- 100 CONTINUE
-*
- ELSE
- JY = KY
- DO 120,J = 1,N
- TEMP = ZERO
- IX = KX
- K = KUP1 - J
- DO 110,I = MAX(1,J-KU),MIN(M,J+KL)
- TEMP = TEMP + A(K+I,J)*X(IX)
- IX = IX + INCX
- 110 CONTINUE
- Y(JY) = Y(JY) + ALPHA*TEMP
- JY = JY + INCY
- IF (J.GT.KU) KX = KX + INCX
- 120 CONTINUE
- END IF
-*
- END IF
-*
- RETURN
-*
-* End of SGBMV .
-*
- END
- SUBROUTINE SSYMV(UPLO,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY)
- CHARACTER *1 UPLO
- INTEGER N,LDA,INCX,INCY
- REAL ALPHA,A(LDA,*),X(*),BETA,Y(*)
-*
-* Purpose
-* =======
-*
-* SSYMV performs the matrix-vector operation
-*
-* y := alpha*A*x + beta*y,
-*
-* where alpha and beta are scalars, x and y are n element vectors and
-* A is an n by n symmetric matrix.
-*
-* Parameters
-* ==========
-*
-* UPLO - CHARACTER*1.
-* On entry, UPLO specifies whether the upper or lower
-* triangular part of the array A is to be referenced as
-* follows:
-*
-* UPLO = 'U' Only the upper triangular part of A
-* is to be referenced.
-*
-* UPLO = 'L' Only the lower triangular part of A
-* is to be referenced.
-*
-* Unchanged on exit.
-*
-* N - INTEGER.
-* On entry, N specifies the order of the matrix A.
-* N must be at least zero.
-* Unchanged on exit.
-*
-* ALPHA - REAL .
-* On entry, ALPHA specifies the scalar alpha.
-* Unchanged on exit.
-*
-* A - REAL array of DIMENSION ( LDA, n ).
-* Before entry with UPLO = 'U', the leading n by n
-* upper triangular part of the array A must contain the upper
-* triangular part of the symmetric matrix and the strictly
-* lower triangular part of A is not referenced.
-* Before entry with UPLO = 'L', the leading n by n
-* lower triangular part of the array A must contain the lower
-* triangular part of the symmetric matrix and the strictly
-* upper triangular part of A is not referenced.
-* Unchanged on exit.
-*
-* LDA - INTEGER.
-* On entry, LDA specifies the first dimension of A as declared
-* in the calling (sub) program. LDA must be at least max(n,1).
-* Unchanged on exit.
-*
-* X - REAL array of dimension at least
-* ( 1 + ( n - 1 )*abs( INCX ) ).
-* Before entry, the incremented array X must contain the n
-* element vector x.
-* Unchanged on exit.
-*
-* INCX - INTEGER.
-* On entry, INCX specifies the increment for the elements of
-* X.
-* Unchanged on exit.
-*
-* BETA - REAL .
-* On entry, BETA specifies the scalar beta. When BETA is
-* supplied as zero then Y need not be set on input.
-* Unchanged on exit.
-*
-* Y - REAL array of dimension at least
-* ( 1 + ( n - 1 )*abs( INCY ) ).
-* Before entry, the incremented array Y must contain the n
-* element vector y. On exit, Y is overwritten by the updated
-* vector y.
-*
-* INCY - INTEGER.
-* On entry, INCY specifies the increment for the elements of
-* Y.
-* Unchanged on exit.
-*
-*
-* Level 2 Blas routine.
-*
-* -- Written on 27-Sept-1985.
-* Sven Hammarling, Nag Central Office.
-C REVISED 860623
-C REVISED YYMMDD
-C BY R. J. HANSON, SANDIA NATIONAL LABS.
-*
- INTEGER I,IX,IY,J,JX,JY
- INTEGER KX,KY
- REAL ONE,ZERO
- PARAMETER (ONE=1.0E+0,ZERO=0.0E+0)
- REAL TEMP1,TEMP2
- LOGICAL OK,LSAME
- OK = (LSAME(UPLO,'U') .OR. LSAME(UPLO,'L')) .AND. (N.GT.0) .AND.
- . (LDA.GE.N)
-*
-* Quick return if possible.
-*
- IF ( .NOT. OK .OR. ((ALPHA.EQ.ZERO).AND. (BETA.EQ.ONE))) RETURN
-*
-* Start the operations. In this version the elements of A are
-* accessed sequentially with one pass through the triangular part
-* of A.
-*
-* First form y := beta*y and set up the start points in X and Y if
-* the increments are not both unity.
-*
- IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
- IF (BETA.NE.ONE) THEN
- IF (BETA.EQ.ZERO) THEN
- DO 10,I = 1,N
- Y(I) = ZERO
- 10 CONTINUE
-*
- ELSE
- DO 20,I = 1,N
- Y(I) = BETA*Y(I)
- 20 CONTINUE
- END IF
-*
- END IF
-*
- ELSE
- IF (INCX.GT.0) THEN
- KX = 1
-*
- ELSE
- KX = 1 - (N-1)*INCX
- END IF
-*
- IF (INCY.GT.0) THEN
- KY = 1
-*
- ELSE
- KY = 1 - (N-1)*INCY
- END IF
-*
- IF (BETA.NE.ONE) THEN
- IY = KY
- IF (BETA.EQ.ZERO) THEN
- DO 30,I = 1,N
- Y(IY) = ZERO
- IY = IY + INCY
- 30 CONTINUE
-*
- ELSE
- DO 40,I = 1,N
- Y(IY) = BETA*Y(IY)
- IY = IY + INCY
- 40 CONTINUE
- END IF
-*
- END IF
-*
- END IF
-*
- IF (ALPHA.EQ.ZERO) RETURN
- IF (LSAME(UPLO,'U')) THEN
-*
-* Form y when A is stored in upper triangle.
-*
- IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
- DO 60,J = 1,N
- TEMP1 = ALPHA*X(J)
- TEMP2 = ZERO
- DO 50,I = 1,J - 1
- Y(I) = Y(I) + TEMP1*A(I,J)
- TEMP2 = TEMP2 + A(I,J)*X(I)
- 50 CONTINUE
- Y(J) = Y(J) + TEMP1*A(J,J) + ALPHA*TEMP2
- 60 CONTINUE
-*
- ELSE
- IX = KX - INCX
- DO 80,J = 1,N
- TEMP1 = ALPHA*X(IX+INCX)
- TEMP2 = ZERO
- IX = KX
- IY = KY
- DO 70,I = 1,J - 1
- Y(IY) = Y(IY) + TEMP1*A(I,J)
- TEMP2 = TEMP2 + A(I,J)*X(IX)
- IX = IX + INCX
- IY = IY + INCY
- 70 CONTINUE
- Y(IY) = Y(IY) + TEMP1*A(J,J) + ALPHA*TEMP2
- 80 CONTINUE
- END IF
-*
- ELSE
-*
-* Form y when A is stored in lower triangle.
-*
- IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
- DO 100,J = 1,N
- TEMP1 = ALPHA*X(J)
- TEMP2 = ZERO
- Y(J) = Y(J) + TEMP1*A(J,J)
- DO 90,I = J + 1,N
- Y(I) = Y(I) + TEMP1*A(I,J)
- TEMP2 = TEMP2 + A(I,J)*X(I)
- 90 CONTINUE
- Y(J) = Y(J) + ALPHA*TEMP2
- 100 CONTINUE
-*
- ELSE
- JX = KX
- JY = KY
- DO 120,J = 1,N
- TEMP1 = ALPHA*X(JX)
- TEMP2 = ZERO
- Y(JY) = Y(JY) + TEMP1*A(J,J)
- IX = JX
- IY = JY
- DO 110,I = J + 1,N
- IX = IX + INCX
- IY = IY + INCY
- Y(IY) = Y(IY) + TEMP1*A(I,J)
- TEMP2 = TEMP2 + A(I,J)*X(IX)
- 110 CONTINUE
- Y(JY) = Y(JY) + ALPHA*TEMP2
- JX = JX + INCX
- JY = JY + INCY
- 120 CONTINUE
- END IF
-*
- END IF
-*
- RETURN
-*
-* End of SSYMV .
-*
- END
- SUBROUTINE SSBMV(UPLO,N,K,ALPHA,A,LDA,X,INCX,BETA,Y,INCY)
- CHARACTER *1 UPLO
- INTEGER N,K,LDA,INCX,INCY
- REAL ALPHA,A(LDA,*),X(*),BETA,Y(*)
-*
-* Purpose
-* =======
-*
-* SSBMV performs the matrix-vector operation
-*
-* y := alpha*A*x + beta*y,
-*
-* where alpha and beta are scalars, x and y are n element vectors and
-* A is an n by n symmetric band matrix, with k super-diagonals.
-*
-* Parameters
-* ==========
-*
-* UPLO - CHARACTER*1.
-* On entry, UPLO specifies whether the upper or lower
-* triangular part of the band matrix A is being supplied as
-* follows:
-*
-* UPLO = 'U' The upper triangular part of A is
-* being supplied.
-*
-* UPLO = 'L' The lower triangular part of A is
-* being supplied.
-*
-* Unchanged on exit.
-*
-* N - INTEGER.
-* On entry, N specifies the order of the matrix A.
-* N must be at least zero.
-* Unchanged on exit.
-*
-* K - INTEGER.
-* On entry, K specifies the number of super-diagonals of the
-* matrix A. K must satisfy 0 .le. K .lt. n.
-* Unchanged on exit.
-*
-* ALPHA - REAL .
-* On entry, ALPHA specifies the scalar alpha.
-* Unchanged on exit.
-*
-* A - REAL array of DIMENSION ( LDA, n ).
-* Before entry with UPLO = 'U', the leading ( k + 1 )
-* by n part of the array A must contain the upper triangular
-* band part of the symmetric matrix, supplied column by
-* column, with the leading diagonal of the matrix in row
-* ( k + 1 ) of the array, the first super-diagonal starting at
-* position 2 in row k, and so on. The top left k by k triangle
-* of the array A is not referenced.
-* Before entry with UPLO = 'L', the leading ( k + 1 )
-* by n part of the array A must contain the lower triangular
-* band part of the symmetric matrix, supplied column by
-* column, with the leading diagonal of the matrix in row 1 of
-* the array, the first sub-diagonal starting at position 1 in
-* row 2, and so on. The bottom right k by k triangle of the
-* array A is not referenced.
-* Unchanged on exit.
-*
-* LDA - INTEGER.
-* On entry, LDA specifies the leading dimension of A as
-* declared in the calling (sub) program. LDA must be at least
-* ( k + 1 ).
-* Unchanged on exit.
-*
-* X - REAL array of DIMENSION at least
-* ( 1 + ( n - 1 )*abs( INCX ) ).
-* Before entry, the incremented array X must contain the
-* vector x.
-* Unchanged on exit.
-*
-* INCX - INTEGER.
-* On entry, INCX specifies the increment for the elements of
-* X.
-* Unchanged on exit.
-*
-* BETA - REAL .
-* On entry, BETA specifies the scalar beta.
-* Unchanged on exit.
-*
-* Y - REAL array of DIMENSION at least
-* ( 1 + ( n - 1 )*abs( INCY ) ).
-* Before entry, the incremented array Y must contain the
-* vector y. On exit, Y is overwritten by the updated vector y.
-*
-* INCY - INTEGER.
-* On entry, INCY specifies the increment for the elements of
-* Y.
-* Unchanged on exit.
-*
-*
-*
-* Level 2 Blas routine.
-*
-* -- Written on 30-September-1985.
-* Sven Hammarling, Nag Central Office.
-C REVISED 860623
-C REVISED YYMMDD
-C BY R. J. HANSON, SANDIA NATIONAL LABS.
-*
- INTRINSIC MAX,MIN
- INTEGER I,IX,IY,J,JX,JY
- INTEGER KPLUS1,KX,KY,L
- REAL ONE,ZERO
- PARAMETER (ONE=1.0E+0,ZERO=0.0E+0)
- REAL TEMP1,TEMP2
- LOGICAL OK,LSAME
- OK = (LSAME(UPLO,'U') .OR. LSAME(UPLO,'L')) .AND. (N.GT.0) .AND.
- . (K.GE.0) .AND. (K.LT.N) .AND. (LDA.GE. (K+1))
-*
-* Quick return if possible.
-*
- IF ( .NOT. OK .OR. ((ALPHA.EQ.ZERO).AND. (BETA.EQ.ONE))) RETURN
-*
-* Start the operations. In this version the elements of the array A
-* are accessed sequentially with one pass through A.
-*
-* First form y := beta*y and set up the start points in X and Y if
-* the increments are not both unity.
-*
- IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
- IF (BETA.NE.ONE) THEN
- IF (BETA.EQ.ZERO) THEN
- DO 10,I = 1,N
- Y(I) = ZERO
- 10 CONTINUE
-*
- ELSE
- DO 20,I = 1,N
- Y(I) = BETA*Y(I)
- 20 CONTINUE
- END IF
-*
- END IF
-*
- ELSE
- IF (INCX.GT.0) THEN
- KX = 1
-*
- ELSE
- KX = 1 - (N-1)*INCX
- END IF
-*
- IF (INCY.GT.0) THEN
- KY = 1
-*
- ELSE
- KY = 1 - (N-1)*INCY
- END IF
-*
- IF (BETA.NE.ONE) THEN
- IY = KY
- IF (BETA.EQ.ZERO) THEN
- DO 30,I = 1,N
- Y(IY) = ZERO
- IY = IY + INCY
- 30 CONTINUE
-*
- ELSE
- DO 40,I = 1,N
- Y(IY) = BETA*Y(IY)
- IY = IY + INCY
- 40 CONTINUE
- END IF
-*
- END IF
-*
- END IF
-*
- IF (ALPHA.EQ.ZERO) RETURN
- IF (LSAME(UPLO,'U')) THEN
-*
-* Form y when upper triangle of A is stored.
-*
- KPLUS1 = K + 1
- IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
- DO 60,J = 1,N
- TEMP1 = ALPHA*X(J)
- TEMP2 = ZERO
- I = MAX(1,J-K)
- DO 50,L = KPLUS1 + I - J,K
- Y(I) = Y(I) + TEMP1*A(L,J)
- TEMP2 = TEMP2 + A(L,J)*X(I)
- I = I + 1
- 50 CONTINUE
- Y(J) = Y(J) + TEMP1*A(KPLUS1,J) + ALPHA*TEMP2
- 60 CONTINUE
-*
- ELSE
- IX = KX - INCX
- DO 80,J = 1,N
- TEMP1 = ALPHA*X(IX+INCX)
- TEMP2 = ZERO
- IX = KX
- IY = KY
- DO 70,L = 1 + MAX(KPLUS1-J,0),K
- Y(IY) = Y(IY) + TEMP1*A(L,J)
- TEMP2 = TEMP2 + A(L,J)*X(IX)
- IX = IX + INCX
- IY = IY + INCY
- 70 CONTINUE
- Y(IY) = Y(IY) + TEMP1*A(KPLUS1,J) + ALPHA*TEMP2
- IF (J.GT.K) THEN
- KX = KX + INCX
- KY = KY + INCY
- END IF
-*
- 80 CONTINUE
- END IF
-*
- ELSE
-*
-* Form y when lower triangle of A is stored.
-*
- IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
- DO 100,J = 1,N
- TEMP1 = ALPHA*X(J)
- TEMP2 = ZERO
- Y(J) = Y(J) + TEMP1*A(1,J)
- I = J + 1
- DO 90,L = 2,1 + MIN(K,N-J)
- Y(I) = Y(I) + TEMP1*A(L,J)
- TEMP2 = TEMP2 + A(L,J)*X(I)
- I = I + 1
- 90 CONTINUE
- Y(J) = Y(J) + ALPHA*TEMP2
- 100 CONTINUE
-*
- ELSE
- JX = KX
- JY = KY
- DO 120,J = 1,N
- TEMP1 = ALPHA*X(JX)
- TEMP2 = ZERO
- Y(JY) = Y(JY) + TEMP1*A(1,J)
- IX = JX
- IY = JY
- DO 110,L = 2,1 + MIN(K,N-J)
- IX = IX + INCX
- IY = IY + INCY
- Y(IY) = Y(IY) + TEMP1*A(L,J)
- TEMP2 = TEMP2 + A(L,J)*X(IX)
- 110 CONTINUE
- Y(JY) = Y(JY) + ALPHA*TEMP2
- JX = JX + INCX
- JY = JY + INCY
- 120 CONTINUE
- END IF
-*
- END IF
-*
- RETURN
-*
-* End of SSBMV .
-*
- END
- SUBROUTINE SSPMV(UPLO,N,ALPHA,AP,X,INCX,BETA,Y,INCY)
- CHARACTER *1 UPLO
- INTEGER N,INCX,INCY
- REAL ALPHA,AP(*),X(*),BETA,Y(*)
-*
-* Purpose
-* =======
-*
-* SSPMV performs the matrix-vector operation
-*
-* y := alpha*A*x + beta*y,
-*
-* where alpha and beta are scalars, x and y are n element vectors and
-* A is an n by n symmetric matrix.
-*
-* Parameters
-* ==========
-*
-* UPLO - CHARACTER*1.
-* On entry, UPLO specifies whether the upper or lower
-* triangular part of the matrix A is supplied in the packed
-* array AP as follows:
-*
-* UPLO = 'U' The upper triangular part of A is
-* supplied in AP.
-*
-* UPLO = 'L' The lower triangular part of A is
-* supplied in AP.
-*
-* Unchanged on exit.
-*
-* N - INTEGER.
-* On entry, N specifies the order of the matrix A.
-* N must be at least zero.
-* Unchanged on exit.
-*
-* ALPHA - REAL .
-* On entry, ALPHA specifies the scalar alpha.
-* Unchanged on exit.
-*
-* AP - REAL array of DIMENSION at least
-* ( ( n*( n + 1 ) )/2 ).
-* Before entry with UPLO = 'U', the array AP must
-* contain the upper triangular part of the symmetric matrix
-* packed sequentially, column by column, so that AP( 1 )
-* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 )
-* and a( 2, 2 ) respectively, and so on.
-* Before entry with UPLO = 'L', the array AP must
-* contain the lower triangular part of the symmetric matrix
-* packed sequentially, column by column, so that AP( 1 )
-* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 )
-* and a( 3, 1 ) respectively, and so on.
-* Unchanged on exit.
-*
-* X - REAL array of dimension at least
-* ( 1 + ( n - 1 )*abs( INCX ) ).
-* Before entry, the incremented array X must contain the n
-* element vector x.
-* Unchanged on exit.
-*
-* INCX - INTEGER.
-* On entry, INCX specifies the increment for the elements of
-* X.
-* Unchanged on exit.
-*
-* BETA - REAL .
-* On entry, BETA specifies the scalar beta. When BETA is
-* supplied as zero then Y need not be set on input.
-* Unchanged on exit.
-*
-* Y - REAL array of dimension at least
-* ( 1 + ( n - 1 )*abs( INCY ) ).
-* Before entry, the incremented array Y must contain the n
-* element vector y. On exit, Y is overwritten by the updated
-* vector y.
-*
-* INCY - INTEGER.
-* On entry, INCY specifies the increment for the elements of
-* Y.
-* Unchanged on exit.
-*
-*
-*
-*
-*
-* Level 2 Blas routine.
-*
-* -- Written on 27-Sept-1985.
-* Sven Hammarling, Nag Central Office.
-C REVISED 860623
-C REVISED YYMMDD
-C BY R. J. HANSON, SANDIA NATIONAL LABS.
-*
- INTEGER I,IX,IY,J,JX,JY
- INTEGER K,KK,KX,KY
- REAL ONE,ZERO
- PARAMETER (ONE=1.0E+0,ZERO=0.0E+0)
- REAL TEMP1,TEMP2
- LOGICAL OK,LSAME
- OK = (LSAME(UPLO,'U') .OR. LSAME(UPLO,'L')) .AND. (N.GT.0)
-*
-* Quick return if possible.
-*
- IF ( .NOT. OK .OR. ((ALPHA.EQ.ZERO).AND. (BETA.EQ.ONE))) RETURN
-*
-* Start the operations. In this version the elements of the array AP
-* are accessed sequentially with one pass through AP.
-*
-* First form y := beta*y and set up the start points in X and Y if
-* the increments are not both unity.
-*
- IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
- IF (BETA.NE.ONE) THEN
- IF (BETA.EQ.ZERO) THEN
- DO 10,I = 1,N
- Y(I) = ZERO
- 10 CONTINUE
-*
- ELSE
- DO 20,I = 1,N
- Y(I) = BETA*Y(I)
- 20 CONTINUE
- END IF
-*
- END IF
-*
- ELSE
- IF (INCX.GT.0) THEN
- KX = 1
-*
- ELSE
- KX = 1 - (N-1)*INCX
- END IF
-*
- IF (INCY.GT.0) THEN
- KY = 1
-*
- ELSE
- KY = 1 - (N-1)*INCY
- END IF
-*
- IF (BETA.NE.ONE) THEN
- IY = KY
- IF (BETA.EQ.ZERO) THEN
- DO 30,I = 1,N
- Y(IY) = ZERO
- IY = IY + INCY
- 30 CONTINUE
-*
- ELSE
- DO 40,I = 1,N
- Y(IY) = BETA*Y(IY)
- IY = IY + INCY
- 40 CONTINUE
- END IF
-*
- END IF
-*
- END IF
-*
- IF (ALPHA.EQ.ZERO) RETURN
- K = 1
- IF (LSAME(UPLO,'U')) THEN
-*
-* Form y when AP contains the upper triangle.
-*
- IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
- DO 60,J = 1,N
- TEMP1 = ALPHA*X(J)
- TEMP2 = ZERO
- DO 50,I = 1,J - 1
- Y(I) = Y(I) + TEMP1*AP(K)
- TEMP2 = TEMP2 + AP(K)*X(I)
- K = K + 1
- 50 CONTINUE
- Y(J) = Y(J) + TEMP1*AP(K) + ALPHA*TEMP2
- K = K + 1
- 60 CONTINUE
-*
- ELSE
- IX = KX - INCX
- DO 80,J = 1,N
- TEMP1 = ALPHA*X(IX+INCX)
- TEMP2 = ZERO
- IX = KX
- IY = KY
- KK = K
- DO 70,K = KK,KK + J - 2
- Y(IY) = Y(IY) + TEMP1*AP(K)
- TEMP2 = TEMP2 + AP(K)*X(IX)
- IX = IX + INCX
- IY = IY + INCY
- 70 CONTINUE
- Y(IY) = Y(IY) + TEMP1*AP(K) + ALPHA*TEMP2
- K = K + 1
- 80 CONTINUE
- END IF
-*
- ELSE
-*
-* Form y when AP contains the upper triangle.
-*
- IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
- DO 100,J = 1,N
- TEMP1 = ALPHA*X(J)
- TEMP2 = ZERO
- Y(J) = Y(J) + TEMP1*AP(K)
- K = K + 1
- DO 90,I = J + 1,N
- Y(I) = Y(I) + TEMP1*AP(K)
- TEMP2 = TEMP2 + AP(K)*X(I)
- K = K + 1
- 90 CONTINUE
- Y(J) = Y(J) + ALPHA*TEMP2
- 100 CONTINUE
-*
- ELSE
- JX = KX
- JY = KY
- DO 120,J = 1,N
- TEMP1 = ALPHA*X(JX)
- TEMP2 = ZERO
- Y(JY) = Y(JY) + TEMP1*AP(K)
- IX = JX
- IY = JY
- KK = K + 1
- DO 110,K = KK,KK + N - (J+1)
- IX = IX + INCX
- IY = IY + INCY
- Y(IY) = Y(IY) + TEMP1*AP(K)
- TEMP2 = TEMP2 + AP(K)*X(IX)
- 110 CONTINUE
- Y(JY) = Y(JY) + ALPHA*TEMP2
- JX = JX + INCX
- JY = JY + INCY
- 120 CONTINUE
- END IF
-*
- END IF
-*
- RETURN
-*
-* End of SSPMV .
-*
- END
- SUBROUTINE STRMV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX)
- CHARACTER *1 UPLO,TRANS,DIAG
- INTEGER N,LDA,INCX
- REAL A(LDA,*),X(*)
-*
-* Purpose
-* =======
-*
-* STRMV performs one of the matrix-vector operations
-*
-* x := A*x, or x := A'*x,
-*
-* where x is n element vector and A is an n by n unit, or non-unit,
-* upper or lower triangular matrix.
-*
-* Parameters
-* ==========
-*
-* UPLO - CHARACTER*1.
-* On entry, UPLO specifies whether the matrix is an upper or
-* lower triangular matrix as follows:
-*
-* UPLO = 'U' A is an upper triangular matrix.
-*
-* UPLO = 'L' A is a lower triangular matrix.
-*
-* Unchanged on exit.
-*
-* TRANS - CHARACTER*1.
-* On entry, TRANS specifies the operation to be performed as
-* follows:
-*
-* TRANS = 'N' x := A*x.
-*
-* TRANS = 'T' x := A'*x.
-*
-* TRANS = 'C' x := A'*x.
-*
-* Unchanged on exit.
-*
-* DIAG - CHARACTER*1.
-* On entry, DIAG specifies whether or not A is unit
-* triangular as follows:
-*
-* DIAG = 'U' A is assumed to be unit triangular.
-*
-* DIAG = 'N' A is not assumed to be unit
-* triangular.
-*
-* Unchanged on exit.
-*
-* N - INTEGER.
-* On entry, N specifies the order of the matrix A.
-* N must be at least zero.
-* Unchanged on exit.
-*
-* A - REAL array of DIMENSION ( LDA, n ).
-* Before entry with UPLO = 'U', the leading n by n
-* upper triangular part of the array A must contain the upper
-* triangular matrix and the strictly lower triangular part of
-* A is not referenced.
-* Before entry with UPLO = 'L', the leading n by n
-* lower triangular part of the array A must contain the lower
-* triangular matrix and the strictly upper triangular part of
-* A is not referenced.
-* Note that when DIAG = 'U', the diagonal elements of
-* A are not referenced either, but are assumed to be unity.
-* Unchanged on exit.
-*
-* LDA - INTEGER.
-* On entry, LDA specifies the first dimension of A as declared
-* in the calling (sub) program. LDA must be at least max(n,1).
-* Unchanged on exit.
-*
-* X - REAL array of dimension at least
-* ( 1 + ( n - 1 )*abs( INCX ) ).
-* Before entry, the incremented array X must contain the n
-* element vector x. On exit, X is overwritten with the
-* tranformed vector x.
-*
-* INCX - INTEGER.
-* On entry, INCX specifies the increment for the elements of
-* X.
-* Unchanged on exit.
-*
-*
-*
-*
-* Level 2 Blas routine.
-*
-* -- Written on 30-September-1985.
-* Sven Hammarling, Nag Central Office.
-C REVISED 860623
-C REVISED YYMMDD
-C BY R. J. HANSON, SANDIA NATIONAL LABS.
-*
- LOGICAL NOUNIT
- INTEGER I,IX,J,JX,KX
- REAL ZERO
- PARAMETER (ZERO=0.0E+0)
- LOGICAL OK,LSAME
- OK = (LSAME(UPLO,'U') .OR. LSAME(UPLO,'L')) .AND.
- . (LSAME(TRANS,'N') .OR. LSAME(TRANS,'T') .OR.
- . LSAME(TRANS,'C')) .AND. (LSAME(DIAG,'U') .OR.
- . LSAME(DIAG,'N')) .AND. (N.GT.0) .AND. (LDA.GE.N)
-*
-*
-* Quick return if possible.
-*
- IF ( .NOT. OK) RETURN
- NOUNIT = LSAME(DIAG,'N')
-*
-* Set up the start point in X if the increment is not unity. This
-* will be ( N - 1 )*INCX too small for descending loops.
-*
- IF (INCX.LE.0) THEN
- KX = 1 - (N-1)*INCX
-*
- ELSE IF (INCX.NE.1) THEN
- KX = 1
- END IF
-*
-* Start the operations. In this version the elements of A are
-* accessed sequentially with one pass through A.
-*
- IF (LSAME(TRANS,'N')) THEN
-*
-* Form x := A*x.
-*
- IF (LSAME(UPLO,'U')) THEN
- IF (INCX.EQ.1) THEN
- DO 20,J = 1,N
- IF (X(J).NE.ZERO) THEN
- DO 10,I = 1,J - 1
- X(I) = X(I) + X(J)*A(I,J)
- 10 CONTINUE
- IF (NOUNIT) X(J) = X(J)*A(J,J)
- END IF
-*
- 20 CONTINUE
-*
- ELSE
- JX = KX
- DO 40,J = 1,N
- IF (X(JX).NE.ZERO) THEN
- IX = KX
- DO 30,I = 1,J - 1
- X(IX) = X(IX) + X(JX)*A(I,J)
- IX = IX + INCX
- 30 CONTINUE
- IF (NOUNIT) X(JX) = X(JX)*A(J,J)
- END IF
-*
- JX = JX + INCX
- 40 CONTINUE
- END IF
-*
- ELSE
- IF (INCX.EQ.1) THEN
- DO 60,J = N,1,-1
- IF (X(J).NE.ZERO) THEN
- DO 50,I = N,J + 1,-1
- X(I) = X(I) + X(J)*A(I,J)
- 50 CONTINUE
- IF (NOUNIT) X(J) = X(J)*A(J,J)
- END IF
-*
- 60 CONTINUE
-*
- ELSE
- KX = KX + (N-1)*INCX
- JX = KX
- DO 80,J = N,1,-1
- IF (X(JX).NE.ZERO) THEN
- IX = KX
- DO 70,I = N,J + 1,-1
- X(IX) = X(IX) + X(JX)*A(I,J)
- IX = IX - INCX
- 70 CONTINUE
- IF (NOUNIT) X(JX) = X(JX)*A(J,J)
- END IF
-*
- JX = JX - INCX
- 80 CONTINUE
- END IF
-*
- END IF
-*
- ELSE
-*
-* Form x := A'*x.
-*
- IF (LSAME(UPLO,'U')) THEN
- IF (INCX.EQ.1) THEN
- DO 100,J = N,1,-1
- IF (NOUNIT) X(J) = X(J)*A(J,J)
- DO 90,I = J - 1,1,-1
- X(J) = X(J) + A(I,J)*X(I)
- 90 CONTINUE
- 100 CONTINUE
-*
- ELSE
- JX = KX + (N-1)*INCX
- DO 120,J = N,1,-1
- IX = JX
- IF (NOUNIT) X(JX) = X(JX)*A(J,J)
- DO 110,I = J - 1,1,-1
- IX = IX - INCX
- X(JX) = X(JX) + A(I,J)*X(IX)
- 110 CONTINUE
- JX = JX - INCX
- 120 CONTINUE
- END IF
-*
- ELSE
- IF (INCX.EQ.1) THEN
- DO 140,J = 1,N
- IF (NOUNIT) X(J) = X(J)*A(J,J)
- DO 130,I = J + 1,N
- X(J) = X(J) + A(I,J)*X(I)
- 130 CONTINUE
- 140 CONTINUE
-*
- ELSE
- JX = KX
- DO 160,J = 1,N
- IX = JX
- IF (NOUNIT) X(JX) = X(JX)*A(J,J)
- DO 150,I = J + 1,N
- IX = IX + INCX
- X(JX) = X(JX) + A(I,J)*X(IX)
- 150 CONTINUE
- JX = JX + INCX
- 160 CONTINUE
- END IF
-*
- END IF
-*
- END IF
-*
- RETURN
-*
-* End of STRMV .
-*
- END
- SUBROUTINE STBMV(UPLO,TRANS,DIAG,N,K,A,LDA,X,INCX)
- CHARACTER *1 UPLO,TRANS,DIAG
- INTEGER N,K,LDA,INCX
- REAL A(LDA,*),X(*)
-*
-* Purpose
-* =======
-*
-* STBMV performs one of the matrix-vector operations
-*
-* x := A*x, or x := A'*x,
-*
-* where x is n element vector and A is an n by n unit, or non-unit,
-* upper or lower triangular band matrix, with ( k + 1 ) diagonals.
-*
-* Parameters
-* ==========
-*
-* UPLO - CHARACTER*1.
-* On entry, UPLO specifies whether the matrix is an upper or
-* lower triangular matrix as follows:
-*
-* UPLO = 'U' A is an upper triangular matrix.
-*
-* UPLO = 'L' A is a lower triangular matrix.
-*
-* Unchanged on exit.
-*
-* TRANS - CHARACTER*1.
-* On entry, TRANS specifies the operation to be performed as
-* follows:
-*
-* TRANS = 'N' x := A*x.
-*
-* TRANS = 'T' x := A'*x.
-*
-* TRANS = 'C' x := A'*x.
-*
-* Unchanged on exit.
-*
-* DIAG - CHARACTER*1.
-* On entry, DIAG specifies whether or not A is unit
-* triangular as follows:
-*
-* DIAG = 'U' A is assumed to be unit triangular.
-*
-* DIAG = 'N' A is not assumed to be unit
-* triangular.
-*
-* Unchanged on exit.
-*
-* N - INTEGER.
-* On entry, N specifies the order of the matrix A.
-* N must be at least zero.
-* Unchanged on exit.
-*
-* K - INTEGER.
-* On entry with UPLO = 'U', K specifies the number of
-* super-diagonals of the matrix A.
-* On entry with UPLO = 'L', K specifies the number of
-* sub-diagonals of the matrix A.
-* K must satisfy 0 .le. K.
-* Unchanged on exit.
-*
-* A - REAL array of DIMENSION ( LDA, n ).
-* Before entry with UPLO = 'U', the leading ( k + 1 )
-* by n part of the array A must contain the upper triangular
-* band part of the matrix of coefficients, supplied column by
-* column, with the leading diagonal of the matrix in row
-* ( k + 1 ) of the array, the first super-diagonal starting at
-* position 2 in row k, and so on. The top left k by k triangle
-* of the array A is not referenced.
-* Before entry with UPLO = 'L', the leading ( k + 1 )
-* by n part of the array A must contain the lower triangular
-* band part of the matrix of coefficients, supplied column by
-* column, with the leading diagonal of the matrix in row 1 of
-* the array, the first sub-diagonal starting at position 1 in
-* row 2, and so on. The bottom right k by k triangle of the
-* array A is not referenced.
-* Note that when DIAG = 'U' the elements of the array A
-* corresponding to the diagonal elements of the matrix are not
-* referenced, but are assumed to be unity.
-* Unchanged on exit.
-*
-* LDA - INTEGER.
-* On entry, LDA specifies the leading dimension of A as
-* declared in the calling (sub) program. LDA must be at least
-* ( k + 1 ).
-* Unchanged on exit.
-*
-* X - REAL array of dimension at least
-* ( 1 + ( n - 1 )*abs( INCX ) ).
-* Before entry, the incremented array X must contain the n
-* element vector x. On exit, X is overwritten with the
-* tranformed vector x.
-*
-* INCX - INTEGER.
-* On entry, INCX specifies the increment for the elements of
-* X.
-* Unchanged on exit.
-*
-*
-*
-*
-* Level 2 Blas routine.
-*
-* -- Written on 5-November-1985.
-* Sven Hammarling, Nag Central Office.
-C REVISED 860623
-C REVISED YYMMDD
-C BY R. J. HANSON, SANDIA NATIONAL LABS.
-*
- INTRINSIC MAX,MIN
- LOGICAL NOUNIT
- INTEGER I,IX,J,JX,KPLUS1,KX
- INTEGER L
- REAL ZERO
- PARAMETER (ZERO=0.0E+0)
- LOGICAL OK,LSAME
- OK = (LSAME(UPLO,'U') .OR. LSAME(UPLO,'L')) .AND.
- . (LSAME(TRANS,'N') .OR. LSAME(TRANS,'T') .OR.
- . LSAME(TRANS,'C')) .AND. (LSAME(DIAG,'U') .OR.
- . LSAME(DIAG,'N')) .AND. (N.GT.0) .AND. (K.GE.0) .AND.
- . (LDA.GE. (K+1))
-*
-*
-* Quick return if possible.
-*
- IF ( .NOT. OK) RETURN
- NOUNIT = LSAME(DIAG,'N')
-*
-* Set up the start point in X if the increment is not unity. This
-* will be ( N - 1 )*INCX too small for descending loops.
-*
- IF (INCX.LE.0) THEN
- KX = 1 - (N-1)*INCX
-*
- ELSE IF (INCX.NE.1) THEN
- KX = 1
- END IF
-*
-* Start the operations. In this version the elements of A are
-* accessed sequentially with one pass through A.
-*
- IF (LSAME(TRANS,'N')) THEN
-*
-* Form x := A*x.
-*
- IF (LSAME(UPLO,'U')) THEN
- KPLUS1 = K + 1
- IF (INCX.EQ.1) THEN
- DO 20,J = 1,N
- IF (X(J).NE.ZERO) THEN
- I = MAX(1,J-K)
- DO 10,L = KPLUS1 + I - J,K
- X(I) = X(I) + X(J)*A(L,J)
- I = I + 1
- 10 CONTINUE
- IF (NOUNIT) X(J) = X(J)*A(KPLUS1,J)
- END IF
-*
- 20 CONTINUE
-*
- ELSE
- JX = KX
- DO 40,J = 1,N
- IF (X(JX).NE.ZERO) THEN
- IX = KX
- DO 30,L = 1 + MAX(KPLUS1-J,0),K
- X(IX) = X(IX) + X(JX)*A(L,J)
- IX = IX + INCX
- 30 CONTINUE
- IF (NOUNIT) X(JX) = X(JX)*A(KPLUS1,J)
- END IF
-*
- JX = JX + INCX
- IF (J.GT.K) KX = KX + INCX
- 40 CONTINUE
- END IF
-*
- ELSE
- IF (INCX.EQ.1) THEN
- DO 60,J = N,1,-1
- IF (X(J).NE.ZERO) THEN
- I = MIN(N,J+K)
- DO 50,L = 1 + I - J,2,-1
- X(I) = X(I) + X(J)*A(L,J)
- I = I - 1
- 50 CONTINUE
- IF (NOUNIT) X(J) = X(J)*A(1,J)
- END IF
-*
- 60 CONTINUE
-*
- ELSE
- KX = KX + (N-1)*INCX
- JX = KX
- DO 80,J = N,1,-1
- IF (X(JX).NE.ZERO) THEN
- IX = KX
- DO 70,L = 1 + MIN(K,N-J),2,-1
- X(IX) = X(IX) + X(JX)*A(L,J)
- IX = IX - INCX
- 70 CONTINUE
- IF (NOUNIT) X(JX) = X(JX)*A(1,J)
- END IF
-*
- JX = JX - INCX
- IF ((N-J).GE.K) KX = KX - INCX
- 80 CONTINUE
- END IF
-*
- END IF
-*
- ELSE
-*
-* Form x := A'*x.
-*
- IF (LSAME(UPLO,'U')) THEN
- KPLUS1 = K + 1
- IF (INCX.EQ.1) THEN
- DO 100,J = N,1,-1
- I = J
- IF (NOUNIT) X(J) = X(J)*A(KPLUS1,J)
- DO 90,L = K,1 + MAX(KPLUS1-J,0),-1
- I = I - 1
- X(J) = X(J) + A(L,J)*X(I)
- 90 CONTINUE
- 100 CONTINUE
-*
- ELSE
- KX = KX + (N-1)*INCX
- JX = KX
- DO 120,J = N,1,-1
- KX = KX - INCX
- IX = KX
- IF (NOUNIT) X(JX) = X(JX)*A(KPLUS1,J)
- DO 110,L = K,1 + MAX(KPLUS1-J,0),-1
- X(JX) = X(JX) + A(L,J)*X(IX)
- IX = IX - INCX
- 110 CONTINUE
- JX = JX - INCX
- 120 CONTINUE
- END IF
-*
- ELSE
- IF (INCX.EQ.1) THEN
- DO 140,J = 1,N
- I = J
- IF (NOUNIT) X(J) = X(J)*A(1,J)
- DO 130,L = 2,1 + MIN(K,N-J)
- I = I + 1
- X(J) = X(J) + A(L,J)*X(I)
- 130 CONTINUE
- 140 CONTINUE
-*
- ELSE
- JX = KX
- DO 160,J = 1,N
- KX = KX + INCX
- IX = KX
- IF (NOUNIT) X(JX) = X(JX)*A(1,J)
- DO 150,L = 2,1 + MIN(K,N-J)
- X(JX) = X(JX) + A(L,J)*X(IX)
- IX = IX + INCX
- 150 CONTINUE
- JX = JX + INCX
- 160 CONTINUE
- END IF
-*
- END IF
-*
- END IF
-*
- RETURN
-*
-* End of STBMV .
-*
- END
- SUBROUTINE STPMV(UPLO,TRANS,DIAG,N,AP,X,INCX)
- CHARACTER *1 UPLO,TRANS,DIAG
- INTEGER N,INCX
- REAL AP(*),X(*)
-*
-* Purpose
-* =======
-*
-* STPMV performs one of the matrix-vector operations
-*
-* x := A*x, or x := A'*x,
-*
-* where x is n element vector and A is an n by n unit, or non-unit,
-* upper or lower triangular matrix.
-*
-* Parameters
-* ==========
-*
-* UPLO - CHARACTER*1.
-* On entry, UPLO specifies whether the matrix is an upper or
-* lower triangular matrix as follows:
-*
-* UPLO = 'U' A is an upper triangular matrix.
-*
-* UPLO = 'L' A is a lower triangular matrix.
-*
-* Unchanged on exit.
-*
-* TRANS - CHARACTER*1.
-* On entry, TRANS specifies the operation to be performed as
-* follows:
-*
-* TRANS = 'N' x := A*x.
-*
-* TRANS = 'T' x := A'*x.
-*
-* TRANS = 'C' x := A'*x.
-*
-* Unchanged on exit.
-*
-* DIAG - CHARACTER*1.
-* On entry, DIAG specifies whether or not A is unit
-* triangular as follows:
-*
-* DIAG = 'U' A is assumed to be unit triangular.
-*
-* DIAG = 'N' A is not assumed to be unit
-* triangular.
-*
-* Unchanged on exit.
-*
-* N - INTEGER.
-* On entry, N specifies the order of the matrix A.
-* N must be at least zero.
-* Unchanged on exit.
-*
-* AP - REAL array of DIMENSION at least
-* ( ( n*( n + 1 ) )/2 ).
-* Before entry with UPLO = 'U', the array AP must
-* contain the upper triangular matrix packed sequentially,
-* column by column, so that AP( 1 ) contains a( 1, 1 ),
-* AP( 2 ) and AP( 3 ) contain a( 1, 2 ) and a( 2, 2 )
-* respectively, and so on.
-* Before entry with UPLO = 'L', the array AP must
-* contain the lower triangular matrix packed sequentially,
-* column by column, so that AP( 1 ) contains a( 1, 1 ),
-* AP( 2 ) and AP( 3 ) contain a( 2, 1 ) and a( 3, 1 )
-* respectively, and so on.
-* Note that when DIAG = 'U', the diagonal elements of
-* A are not referenced, but are assumed to be unity.
-* Unchanged on exit.
-*
-* X - REAL array of dimension at least
-* ( 1 + ( n - 1 )*abs( INCX ) ).
-* Before entry, the incremented array X must contain the n
-* element vector x. On exit, X is overwritten with the
-* tranformed vector x.
-*
-* INCX - INTEGER.
-* On entry, INCX specifies the increment for the elements of
-* X.
-* Unchanged on exit.
-*
-*
-* Note that UPLO, TRANS, DIAG and N must be such that the value of the
-* LOGICAL variable OK in the following statement is true.
-*
-*
-*
-* Level 2 Blas routine.
-*
-* -- Written on 2-October-1985.
-* Sven Hammarling, Nag Central Office.
-C REVISED 860623
-C REVISED YYMMDD
-C BY R. J. HANSON, SANDIA NATIONAL LABS.
-*
- LOGICAL NOUNIT
- INTEGER I,IX,J,JX,K,KK
- INTEGER KX
- REAL ZERO
- PARAMETER (ZERO=0.0E+0)
- LOGICAL OK,LSAME
- OK = (LSAME(UPLO,'U') .OR. LSAME(UPLO,'L')) .AND.
- . (LSAME(TRANS,'N') .OR. LSAME(TRANS,'T') .OR.
- . LSAME(TRANS,'C')) .AND. (LSAME(DIAG,'U') .OR.
- . LSAME(DIAG,'N')) .AND. (N.GT.0)
-*
-*
-* Quick return if possible.
-*
- IF ( .NOT. OK) RETURN
- NOUNIT = LSAME(DIAG,'N')
-*
-* Set up the start point in X if the increment is not unity. This
-* will be ( N - 1 )*INCX too small for descending loops.
-*
- IF (INCX.LE.0) THEN
- KX = 1 - (N-1)*INCX
-*
- ELSE IF (INCX.NE.1) THEN
- KX = 1
- END IF
-*
-* Start the operations. In this version the elements of AP are
-* accessed sequentially with one pass through AP.
-*
- IF (LSAME(TRANS,'N')) THEN
-*
-* Form x:= A*x.
-*
- IF (LSAME(UPLO,'U')) THEN
- K = 1
- IF (INCX.EQ.1) THEN
- DO 20,J = 1,N
- IF (X(J).NE.ZERO) THEN
- DO 10,I = 1,J - 1
- X(I) = X(I) + X(J)*AP(K)
- K = K + 1
- 10 CONTINUE
- IF (NOUNIT) X(J) = X(J)*AP(K)
- K = K + 1
-*
- ELSE
- K = K + J
- END IF
-*
- 20 CONTINUE
-*
- ELSE
- JX = KX
- DO 40,J = 1,N
- IF (X(JX).NE.ZERO) THEN
- IX = KX
- KK = K
- DO 30,K = KK,KK + J - 2
- X(IX) = X(IX) + X(JX)*AP(K)
- IX = IX + INCX
- 30 CONTINUE
- IF (NOUNIT) X(JX) = X(JX)*AP(K)
- K = K + 1
-*
- ELSE
- K = K + J
- END IF
-*
- JX = JX + INCX
- 40 CONTINUE
- END IF
-*
- ELSE
- K = (N* (N+1))/2
- IF (INCX.EQ.1) THEN
- DO 60,J = N,1,-1
- IF (X(J).NE.ZERO) THEN
- DO 50,I = N,J + 1,-1
- X(I) = X(I) + X(J)*AP(K)
- K = K - 1
- 50 CONTINUE
- IF (NOUNIT) X(J) = X(J)*AP(K)
- K = K - 1
-*
- ELSE
- K = K - (N-J+1)
- END IF
-*
- 60 CONTINUE
-*
- ELSE
- KX = KX + (N-1)*INCX
- JX = KX
- DO 80,J = N,1,-1
- IF (X(JX).NE.ZERO) THEN
- IX = KX
- KK = K
- DO 70,K = KK,KK - (N- (J+1)),-1
- X(IX) = X(IX) + X(JX)*AP(K)
- IX = IX - INCX
- 70 CONTINUE
- IF (NOUNIT) X(JX) = X(JX)*AP(K)
- K = K - 1
-*
- ELSE
- K = K - (N-J+1)
- END IF
-*
- JX = JX - INCX
- 80 CONTINUE
- END IF
-*
- END IF
-*
- ELSE
-*
-* Form x := A'*x.
-*
- IF (LSAME(UPLO,'U')) THEN
- K = (N* (N+1))/2
- IF (INCX.EQ.1) THEN
- DO 100,J = N,1,-1
- IF (NOUNIT) X(J) = X(J)*AP(K)
- K = K - 1
- DO 90,I = J - 1,1,-1
- X(J) = X(J) + AP(K)*X(I)
- K = K - 1
- 90 CONTINUE
- 100 CONTINUE
-*
- ELSE
- JX = KX + (N-1)*INCX
- DO 120,J = N,1,-1
- IX = JX
- IF (NOUNIT) X(JX) = X(JX)*AP(K)
- KK = K - 1
- DO 110,K = KK,KK - J + 2,-1
- IX = IX - INCX
- X(JX) = X(JX) + AP(K)*X(IX)
- 110 CONTINUE
- JX = JX - INCX
- 120 CONTINUE
- END IF
-*
- ELSE
- K = 1
- IF (INCX.EQ.1) THEN
- DO 140,J = 1,N
- IF (NOUNIT) X(J) = X(J)*AP(K)
- K = K + 1
- DO 130,I = J + 1,N
- X(J) = X(J) + AP(K)*X(I)
- K = K + 1
- 130 CONTINUE
- 140 CONTINUE
-*
- ELSE
- JX = KX
- DO 160,J = 1,N
- IX = JX
- IF (NOUNIT) X(JX) = X(JX)*AP(K)
- KK = K + 1
- DO 150,K = KK,KK + N - (J+1)
- IX = IX + INCX
- X(JX) = X(JX) + AP(K)*X(IX)
- 150 CONTINUE
- JX = JX + INCX
- 160 CONTINUE
- END IF
-*
- END IF
-*
- END IF
-*
- RETURN
-*
-* End of STPMV .
-*
- END
- SUBROUTINE STRSV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX)
- CHARACTER *1 UPLO,TRANS,DIAG
- INTEGER N,LDA,INCX
- REAL A(LDA,*),X(*)
-*
-* Purpose
-* =======
-*
-* STRSV solves one of the systems of equations
-*
-* A*x = b, or A'*x = b,
-*
-* where b and x are n element vectors and A is an n by n unit, or
-* non-unit, upper or lower triangular matrix.
-*
-* No test for singularity or near-singularity is included in this
-* routine. Such tests must be performed before calling this routine.
-*
-* Parameters
-* ==========
-*
-* UPLO - CHARACTER*1.
-* On entry, UPLO specifies whether the matrix is an upper or
-* lower triangular matrix as follows:
-*
-* UPLO = 'U' A is an upper triangular matrix.
-*
-* UPLO = 'L' A is a lower triangular matrix.
-*
-* Unchanged on exit.
-*
-* TRANS - CHARACTER*1.
-* On entry, TRANS specifies the equations to be solved as
-* follows:
-*
-* TRANS = 'N' A*x = b.
-*
-* TRANS = 'T' A'*x = b.
-*
-* TRANS = 'C' A'*x = b.
-*
-* Unchanged on exit.
-*
-* DIAG - CHARACTER*1.
-* On entry, DIAG specifies whether or not A is unit
-* triangular as follows:
-*
-* DIAG = 'U' A is assumed to be unit triangular.
-*
-* DIAG = 'N' A is not assumed to be unit
-* triangular.
-*
-* Unchanged on exit.
-*
-* N - INTEGER.
-* On entry, N specifies the order of the matrix A.
-* N must be at least zero.
-* Unchanged on exit.
-*
-* A - REAL array of DIMENSION ( LDA, n ).
-* Before entry with UPLO = 'U', the leading n by n
-* upper triangular part of the array A must contain the upper
-* triangular matrix and the strictly lower triangular part of
-* A is not referenced.
-* Before entry with UPLO = 'L', the leading n by n
-* lower triangular part of the array A must contain the lower
-* triangular matrix and the strictly upper triangular part of
-* A is not referenced.
-* Note that when DIAG = 'U', the diagonal elements of
-* A are not referenced either, but are assumed to be unity.
-* Unchanged on exit.
-*
-* LDA - INTEGER.
-* On entry, LDA specifies the first dimension of A as declared
-* in the calling (sub) program. LDA must be at least max(n,1).
-* Unchanged on exit.
-*
-* X - REAL array of dimension at least
-* ( 1 + ( n - 1 )*abs( INCX ) ).
-* Before entry, the incremented array X must contain the n
-* element right-hand side vector b. On exit, X is overwritten
-* with the solution vector x.
-*
-* INCX - INTEGER.
-* On entry, INCX specifies the increment for the elements of
-* X.
-* Unchanged on exit.
-*
-*
-*
-*
-* Level 2 Blas routine.
-*
-* -- Written on 30-September-1985.
-* Sven Hammarling, Nag Central Office.
-C REVISED 860623
-C REVISED YYMMDD
-C BY R. J. HANSON, SANDIA NATIONAL LABS.
-*
- LOGICAL NOUNIT
- INTEGER I,IX,J,JX,KX
- REAL ZERO
- PARAMETER (ZERO=0.0E+0)
- LOGICAL OK,LSAME
- OK = (LSAME(UPLO,'U') .OR. LSAME(UPLO,'L')) .AND.
- . (LSAME(TRANS,'N') .OR. LSAME(TRANS,'T') .OR.
- . LSAME(TRANS,'C')) .AND. (LSAME(DIAG,'U') .OR.
- . LSAME(DIAG,'N')) .AND. (N.GT.0) .AND. (LDA.GE.N)
-*
-*
-* Quick return if possible.
-*
- IF ( .NOT. OK) RETURN
- NOUNIT = LSAME(DIAG,'N')
-*
-* Set up the start point in X if the increment is not unity. This
-* will be ( N - 1 )*INCX too small for descending loops.
-*
- IF (INCX.LE.0) THEN
- KX = 1 - (N-1)*INCX
-*
- ELSE IF (INCX.NE.1) THEN
- KX = 1
- END IF
-*
-* Start the operations. In this version the elements of A are
-* accessed sequentially with one pass through A.
-*
- IF (LSAME(TRANS,'N')) THEN
-*
-* Form x := inv( A )*x.
-*
- IF (LSAME(UPLO,'U')) THEN
- IF (INCX.EQ.1) THEN
- DO 20,J = N,1,-1
- IF (X(J).NE.ZERO) THEN
- IF (NOUNIT) X(J) = X(J)/A(J,J)
- DO 10,I = J - 1,1,-1
- X(I) = X(I) - X(J)*A(I,J)
- 10 CONTINUE
- END IF
-*
- 20 CONTINUE
-*
- ELSE
- JX = KX + (N-1)*INCX
- DO 40,J = N,1,-1
- IF (X(JX).NE.ZERO) THEN
- IF (NOUNIT) X(JX) = X(JX)/A(J,J)
- IX = JX
- DO 30,I = J - 1,1,-1
- IX = IX - INCX
- X(IX) = X(IX) - X(JX)*A(I,J)
- 30 CONTINUE
- END IF
-*
- JX = JX - INCX
- 40 CONTINUE
- END IF
-*
- ELSE
- IF (INCX.EQ.1) THEN
- DO 60,J = 1,N
- IF (X(J).NE.ZERO) THEN
- IF (NOUNIT) X(J) = X(J)/A(J,J)
- DO 50,I = J + 1,N
- X(I) = X(I) - X(J)*A(I,J)
- 50 CONTINUE
- END IF
-*
- 60 CONTINUE
-*
- ELSE
- JX = KX
- DO 80,J = 1,N
- IF (X(JX).NE.ZERO) THEN
- IF (NOUNIT) X(JX) = X(JX)/A(J,J)
- IX = JX
- DO 70,I = J + 1,N
- IX = IX + INCX
- X(IX) = X(IX) - X(JX)*A(I,J)
- 70 CONTINUE
- END IF
-*
- JX = JX + INCX
- 80 CONTINUE
- END IF
-*
- END IF
-*
- ELSE
-*
-* Form x := inv( A' )*x.
-*
- IF (LSAME(UPLO,'U')) THEN
- IF (INCX.EQ.1) THEN
- DO 100,J = 1,N
- DO 90,I = 1,J - 1
- X(J) = X(J) - A(I,J)*X(I)
- 90 CONTINUE
- IF (NOUNIT) X(J) = X(J)/A(J,J)
- 100 CONTINUE
-*
- ELSE
- JX = KX
- DO 120,J = 1,N
- IX = KX
- DO 110,I = 1,J - 1
- X(JX) = X(JX) - A(I,J)*X(IX)
- IX = IX + INCX
- 110 CONTINUE
- IF (NOUNIT) X(JX) = X(JX)/A(J,J)
- JX = JX + INCX
- 120 CONTINUE
- END IF
-*
- ELSE
- IF (INCX.EQ.1) THEN
- DO 140,J = N,1,-1
- DO 130,I = N,J + 1,-1
- X(J) = X(J) - A(I,J)*X(I)
- 130 CONTINUE
- IF (NOUNIT) X(J) = X(J)/A(J,J)
- 140 CONTINUE
-*
- ELSE
- KX = KX + (N-1)*INCX
- JX = KX
- DO 160,J = N,1,-1
- IX = KX
- DO 150,I = N,J + 1,-1
- X(JX) = X(JX) - A(I,J)*X(IX)
- IX = IX - INCX
- 150 CONTINUE
- IF (NOUNIT) X(JX) = X(JX)/A(J,J)
- JX = JX - INCX
- 160 CONTINUE
- END IF
-*
- END IF
-*
- END IF
-*
- RETURN
-*
-* End of STRSV .
-*
- END
- SUBROUTINE STBSV(UPLO,TRANS,DIAG,N,K,A,LDA,X,INCX)
- CHARACTER *1 UPLO,TRANS,DIAG
- INTEGER N,K,LDA,INCX
- REAL A(LDA,*),X(*)
-*
-* Purpose
-* =======
-*
-* STBSV solves one of the systems of equations
-*
-* A*x = b, or A'*x = b,
-*
-* where b and x are n element vectors and A is an n by n unit, or
-* non-unit, upper or lower triangular band matrix, with ( k + 1 )
-* diagonals.
-*
-* No test for singularity or near-singularity is included in this
-* routine. Such tests must be performed before calling this routine.
-*
-* Parameters
-* ==========
-*
-* UPLO - CHARACTER*1.
-* On entry, UPLO specifies whether the matrix is an upper or
-* lower triangular matrix as follows:
-*
-* UPLO = 'U' A is an upper triangular matrix.
-*
-* UPLO = 'L' A is a lower triangular matrix.
-*
-* Unchanged on exit.
-*
-* TRANS - CHARACTER*1.
-* On entry, TRANS specifies the equations to be solved as
-* follows:
-*
-* TRANS = 'N' A*x = b.
-*
-* TRANS = 'T' A'*x = b.
-*
-* TRANS = 'C' A'*x = b.
-*
-* Unchanged on exit.
-*
-* DIAG - CHARACTER*1.
-* On entry, DIAG specifies whether or not A is unit
-* triangular as follows:
-*
-* DIAG = 'U' A is assumed to be unit triangular.
-*
-* DIAG = 'N' A is not assumed to be unit
-* triangular.
-*
-* Unchanged on exit.
-*
-* N - INTEGER.
-* On entry, N specifies the order of the matrix A.
-* N must be at least zero.
-* Unchanged on exit.
-*
-* K - INTEGER.
-* On entry with UPLO = 'U', K specifies the number of
-* super-diagonals of the matrix A.
-* On entry with UPLO = 'L', K specifies the number of
-* sub-diagonals of the matrix A.
-* K must satisfy 0 .le. K.
-* Unchanged on exit.
-*
-* A - REAL array of DIMENSION ( LDA, n ).
-* Before entry with UPLO = 'U', the leading ( k + 1 )
-* by n part of the array A must contain the upper triangular
-* band part of the matrix of coefficients, supplied column by
-* column, with the leading diagonal of the matrix in row
-* ( k + 1 ) of the array, the first super-diagonal starting at
-* position 2 in row k, and so on. The top left k by k triangle
-* of the array A is not referenced.
-* Before entry with UPLO = 'L', the leading ( k + 1 )
-* by n part of the array A must contain the lower triangular
-* band part of the matrix of coefficients, supplied column by
-* column, with the leading diagonal of the matrix in row 1 of
-* the array, the first sub-diagonal starting at position 1 in
-* row 2, and so on. The bottom right k by k triangle of the
-* array A is not referenced.
-* Note that when DIAG = 'U' the elements of the array A
-* corresponding to the diagonal elements of the matrix are not
-* referenced, but are assumed to be unity.
-* Unchanged on exit.
-*
-* LDA - INTEGER.
-* On entry, LDA specifies the leading dimension of A as
-* declared in the calling (sub) program. LDA must be at least
-* ( k + 1 ).
-* Unchanged on exit.
-*
-* X - REAL array of dimension at least
-* ( 1 + ( n - 1 )*abs( INCX ) ).
-* Before entry, the incremented array X must contain the n
-* element right-hand side vector b. On exit, X is overwritten
-* with the solution vector x.
-*
-* INCX - INTEGER.
-* On entry, INCX specifies the increment for the elements of
-* X.
-* Unchanged on exit.
-*
-*
-*
-*
-*
-* Level 2 Blas routine.
-*
-* -- Written on 7-November-1985.
-* Sven Hammarling, Nag Central Office.
-C REVISED 860623
-C REVISED YYMMDD
-C BY R. J. HANSON, SANDIA NATIONAL LABS.
-*
- INTRINSIC MAX,MIN
- LOGICAL NOUNIT
- INTEGER I,IX,J,JX,KPLUS1,KX
- INTEGER L
- REAL ZERO
- PARAMETER (ZERO=0.0E+0)
- LOGICAL OK,LSAME
- OK = (LSAME(UPLO,'U') .OR. LSAME(UPLO,'L')) .AND.
- . (LSAME(TRANS,'N') .OR. LSAME(TRANS,'T') .OR.
- . LSAME(TRANS,'C')) .AND. (LSAME(DIAG,'U') .OR.
- . LSAME(DIAG,'N')) .AND. (N.GT.0) .AND. (K.GE.0) .AND.
- . (LDA.GE. (K+1))
-*
-*
-* Quick return if possible.
-*
- IF ( .NOT. OK) RETURN
- NOUNIT = LSAME(DIAG,'N')
-*
-* Set up the start point in X if the increment is not unity. This
-* will be ( N - 1 )*INCX too small for descending loops.
-*
- IF (INCX.LE.0) THEN
- KX = 1 - (N-1)*INCX
-*
- ELSE IF (INCX.NE.1) THEN
- KX = 1
- END IF
-*
-* Start the operations. In this version the elements of A are
-* accessed by sequentially with one pass through A.
-*
- IF (LSAME(TRANS,'N')) THEN
-*
-* Form x := inv( A )*x.
-*
- IF (LSAME(UPLO,'U')) THEN
- KPLUS1 = K + 1
- IF (INCX.EQ.1) THEN
- DO 20,J = N,1,-1
- IF (X(J).NE.ZERO) THEN
- IF (NOUNIT) X(J) = X(J)/A(KPLUS1,J)
- I = J
- DO 10,L = K,1 + MAX(KPLUS1-J,0),-1
- I = I - 1
- X(I) = X(I) - X(J)*A(L,J)
- 10 CONTINUE
- END IF
-*
- 20 CONTINUE
-*
- ELSE
- KX = KX + (N-1)*INCX
- JX = KX
- DO 40,J = N,1,-1
- KX = KX - INCX
- IX = KX
- IF (X(JX).NE.ZERO) THEN
- IF (NOUNIT) X(JX) = X(JX)/A(KPLUS1,J)
- DO 30 L = K,1 + MAX(KPLUS1-J,0),-1
- X(IX) = X(IX) - X(JX)*A(L,J)
- IX = IX - INCX
- 30 CONTINUE
- END IF
-*
- JX = JX - INCX
- 40 CONTINUE
- END IF
-*
- ELSE
- IF (INCX.EQ.1) THEN
- DO 60,J = 1,N
- IF (X(J).NE.ZERO) THEN
- IF (NOUNIT) X(J) = X(J)/A(1,J)
- I = J
- DO 50,L = 2,1 + MIN(K,N-J)
- I = I + 1
- X(I) = X(I) - X(J)*A(L,J)
- 50 CONTINUE
- END IF
-*
- 60 CONTINUE
-*
- ELSE
- JX = KX
- DO 80,J = 1,N
- KX = KX + INCX
- IF (X(JX).NE.ZERO) THEN
- IF (NOUNIT) X(JX) = X(JX)/A(1,J)
- IX = KX
- DO 70,L = 2,1 + MIN(K,N-J)
- X(IX) = X(IX) - X(JX)*A(L,J)
- IX = IX + INCX
- 70 CONTINUE
- END IF
-*
- JX = JX + INCX
- 80 CONTINUE
- END IF
-*
- END IF
-*
- ELSE
-*
-* Form x := inv( A')*x.
-*
- IF (LSAME(UPLO,'U')) THEN
- KPLUS1 = K + 1
- IF (INCX.EQ.1) THEN
- DO 100,J = 1,N
- I = MAX(1,J-K)
- DO 90,L = KPLUS1 + I - J,K
- X(J) = X(J) - A(L,J)*X(I)
- I = I + 1
- 90 CONTINUE
- IF (NOUNIT) X(J) = X(J)/A(KPLUS1,J)
- 100 CONTINUE
-*
- ELSE
- JX = KX
- DO 120,J = 1,N
- IX = KX
- DO 110,L = 1 + MAX(KPLUS1-J,0),K
- X(JX) = X(JX) - A(L,J)*X(IX)
- IX = IX + INCX
- 110 CONTINUE
- IF (NOUNIT) X(JX) = X(JX)/A(KPLUS1,J)
- JX = JX + INCX
- IF (J.GT.K) KX = KX + INCX
- 120 CONTINUE
- END IF
-*
- ELSE
- IF (INCX.EQ.1) THEN
- DO 140,J = N,1,-1
- I = MIN(N,J+K)
- DO 130,L = 1 + I - J,2,-1
- X(J) = X(J) - A(L,J)*X(I)
- I = I - 1
- 130 CONTINUE
- IF (NOUNIT) X(J) = X(J)/A(1,J)
- 140 CONTINUE
-*
- ELSE
- KX = KX + (N-1)*INCX
- JX = KX
- DO 160,J = N,1,-1
- IX = KX
- DO 150,L = 1 + MIN(K,N-J),2,-1
- X(JX) = X(JX) - A(L,J)*X(IX)
- IX = IX - INCX
- 150 CONTINUE
- IF (NOUNIT) X(JX) = X(JX)/A(1,J)
- JX = JX - INCX
- IF ((N-J).GE.K) KX = KX - INCX
- 160 CONTINUE
- END IF
-*
- END IF
-*
- END IF
-*
- RETURN
-*
-* End of STBSV .
-*
- END
- SUBROUTINE STPSV(UPLO,TRANS,DIAG,N,AP,X,INCX)
- CHARACTER *1 UPLO,TRANS,DIAG
- INTEGER N,INCX
- REAL AP(*),X(*)
-*
-* Purpose
-* =======
-*
-* STPSV solves one of the systems of equations
-*
-* A*x = b, or A'*x = b,
-*
-* where b and x are n element vectors and A is an n by n unit, or
-* non-unit, upper or lower triangular matrix.
-*
-* No test for singularity or near-singularity is included in this
-* routine. Such tests must be performed before calling this routine.
-*
-* Parameters
-* ==========
-*
-* UPLO - CHARACTER*1.
-* On entry, UPLO specifies whether the matrix is an upper or
-* lower triangular matrix as follows:
-*
-* UPLO = 'U' A is an upper triangular matrix.
-*
-* UPLO = 'L' A is a lower triangular matrix.
-*
-* Unchanged on exit.
-*
-* TRANS - CHARACTER*1.
-* On entry, TRANS specifies the equations to be solved as
-* follows:
-*
-* TRANS = 'N' A*x = b.
-*
-* TRANS = 'T' A'*x = b.
-*
-* TRANS = 'C' A'*x = b.
-*
-* Unchanged on exit.
-*
-* DIAG - CHARACTER*1.
-* On entry, DIAG specifies whether or not A is unit
-* triangular as follows:
-*
-* DIAG = 'U' A is assumed to be unit triangular.
-*
-* DIAG = 'N' A is not assumed to be unit
-* triangular.
-*
-* Unchanged on exit.
-*
-* N - INTEGER.
-* On entry, N specifies the order of the matrix A.
-* N must be at least zero.
-* Unchanged on exit.
-*
-* AP - REAL array of DIMENSION at least
-* ( ( n*( n + 1 ) )/2 ).
-* Before entry with UPLO = 'U', the array AP must
-* contain the upper triangular matrix packed sequentially,
-* column by column, so that AP( 1 ) contains a( 1, 1 ),
-* AP( 2 ) and AP( 3 ) contain a( 1, 2 ) and a( 2, 2 )
-* respectively, and so on.
-* Before entry with UPLO = 'L', the array AP must
-* contain the lower triangular matrix packed sequentially,
-* column by column, so that AP( 1 ) contains a( 1, 1 ),
-* AP( 2 ) and AP( 3 ) contain a( 2, 1 ) and a( 3, 1 )
-* respectively, and so on.
-* Note that when DIAG = 'U', the diagonal elements of
-* A are not referenced, but are assumed to be unity.
-* Unchanged on exit.
-*
-* X - REAL array of dimension at least
-* ( 1 + ( n - 1 )*abs( INCX ) ).
-* Before entry, the incremented array X must contain the n
-* element right-hand side vector b. On exit, X is overwritten
-* with the solution vector x.
-*
-* INCX - INTEGER.
-* On entry, INCX specifies the increment for the elements of
-* X.
-* Unchanged on exit.
-*
-*
-*
-*
-*
-* Level 2 Blas routine.
-*
-* -- Written on 11-November-1985.
-* Sven Hammarling, Nag Central Office.
-C REVISED 860623
-C REVISED YYMMDD
-C BY R. J. HANSON, SANDIA NATIONAL LABS.
-*
- LOGICAL NOUNIT
- INTEGER I,IX,J,JX,K,KK
- INTEGER KX
- REAL ZERO
- PARAMETER (ZERO=0.0E+0)
- LOGICAL OK,LSAME
- OK = (LSAME(UPLO,'U') .OR. LSAME(UPLO,'L')) .AND.
- . (LSAME(TRANS,'N') .OR. LSAME(TRANS,'T') .OR.
- . LSAME(TRANS,'C')) .AND. (LSAME(DIAG,'U') .OR.
- . LSAME(DIAG,'N')) .AND. (N.GT.0)
-*
-* Quick return if possible.
-*
- IF ( .NOT. OK) RETURN
- NOUNIT = LSAME(DIAG,'N')
-*
-* Set up the start point in X if the increment is not unity. This
-* will be ( N - 1 )*INCX too small for descending loops.
-*
- IF (INCX.LE.0) THEN
- KX = 1 - (N-1)*INCX
-*
- ELSE IF (INCX.NE.1) THEN
- KX = 1
- END IF
-*
-* Start the operations. In this version the elements of AP are
-* accessed sequentially with one pass through AP.
-*
- IF (LSAME(TRANS,'N')) THEN
-*
-* Form x := inv( A )*x.
-*
- IF (LSAME(UPLO,'U')) THEN
- K = (N* (N+1))/2
- IF (INCX.EQ.1) THEN
- DO 20,J = N,1,-1
- IF (X(J).NE.ZERO) THEN
- IF (NOUNIT) X(J) = X(J)/AP(K)
- K = K - 1
- DO 10,I = J - 1,1,-1
- X(I) = X(I) - X(J)*AP(K)
- K = K - 1
- 10 CONTINUE
-*
- ELSE
- K = K - J
- END IF
-*
- 20 CONTINUE
-*
- ELSE
- JX = KX + (N-1)*INCX
- DO 40,J = N,1,-1
- IF (X(JX).NE.ZERO) THEN
- IF (NOUNIT) X(JX) = X(JX)/AP(K)
- IX = JX
- KK = K - 1
- DO 30,K = KK,KK - J + 2,-1
- IX = IX - INCX
- X(IX) = X(IX) - X(JX)*AP(K)
- 30 CONTINUE
-*
- ELSE
- K = K - J
- END IF
-*
- JX = JX - INCX
- 40 CONTINUE
- END IF
-*
- ELSE
- K = 1
- IF (INCX.EQ.1) THEN
- DO 60,J = 1,N
- IF (X(J).NE.ZERO) THEN
- IF (NOUNIT) X(J) = X(J)/AP(K)
- K = K + 1
- DO 50,I = J + 1,N
- X(I) = X(I) - X(J)*AP(K)
- K = K + 1
- 50 CONTINUE
-*
- ELSE
- K = K + N - J + 1
- END IF
-*
- 60 CONTINUE
-*
- ELSE
- JX = KX
- DO 80,J = 1,N
- IF (X(JX).NE.ZERO) THEN
- IF (NOUNIT) X(JX) = X(JX)/AP(K)
- IX = JX
- KK = K + 1
- DO 70,K = KK,KK + N - (J+1)
- IX = IX + INCX
- X(IX) = X(IX) - X(JX)*AP(K)
- 70 CONTINUE
-*
- ELSE
- K = K + N - J + 1
- END IF
-*
- JX = JX + INCX
- 80 CONTINUE
- END IF
-*
- END IF
-*
- ELSE
-*
-* Form x := inv( A' )*x.
-*
- IF (LSAME(UPLO,'U')) THEN
- K = 1
- IF (INCX.EQ.1) THEN
- DO 100,J = 1,N
- DO 90,I = 1,J - 1
- X(J) = X(J) - AP(K)*X(I)
- K = K + 1
- 90 CONTINUE
- IF (NOUNIT) X(J) = X(J)/AP(K)
- K = K + 1
- 100 CONTINUE
-*
- ELSE
- JX = KX
- DO 120,J = 1,N
- IX = KX
- KK = K
- DO 110,K = KK,KK + J - 2
- X(JX) = X(JX) - AP(K)*X(IX)
- IX = IX + INCX
- 110 CONTINUE
- IF (NOUNIT) X(JX) = X(JX)/AP(K)
- K = K + 1
- JX = JX + INCX
- 120 CONTINUE
- END IF
-*
- ELSE
- K = (N* (N+1))/2
- IF (INCX.EQ.1) THEN
- DO 140,J = N,1,-1
- DO 130,I = N,J + 1,-1
- X(J) = X(J) - AP(K)*X(I)
- K = K - 1
- 130 CONTINUE
- IF (NOUNIT) X(J) = X(J)/AP(K)
- K = K - 1
- 140 CONTINUE
-*
- ELSE
- KX = KX + (N-1)*INCX
- JX = KX
- DO 160,J = N,1,-1
- IX = KX
- KK = K
- DO 150,K = KK,KK - (N- (J+1)),-1
- X(JX) = X(JX) - AP(K)*X(IX)
- IX = IX - INCX
- 150 CONTINUE
- IF (NOUNIT) X(JX) = X(JX)/AP(K)
- K = K - 1
- JX = JX - INCX
- 160 CONTINUE
- END IF
-*
- END IF
-*
- END IF
-*
- RETURN
-*
-* End of STPSV .
-*
- END
- SUBROUTINE SGER(M,N,ALPHA,X,INCX,Y,INCY,A,LDA)
- INTEGER M,N,INCX,INCY,LDA
- REAL ALPHA,X(*),Y(*),A(LDA,*)
-*
-* Purpose
-* =======
-*
-* SGER performs the rank 1 operation
-*
-* A := alpha*x*y' + A,
-*
-* where alpha is a scalar, x is an m element vector, y is an n element
-* vector and A is an m by n matrix.
-*
-* Parameters
-* ==========
-*
-* M - INTEGER.
-* On entry, M specifies the number of rows of the matrix A.
-* M must be at least zero.
-* Unchanged on exit.
-*
-* N - INTEGER.
-* On entry, N specifies the number of columns of the matrix A.
-* N must be at least zero.
-* Unchanged on exit.
-*
-* ALPHA - REAL .
-* On entry, ALPHA specifies the scalar alpha.
-* Unchanged on exit.
-*
-* X - REAL array of dimension at least
-* ( 1 + ( m - 1 )*abs( INCX ) ).
-* Before entry, the incremented array X must contain the m
-* element vector x.
-* Unchanged on exit.
-*
-* INCX - INTEGER.
-* On entry, INCX specifies the increment for the elements of
-* X.
-* Unchanged on exit.
-*
-* Y - REAL array of dimension at least
-* ( 1 + ( n - 1 )*abs( INCY ) ).
-* Before entry, the incremented array Y must contain the n
-* element vector y.
-* Unchanged on exit.
-*
-* INCY - INTEGER.
-* On entry, INCY specifies the increment for the elements of
-* Y.
-* Unchanged on exit.
-*
-* A - REAL array of DIMENSION ( LDA, n ).
-* Before entry, the leading m by n part of the array A must
-* contain the matrix of coefficients. On exit, A is
-* overwritten by the updated matrix.
-*
-* LDA - INTEGER.
-* On entry, LDA specifies the first dimension of A as declared
-* in the calling (sub) program. LDA must be at least max(1,m).
-* Unchanged on exit.
-*
-*
-*
-* Level 2 Blas routine.
-*
-* -- Written on 30-August-1985.
-* Sven Hammarling, Nag Central Office.
-C REVISED 860623
-C REVISED YYMMDD
-C BY R. J. HANSON, SANDIA NATIONAL LABS.
-*
- INTEGER I,IX,J,JY,KX
- REAL ZERO
- PARAMETER (ZERO=0.0E+0)
- REAL TEMP
- LOGICAL OK
- OK = (M.GT.0) .AND. (N.GT.0) .AND. (LDA.GE.M)
-*
-*
-* Quick return if possible.
-*
- IF ( .NOT. OK .OR. (ALPHA.EQ.ZERO)) RETURN
-*
-* Start the operations. In this version the elements of A are
-* accessed sequentially with one pass through A.
-*
- IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
- DO 20,J = 1,N
- IF (Y(J).NE.ZERO) THEN
- TEMP = ALPHA*Y(J)
- DO 10,I = 1,M
- A(I,J) = A(I,J) + X(I)*TEMP
- 10 CONTINUE
- END IF
-*
- 20 CONTINUE
-*
- ELSE
- IF (INCX.GT.0) THEN
- KX = 1
-*
- ELSE
- KX = 1 - (M-1)*INCX
- END IF
-*
- IF (INCY.GT.0) THEN
- JY = 1
-*
- ELSE
- JY = 1 - (N-1)*INCY
- END IF
-*
- DO 40,J = 1,N
- IF (Y(JY).NE.ZERO) THEN
- TEMP = ALPHA*Y(JY)
- IX = KX
- DO 30,I = 1,M
- A(I,J) = A(I,J) + X(IX)*TEMP
- IX = IX + INCX
- 30 CONTINUE
- END IF
-*
- JY = JY + INCY
- 40 CONTINUE
- END IF
-*
- RETURN
-*
-* End of SGER .
-*
- END
- SUBROUTINE SSYR(UPLO,N,ALPHA,X,INCX,A,LDA)
- CHARACTER *1 UPLO
- INTEGER N,INCX,LDA
- REAL ALPHA,X(*),A(LDA,*)
-*
-* Purpose
-* =======
-*
-* SSYR performs the symmetric rank 1 operation
-*
-* A := alpha*x*x' + A,
-*
-* where alpha is a real scalar, x is an n element vector and A is an
-* n by n symmetric matrix.
-*
-* Parameters
-* ==========
-*
-* UPLO - CHARACTER*1.
-* On entry, UPLO specifies whether the upper or lower
-* triangular part of the array A is to be referenced as
-* follows:
-*
-* UPLO = 'U' Only the upper triangular part of A
-* is to be referenced.
-*
-* UPLO = 'L' Only the lower triangular part of A
-* is to be referenced.
-*
-* Unchanged on exit.
-*
-* N - INTEGER.
-* On entry, N specifies the order of the matrix A.
-* N must be at least zero.
-* Unchanged on exit.
-*
-* ALPHA - REAL .
-* On entry, ALPHA specifies the scalar alpha.
-* Unchanged on exit.
-*
-* X - REAL array of dimension at least
-* ( 1 + ( n - 1 )*abs( INCX ) ).
-* Before entry, the incremented array X must contain the n
-* element vector x.
-* Unchanged on exit.
-*
-* INCX - INTEGER.
-* On entry, INCX specifies the increment for the elements of
-* X.
-* Unchanged on exit.
-*
-* A - REAL array of DIMENSION ( LDA, n ).
-* Before entry with UPLO = 'U', the leading n by n
-* upper triangular part of the array A must contain the upper
-* triangular part of the symmetric matrix and the strictly
-* lower triangular part of A is not referenced. On exit, the
-* upper triangular part of the array A is overwritten by the
-* upper triangular part of the updated matrix.
-* Before entry with UPLO = 'L', the leading n by n
-* lower triangular part of the array A must contain the lower
-* triangular part of the symmetric matrix and the strictly
-* upper triangular part of A is not referenced. On exit, the
-* lower triangular part of the array A is overwritten by the
-* lower triangular part of the updated matrix.
-*
-* LDA - INTEGER.
-* On entry, LDA specifies the first dimension of A as declared
-* in the calling (sub) program. LDA must be at least max(1,n).
-* Unchanged on exit.
-*
-*
-*
-*
-*
-* Level 2 Blas routine.
-*
-* -- Written on 27-September-1985.
-* Sven Hammarling, Nag Central Office.
-C REVISED 860623
-C REVISED YYMMDD
-C BY R. J. HANSON, SANDIA NATIONAL LABS.
-*
- INTEGER I,IX,J,JX,KX
- REAL ZERO
- PARAMETER (ZERO=0.0E+0)
- REAL TEMP
- LOGICAL OK,LSAME
- OK = (LSAME(UPLO,'U') .OR. LSAME(UPLO,'L')) .AND. (N.GT.0) .AND.
- . (LDA.GE.N)
-*
-* Quick return if possible.
-*
- IF ( .NOT. OK .OR. (ALPHA.EQ.ZERO)) RETURN
-*
-* Set the start point in X if the increment is not unity.
-*
- IF (INCX.LE.0) THEN
- KX = 1 - (N-1)*INCX
-*
- ELSE IF (INCX.NE.1) THEN
- KX = 1
- END IF
-*
-* Start the operations. In this version the elements of A are
-* accessed sequentially with one pass through the triangular part
-* of A.
-*
- IF (LSAME(UPLO,'U')) THEN
-*
-* Form A when A is stored in upper triangle.
-*
- IF (INCX.EQ.1) THEN
- DO 20,J = 1,N
- IF (X(J).NE.ZERO) THEN
- TEMP = ALPHA*X(J)
- DO 10,I = 1,J
- A(I,J) = A(I,J) + X(I)*TEMP
- 10 CONTINUE
- END IF
-*
- 20 CONTINUE
-*
- ELSE
- JX = KX
- DO 40,J = 1,N
- IF (X(JX).NE.ZERO) THEN
- TEMP = ALPHA*X(JX)
- IX = KX
- DO 30,I = 1,J
- A(I,J) = A(I,J) + X(IX)*TEMP
- IX = IX + INCX
- 30 CONTINUE
- END IF
-*
- JX = JX + INCX
- 40 CONTINUE
- END IF
-*
- ELSE
-*
-* Form A when A is stored in lower triangle.
-*
- IF (INCX.EQ.1) THEN
- DO 60,J = 1,N
- IF (X(J).NE.ZERO) THEN
- TEMP = ALPHA*X(J)
- DO 50,I = J,N
- A(I,J) = A(I,J) + X(I)*TEMP
- 50 CONTINUE
- END IF
-*
- 60 CONTINUE
-*
- ELSE
- JX = KX
- DO 80,J = 1,N
- IF (X(JX).NE.ZERO) THEN
- TEMP = ALPHA*X(JX)
- IX = JX
- DO 70,I = J,N
- A(I,J) = A(I,J) + X(IX)*TEMP
- IX = IX + INCX
- 70 CONTINUE
- END IF
-*
- JX = JX + INCX
- 80 CONTINUE
- END IF
-*
- END IF
-*
- RETURN
-*
-* End of SSYR .
-*
- END
- SUBROUTINE SSPR(UPLO,N,ALPHA,X,INCX,AP)
- CHARACTER *1 UPLO
- INTEGER N,INCX
- REAL ALPHA,X(*),AP(*)
-*
-* Purpose
-* =======
-*
-* SSPR performs the symmetric rank 1 operation
-*
-* A := alpha*x*x' + A,
-*
-* where alpha is a real scalar, x is an n element vector and A is an
-* n by n symmetric matrix.
-*
-* Parameters
-* ==========
-*
-* UPLO - CHARACTER*1.
-* On entry, UPLO specifies whether the upper or lower
-* triangular part of the matrix A is supplied in the packed
-* array AP as follows:
-*
-* UPLO = 'U' The upper triangular part of A is
-* supplied in AP.
-*
-* UPLO = 'L' The lower triangular part of A is
-* supplied in AP.
-*
-* Unchanged on exit.
-*
-* N - INTEGER.
-* On entry, N specifies the order of the matrix A.
-* N must be at least zero.
-* Unchanged on exit.
-*
-* ALPHA - REAL .
-* On entry, ALPHA specifies the scalar alpha.
-* Unchanged on exit.
-*
-* X - REAL array of dimension at least
-* ( 1 + ( n - 1 )*abs( INCX ) ).
-* Before entry, the incremented array X must contain the n
-* element vector x.
-* Unchanged on exit.
-*
-* INCX - INTEGER.
-* On entry, INCX specifies the increment for the elements of
-* X.
-* Unchanged on exit.
-*
-* AP - REAL array of DIMENSION at least
-* ( ( n*( n + 1 ) )/2 ).
-* Before entry with UPLO = 'U', the array AP must
-* contain the upper triangular part of the symmetric matrix
-* packed sequentially, column by column, so that AP( 1 )
-* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 )
-* and a( 2, 2 ) respectively, and so on. On exit, the array
-* AP is overwritten by the upper triangular part of the
-* updated matrix.
-* Before entry with UPLO = 'L', the array AP must
-* contain the lower triangular part of the symmetric matrix
-* packed sequentially, column by column, so that AP( 1 )
-* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 )
-* and a( 3, 1 ) respectively, and so on. On exit, the array
-* AP is overwritten by the lower triangular part of the
-* updated matrix.
-*
-*
-*
-*
-* Level 2 Blas routine.
-*
-* -- Written on 30-September-1985.
-* Sven Hammarling, Nag Central Office.
-C REVISED 860623
-C REVISED YYMMDD
-C BY R. J. HANSON, SANDIA NATIONAL LABS.
-*
- INTEGER I,IX,J,JX,K,KK
- INTEGER KX
- REAL ZERO
- PARAMETER (ZERO=0.0E+0)
- REAL TEMP
- LOGICAL OK,LSAME
- OK = (LSAME(UPLO,'U') .OR. LSAME(UPLO,'L')) .AND. (N.GT.0)
-*
-* Quick return if possible.
-*
- IF ( .NOT. OK .OR. (ALPHA.EQ.ZERO)) RETURN
-*
-* Set the start point in X if the increment is not unity.
-*
- IF (INCX.LE.0) THEN
- KX = 1 - (N-1)*INCX
-*
- ELSE IF (INCX.NE.1) THEN
- KX = 1
- END IF
-*
-* Start the operations. In this version the elements of the array AP
-* are accessed sequentially with one pass through AP.
-*
- K = 1
- IF (LSAME(UPLO,'U')) THEN
-*
-* Form A when upper triangle is stored in AP.
-*
- IF (INCX.EQ.1) THEN
- DO 20,J = 1,N
- IF (X(J).NE.ZERO) THEN
- TEMP = ALPHA*X(J)
- DO 10,I = 1,J
- AP(K) = AP(K) + X(I)*TEMP
- K = K + 1
- 10 CONTINUE
-*
- ELSE
- K = K + J
- END IF
-*
- 20 CONTINUE
-*
- ELSE
- JX = KX
- DO 40,J = 1,N
- IF (X(JX).NE.ZERO) THEN
- TEMP = ALPHA*X(JX)
- IX = KX
- KK = K
- DO 30,K = KK,KK + J - 1
- AP(K) = AP(K) + X(IX)*TEMP
- IX = IX + INCX
- 30 CONTINUE
-*
- ELSE
- K = K + J
- END IF
-*
- JX = JX + INCX
- 40 CONTINUE
- END IF
-*
- ELSE
-*
-* Form A when lower triangle is stored in AP.
-*
- IF (INCX.EQ.1) THEN
- DO 60,J = 1,N
- IF (X(J).NE.ZERO) THEN
- TEMP = ALPHA*X(J)
- DO 50,I = J,N
- AP(K) = AP(K) + X(I)*TEMP
- K = K + 1
- 50 CONTINUE
-*
- ELSE
- K = K + N - J + 1
- END IF
-*
- 60 CONTINUE
-*
- ELSE
- JX = KX
- DO 80,J = 1,N
- IF (X(JX).NE.ZERO) THEN
- TEMP = ALPHA*X(JX)
- IX = JX
- KK = K
- DO 70,K = KK,KK + N - J
- AP(K) = AP(K) + X(IX)*TEMP
- IX = IX + INCX
- 70 CONTINUE
-*
- ELSE
- K = K + N - J + 1
- END IF
-*
- JX = JX + INCX
- 80 CONTINUE
- END IF
-*
- END IF
-*
- RETURN
-*
-* End of SSPR .
-*
- END
- SUBROUTINE SSYR2(UPLO,N,ALPHA,X,INCX,Y,INCY,A,LDA)
- CHARACTER *1 UPLO
- INTEGER N,INCX,INCY,LDA
- REAL ALPHA,X(*),Y(*),A(LDA,*)
-*
-* Purpose
-* =======
-*
-* SSYR2 performs the symmetric rank 2 operation
-*
-* A := alpha*x*y' + alpha*y*x' + A,
-*
-* where alpha is a scalar, x and y are n element vectors and A is an n
-* by n symmetric matrix.
-*
-* Parameters
-* ==========
-*
-* UPLO - CHARACTER*1.
-* On entry, UPLO specifies whether the upper or lower
-* triangular part of the array A is to be referenced as
-* follows:
-*
-* UPLO = 'U' Only the upper triangular part of A
-* is to be referenced.
-*
-* UPLO = 'L' Only the lower triangular part of A
-* is to be referenced.
-*
-* Unchanged on exit.
-*
-* N - INTEGER.
-* On entry, N specifies the order of the matrix A.
-* N must be at least zero.
-* Unchanged on exit.
-*
-* ALPHA - REAL .
-* On entry, ALPHA specifies the scalar alpha.
-* Unchanged on exit.
-*
-* X - REAL array of dimension at least
-* ( 1 + ( n - 1 )*abs( INCX ) ).
-* Before entry, the incremented array X must contain the n
-* element vector x.
-* Unchanged on exit.
-*
-* INCX - INTEGER.
-* On entry, INCX specifies the increment for the elements of
-* X.
-* Unchanged on exit.
-*
-* Y - REAL array of dimension at least
-* ( 1 + ( n - 1 )*abs( INCY ) ).
-* Before entry, the incremented array Y must contain the n
-* element vector y.
-* Unchanged on exit.
-*
-* INCY - INTEGER.
-* On entry, INCY specifies the increment for the elements of
-* Y.
-* Unchanged on exit.
-*
-* A - REAL array of DIMENSION ( LDA, n ).
-* Before entry with UPLO = 'U', the leading n by n
-* upper triangular part of the array A must contain the upper
-* triangular part of the symmetric matrix and the strictly
-* lower triangular part of A is not referenced. On exit, the
-* upper triangular part of the array A is overwritten by the
-* upper triangular part of the updated matrix.
-* Before entry with UPLO = 'L', the leading n by n
-* lower triangular part of the array A must contain the lower
-* triangular part of the symmetric matrix and the strictly
-* upper triangular part of A is not referenced. On exit, the
-* lower triangular part of the array A is overwritten by the
-* lower triangular part of the updated matrix.
-*
-* LDA - INTEGER.
-* On entry, LDA specifies the first dimension of A as declared
-* in the calling (sub) program. LDA must be at least max(1,n).
-* Unchanged on exit.
-*
-*
-*
-*
-*
-* Level 2 Blas routine.
-*
-* -- Written on 27-September-1985.
-* Sven Hammarling, Nag Central Office.
-C REVISED 860623
-C REVISED YYMMDD
-C BY R. J. HANSON, SANDIA NATIONAL LABS.
-*
- INTEGER I,IX,IY,J,JX,JY
- INTEGER KX,KY
- REAL ZERO
- PARAMETER (ZERO=0.0E+0)
- REAL TEMP1,TEMP2
- LOGICAL OK,LSAME
- OK = (LSAME(UPLO,'U') .OR. LSAME(UPLO,'L')) .AND. (N.GT.0) .AND.
- . (LDA.GE.N)
-*
-* Quick return if possible.
-*
- IF ( .NOT. OK .OR. (ALPHA.EQ.ZERO)) RETURN
-*
-* Set up the start points in X and Y if the increments are not both
-* unity.
-*
- IF ((INCX.NE.1) .OR. (INCY.NE.1)) THEN
- IF (INCX.GT.0) THEN
- KX = 1
-*
- ELSE
- KX = 1 - (N-1)*INCX
- END IF
-*
- IF (INCY.GT.0) THEN
- KY = 1
-*
- ELSE
- KY = 1 - (N-1)*INCY
- END IF
-*
- END IF
-*
-* Start the operations. In this version the elements of A are
-* accessed sequentially with one pass through the triangular part
-* of A.
-*
- IF (LSAME(UPLO,'U')) THEN
-*
-* Form A when A is stored in the upper triangle.
-*
- IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
- DO 20,J = 1,N
- IF ((X(J).NE.ZERO) .OR. (Y(J).NE.ZERO)) THEN
- TEMP1 = ALPHA*Y(J)
- TEMP2 = ALPHA*X(J)
- DO 10,I = 1,J
- A(I,J) = A(I,J) + X(I)*TEMP1 + Y(I)*TEMP2
- 10 CONTINUE
- END IF
-*
- 20 CONTINUE
-*
- ELSE
- JX = KX
- JY = KY
- DO 40,J = 1,N
- IF ((X(JX).NE.ZERO) .OR. (Y(JY).NE.ZERO)) THEN
- TEMP1 = ALPHA*Y(JY)
- TEMP2 = ALPHA*X(JX)
- IX = KX
- IY = KY
- DO 30,I = 1,J
- A(I,J) = A(I,J) + X(IX)*TEMP1 + Y(IY)*TEMP2
- IX = IX + INCX
- IY = IY + INCY
- 30 CONTINUE
- END IF
-*
- JX = JX + INCX
- JY = JY + INCY
- 40 CONTINUE
- END IF
-*
- ELSE
-*
-* Form A when A is stored in the upper triangle.
-*
- IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
- DO 60,J = 1,N
- IF ((X(J).NE.ZERO) .OR. (Y(J).NE.ZERO)) THEN
- TEMP1 = ALPHA*Y(J)
- TEMP2 = ALPHA*X(J)
- DO 50,I = J,N
- A(I,J) = A(I,J) + X(I)*TEMP1 + Y(I)*TEMP2
- 50 CONTINUE
- END IF
-*
- 60 CONTINUE
-*
- ELSE
- JX = KX
- JY = KY
- DO 80,J = 1,N
- IF ((X(JX).NE.ZERO) .OR. (Y(JY).NE.ZERO)) THEN
- TEMP1 = ALPHA*Y(JY)
- TEMP2 = ALPHA*X(JX)
- IX = JX
- IY = JY
- DO 70,I = J,N
- A(I,J) = A(I,J) + X(IX)*TEMP1 + Y(IY)*TEMP2
- IX = IX + INCX
- IY = IY + INCY
- 70 CONTINUE
- END IF
-*
- JX = JX + INCX
- JY = JY + INCY
- 80 CONTINUE
- END IF
-*
- END IF
-*
- RETURN
-*
-* End of SSYR2 .
-*
- END
- SUBROUTINE SSPR2(UPLO,N,ALPHA,X,INCX,Y,INCY,AP)
- CHARACTER *1 UPLO
- INTEGER N,INCX,INCY
- REAL ALPHA,X(*),Y(*),AP(*)
-*
-* Purpose
-* =======
-*
-* SSPR2 performs the symmetric rank 2 operation
-*
-* A := alpha*x*y' + alpha*y*x' + A,
-*
-* where alpha is a scalar, x and y are n element vectors and A is an
-* n by n symmetric matrix.
-*
-* Parameters
-* ==========
-*
-* UPLO - CHARACTER*1.
-* On entry, UPLO specifies whether the upper or lower
-* triangular part of the matrix A is supplied in the packed
-* array AP as follows:
-*
-* UPLO = 'U' The upper triangular part of A is
-* supplied in AP.
-*
-* UPLO = 'L' The lower triangular part of A is
-* supplied in AP.
-*
-* Unchanged on exit.
-*
-* N - INTEGER.
-* On entry, N specifies the order of the matrix A.
-* N must be at least zero.
-* Unchanged on exit.
-*
-* ALPHA - REAL .
-* On entry, ALPHA specifies the scalar alpha.
-* Unchanged on exit.
-*
-* X - REAL array of dimension at least
-* ( 1 + ( n - 1 )*abs( INCX ) ).
-* Before entry, the incremented array X must contain the n
-* element vector x.
-* Unchanged on exit.
-*
-* INCX - INTEGER.
-* On entry, INCX specifies the increment for the elements of
-* X.
-* Unchanged on exit.
-*
-* Y - REAL array of dimension at least
-* ( 1 + ( n - 1 )*abs( INCY ) ).
-* Before entry, the incremented array Y must contain the n
-* element vector y.
-* Unchanged on exit.
-*
-* INCY - INTEGER.
-* On entry, INCY specifies the increment for the elements of
-* Y.
-* Unchanged on exit.
-*
-* AP - REAL array of DIMENSION at least
-* ( ( n*( n + 1 ) )/2 ).
-* Before entry with UPLO = 'U', the array AP must
-* contain the upper triangular part of the symmetric matrix
-* packed sequentially, column by column, so that AP( 1 )
-* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 )
-* and a( 2, 2 ) respectively, and so on. On exit, the array
-* AP is overwritten by the upper triangular part of the
-* updated matrix.
-* Before entry with UPLO = 'L', the array AP must
-* contain the lower triangular part of the symmetric matrix
-* packed sequentially, column by column, so that AP( 1 )
-* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 )
-* and a( 3, 1 ) respectively, and so on. On exit, the array
-* AP is overwritten by the lower triangular part of the
-* updated matrix.
-*
-*
-*
-*
-*
-* Level 2 Blas routine.
-*
-* -- Written on 30-September-1985.
-* Sven Hammarling, Nag Central Office.
-C REVISED 860623
-C REVISED YYMMDD
-C BY R. J. HANSON, SANDIA NATIONAL LABS.
-*
- INTEGER I,IX,IY,J,JX,JY
- INTEGER K,KK,KX,KY
- REAL ZERO
- PARAMETER (ZERO=0.0E+0)
- REAL TEMP1,TEMP2
- LOGICAL OK,LSAME
- OK = (LSAME(UPLO,'U') .OR. LSAME(UPLO,'L')) .AND. (N.GT.0)
-*
-* Quick return if possible.
-*
- IF ( .NOT. OK .OR. (ALPHA.EQ.ZERO)) RETURN
-*
-* Set up the start points in X and Y if the increments are not both
-* unity.
-*
- IF ((INCX.NE.1) .OR. (INCY.NE.1)) THEN
- IF (INCX.GT.0) THEN
- KX = 1
-*
- ELSE
- KX = 1 - (N-1)*INCX
- END IF
-*
- IF (INCY.GT.0) THEN
- KY = 1
-*
- ELSE
- KY = 1 - (N-1)*INCY
- END IF
-*
- END IF
-*
-* Start the operations. In this version the elements of the array AP
-* are accessed sequentially with one pass through AP.
-*
- K = 1
- IF (LSAME(UPLO,'U')) THEN
-*
-* Form A when upper triangle is stored in AP.
-*
- IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
- DO 20,J = 1,N
- IF ((X(J).NE.ZERO) .OR. (Y(J).NE.ZERO)) THEN
- TEMP1 = ALPHA*Y(J)
- TEMP2 = ALPHA*X(J)
- DO 10,I = 1,J
- AP(K) = AP(K) + X(I)*TEMP1 + Y(I)*TEMP2
- K = K + 1
- 10 CONTINUE
-*
- ELSE
- K = K + J
- END IF
-*
- 20 CONTINUE
-*
- ELSE
- JX = KX
- JY = KY
- DO 40,J = 1,N
- IF ((X(JX).NE.ZERO) .OR. (Y(JY).NE.ZERO)) THEN
- TEMP1 = ALPHA*Y(JY)
- TEMP2 = ALPHA*X(JX)
- IX = KX
- IY = KY
- KK = K
- DO 30,K = KK,KK + J - 1
- AP(K) = AP(K) + X(IX)*TEMP1 + Y(IY)*TEMP2
- IX = IX + INCX
- IY = IY + INCY
- 30 CONTINUE
-*
- ELSE
- K = K + J
- END IF
-*
- JX = JX + INCX
- JY = JY + INCY
- 40 CONTINUE
- END IF
-*
- ELSE
-*
-* Form A when lower triangle is stored in AP.
-*
- IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
- DO 60,J = 1,N
- IF ((X(J).NE.ZERO) .OR. (Y(J).NE.ZERO)) THEN
- TEMP1 = ALPHA*Y(J)
- TEMP2 = ALPHA*X(J)
- DO 50,I = J,N
- AP(K) = AP(K) + X(I)*TEMP1 + Y(I)*TEMP2
- K = K + 1
- 50 CONTINUE
-*
- ELSE
- K = K + N - J + 1
- END IF
-*
- 60 CONTINUE
-*
- ELSE
- JX = KX
- JY = KY
- DO 80,J = 1,N
- IF ((X(JX).NE.ZERO) .OR. (Y(JY).NE.ZERO)) THEN
- TEMP1 = ALPHA*Y(JY)
- TEMP2 = ALPHA*X(JX)
- IX = JX
- IY = JY
- KK = K
- DO 70,K = KK,KK + N - J
- AP(K) = AP(K) + X(IX)*TEMP1 + Y(IY)*TEMP2
- IX = IX + INCX
- IY = IY + INCY
- 70 CONTINUE
-*
- ELSE
- K = K + N - J + 1
- END IF
-*
- JX = JX + INCX
- JY = JY + INCY
- 80 CONTINUE
- END IF
-*
- END IF
-*
- RETURN
-*
-* End of SSPR2 .
-*
- END
- LOGICAL FUNCTION LSAME(CA,CB)
-C TEST IF TWO CHARACTERS ARE ESSENTIALLY THE SAME.
-C THE CHARACTER CB IS ONE OF THE FORTRAN SET.
-C (LOWER AND UPPER CASE LETTERS ARE EQUIVALENT.)
-C THIS IS A SUBPROGRAM FOR THE LEVEL TWO BLAS.
-C REVISED 860623
-C REVISED YYMMDD
-C AUTH=R. J. HANSON, SANDIA NATIONAL LABS.
-C
-C THIS SUBPROGRAM IS MACHINE-DEPENDENT.
-C VERSION FOR CDC SYSTEMS USING 6-12 BIT REPRESENTATIONS.
- CHARACTER CA(*)
- CHARACTER *1 CB
- INTEGER ICIRFX
- DATA ICIRFX/62/
-C SEE IF THE FIRST CHAR. IN STRING CA EQUALS STRING CB.
- LSAME = CA(1) .EQ. CB .AND. CA(1) .NE. CHAR(ICIRFX)
- IF (LSAME) RETURN
-C THE CHARS. ARE NOT IDENTICAL. NOW CHECK THEM FOR EQUIVALENCE.
-C LOOK FOR THE 'ESCAPE' CHARACTER, CIRCUMFLEX, FOLLOWED BY
-C THE LETTER.
- IVAL = ICHAR(CA(2))
- IF (IVAL.GE.ICHAR('A') .AND. IVAL.LE.ICHAR('Z')) THEN
- LSAME = CA(1) .EQ. CHAR(ICIRFX) .AND. CA(2) .EQ. CB
- END IF
-*
- RETURN
-C END
-C LOGICAL FUNCTION LSAME(CA,CB)
-C TEST IF TWO CHARACTERS ARE ESSENTIALLY THE SAME.
-C THE CHARACTER CB IS ONE OF THE FORTRAN SET.
-C (LOWER AND UPPER CASE LETTERS ARE EQUIVALENT.)
-C THIS IS A SUBPROGRAM FOR THE LEVEL TWO BLAS.
-C REVISED 860623
-C REVISED YYMMDD
-C AUTH=R. J. HANSON, SANDIA NATIONAL LABS.
-C
-C THIS SUBPROGRAM IS MACHINE-DEPENDENT.
-C VERSION FOR ANY ASCII MACHINE.
-C CHARACTER *1 CA
-C CHARACTER *1 CB
-C INTEGER IOFF
-C DATA IOFF/32/
-C SEE IF THE CHAR. IN STRING CA EQUALS STRING CB.
-C LSAME = CA .EQ. CB
-C IF (LSAME) RETURN
-C THE CHARS. ARE NOT IDENTICAL. NOW CHECK THEM FOR EQUIVALENCE.
-C ISHIFT = ICHAR(CA) - IOFF
-C IF (ISHIFT.GE.ICHAR('A') .AND. ISHIFT.LE.ICHAR('Z')) THEN
-C LSAME = ISHIFT .EQ. ICHAR(CB)
-C END IF
-C
-C RETURN
-C END
-C
-C LOGICAL FUNCTION LSAME(CA,CB)
-C TEST IF TWO CHARACTERS ARE ESSENTIALLY THE SAME.
-C THE CHARACTER CB IS ONE OF THE FORTRAN SET.
-C (LOWER AND UPPER CASE LETTERS ARE EQUIVALENT.)
-C THIS IS A SUBPROGRAM FOR THE LEVEL TWO BLAS.
-C REVISED 860623
-C REVISED YYMMDD
-C AUTH=R. J. HANSON, SANDIA NATIONAL LABS.
-C
-C THIS SUBPROGRAM IS MACHINE-DEPENDENT.
-C VERSION FOR ANY EBCDIC MACHINE.
-C CHARACTER *1 CA
-C CHARACTER *1 CB
-C INTEGER IOFF
-C DATA IOFF/64/
-C SEE IF THE CHAR. IN STRING CA EQUALS STRING CB.
-C LSAME = CA .EQ. CB
-C IF (LSAME) RETURN
-C THE CHARS. ARE NOT IDENTICAL. NOW CHECK THEM FOR EQUIVALENCE.
-C ISHIFT = ICHAR(CA) + IOFF
-C IF (ISHIFT.GE.ICHAR('A') .AND. ISHIFT.LE.ICHAR('I')) THEN
-C LSAME = ISHIFT .EQ. ICHAR(CB)
-C END IF
-C
-C IF (ISHIFT.GE.ICHAR('J') .AND. ISHIFT.LE.ICHAR('R')) THEN
-C LSAME = ISHIFT .EQ. ICHAR(CB)
-C END IF
-C
-C IF (ISHIFT.GE.ICHAR('S') .AND. ISHIFT.LE.ICHAR('Z')) THEN
-C LSAME = ISHIFT .EQ. ICHAR(CB)
-C END IF
-C
-C RETURN
-C END
- END
- subroutine dcopy(n,dx,incx,dy,incy)
-c
-c copies a vector, x, to a vector, y.
-c uses unrolled loops for increments equal to one.
-c jack dongarra, linpack, 3/11/78.
-c modified 12/3/93, array(1) declarations changed to array(*)
-c
- double precision dx(*),dy(*)
- integer i,incx,incy,ix,iy,m,mp1,n
-c
- if(n.le.0)return
- if(incx.eq.1.and.incy.eq.1)go to 20
-c
-c code for unequal increments or equal increments
-c not equal to 1
-c
- ix = 1
- iy = 1
- if(incx.lt.0)ix = (-n+1)*incx + 1
- if(incy.lt.0)iy = (-n+1)*incy + 1
- do 10 i = 1,n
- dy(iy) = dx(ix)
- ix = ix + incx
- iy = iy + incy
- 10 continue
- return
-c
-c code for both increments equal to 1
-c
-c
-c clean-up loop
-c
- 20 m = mod(n,7)
- if( m .eq. 0 ) go to 40
- do 30 i = 1,m
- dy(i) = dx(i)
- 30 continue
- if( n .lt. 7 ) return
- 40 mp1 = m + 1
- do 50 i = mp1,n,7
- dy(i) = dx(i)
- dy(i + 1) = dx(i + 1)
- dy(i + 2) = dx(i + 2)
- dy(i + 3) = dx(i + 3)
- dy(i + 4) = dx(i + 4)
- dy(i + 5) = dx(i + 5)
- dy(i + 6) = dx(i + 6)
- 50 continue
- return
- end
- SUBROUTINE DGEMM ( TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB,
- $ BETA, C, LDC )
-* .. Scalar Arguments ..
- CHARACTER*1 TRANSA, TRANSB
- INTEGER M, N, K, LDA, LDB, LDC
- REAL ALPHA, BETA
-* .. Array Arguments ..
- REAL A( LDA, * ), B( LDB, * ), C( LDC, * )
-* ..
-*
-* Purpose
-* =======
-*
-* DGEMM performs one of the matrix-matrix operations
-*
-* C := alpha*op( A )*op( B ) + beta*C,
-*
-* where op( X ) is one of
-*
-* op( X ) = X or op( X ) = X',
-*
-* alpha and beta are scalars, and A, B and C are matrices, with op( A )
-* an m by k matrix, op( B ) a k by n matrix and C an m by n matrix.
-*
-* Parameters
-* ==========
-*
-* TRANSA - CHARACTER*1.
-* On entry, TRANSA specifies the form of op( A ) to be used in
-* the matrix multiplication as follows:
-*
-* TRANSA = 'N' or 'n', op( A ) = A.
-*
-* TRANSA = 'T' or 't', op( A ) = A'.
-*
-* TRANSA = 'C' or 'c', op( A ) = A'.
-*
-* Unchanged on exit.
-*
-* TRANSB - CHARACTER*1.
-* On entry, TRANSB specifies the form of op( B ) to be used in
-* the matrix multiplication as follows:
-*
-* TRANSB = 'N' or 'n', op( B ) = B.
-*
-* TRANSB = 'T' or 't', op( B ) = B'.
-*
-* TRANSB = 'C' or 'c', op( B ) = B'.
-*
-* Unchanged on exit.
-*
-* M - INTEGER.
-* On entry, M specifies the number of rows of the matrix
-* op( A ) and of the matrix C. M must be at least zero.
-* Unchanged on exit.
-*
-* N - INTEGER.
-* On entry, N specifies the number of columns of the matrix
-* op( B ) and the number of columns of the matrix C. N must be
-* at least zero.
-* Unchanged on exit.
-*
-* K - INTEGER.
-* On entry, K specifies the number of columns of the matrix
-* op( A ) and the number of rows of the matrix op( B ). K must
-* be at least zero.
-* Unchanged on exit.
-*
-* ALPHA - REAL.
-* On entry, ALPHA specifies the scalar alpha.
-* Unchanged on exit.
-*
-* A - REAL array of DIMENSION ( LDA, ka ), where ka is
-* k when TRANSA = 'N' or 'n', and is m otherwise.
-* Before entry with TRANSA = 'N' or 'n', the leading m by k
-* part of the array A must contain the matrix A, otherwise
-* the leading k by m part of the array A must contain the
-* matrix A.
-* Unchanged on exit.
-*
-* LDA - INTEGER.
-* On entry, LDA specifies the first dimension of A as declared
-* in the calling (sub) program. When TRANSA = 'N' or 'n' then
-* LDA must be at least max( 1, m ), otherwise LDA must be at
-* least max( 1, k ).
-* Unchanged on exit.
-*
-* B - REAL array of DIMENSION ( LDB, kb ), where kb is
-* n when TRANSB = 'N' or 'n', and is k otherwise.
-* Before entry with TRANSB = 'N' or 'n', the leading k by n
-* part of the array B must contain the matrix B, otherwise
-* the leading n by k part of the array B must contain the
-* matrix B.
-* Unchanged on exit.
-*
-* LDB - INTEGER.
-* On entry, LDB specifies the first dimension of B as declared
-* in the calling (sub) program. When TRANSB = 'N' or 'n' then
-* LDB must be at least max( 1, k ), otherwise LDB must be at
-* least max( 1, n ).
-* Unchanged on exit.
-*
-* BETA - REAL.
-* On entry, BETA specifies the scalar beta. When BETA is
-* supplied as zero then C need not be set on input.
-* Unchanged on exit.
-*
-* C - REAL array of DIMENSION ( LDC, n ).
-* Before entry, the leading m by n part of the array C must
-* contain the matrix C, except when beta is zero, in which
-* case C need not be set on entry.
-* On exit, the array C is overwritten by the m by n matrix
-* ( alpha*op( A )*op( B ) + beta*C ).
-*
-* LDC - INTEGER.
-* On entry, LDC specifies the first dimension of C as declared
-* in the calling (sub) program. LDC must be at least
-* max( 1, m ).
-* Unchanged on exit.
-*
-*
-* Level 3 Blas routine.
-*
-* -- Written on 8-February-1989.
-* Jack Dongarra, Argonne National Laboratory.
-* Iain Duff, AERE Harwell.
-* Jeremy Du Croz, Numerical Algorithms Group Ltd.
-* Sven Hammarling, Numerical Algorithms Group Ltd.
-*
-*
-* .. External Functions ..
- LOGICAL LSAME
- EXTERNAL LSAME
-* .. External Subroutines ..
- EXTERNAL XERBLA
-* .. Intrinsic Functions ..
- INTRINSIC MAX
-* .. Local Scalars ..
- LOGICAL NOTA, NOTB
- INTEGER I, INFO, J, L, NCOLA, NROWA, NROWB
- REAL TEMP
-* .. Parameters ..
- REAL ONE , ZERO
- PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
-* ..
-* .. Executable Statements ..
-*
-* Set NOTA and NOTB as true if A and B respectively are not
-* transposed and set NROWA, NCOLA and NROWB as the number of rows
-* and columns of A and the number of rows of B respectively.
-*
- NOTA = LSAME( TRANSA, 'N' )
- NOTB = LSAME( TRANSB, 'N' )
- IF( NOTA )THEN
- NROWA = M
- NCOLA = K
- ELSE
- NROWA = K
- NCOLA = M
- END IF
- IF( NOTB )THEN
- NROWB = K
- ELSE
- NROWB = N
- END IF
-*
-* Test the input parameters.
-*
- INFO = 0
- IF( ( .NOT.NOTA ).AND.
- $ ( .NOT.LSAME( TRANSA, 'C' ) ).AND.
- $ ( .NOT.LSAME( TRANSA, 'T' ) ) )THEN
- INFO = 1
- ELSE IF( ( .NOT.NOTB ).AND.
- $ ( .NOT.LSAME( TRANSB, 'C' ) ).AND.
- $ ( .NOT.LSAME( TRANSB, 'T' ) ) )THEN
- INFO = 2
- ELSE IF( M .LT.0 )THEN
- INFO = 3
- ELSE IF( N .LT.0 )THEN
- INFO = 4
- ELSE IF( K .LT.0 )THEN
- INFO = 5
- ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN
- INFO = 8
- ELSE IF( LDB.LT.MAX( 1, NROWB ) )THEN
- INFO = 10
- ELSE IF( LDC.LT.MAX( 1, M ) )THEN
- INFO = 13
- END IF
- IF( INFO.NE.0 )THEN
- CALL XERBLA( 'DGEMM ', INFO )
- RETURN
- END IF
-*
-* Quick return if possible.
-*
- IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR.
- $ ( ( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) ).AND.( BETA.EQ.ONE ) ) )
- $ RETURN
-*
-* And if alpha.eq.zero.
-*
- IF( ALPHA.EQ.ZERO )THEN
- IF( BETA.EQ.ZERO )THEN
- DO 20, J = 1, N
- DO 10, I = 1, M
- C( I, J ) = ZERO
- 10 CONTINUE
- 20 CONTINUE
- ELSE
- DO 40, J = 1, N
- DO 30, I = 1, M
- C( I, J ) = BETA*C( I, J )
- 30 CONTINUE
- 40 CONTINUE
- END IF
- RETURN
- END IF
-*
-* Start the operations.
-*
- IF( NOTB )THEN
- IF( NOTA )THEN
-*
-* Form C := alpha*A*B + beta*C.
-*
- DO 90, J = 1, N
- IF( BETA.EQ.ZERO )THEN
- DO 50, I = 1, M
- C( I, J ) = ZERO
- 50 CONTINUE
- ELSE IF( BETA.NE.ONE )THEN
- DO 60, I = 1, M
- C( I, J ) = BETA*C( I, J )
- 60 CONTINUE
- END IF
- DO 80, L = 1, K
- IF( B( L, J ).NE.ZERO )THEN
- TEMP = ALPHA*B( L, J )
- DO 70, I = 1, M
- C( I, J ) = C( I, J ) + TEMP*A( I, L )
- 70 CONTINUE
- END IF
- 80 CONTINUE
- 90 CONTINUE
- ELSE
-*
-* Form C := alpha*A'*B + beta*C
-*
- DO 120, J = 1, N
- DO 110, I = 1, M
- TEMP = ZERO
- DO 100, L = 1, K
- TEMP = TEMP + A( L, I )*B( L, J )
- 100 CONTINUE
- IF( BETA.EQ.ZERO )THEN
- C( I, J ) = ALPHA*TEMP
- ELSE
- C( I, J ) = ALPHA*TEMP + BETA*C( I, J )
- END IF
- 110 CONTINUE
- 120 CONTINUE
- END IF
- ELSE
- IF( NOTA )THEN
-*
-* Form C := alpha*A*B' + beta*C
-*
- DO 170, J = 1, N
- IF( BETA.EQ.ZERO )THEN
- DO 130, I = 1, M
- C( I, J ) = ZERO
- 130 CONTINUE
- ELSE IF( BETA.NE.ONE )THEN
- DO 140, I = 1, M
- C( I, J ) = BETA*C( I, J )
- 140 CONTINUE
- END IF
- DO 160, L = 1, K
- IF( B( J, L ).NE.ZERO )THEN
- TEMP = ALPHA*B( J, L )
- DO 150, I = 1, M
- C( I, J ) = C( I, J ) + TEMP*A( I, L )
- 150 CONTINUE
- END IF
- 160 CONTINUE
- 170 CONTINUE
- ELSE
-*
-* Form C := alpha*A'*B' + beta*C
-*
- DO 200, J = 1, N
- DO 190, I = 1, M
- TEMP = ZERO
- DO 180, L = 1, K
- TEMP = TEMP + A( L, I )*B( J, L )
- 180 CONTINUE
- IF( BETA.EQ.ZERO )THEN
- C( I, J ) = ALPHA*TEMP
- ELSE
- C( I, J ) = ALPHA*TEMP + BETA*C( I, J )
- END IF
- 190 CONTINUE
- 200 CONTINUE
- END IF
- END IF
-*
- RETURN
-*
-* End of DGEMM .
-*
- END
- SUBROUTINE DGEMV ( TRANS, M, N, ALPHA, A, LDA, X, INCX,
- $ BETA, Y, INCY )
-* .. Scalar Arguments ..
- REAL ALPHA, BETA
- INTEGER INCX, INCY, LDA, M, N
- CHARACTER*1 TRANS
-* .. Array Arguments ..
- REAL A( LDA, * ), X( * ), Y( * )
-* ..
-*
-* Purpose
-* =======
-*
-* DGEMV performs one of the matrix-vector operations
-*
-* y := alpha*A*x + beta*y, or y := alpha*A'*x + beta*y,
-*
-* where alpha and beta are scalars, x and y are vectors and A is an
-* m by n matrix.
-*
-* Parameters
-* ==========
-*
-* TRANS - CHARACTER*1.
-* On entry, TRANS specifies the operation to be performed as
-* follows:
-*
-* TRANS = 'N' or 'n' y := alpha*A*x + beta*y.
-*
-* TRANS = 'T' or 't' y := alpha*A'*x + beta*y.
-*
-* TRANS = 'C' or 'c' y := alpha*A'*x + beta*y.
-*
-* Unchanged on exit.
-*
-* M - INTEGER.
-* On entry, M specifies the number of rows of the matrix A.
-* M must be at least zero.
-* Unchanged on exit.
-*
-* N - INTEGER.
-* On entry, N specifies the number of columns of the matrix A.
-* N must be at least zero.
-* Unchanged on exit.
-*
-* ALPHA - REAL.
-* On entry, ALPHA specifies the scalar alpha.
-* Unchanged on exit.
-*
-* A - REAL array of DIMENSION ( LDA, n ).
-* Before entry, the leading m by n part of the array A must
-* contain the matrix of coefficients.
-* Unchanged on exit.
-*
-* LDA - INTEGER.
-* On entry, LDA specifies the first dimension of A as declared
-* in the calling (sub) program. LDA must be at least
-* max( 1, m ).
-* Unchanged on exit.
-*
-* X - REAL array of DIMENSION at least
-* ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n'
-* and at least
-* ( 1 + ( m - 1 )*abs( INCX ) ) otherwise.
-* Before entry, the incremented array X must contain the
-* vector x.
-* Unchanged on exit.
-*
-* INCX - INTEGER.
-* On entry, INCX specifies the increment for the elements of
-* X. INCX must not be zero.
-* Unchanged on exit.
-*
-* BETA - REAL.
-* On entry, BETA specifies the scalar beta. When BETA is
-* supplied as zero then Y need not be set on input.
-* Unchanged on exit.
-*
-* Y - REAL array of DIMENSION at least
-* ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n'
-* and at least
-* ( 1 + ( n - 1 )*abs( INCY ) ) otherwise.
-* Before entry with BETA non-zero, the incremented array Y
-* must contain the vector y. On exit, Y is overwritten by the
-* updated vector y.
-*
-* INCY - INTEGER.
-* On entry, INCY specifies the increment for the elements of
-* Y. INCY must not be zero.
-* Unchanged on exit.
-*
-*
-* Level 2 Blas routine.
-*
-* -- Written on 22-October-1986.
-* Jack Dongarra, Argonne National Lab.
-* Jeremy Du Croz, Nag Central Office.
-* Sven Hammarling, Nag Central Office.
-* Richard Hanson, Sandia National Labs.
-*
-*
-* .. Parameters ..
- REAL ONE , ZERO
- PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
-* .. Local Scalars ..
- REAL TEMP
- INTEGER I, INFO, IX, IY, J, JX, JY, KX, KY, LENX, LENY
-* .. External Functions ..
- LOGICAL LSAME
- EXTERNAL LSAME
-* .. External Subroutines ..
- EXTERNAL XERBLA
-* .. Intrinsic Functions ..
- INTRINSIC MAX
-* ..
-* .. Executable Statements ..
-*
-* Test the input parameters.
-*
- INFO = 0
- IF ( .NOT.LSAME( TRANS, 'N' ).AND.
- $ .NOT.LSAME( TRANS, 'T' ).AND.
- $ .NOT.LSAME( TRANS, 'C' ) )THEN
- INFO = 1
- ELSE IF( M.LT.0 )THEN
- INFO = 2
- ELSE IF( N.LT.0 )THEN
- INFO = 3
- ELSE IF( LDA.LT.MAX( 1, M ) )THEN
- INFO = 6
- ELSE IF( INCX.EQ.0 )THEN
- INFO = 8
- ELSE IF( INCY.EQ.0 )THEN
- INFO = 11
- END IF
- IF( INFO.NE.0 )THEN
- CALL XERBLA( 'DGEMV ', INFO )
- RETURN
- END IF
-*
-* Quick return if possible.
-*
- IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR.
- $ ( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) )
- $ RETURN
-*
-* Set LENX and LENY, the lengths of the vectors x and y, and set
-* up the start points in X and Y.
-*
- IF( LSAME( TRANS, 'N' ) )THEN
- LENX = N
- LENY = M
- ELSE
- LENX = M
- LENY = N
- END IF
- IF( INCX.GT.0 )THEN
- KX = 1
- ELSE
- KX = 1 - ( LENX - 1 )*INCX
- END IF
- IF( INCY.GT.0 )THEN
- KY = 1
- ELSE
- KY = 1 - ( LENY - 1 )*INCY
- END IF
-*
-* Start the operations. In this version the elements of A are
-* accessed sequentially with one pass through A.
-*
-* First form y := beta*y.
-*
- IF( BETA.NE.ONE )THEN
- IF( INCY.EQ.1 )THEN
- IF( BETA.EQ.ZERO )THEN
- DO 10, I = 1, LENY
- Y( I ) = ZERO
- 10 CONTINUE
- ELSE
- DO 20, I = 1, LENY
- Y( I ) = BETA*Y( I )
- 20 CONTINUE
- END IF
- ELSE
- IY = KY
- IF( BETA.EQ.ZERO )THEN
- DO 30, I = 1, LENY
- Y( IY ) = ZERO
- IY = IY + INCY
- 30 CONTINUE
- ELSE
- DO 40, I = 1, LENY
- Y( IY ) = BETA*Y( IY )
- IY = IY + INCY
- 40 CONTINUE
- END IF
- END IF
- END IF
- IF( ALPHA.EQ.ZERO )
- $ RETURN
- IF( LSAME( TRANS, 'N' ) )THEN
-*
-* Form y := alpha*A*x + y.
-*
- JX = KX
- IF( INCY.EQ.1 )THEN
- DO 60, J = 1, N
- IF( X( JX ).NE.ZERO )THEN
- TEMP = ALPHA*X( JX )
- DO 50, I = 1, M
- Y( I ) = Y( I ) + TEMP*A( I, J )
- 50 CONTINUE
- END IF
- JX = JX + INCX
- 60 CONTINUE
- ELSE
- DO 80, J = 1, N
- IF( X( JX ).NE.ZERO )THEN
- TEMP = ALPHA*X( JX )
- IY = KY
- DO 70, I = 1, M
- Y( IY ) = Y( IY ) + TEMP*A( I, J )
- IY = IY + INCY
- 70 CONTINUE
- END IF
- JX = JX + INCX
- 80 CONTINUE
- END IF
- ELSE
-*
-* Form y := alpha*A'*x + y.
-*
- JY = KY
- IF( INCX.EQ.1 )THEN
- DO 100, J = 1, N
- TEMP = ZERO
- DO 90, I = 1, M
- TEMP = TEMP + A( I, J )*X( I )
- 90 CONTINUE
- Y( JY ) = Y( JY ) + ALPHA*TEMP
- JY = JY + INCY
- 100 CONTINUE
- ELSE
- DO 120, J = 1, N
- TEMP = ZERO
- IX = KX
- DO 110, I = 1, M
- TEMP = TEMP + A( I, J )*X( IX )
- IX = IX + INCX
- 110 CONTINUE
- Y( JY ) = Y( JY ) + ALPHA*TEMP
- JY = JY + INCY
- 120 CONTINUE
- END IF
- END IF
-*
- RETURN
-*
-* End of DGEMV .
-*
- END
- SUBROUTINE DGER ( M, N, ALPHA, X, INCX, Y, INCY, A, LDA )
-* .. Scalar Arguments ..
- REAL ALPHA
- INTEGER INCX, INCY, LDA, M, N
-* .. Array Arguments ..
- REAL A( LDA, * ), X( * ), Y( * )
-* ..
-*
-* Purpose
-* =======
-*
-* DGER performs the rank 1 operation
-*
-* A := alpha*x*y' + A,
-*
-* where alpha is a scalar, x is an m element vector, y is an n element
-* vector and A is an m by n matrix.
-*
-* Parameters
-* ==========
-*
-* M - INTEGER.
-* On entry, M specifies the number of rows of the matrix A.
-* M must be at least zero.
-* Unchanged on exit.
-*
-* N - INTEGER.
-* On entry, N specifies the number of columns of the matrix A.
-* N must be at least zero.
-* Unchanged on exit.
-*
-* ALPHA - REAL.
-* On entry, ALPHA specifies the scalar alpha.
-* Unchanged on exit.
-*
-* X - REAL array of dimension at least
-* ( 1 + ( m - 1 )*abs( INCX ) ).
-* Before entry, the incremented array X must contain the m
-* element vector x.
-* Unchanged on exit.
-*
-* INCX - INTEGER.
-* On entry, INCX specifies the increment for the elements of
-* X. INCX must not be zero.
-* Unchanged on exit.
-*
-* Y - REAL array of dimension at least
-* ( 1 + ( n - 1 )*abs( INCY ) ).
-* Before entry, the incremented array Y must contain the n
-* element vector y.
-* Unchanged on exit.
-*
-* INCY - INTEGER.
-* On entry, INCY specifies the increment for the elements of
-* Y. INCY must not be zero.
-* Unchanged on exit.
-*
-* A - REAL array of DIMENSION ( LDA, n ).
-* Before entry, the leading m by n part of the array A must
-* contain the matrix of coefficients. On exit, A is
-* overwritten by the updated matrix.
-*
-* LDA - INTEGER.
-* On entry, LDA specifies the first dimension of A as declared
-* in the calling (sub) program. LDA must be at least
-* max( 1, m ).
-* Unchanged on exit.
-*
-*
-* Level 2 Blas routine.
-*
-* -- Written on 22-October-1986.
-* Jack Dongarra, Argonne National Lab.
-* Jeremy Du Croz, Nag Central Office.
-* Sven Hammarling, Nag Central Office.
-* Richard Hanson, Sandia National Labs.
-*
-*
-* .. Parameters ..
- REAL ZERO
- PARAMETER ( ZERO = 0.0D+0 )
-* .. Local Scalars ..
- REAL TEMP
- INTEGER I, INFO, IX, J, JY, KX
-* .. External Subroutines ..
- EXTERNAL XERBLA
-* .. Intrinsic Functions ..
- INTRINSIC MAX
-* ..
-* .. Executable Statements ..
-*
-* Test the input parameters.
-*
- INFO = 0
- IF ( M.LT.0 )THEN
- INFO = 1
- ELSE IF( N.LT.0 )THEN
- INFO = 2
- ELSE IF( INCX.EQ.0 )THEN
- INFO = 5
- ELSE IF( INCY.EQ.0 )THEN
- INFO = 7
- ELSE IF( LDA.LT.MAX( 1, M ) )THEN
- INFO = 9
- END IF
- IF( INFO.NE.0 )THEN
- CALL XERBLA( 'DGER ', INFO )
- RETURN
- END IF
-*
-* Quick return if possible.
-*
- IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR.( ALPHA.EQ.ZERO ) )
- $ RETURN
-*
-* Start the operations. In this version the elements of A are
-* accessed sequentially with one pass through A.
-*
- IF( INCY.GT.0 )THEN
- JY = 1
- ELSE
- JY = 1 - ( N - 1 )*INCY
- END IF
- IF( INCX.EQ.1 )THEN
- DO 20, J = 1, N
- IF( Y( JY ).NE.ZERO )THEN
- TEMP = ALPHA*Y( JY )
- DO 10, I = 1, M
- A( I, J ) = A( I, J ) + X( I )*TEMP
- 10 CONTINUE
- END IF
- JY = JY + INCY
- 20 CONTINUE
- ELSE
- IF( INCX.GT.0 )THEN
- KX = 1
- ELSE
- KX = 1 - ( M - 1 )*INCX
- END IF
- DO 40, J = 1, N
- IF( Y( JY ).NE.ZERO )THEN
- TEMP = ALPHA*Y( JY )
- IX = KX
- DO 30, I = 1, M
- A( I, J ) = A( I, J ) + X( IX )*TEMP
- IX = IX + INCX
- 30 CONTINUE
- END IF
- JY = JY + INCY
- 40 CONTINUE
- END IF
-*
- RETURN
-*
-* End of DGER .
-*
- END
- subroutine dscal(n,da,dx,incx)
-c
-c scales a vector by a constant.
-c uses unrolled loops for increment equal to one.
-c jack dongarra, linpack, 3/11/78.
-c modified 3/93 to return if incx .le. 0.
-c modified 12/3/93, array(1) declarations changed to array(*)
-c
- double precision da,dx(*)
- integer i,incx,m,mp1,n,nincx
-c
- if( n.le.0 .or. incx.le.0 )return
- if(incx.eq.1)go to 20
-c
-c code for increment not equal to 1
-c
- nincx = n*incx
- do 10 i = 1,nincx,incx
- dx(i) = da*dx(i)
- 10 continue
- return
-c
-c code for increment equal to 1
-c
-c
-c clean-up loop
-c
- 20 m = mod(n,5)
- if( m .eq. 0 ) go to 40
- do 30 i = 1,m
- dx(i) = da*dx(i)
- 30 continue
- if( n .lt. 5 ) return
- 40 mp1 = m + 1
- do 50 i = mp1,n,5
- dx(i) = da*dx(i)
- dx(i + 1) = da*dx(i + 1)
- dx(i + 2) = da*dx(i + 2)
- dx(i + 3) = da*dx(i + 3)
- dx(i + 4) = da*dx(i + 4)
- 50 continue
- return
- end
- subroutine dswap (n,dx,incx,dy,incy)
-c
-c interchanges two vectors.
-c uses unrolled loops for increments equal one.
-c jack dongarra, linpack, 3/11/78.
-c modified 12/3/93, array(1) declarations changed to array(*)
-c
- double precision dx(*),dy(*),dtemp
- integer i,incx,incy,ix,iy,m,mp1,n
-c
- if(n.le.0)return
- if(incx.eq.1.and.incy.eq.1)go to 20
-c
-c code for unequal increments or equal increments not equal
-c to 1
-c
- ix = 1
- iy = 1
- if(incx.lt.0)ix = (-n+1)*incx + 1
- if(incy.lt.0)iy = (-n+1)*incy + 1
- do 10 i = 1,n
- dtemp = dx(ix)
- dx(ix) = dy(iy)
- dy(iy) = dtemp
- ix = ix + incx
- iy = iy + incy
- 10 continue
- return
-c
-c code for both increments equal to 1
-c
-c
-c clean-up loop
-c
- 20 m = mod(n,3)
- if( m .eq. 0 ) go to 40
- do 30 i = 1,m
- dtemp = dx(i)
- dx(i) = dy(i)
- dy(i) = dtemp
- 30 continue
- if( n .lt. 3 ) return
- 40 mp1 = m + 1
- do 50 i = mp1,n,3
- dtemp = dx(i)
- dx(i) = dy(i)
- dy(i) = dtemp
- dtemp = dx(i + 1)
- dx(i + 1) = dy(i + 1)
- dy(i + 1) = dtemp
- dtemp = dx(i + 2)
- dx(i + 2) = dy(i + 2)
- dy(i + 2) = dtemp
- 50 continue
- return
- end
- SUBROUTINE DTBSV ( UPLO, TRANS, DIAG, N, K, A, LDA, X, INCX )
-* .. Scalar Arguments ..
- INTEGER INCX, K, LDA, N
- CHARACTER*1 DIAG, TRANS, UPLO
-* .. Array Arguments ..
- REAL A( LDA, * ), X( * )
-* ..
-*
-* Purpose
-* =======
-*
-* DTBSV solves one of the systems of equations
-*
-* A*x = b, or A'*x = b,
-*
-* where b and x are n element vectors and A is an n by n unit, or
-* non-unit, upper or lower triangular band matrix, with ( k + 1 )
-* diagonals.
-*
-* No test for singularity or near-singularity is included in this
-* routine. Such tests must be performed before calling this routine.
-*
-* Parameters
-* ==========
-*
-* UPLO - CHARACTER*1.
-* On entry, UPLO specifies whether the matrix is an upper or
-* lower triangular matrix as follows:
-*
-* UPLO = 'U' or 'u' A is an upper triangular matrix.
-*
-* UPLO = 'L' or 'l' A is a lower triangular matrix.
-*
-* Unchanged on exit.
-*
-* TRANS - CHARACTER*1.
-* On entry, TRANS specifies the equations to be solved as
-* follows:
-*
-* TRANS = 'N' or 'n' A*x = b.
-*
-* TRANS = 'T' or 't' A'*x = b.
-*
-* TRANS = 'C' or 'c' A'*x = b.
-*
-* Unchanged on exit.
-*
-* DIAG - CHARACTER*1.
-* On entry, DIAG specifies whether or not A is unit
-* triangular as follows:
-*
-* DIAG = 'U' or 'u' A is assumed to be unit triangular.
-*
-* DIAG = 'N' or 'n' A is not assumed to be unit
-* triangular.
-*
-* Unchanged on exit.
-*
-* N - INTEGER.
-* On entry, N specifies the order of the matrix A.
-* N must be at least zero.
-* Unchanged on exit.
-*
-* K - INTEGER.
-* On entry with UPLO = 'U' or 'u', K specifies the number of
-* super-diagonals of the matrix A.
-* On entry with UPLO = 'L' or 'l', K specifies the number of
-* sub-diagonals of the matrix A.
-* K must satisfy 0 .le. K.
-* Unchanged on exit.
-*
-* A - REAL array of DIMENSION ( LDA, n ).
-* Before entry with UPLO = 'U' or 'u', the leading ( k + 1 )
-* by n part of the array A must contain the upper triangular
-* band part of the matrix of coefficients, supplied column by
-* column, with the leading diagonal of the matrix in row
-* ( k + 1 ) of the array, the first super-diagonal starting at
-* position 2 in row k, and so on. The top left k by k triangle
-* of the array A is not referenced.
-* The following program segment will transfer an upper
-* triangular band matrix from conventional full matrix storage
-* to band storage:
-*
-* DO 20, J = 1, N
-* M = K + 1 - J
-* DO 10, I = MAX( 1, J - K ), J
-* A( M + I, J ) = matrix( I, J )
-* 10 CONTINUE
-* 20 CONTINUE
-*
-* Before entry with UPLO = 'L' or 'l', the leading ( k + 1 )
-* by n part of the array A must contain the lower triangular
-* band part of the matrix of coefficients, supplied column by
-* column, with the leading diagonal of the matrix in row 1 of
-* the array, the first sub-diagonal starting at position 1 in
-* row 2, and so on. The bottom right k by k triangle of the
-* array A is not referenced.
-* The following program segment will transfer a lower
-* triangular band matrix from conventional full matrix storage
-* to band storage:
-*
-* DO 20, J = 1, N
-* M = 1 - J
-* DO 10, I = J, MIN( N, J + K )
-* A( M + I, J ) = matrix( I, J )
-* 10 CONTINUE
-* 20 CONTINUE
-*
-* Note that when DIAG = 'U' or 'u' the elements of the array A
-* corresponding to the diagonal elements of the matrix are not
-* referenced, but are assumed to be unity.
-* Unchanged on exit.
-*
-* LDA - INTEGER.
-* On entry, LDA specifies the first dimension of A as declared
-* in the calling (sub) program. LDA must be at least
-* ( k + 1 ).
-* Unchanged on exit.
-*
-* X - REAL array of dimension at least
-* ( 1 + ( n - 1 )*abs( INCX ) ).
-* Before entry, the incremented array X must contain the n
-* element right-hand side vector b. On exit, X is overwritten
-* with the solution vector x.
-*
-* INCX - INTEGER.
-* On entry, INCX specifies the increment for the elements of
-* X. INCX must not be zero.
-* Unchanged on exit.
-*
-*
-* Level 2 Blas routine.
-*
-* -- Written on 22-October-1986.
-* Jack Dongarra, Argonne National Lab.
-* Jeremy Du Croz, Nag Central Office.
-* Sven Hammarling, Nag Central Office.
-* Richard Hanson, Sandia National Labs.
-*
-*
-* .. Parameters ..
- REAL ZERO
- PARAMETER ( ZERO = 0.0D+0 )
-* .. Local Scalars ..
- REAL TEMP
- INTEGER I, INFO, IX, J, JX, KPLUS1, KX, L
- LOGICAL NOUNIT
-* .. External Functions ..
- LOGICAL LSAME
- EXTERNAL LSAME
-* .. External Subroutines ..
- EXTERNAL XERBLA
-* .. Intrinsic Functions ..
- INTRINSIC MAX, MIN
-* ..
-* .. Executable Statements ..
-*
-* Test the input parameters.
-*
- INFO = 0
- IF ( .NOT.LSAME( UPLO , 'U' ).AND.
- $ .NOT.LSAME( UPLO , 'L' ) )THEN
- INFO = 1
- ELSE IF( .NOT.LSAME( TRANS, 'N' ).AND.
- $ .NOT.LSAME( TRANS, 'T' ).AND.
- $ .NOT.LSAME( TRANS, 'C' ) )THEN
- INFO = 2
- ELSE IF( .NOT.LSAME( DIAG , 'U' ).AND.
- $ .NOT.LSAME( DIAG , 'N' ) )THEN
- INFO = 3
- ELSE IF( N.LT.0 )THEN
- INFO = 4
- ELSE IF( K.LT.0 )THEN
- INFO = 5
- ELSE IF( LDA.LT.( K + 1 ) )THEN
- INFO = 7
- ELSE IF( INCX.EQ.0 )THEN
- INFO = 9
- END IF
- IF( INFO.NE.0 )THEN
- CALL XERBLA( 'DTBSV ', INFO )
- RETURN
- END IF
-*
-* Quick return if possible.
-*
- IF( N.EQ.0 )
- $ RETURN
-*
- NOUNIT = LSAME( DIAG, 'N' )
-*
-* Set up the start point in X if the increment is not unity. This
-* will be ( N - 1 )*INCX too small for descending loops.
-*
- IF( INCX.LE.0 )THEN
- KX = 1 - ( N - 1 )*INCX
- ELSE IF( INCX.NE.1 )THEN
- KX = 1
- END IF
-*
-* Start the operations. In this version the elements of A are
-* accessed by sequentially with one pass through A.
-*
- IF( LSAME( TRANS, 'N' ) )THEN
-*
-* Form x := inv( A )*x.
-*
- IF( LSAME( UPLO, 'U' ) )THEN
- KPLUS1 = K + 1
- IF( INCX.EQ.1 )THEN
- DO 20, J = N, 1, -1
- IF( X( J ).NE.ZERO )THEN
- L = KPLUS1 - J
- IF( NOUNIT )
- $ X( J ) = X( J )/A( KPLUS1, J )
- TEMP = X( J )
- DO 10, I = J - 1, MAX( 1, J - K ), -1
- X( I ) = X( I ) - TEMP*A( L + I, J )
- 10 CONTINUE
- END IF
- 20 CONTINUE
- ELSE
- KX = KX + ( N - 1 )*INCX
- JX = KX
- DO 40, J = N, 1, -1
- KX = KX - INCX
- IF( X( JX ).NE.ZERO )THEN
- IX = KX
- L = KPLUS1 - J
- IF( NOUNIT )
- $ X( JX ) = X( JX )/A( KPLUS1, J )
- TEMP = X( JX )
- DO 30, I = J - 1, MAX( 1, J - K ), -1
- X( IX ) = X( IX ) - TEMP*A( L + I, J )
- IX = IX - INCX
- 30 CONTINUE
- END IF
- JX = JX - INCX
- 40 CONTINUE
- END IF
- ELSE
- IF( INCX.EQ.1 )THEN
- DO 60, J = 1, N
- IF( X( J ).NE.ZERO )THEN
- L = 1 - J
- IF( NOUNIT )
- $ X( J ) = X( J )/A( 1, J )
- TEMP = X( J )
- DO 50, I = J + 1, MIN( N, J + K )
- X( I ) = X( I ) - TEMP*A( L + I, J )
- 50 CONTINUE
- END IF
- 60 CONTINUE
- ELSE
- JX = KX
- DO 80, J = 1, N
- KX = KX + INCX
- IF( X( JX ).NE.ZERO )THEN
- IX = KX
- L = 1 - J
- IF( NOUNIT )
- $ X( JX ) = X( JX )/A( 1, J )
- TEMP = X( JX )
- DO 70, I = J + 1, MIN( N, J + K )
- X( IX ) = X( IX ) - TEMP*A( L + I, J )
- IX = IX + INCX
- 70 CONTINUE
- END IF
- JX = JX + INCX
- 80 CONTINUE
- END IF
- END IF
- ELSE
-*
-* Form x := inv( A')*x.
-*
- IF( LSAME( UPLO, 'U' ) )THEN
- KPLUS1 = K + 1
- IF( INCX.EQ.1 )THEN
- DO 100, J = 1, N
- TEMP = X( J )
- L = KPLUS1 - J
- DO 90, I = MAX( 1, J - K ), J - 1
- TEMP = TEMP - A( L + I, J )*X( I )
- 90 CONTINUE
- IF( NOUNIT )
- $ TEMP = TEMP/A( KPLUS1, J )
- X( J ) = TEMP
- 100 CONTINUE
- ELSE
- JX = KX
- DO 120, J = 1, N
- TEMP = X( JX )
- IX = KX
- L = KPLUS1 - J
- DO 110, I = MAX( 1, J - K ), J - 1
- TEMP = TEMP - A( L + I, J )*X( IX )
- IX = IX + INCX
- 110 CONTINUE
- IF( NOUNIT )
- $ TEMP = TEMP/A( KPLUS1, J )
- X( JX ) = TEMP
- JX = JX + INCX
- IF( J.GT.K )
- $ KX = KX + INCX
- 120 CONTINUE
- END IF
- ELSE
- IF( INCX.EQ.1 )THEN
- DO 140, J = N, 1, -1
- TEMP = X( J )
- L = 1 - J
- DO 130, I = MIN( N, J + K ), J + 1, -1
- TEMP = TEMP - A( L + I, J )*X( I )
- 130 CONTINUE
- IF( NOUNIT )
- $ TEMP = TEMP/A( 1, J )
- X( J ) = TEMP
- 140 CONTINUE
- ELSE
- KX = KX + ( N - 1 )*INCX
- JX = KX
- DO 160, J = N, 1, -1
- TEMP = X( JX )
- IX = KX
- L = 1 - J
- DO 150, I = MIN( N, J + K ), J + 1, -1
- TEMP = TEMP - A( L + I, J )*X( IX )
- IX = IX - INCX
- 150 CONTINUE
- IF( NOUNIT )
- $ TEMP = TEMP/A( 1, J )
- X( JX ) = TEMP
- JX = JX - INCX
- IF( ( N - J ).GE.K )
- $ KX = KX - INCX
- 160 CONTINUE
- END IF
- END IF
- END IF
-*
- RETURN
-*
-* End of DTBSV .
-*
- END
- SUBROUTINE DTRSM ( SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA,
- $ B, LDB )
-* .. Scalar Arguments ..
- CHARACTER*1 SIDE, UPLO, TRANSA, DIAG
- INTEGER M, N, LDA, LDB
- REAL ALPHA
-* .. Array Arguments ..
- REAL A( LDA, * ), B( LDB, * )
-* ..
-*
-* Purpose
-* =======
-*
-* DTRSM solves one of the matrix equations
-*
-* op( A )*X = alpha*B, or X*op( A ) = alpha*B,
-*
-* where alpha is a scalar, X and B are m by n matrices, A is a unit, or
-* non-unit, upper or lower triangular matrix and op( A ) is one of
-*
-* op( A ) = A or op( A ) = A'.
-*
-* The matrix X is overwritten on B.
-*
-* Parameters
-* ==========
-*
-* SIDE - CHARACTER*1.
-* On entry, SIDE specifies whether op( A ) appears on the left
-* or right of X as follows:
-*
-* SIDE = 'L' or 'l' op( A )*X = alpha*B.
-*
-* SIDE = 'R' or 'r' X*op( A ) = alpha*B.
-*
-* Unchanged on exit.
-*
-* UPLO - CHARACTER*1.
-* On entry, UPLO specifies whether the matrix A is an upper or
-* lower triangular matrix as follows:
-*
-* UPLO = 'U' or 'u' A is an upper triangular matrix.
-*
-* UPLO = 'L' or 'l' A is a lower triangular matrix.
-*
-* Unchanged on exit.
-*
-* TRANSA - CHARACTER*1.
-* On entry, TRANSA specifies the form of op( A ) to be used in
-* the matrix multiplication as follows:
-*
-* TRANSA = 'N' or 'n' op( A ) = A.
-*
-* TRANSA = 'T' or 't' op( A ) = A'.
-*
-* TRANSA = 'C' or 'c' op( A ) = A'.
-*
-* Unchanged on exit.
-*
-* DIAG - CHARACTER*1.
-* On entry, DIAG specifies whether or not A is unit triangular
-* as follows:
-*
-* DIAG = 'U' or 'u' A is assumed to be unit triangular.
-*
-* DIAG = 'N' or 'n' A is not assumed to be unit
-* triangular.
-*
-* Unchanged on exit.
-*
-* M - INTEGER.
-* On entry, M specifies the number of rows of B. M must be at
-* least zero.
-* Unchanged on exit.
-*
-* N - INTEGER.
-* On entry, N specifies the number of columns of B. N must be
-* at least zero.
-* Unchanged on exit.
-*
-* ALPHA - REAL.
-* On entry, ALPHA specifies the scalar alpha. When alpha is
-* zero then A is not referenced and B need not be set before
-* entry.
-* Unchanged on exit.
-*
-* A - REAL array of DIMENSION ( LDA, k ), where k is m
-* when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'.
-* Before entry with UPLO = 'U' or 'u', the leading k by k
-* upper triangular part of the array A must contain the upper
-* triangular matrix and the strictly lower triangular part of
-* A is not referenced.
-* Before entry with UPLO = 'L' or 'l', the leading k by k
-* lower triangular part of the array A must contain the lower
-* triangular matrix and the strictly upper triangular part of
-* A is not referenced.
-* Note that when DIAG = 'U' or 'u', the diagonal elements of
-* A are not referenced either, but are assumed to be unity.
-* Unchanged on exit.
-*
-* LDA - INTEGER.
-* On entry, LDA specifies the first dimension of A as declared
-* in the calling (sub) program. When SIDE = 'L' or 'l' then
-* LDA must be at least max( 1, m ), when SIDE = 'R' or 'r'
-* then LDA must be at least max( 1, n ).
-* Unchanged on exit.
-*
-* B - REAL array of DIMENSION ( LDB, n ).
-* Before entry, the leading m by n part of the array B must
-* contain the right-hand side matrix B, and on exit is
-* overwritten by the solution matrix X.
-*
-* LDB - INTEGER.
-* On entry, LDB specifies the first dimension of B as declared
-* in the calling (sub) program. LDB must be at least
-* max( 1, m ).
-* Unchanged on exit.
-*
-*
-* Level 3 Blas routine.
-*
-*
-* -- Written on 8-February-1989.
-* Jack Dongarra, Argonne National Laboratory.
-* Iain Duff, AERE Harwell.
-* Jeremy Du Croz, Numerical Algorithms Group Ltd.
-* Sven Hammarling, Numerical Algorithms Group Ltd.
-*
-*
-* .. External Functions ..
- LOGICAL LSAME
- EXTERNAL LSAME
-* .. External Subroutines ..
- EXTERNAL XERBLA
-* .. Intrinsic Functions ..
- INTRINSIC MAX
-* .. Local Scalars ..
- LOGICAL LSIDE, NOUNIT, UPPER
- INTEGER I, INFO, J, K, NROWA
- REAL TEMP
-* .. Parameters ..
- REAL ONE , ZERO
- PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
-* ..
-* .. Executable Statements ..
-*
-* Test the input parameters.
-*
- LSIDE = LSAME( SIDE , 'L' )
- IF( LSIDE )THEN
- NROWA = M
- ELSE
- NROWA = N
- END IF
- NOUNIT = LSAME( DIAG , 'N' )
- UPPER = LSAME( UPLO , 'U' )
-*
- INFO = 0
- IF( ( .NOT.LSIDE ).AND.
- $ ( .NOT.LSAME( SIDE , 'R' ) ) )THEN
- INFO = 1
- ELSE IF( ( .NOT.UPPER ).AND.
- $ ( .NOT.LSAME( UPLO , 'L' ) ) )THEN
- INFO = 2
- ELSE IF( ( .NOT.LSAME( TRANSA, 'N' ) ).AND.
- $ ( .NOT.LSAME( TRANSA, 'T' ) ).AND.
- $ ( .NOT.LSAME( TRANSA, 'C' ) ) )THEN
- INFO = 3
- ELSE IF( ( .NOT.LSAME( DIAG , 'U' ) ).AND.
- $ ( .NOT.LSAME( DIAG , 'N' ) ) )THEN
- INFO = 4
- ELSE IF( M .LT.0 )THEN
- INFO = 5
- ELSE IF( N .LT.0 )THEN
- INFO = 6
- ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN
- INFO = 9
- ELSE IF( LDB.LT.MAX( 1, M ) )THEN
- INFO = 11
- END IF
- IF( INFO.NE.0 )THEN
- CALL XERBLA( 'DTRSM ', INFO )
- RETURN
- END IF
-*
-* Quick return if possible.
-*
- IF( N.EQ.0 )
- $ RETURN
-*
-* And when alpha.eq.zero.
-*
- IF( ALPHA.EQ.ZERO )THEN
- DO 20, J = 1, N
- DO 10, I = 1, M
- B( I, J ) = ZERO
- 10 CONTINUE
- 20 CONTINUE
- RETURN
- END IF
-*
-* Start the operations.
-*
- IF( LSIDE )THEN
- IF( LSAME( TRANSA, 'N' ) )THEN
-*
-* Form B := alpha*inv( A )*B.
-*
- IF( UPPER )THEN
- DO 60, J = 1, N
- IF( ALPHA.NE.ONE )THEN
- DO 30, I = 1, M
- B( I, J ) = ALPHA*B( I, J )
- 30 CONTINUE
- END IF
- DO 50, K = M, 1, -1
- IF( B( K, J ).NE.ZERO )THEN
- IF( NOUNIT )
- $ B( K, J ) = B( K, J )/A( K, K )
- DO 40, I = 1, K - 1
- B( I, J ) = B( I, J ) - B( K, J )*A( I, K )
- 40 CONTINUE
- END IF
- 50 CONTINUE
- 60 CONTINUE
- ELSE
- DO 100, J = 1, N
- IF( ALPHA.NE.ONE )THEN
- DO 70, I = 1, M
- B( I, J ) = ALPHA*B( I, J )
- 70 CONTINUE
- END IF
- DO 90 K = 1, M
- IF( B( K, J ).NE.ZERO )THEN
- IF( NOUNIT )
- $ B( K, J ) = B( K, J )/A( K, K )
- DO 80, I = K + 1, M
- B( I, J ) = B( I, J ) - B( K, J )*A( I, K )
- 80 CONTINUE
- END IF
- 90 CONTINUE
- 100 CONTINUE
- END IF
- ELSE
-*
-* Form B := alpha*inv( A' )*B.
-*
- IF( UPPER )THEN
- DO 130, J = 1, N
- DO 120, I = 1, M
- TEMP = ALPHA*B( I, J )
- DO 110, K = 1, I - 1
- TEMP = TEMP - A( K, I )*B( K, J )
- 110 CONTINUE
- IF( NOUNIT )
- $ TEMP = TEMP/A( I, I )
- B( I, J ) = TEMP
- 120 CONTINUE
- 130 CONTINUE
- ELSE
- DO 160, J = 1, N
- DO 150, I = M, 1, -1
- TEMP = ALPHA*B( I, J )
- DO 140, K = I + 1, M
- TEMP = TEMP - A( K, I )*B( K, J )
- 140 CONTINUE
- IF( NOUNIT )
- $ TEMP = TEMP/A( I, I )
- B( I, J ) = TEMP
- 150 CONTINUE
- 160 CONTINUE
- END IF
- END IF
- ELSE
- IF( LSAME( TRANSA, 'N' ) )THEN
-*
-* Form B := alpha*B*inv( A ).
-*
- IF( UPPER )THEN
- DO 210, J = 1, N
- IF( ALPHA.NE.ONE )THEN
- DO 170, I = 1, M
- B( I, J ) = ALPHA*B( I, J )
- 170 CONTINUE
- END IF
- DO 190, K = 1, J - 1
- IF( A( K, J ).NE.ZERO )THEN
- DO 180, I = 1, M
- B( I, J ) = B( I, J ) - A( K, J )*B( I, K )
- 180 CONTINUE
- END IF
- 190 CONTINUE
- IF( NOUNIT )THEN
- TEMP = ONE/A( J, J )
- DO 200, I = 1, M
- B( I, J ) = TEMP*B( I, J )
- 200 CONTINUE
- END IF
- 210 CONTINUE
- ELSE
- DO 260, J = N, 1, -1
- IF( ALPHA.NE.ONE )THEN
- DO 220, I = 1, M
- B( I, J ) = ALPHA*B( I, J )
- 220 CONTINUE
- END IF
- DO 240, K = J + 1, N
- IF( A( K, J ).NE.ZERO )THEN
- DO 230, I = 1, M
- B( I, J ) = B( I, J ) - A( K, J )*B( I, K )
- 230 CONTINUE
- END IF
- 240 CONTINUE
- IF( NOUNIT )THEN
- TEMP = ONE/A( J, J )
- DO 250, I = 1, M
- B( I, J ) = TEMP*B( I, J )
- 250 CONTINUE
- END IF
- 260 CONTINUE
- END IF
- ELSE
-*
-* Form B := alpha*B*inv( A' ).
-*
- IF( UPPER )THEN
- DO 310, K = N, 1, -1
- IF( NOUNIT )THEN
- TEMP = ONE/A( K, K )
- DO 270, I = 1, M
- B( I, K ) = TEMP*B( I, K )
- 270 CONTINUE
- END IF
- DO 290, J = 1, K - 1
- IF( A( J, K ).NE.ZERO )THEN
- TEMP = A( J, K )
- DO 280, I = 1, M
- B( I, J ) = B( I, J ) - TEMP*B( I, K )
- 280 CONTINUE
- END IF
- 290 CONTINUE
- IF( ALPHA.NE.ONE )THEN
- DO 300, I = 1, M
- B( I, K ) = ALPHA*B( I, K )
- 300 CONTINUE
- END IF
- 310 CONTINUE
- ELSE
- DO 360, K = 1, N
- IF( NOUNIT )THEN
- TEMP = ONE/A( K, K )
- DO 320, I = 1, M
- B( I, K ) = TEMP*B( I, K )
- 320 CONTINUE
- END IF
- DO 340, J = K + 1, N
- IF( A( J, K ).NE.ZERO )THEN
- TEMP = A( J, K )
- DO 330, I = 1, M
- B( I, J ) = B( I, J ) - TEMP*B( I, K )
- 330 CONTINUE
- END IF
- 340 CONTINUE
- IF( ALPHA.NE.ONE )THEN
- DO 350, I = 1, M
- B( I, K ) = ALPHA*B( I, K )
- 350 CONTINUE
- END IF
- 360 CONTINUE
- END IF
- END IF
- END IF
-*
- RETURN
-*
-* End of DTRSM .
-*
- END
- integer function idamax(n,dx,incx)
-c
-c finds the index of element having max. absolute value.
-c jack dongarra, linpack, 3/11/78.
-c modified 3/93 to return if incx .le. 0.
-c modified 12/3/93, array(1) declarations changed to array(*)
-c
- double precision dx(*),dmax
- integer i,incx,ix,n
-c
- idamax = 0
- if( n.lt.1 .or. incx.le.0 ) return
- idamax = 1
- if(n.eq.1)return
- if(incx.eq.1)go to 20
-c
-c code for increment not equal to 1
-c
- ix = 1
- dmax = dabs(dx(1))
- ix = ix + incx
- do 10 i = 2,n
- if(dabs(dx(ix)).le.dmax) go to 5
- idamax = i
- dmax = dabs(dx(ix))
- 5 ix = ix + incx
- 10 continue
- return
-c
-c code for increment equal to 1
-c
- 20 dmax = dabs(dx(1))
- do 30 i = 2,n
- if(dabs(dx(i)).le.dmax) go to 30
- idamax = i
- dmax = dabs(dx(i))
- 30 continue
- return
- end
- SUBROUTINE XERBLA( SRNAME, INFO )
-*
-* -- LAPACK auxiliary routine (preliminary version) --
-* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
-* Courant Institute, Argonne National Lab, and Rice University
-* February 29, 1992
-*
-* .. Scalar Arguments ..
- CHARACTER*6 SRNAME
- INTEGER INFO
-* ..
-*
-* Purpose
-* =======
-*
-* XERBLA is an error handler for the LAPACK routines.
-* It is called by an LAPACK 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 XERBLA.
-*
-* INFO (input) INTEGER
-* The position of the invalid parameter in the parameter list
-* of the calling routine.
-*
-*
- WRITE( *, FMT = 9999 )SRNAME, INFO
-*
- STOP
-*
- 9999 FORMAT( ' ** On entry to ', A6, ' parameter number ', I2, ' had ',
- $ 'an illegal value' )
-*
-* End of XERBLA
-*
- END
- SUBROUTINE DGBTF2( M, N, KL, KU, AB, LDAB, IPIV, INFO )
-*
-* -- LAPACK routine (version 3.0) --
-* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
-* Courant Institute, Argonne National Lab, and Rice University
-* February 29, 1992
-*
-* .. Scalar Arguments ..
- INTEGER INFO, KL, KU, LDAB, M, N
-* ..
-* .. Array Arguments ..
- INTEGER IPIV( * )
- REAL AB( LDAB, * )
-* ..
-*
-* Purpose
-* =======
-*
-* DGBTF2 computes an LU factorization of a real m-by-n band matrix A
-* using partial pivoting with row interchanges.
-*
-* This is the unblocked version of the algorithm, calling Level 2 BLAS.
-*
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows of the matrix A. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix A. N >= 0.
-*
-* KL (input) INTEGER
-* The number of subdiagonals within the band of A. KL >= 0.
-*
-* KU (input) INTEGER
-* The number of superdiagonals within the band of A. KU >= 0.
-*
-* AB (input/output) REAL array, dimension (LDAB,N)
-* On entry, the matrix A in band storage, in rows KL+1 to
-* 2*KL+KU+1; rows 1 to KL of the array need not be set.
-* The j-th column of A is stored in the j-th column of the
-* array AB as follows:
-* AB(kl+ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl)
-*
-* On exit, details of the factorization: U is stored as an
-* upper triangular band matrix with KL+KU superdiagonals in
-* rows 1 to KL+KU+1, and the multipliers used during the
-* factorization are stored in rows KL+KU+2 to 2*KL+KU+1.
-* See below for further details.
-*
-* LDAB (input) INTEGER
-* The leading dimension of the array AB. LDAB >= 2*KL+KU+1.
-*
-* IPIV (output) INTEGER array, dimension (min(M,N))
-* The pivot indices; for 1 <= i <= min(M,N), row i of the
-* matrix was interchanged with row IPIV(i).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = +i, U(i,i) is exactly zero. The factorization
-* has been completed, but the factor U is exactly
-* singular, and division by zero will occur if it is used
-* to solve a system of equations.
-*
-* Further Details
-* ===============
-*
-* The band storage scheme is illustrated by the following example, when
-* M = N = 6, KL = 2, KU = 1:
-*
-* On entry: On exit:
-*
-* * * * + + + * * * u14 u25 u36
-* * * + + + + * * u13 u24 u35 u46
-* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56
-* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66
-* a21 a32 a43 a54 a65 * m21 m32 m43 m54 m65 *
-* a31 a42 a53 a64 * * m31 m42 m53 m64 * *
-*
-* Array elements marked * are not used by the routine; elements marked
-* + need not be set on entry, but are required by the routine to store
-* elements of U, because of fill-in resulting from the row
-* interchanges.
-*
-* =====================================================================
-*
-* .. Parameters ..
- REAL ONE, ZERO
- PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
-* ..
-* .. Local Scalars ..
- INTEGER I, J, JP, JU, KM, KV
-* ..
-* .. External Functions ..
- INTEGER IDAMAX
- EXTERNAL IDAMAX
-* ..
-* .. External Subroutines ..
- EXTERNAL DGER, DSCAL, DSWAP, XERBLA
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC MAX, MIN
-* ..
-* .. Executable Statements ..
-*
-* KV is the number of superdiagonals in the factor U, allowing for
-* fill-in.
-*
- KV = KU + KL
-*
-* Test the input parameters.
-*
- INFO = 0
- IF( M.LT.0 ) THEN
- INFO = -1
- ELSE IF( N.LT.0 ) THEN
- INFO = -2
- ELSE IF( KL.LT.0 ) THEN
- INFO = -3
- ELSE IF( KU.LT.0 ) THEN
- INFO = -4
- ELSE IF( LDAB.LT.KL+KV+1 ) THEN
- INFO = -6
- END IF
- IF( INFO.NE.0 ) THEN
- CALL XERBLA( 'DGBTF2', -INFO )
- RETURN
- END IF
-*
-* Quick return if possible
-*
- IF( M.EQ.0 .OR. N.EQ.0 )
- $ RETURN
-*
-* Gaussian elimination with partial pivoting
-*
-* Set fill-in elements in columns KU+2 to KV to zero.
-*
- DO 20 J = KU + 2, MIN( KV, N )
- DO 10 I = KV - J + 2, KL
- AB( I, J ) = ZERO
- 10 CONTINUE
- 20 CONTINUE
-*
-* JU is the index of the last column affected by the current stage
-* of the factorization.
-*
- JU = 1
-*
- DO 40 J = 1, MIN( M, N )
-*
-* Set fill-in elements in column J+KV to zero.
-*
- IF( J+KV.LE.N ) THEN
- DO 30 I = 1, KL
- AB( I, J+KV ) = ZERO
- 30 CONTINUE
- END IF
-*
-* Find pivot and test for singularity. KM is the number of
-* subdiagonal elements in the current column.
-*
- KM = MIN( KL, M-J )
- JP = IDAMAX( KM+1, AB( KV+1, J ), 1 )
- IPIV( J ) = JP + J - 1
- IF( AB( KV+JP, J ).NE.ZERO ) THEN
- JU = MAX( JU, MIN( J+KU+JP-1, N ) )
-*
-* Apply interchange to columns J to JU.
-*
- IF( JP.NE.1 )
- $ CALL DSWAP( JU-J+1, AB( KV+JP, J ), LDAB-1,
- $ AB( KV+1, J ), LDAB-1 )
-*
- IF( KM.GT.0 ) THEN
-*
-* Compute multipliers.
-*
- CALL DSCAL( KM, ONE / AB( KV+1, J ), AB( KV+2, J ), 1 )
-*
-* Update trailing submatrix within the band.
-*
- IF( JU.GT.J )
- $ CALL DGER( KM, JU-J, -ONE, AB( KV+2, J ), 1,
- $ AB( KV, J+1 ), LDAB-1, AB( KV+1, J+1 ),
- $ LDAB-1 )
- END IF
- ELSE
-*
-* If pivot is zero, set INFO to the index of the pivot
-* unless a zero pivot has already been found.
-*
- IF( INFO.EQ.0 )
- $ INFO = J
- END IF
- 40 CONTINUE
- RETURN
-*
-* End of DGBTF2
-*
- END
- SUBROUTINE DGBTRF( M, N, KL, KU, AB, LDAB, IPIV, INFO )
-*
-* -- LAPACK routine (version 3.0) --
-* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
-* Courant Institute, Argonne National Lab, and Rice University
-* February 29, 1992
-*
-* .. Scalar Arguments ..
- INTEGER INFO, KL, KU, LDAB, M, N
-* ..
-* .. Array Arguments ..
- INTEGER IPIV( * )
- REAL AB( LDAB, * )
-* ..
-*
-* Purpose
-* =======
-*
-* DGBTRF computes an LU factorization of a real m-by-n band matrix A
-* using partial pivoting with row interchanges.
-*
-* This is the blocked version of the algorithm, calling Level 3 BLAS.
-*
-* Arguments
-* =========
-*
-* M (input) INTEGER
-* The number of rows of the matrix A. M >= 0.
-*
-* N (input) INTEGER
-* The number of columns of the matrix A. N >= 0.
-*
-* KL (input) INTEGER
-* The number of subdiagonals within the band of A. KL >= 0.
-*
-* KU (input) INTEGER
-* The number of superdiagonals within the band of A. KU >= 0.
-*
-* AB (input/output) REAL array, dimension (LDAB,N)
-* On entry, the matrix A in band storage, in rows KL+1 to
-* 2*KL+KU+1; rows 1 to KL of the array need not be set.
-* The j-th column of A is stored in the j-th column of the
-* array AB as follows:
-* AB(kl+ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl)
-*
-* On exit, details of the factorization: U is stored as an
-* upper triangular band matrix with KL+KU superdiagonals in
-* rows 1 to KL+KU+1, and the multipliers used during the
-* factorization are stored in rows KL+KU+2 to 2*KL+KU+1.
-* See below for further details.
-*
-* LDAB (input) INTEGER
-* The leading dimension of the array AB. LDAB >= 2*KL+KU+1.
-*
-* IPIV (output) INTEGER array, dimension (min(M,N))
-* The pivot indices; for 1 <= i <= min(M,N), row i of the
-* matrix was interchanged with row IPIV(i).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-* > 0: if INFO = +i, U(i,i) is exactly zero. The factorization
-* has been completed, but the factor U is exactly
-* singular, and division by zero will occur if it is used
-* to solve a system of equations.
-*
-* Further Details
-* ===============
-*
-* The band storage scheme is illustrated by the following example, when
-* M = N = 6, KL = 2, KU = 1:
-*
-* On entry: On exit:
-*
-* * * * + + + * * * u14 u25 u36
-* * * + + + + * * u13 u24 u35 u46
-* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56
-* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66
-* a21 a32 a43 a54 a65 * m21 m32 m43 m54 m65 *
-* a31 a42 a53 a64 * * m31 m42 m53 m64 * *
-*
-* Array elements marked * are not used by the routine; elements marked
-* + need not be set on entry, but are required by the routine to store
-* elements of U because of fill-in resulting from the row interchanges.
-*
-* =====================================================================
-*
-* .. Parameters ..
- REAL ONE, ZERO
- PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
- INTEGER NBMAX, LDWORK
- PARAMETER ( NBMAX = 64, LDWORK = NBMAX+1 )
-* ..
-* .. Local Scalars ..
- INTEGER I, I2, I3, II, IP, J, J2, J3, JB, JJ, JM, JP,
- $ JU, K2, KM, KV, NB, NW
- REAL TEMP
-* ..
-* .. Local Arrays ..
- REAL WORK13( LDWORK, NBMAX ),
- $ WORK31( LDWORK, NBMAX )
-* ..
-* .. External Functions ..
- INTEGER IDAMAX, ILAENV
- EXTERNAL IDAMAX, ILAENV
-* ..
-* .. External Subroutines ..
- EXTERNAL DCOPY, DGBTF2, DGEMM, DGER, DLASWP, DSCAL,
- $ DSWAP, DTRSM, XERBLA
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC MAX, MIN
-* ..
-* .. Executable Statements ..
-*
-* KV is the number of superdiagonals in the factor U, allowing for
-* fill-in
-*
- KV = KU + KL
-*
-* Test the input parameters.
-*
- INFO = 0
- IF( M.LT.0 ) THEN
- INFO = -1
- ELSE IF( N.LT.0 ) THEN
- INFO = -2
- ELSE IF( KL.LT.0 ) THEN
- INFO = -3
- ELSE IF( KU.LT.0 ) THEN
- INFO = -4
- ELSE IF( LDAB.LT.KL+KV+1 ) THEN
- INFO = -6
- END IF
- IF( INFO.NE.0 ) THEN
- CALL XERBLA( 'DGBTRF', -INFO )
- RETURN
- END IF
-*
-* Quick return if possible
-*
- IF( M.EQ.0 .OR. N.EQ.0 )
- $ RETURN
-*
-* Determine the block size for this environment
-*
- NB = ILAENV( 1, 'DGBTRF', ' ', M, N, KL, KU )
-*
-* The block size must not exceed the limit set by the size of the
-* local arrays WORK13 and WORK31.
-*
- NB = MIN( NB, NBMAX )
-*
- IF( NB.LE.1 .OR. NB.GT.KL ) THEN
-*
-* Use unblocked code
-*
- CALL DGBTF2( M, N, KL, KU, AB, LDAB, IPIV, INFO )
- ELSE
-*
-* Use blocked code
-*
-* Zero the superdiagonal elements of the work array WORK13
-*
- DO 20 J = 1, NB
- DO 10 I = 1, J - 1
- WORK13( I, J ) = ZERO
- 10 CONTINUE
- 20 CONTINUE
-*
-* Zero the subdiagonal elements of the work array WORK31
-*
- DO 40 J = 1, NB
- DO 30 I = J + 1, NB
- WORK31( I, J ) = ZERO
- 30 CONTINUE
- 40 CONTINUE
-*
-* Gaussian elimination with partial pivoting
-*
-* Set fill-in elements in columns KU+2 to KV to zero
-*
- DO 60 J = KU + 2, MIN( KV, N )
- DO 50 I = KV - J + 2, KL
- AB( I, J ) = ZERO
- 50 CONTINUE
- 60 CONTINUE
-*
-* JU is the index of the last column affected by the current
-* stage of the factorization
-*
- JU = 1
-*
- DO 180 J = 1, MIN( M, N ), NB
- JB = MIN( NB, MIN( M, N )-J+1 )
-*
-* The active part of the matrix is partitioned
-*
-* A11 A12 A13
-* A21 A22 A23
-* A31 A32 A33
-*
-* Here A11, A21 and A31 denote the current block of JB columns
-* which is about to be factorized. The number of rows in the
-* partitioning are JB, I2, I3 respectively, and the numbers
-* of columns are JB, J2, J3. The superdiagonal elements of A13
-* and the subdiagonal elements of A31 lie outside the band.
-*
- I2 = MIN( KL-JB, M-J-JB+1 )
- I3 = MIN( JB, M-J-KL+1 )
-*
-* J2 and J3 are computed after JU has been updated.
-*
-* Factorize the current block of JB columns
-*
- DO 80 JJ = J, J + JB - 1
-*
-* Set fill-in elements in column JJ+KV to zero
-*
- IF( JJ+KV.LE.N ) THEN
- DO 70 I = 1, KL
- AB( I, JJ+KV ) = ZERO
- 70 CONTINUE
- END IF
-*
-* Find pivot and test for singularity. KM is the number of
-* subdiagonal elements in the current column.
-*
- KM = MIN( KL, M-JJ )
- JP = IDAMAX( KM+1, AB( KV+1, JJ ), 1 )
- IPIV( JJ ) = JP + JJ - J
- IF( AB( KV+JP, JJ ).NE.ZERO ) THEN
- JU = MAX( JU, MIN( JJ+KU+JP-1, N ) )
- IF( JP.NE.1 ) THEN
-*
-* Apply interchange to columns J to J+JB-1
-*
- IF( JP+JJ-1.LT.J+KL ) THEN
-*
- CALL DSWAP( JB, AB( KV+1+JJ-J, J ), LDAB-1,
- $ AB( KV+JP+JJ-J, J ), LDAB-1 )
- ELSE
-*
-* The interchange affects columns J to JJ-1 of A31
-* which are stored in the work array WORK31
-*
- CALL DSWAP( JJ-J, AB( KV+1+JJ-J, J ), LDAB-1,
- $ WORK31( JP+JJ-J-KL, 1 ), LDWORK )
- CALL DSWAP( J+JB-JJ, AB( KV+1, JJ ), LDAB-1,
- $ AB( KV+JP, JJ ), LDAB-1 )
- END IF
- END IF
-*
-* Compute multipliers
-*
- CALL DSCAL( KM, ONE / AB( KV+1, JJ ), AB( KV+2, JJ ),
- $ 1 )
-*
-* Update trailing submatrix within the band and within
-* the current block. JM is the index of the last column
-* which needs to be updated.
-*
- JM = MIN( JU, J+JB-1 )
- IF( JM.GT.JJ )
- $ CALL DGER( KM, JM-JJ, -ONE, AB( KV+2, JJ ), 1,
- $ AB( KV, JJ+1 ), LDAB-1,
- $ AB( KV+1, JJ+1 ), LDAB-1 )
- ELSE
-*
-* If pivot is zero, set INFO to the index of the pivot
-* unless a zero pivot has already been found.
-*
- IF( INFO.EQ.0 )
- $ INFO = JJ
- END IF
-*
-* Copy current column of A31 into the work array WORK31
-*
- NW = MIN( JJ-J+1, I3 )
- IF( NW.GT.0 )
- $ CALL DCOPY( NW, AB( KV+KL+1-JJ+J, JJ ), 1,
- $ WORK31( 1, JJ-J+1 ), 1 )
- 80 CONTINUE
- IF( J+JB.LE.N ) THEN
-*
-* Apply the row interchanges to the other blocks.
-*
- J2 = MIN( JU-J+1, KV ) - JB
- J3 = MAX( 0, JU-J-KV+1 )
-*
-* Use DLASWP to apply the row interchanges to A12, A22, and
-* A32.
-*
- CALL DLASWP( J2, AB( KV+1-JB, J+JB ), LDAB-1, 1, JB,
- $ IPIV( J ), 1 )
-*
-* Adjust the pivot indices.
-*
- DO 90 I = J, J + JB - 1
- IPIV( I ) = IPIV( I ) + J - 1
- 90 CONTINUE
-*
-* Apply the row interchanges to A13, A23, and A33
-* columnwise.
-*
- K2 = J - 1 + JB + J2
- DO 110 I = 1, J3
- JJ = K2 + I
- DO 100 II = J + I - 1, J + JB - 1
- IP = IPIV( II )
- IF( IP.NE.II ) THEN
- TEMP = AB( KV+1+II-JJ, JJ )
- AB( KV+1+II-JJ, JJ ) = AB( KV+1+IP-JJ, JJ )
- AB( KV+1+IP-JJ, JJ ) = TEMP
- END IF
- 100 CONTINUE
- 110 CONTINUE
-*
-* Update the relevant part of the trailing submatrix
-*
- IF( J2.GT.0 ) THEN
-*
-* Update A12
-*
- CALL DTRSM( 'Left', 'Lower', 'No transpose', 'Unit',
- $ JB, J2, ONE, AB( KV+1, J ), LDAB-1,
- $ AB( KV+1-JB, J+JB ), LDAB-1 )
-*
- IF( I2.GT.0 ) THEN
-*
-* Update A22
-*
- CALL DGEMM( 'No transpose', 'No transpose', I2, J2,
- $ JB, -ONE, AB( KV+1+JB, J ), LDAB-1,
- $ AB( KV+1-JB, J+JB ), LDAB-1, ONE,
- $ AB( KV+1, J+JB ), LDAB-1 )
- END IF
-*
- IF( I3.GT.0 ) THEN
-*
-* Update A32
-*
- CALL DGEMM( 'No transpose', 'No transpose', I3, J2,
- $ JB, -ONE, WORK31, LDWORK,
- $ AB( KV+1-JB, J+JB ), LDAB-1, ONE,
- $ AB( KV+KL+1-JB, J+JB ), LDAB-1 )
- END IF
- END IF
-*
- IF( J3.GT.0 ) THEN
-*
-* Copy the lower triangle of A13 into the work array
-* WORK13
-*
- DO 130 JJ = 1, J3
- DO 120 II = JJ, JB
- WORK13( II, JJ ) = AB( II-JJ+1, JJ+J+KV-1 )
- 120 CONTINUE
- 130 CONTINUE
-*
-* Update A13 in the work array
-*
- CALL DTRSM( 'Left', 'Lower', 'No transpose', 'Unit',
- $ JB, J3, ONE, AB( KV+1, J ), LDAB-1,
- $ WORK13, LDWORK )
-*
- IF( I2.GT.0 ) THEN
-*
-* Update A23
-*
- CALL DGEMM( 'No transpose', 'No transpose', I2, J3,
- $ JB, -ONE, AB( KV+1+JB, J ), LDAB-1,
- $ WORK13, LDWORK, ONE, AB( 1+JB, J+KV ),
- $ LDAB-1 )
- END IF
-*
- IF( I3.GT.0 ) THEN
-*
-* Update A33
-*
- CALL DGEMM( 'No transpose', 'No transpose', I3, J3,
- $ JB, -ONE, WORK31, LDWORK, WORK13,
- $ LDWORK, ONE, AB( 1+KL, J+KV ), LDAB-1 )
- END IF
-*
-* Copy the lower triangle of A13 back into place
-*
- DO 150 JJ = 1, J3
- DO 140 II = JJ, JB
- AB( II-JJ+1, JJ+J+KV-1 ) = WORK13( II, JJ )
- 140 CONTINUE
- 150 CONTINUE
- END IF
- ELSE
-*
-* Adjust the pivot indices.
-*
- DO 160 I = J, J + JB - 1
- IPIV( I ) = IPIV( I ) + J - 1
- 160 CONTINUE
- END IF
-*
-* Partially undo the interchanges in the current block to
-* restore the upper triangular form of A31 and copy the upper
-* triangle of A31 back into place
-*
- DO 170 JJ = J + JB - 1, J, -1
- JP = IPIV( JJ ) - JJ + 1
- IF( JP.NE.1 ) THEN
-*
-* Apply interchange to columns J to JJ-1
-*
- IF( JP+JJ-1.LT.J+KL ) THEN
-*
-* The interchange does not affect A31
-*
- CALL DSWAP( JJ-J, AB( KV+1+JJ-J, J ), LDAB-1,
- $ AB( KV+JP+JJ-J, J ), LDAB-1 )
- ELSE
-*
-* The interchange does affect A31
-*
- CALL DSWAP( JJ-J, AB( KV+1+JJ-J, J ), LDAB-1,
- $ WORK31( JP+JJ-J-KL, 1 ), LDWORK )
- END IF
- END IF
-*
-* Copy the current column of A31 back into place
-*
- NW = MIN( I3, JJ-J+1 )
- IF( NW.GT.0 )
- $ CALL DCOPY( NW, WORK31( 1, JJ-J+1 ), 1,
- $ AB( KV+KL+1-JJ+J, JJ ), 1 )
- 170 CONTINUE
- 180 CONTINUE
- END IF
-*
- RETURN
-*
-* End of DGBTRF
-*
- END
- SUBROUTINE DGBTRS( TRANS, N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB,
- $ INFO )
-*
-* -- LAPACK routine (version 3.0) --
-* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
-* Courant Institute, Argonne National Lab, and Rice University
-* March 31, 1993
-*
-* .. Scalar Arguments ..
- CHARACTER TRANS
- INTEGER INFO, KL, KU, LDAB, LDB, N, NRHS
-* ..
-* .. Array Arguments ..
- INTEGER IPIV( * )
- REAL AB( LDAB, * ), B( LDB, * )
-* ..
-*
-* Purpose
-* =======
-*
-* DGBTRS solves a system of linear equations
-* A * X = B or A' * X = B
-* with a general band matrix A using the LU factorization computed
-* by DGBTRF.
-*
-* Arguments
-* =========
-*
-* TRANS (input) CHARACTER*1
-* Specifies the form of the system of equations.
-* = 'N': A * X = B (No transpose)
-* = 'T': A'* X = B (Transpose)
-* = 'C': A'* X = B (Conjugate transpose = Transpose)
-*
-* N (input) INTEGER
-* The order of the matrix A. N >= 0.
-*
-* KL (input) INTEGER
-* The number of subdiagonals within the band of A. KL >= 0.
-*
-* KU (input) INTEGER
-* The number of superdiagonals within the band of A. KU >= 0.
-*
-* NRHS (input) INTEGER
-* The number of right hand sides, i.e., the number of columns
-* of the matrix B. NRHS >= 0.
-*
-* AB (input) REAL array, dimension (LDAB,N)
-* Details of the LU factorization of the band matrix A, as
-* computed by DGBTRF. U is stored as an upper triangular band
-* matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and
-* the multipliers used during the factorization are stored in
-* rows KL+KU+2 to 2*KL+KU+1.
-*
-* LDAB (input) INTEGER
-* The leading dimension of the array AB. LDAB >= 2*KL+KU+1.
-*
-* IPIV (input) INTEGER array, dimension (N)
-* The pivot indices; for 1 <= i <= N, row i of the matrix was
-* interchanged with row IPIV(i).
-*
-* B (input/output) REAL array, dimension (LDB,NRHS)
-* On entry, the right hand side matrix B.
-* On exit, the solution matrix X.
-*
-* LDB (input) INTEGER
-* The leading dimension of the array B. LDB >= max(1,N).
-*
-* INFO (output) INTEGER
-* = 0: successful exit
-* < 0: if INFO = -i, the i-th argument had an illegal value
-*
-* =====================================================================
-*
-* .. Parameters ..
- REAL ONE
- PARAMETER ( ONE = 1.0D+0 )
-* ..
-* .. Local Scalars ..
- LOGICAL LNOTI, NOTRAN
- INTEGER I, J, KD, L, LM
-* ..
-* .. External Functions ..
- LOGICAL LSAME
- EXTERNAL LSAME
-* ..
-* .. External Subroutines ..
- EXTERNAL DGEMV, DGER, DSWAP, DTBSV, XERBLA
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC MAX, MIN
-* ..
-* .. Executable Statements ..
-*
-* Test the input parameters.
-*
- INFO = 0
- NOTRAN = LSAME( TRANS, 'N' )
- IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT.
- $ LSAME( TRANS, 'C' ) ) THEN
- INFO = -1
- ELSE IF( N.LT.0 ) THEN
- INFO = -2
- ELSE IF( KL.LT.0 ) THEN
- INFO = -3
- ELSE IF( KU.LT.0 ) THEN
- INFO = -4
- ELSE IF( NRHS.LT.0 ) THEN
- INFO = -5
- ELSE IF( LDAB.LT.( 2*KL+KU+1 ) ) THEN
- INFO = -7
- ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
- INFO = -10
- END IF
- IF( INFO.NE.0 ) THEN
- CALL XERBLA( 'DGBTRS', -INFO )
- RETURN
- END IF
-*
-* Quick return if possible
-*
- IF( N.EQ.0 .OR. NRHS.EQ.0 )
- $ RETURN
-*
- KD = KU + KL + 1
- LNOTI = KL.GT.0
-*
- IF( NOTRAN ) THEN
-*
-* Solve A*X = B.
-*
-* Solve L*X = B, overwriting B with X.
-*
-* L is represented as a product of permutations and unit lower
-* triangular matrices L = P(1) * L(1) * ... * P(n-1) * L(n-1),
-* where each transformation L(i) is a rank-one modification of
-* the identity matrix.
-*
- IF( LNOTI ) THEN
- DO 10 J = 1, N - 1
- LM = MIN( KL, N-J )
- L = IPIV( J )
- IF( L.NE.J )
- $ CALL DSWAP( NRHS, B( L, 1 ), LDB, B( J, 1 ), LDB )
- CALL DGER( LM, NRHS, -ONE, AB( KD+1, J ), 1, B( J, 1 ),
- $ LDB, B( J+1, 1 ), LDB )
- 10 CONTINUE
- END IF
-*
- DO 20 I = 1, NRHS
-*
-* Solve U*X = B, overwriting B with X.
-*
- CALL DTBSV( 'Upper', 'No transpose', 'Non-unit', N, KL+KU,
- $ AB, LDAB, B( 1, I ), 1 )
- 20 CONTINUE
-*
- ELSE
-*
-* Solve A'*X = B.
-*
- DO 30 I = 1, NRHS
-*
-* Solve U'*X = B, overwriting B with X.
-*
- CALL DTBSV( 'Upper', 'Transpose', 'Non-unit', N, KL+KU, AB,
- $ LDAB, B( 1, I ), 1 )
- 30 CONTINUE
-*
-* Solve L'*X = B, overwriting B with X.
-*
- IF( LNOTI ) THEN
- DO 40 J = N - 1, 1, -1
- LM = MIN( KL, N-J )
- CALL DGEMV( 'Transpose', LM, NRHS, -ONE, B( J+1, 1 ),
- $ LDB, AB( KD+1, J ), 1, ONE, B( J, 1 ), LDB )
- L = IPIV( J )
- IF( L.NE.J )
- $ CALL DSWAP( NRHS, B( L, 1 ), LDB, B( J, 1 ), LDB )
- 40 CONTINUE
- END IF
- END IF
- RETURN
-*
-* End of DGBTRS
-*
- END
- SUBROUTINE DLASWP( N, A, LDA, K1, K2, IPIV, INCX )
-*
-* -- LAPACK auxiliary routine (version 3.0) --
-* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
-* Courant Institute, Argonne National Lab, and Rice University
-* June 30, 1999
-*
-* .. Scalar Arguments ..
- INTEGER INCX, K1, K2, LDA, N
-* ..
-* .. Array Arguments ..
- INTEGER IPIV( * )
- REAL A( LDA, * )
-* ..
-*
-* Purpose
-* =======
-*
-* DLASWP performs a series of row interchanges on the matrix A.
-* One row interchange is initiated for each of rows K1 through K2 of A.
-*
-* Arguments
-* =========
-*
-* N (input) INTEGER
-* The number of columns of the matrix A.
-*
-* A (input/output) REAL array, dimension (LDA,N)
-* On entry, the matrix of column dimension N to which the row
-* interchanges will be applied.
-* On exit, the permuted matrix.
-*
-* LDA (input) INTEGER
-* The leading dimension of the array A.
-*
-* K1 (input) INTEGER
-* The first element of IPIV for which a row interchange will
-* be done.
-*
-* K2 (input) INTEGER
-* The last element of IPIV for which a row interchange will
-* be done.
-*
-* IPIV (input) INTEGER array, dimension (M*abs(INCX))
-* The vector of pivot indices. Only the elements in positions
-* K1 through K2 of IPIV are accessed.
-* IPIV(K) = L implies rows K and L are to be interchanged.
-*
-* INCX (input) INTEGER
-* The increment between successive values of IPIV. If IPIV
-* is negative, the pivots are applied in reverse order.
-*
-* Further Details
-* ===============
-*
-* Modified by
-* R. C. Whaley, Computer Science Dept., Univ. of Tenn., Knoxville, USA
-*
-* =====================================================================
-*
-* .. Local Scalars ..
- INTEGER I, I1, I2, INC, IP, IX, IX0, J, K, N32
- REAL TEMP
-* ..
-* .. Executable Statements ..
-*
-* Interchange row I with row IPIV(I) for each of rows K1 through K2.
-*
- IF( INCX.GT.0 ) THEN
- IX0 = K1
- I1 = K1
- I2 = K2
- INC = 1
- ELSE IF( INCX.LT.0 ) THEN
- IX0 = 1 + ( 1-K2 )*INCX
- I1 = K2
- I2 = K1
- INC = -1
- ELSE
- RETURN
- END IF
-*
- N32 = ( N / 32 )*32
- IF( N32.NE.0 ) THEN
- DO 30 J = 1, N32, 32
- IX = IX0
- DO 20 I = I1, I2, INC
- IP = IPIV( IX )
- IF( IP.NE.I ) THEN
- DO 10 K = J, J + 31
- TEMP = A( I, K )
- A( I, K ) = A( IP, K )
- A( IP, K ) = TEMP
- 10 CONTINUE
- END IF
- IX = IX + INCX
- 20 CONTINUE
- 30 CONTINUE
- END IF
- IF( N32.NE.N ) THEN
- N32 = N32 + 1
- IX = IX0
- DO 50 I = I1, I2, INC
- IP = IPIV( IX )
- IF( IP.NE.I ) THEN
- DO 40 K = N32, N
- TEMP = A( I, K )
- A( I, K ) = A( IP, K )
- A( IP, K ) = TEMP
- 40 CONTINUE
- END IF
- IX = IX + INCX
- 50 CONTINUE
- END IF
-*
- RETURN
-*
-* End of DLASWP
-*
- END
- INTEGER FUNCTION IEEECK( ISPEC, ZERO, ONE )
-*
-* -- LAPACK auxiliary routine (version 3.0) --
-* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
-* Courant Institute, Argonne National Lab, and Rice University
-* June 30, 1998
-*
-* .. Scalar Arguments ..
- INTEGER ISPEC
- REAL ONE, ZERO
-* ..
-*
-* Purpose
-* =======
-*
-* IEEECK is called from the ILAENV to verify that Infinity and
-* possibly NaN arithmetic is safe (i.e. will not trap).
-*
-* Arguments
-* =========
-*
-* ISPEC (input) INTEGER
-* Specifies whether to test just for inifinity arithmetic
-* or whether to test for infinity and NaN arithmetic.
-* = 0: Verify infinity arithmetic only.
-* = 1: Verify infinity and NaN arithmetic.
-*
-* ZERO (input) REAL
-* Must contain the value 0.0
-* This is passed to prevent the compiler from optimizing
-* away this code.
-*
-* ONE (input) REAL
-* Must contain the value 1.0
-* This is passed to prevent the compiler from optimizing
-* away this code.
-*
-* RETURN VALUE: INTEGER
-* = 0: Arithmetic failed to produce the correct answers
-* = 1: Arithmetic produced the correct answers
-*
-* .. Local Scalars ..
- REAL NAN1, NAN2, NAN3, NAN4, NAN5, NAN6, NEGINF,
- $ NEGZRO, NEWZRO, POSINF
-* ..
-* .. Executable Statements ..
- IEEECK = 1
-*
- POSINF = ONE / ZERO
- IF( POSINF.LE.ONE ) THEN
- IEEECK = 0
- RETURN
- END IF
-*
- NEGINF = -ONE / ZERO
- IF( NEGINF.GE.ZERO ) THEN
- IEEECK = 0
- RETURN
- END IF
-*
- NEGZRO = ONE / ( NEGINF+ONE )
- IF( NEGZRO.NE.ZERO ) THEN
- IEEECK = 0
- RETURN
- END IF
-*
- NEGINF = ONE / NEGZRO
- IF( NEGINF.GE.ZERO ) THEN
- IEEECK = 0
- RETURN
- END IF
-*
- NEWZRO = NEGZRO + ZERO
- IF( NEWZRO.NE.ZERO ) THEN
- IEEECK = 0
- RETURN
- END IF
-*
- POSINF = ONE / NEWZRO
- IF( POSINF.LE.ONE ) THEN
- IEEECK = 0
- RETURN
- END IF
-*
- NEGINF = NEGINF*POSINF
- IF( NEGINF.GE.ZERO ) THEN
- IEEECK = 0
- RETURN
- END IF
-*
- POSINF = POSINF*POSINF
- IF( POSINF.LE.ONE ) THEN
- IEEECK = 0
- RETURN
- END IF
-*
-*
-*
-*
-* Return if we were only asked to check infinity arithmetic
-*
- IF( ISPEC.EQ.0 )
- $ RETURN
-*
- NAN1 = POSINF + NEGINF
-*
- NAN2 = POSINF / NEGINF
-*
- NAN3 = POSINF / POSINF
-*
- NAN4 = POSINF*ZERO
-*
- NAN5 = NEGINF*NEGZRO
-*
- NAN6 = NAN5*0.0
-*
- IF( NAN1.EQ.NAN1 ) THEN
- IEEECK = 0
- RETURN
- END IF
-*
- IF( NAN2.EQ.NAN2 ) THEN
- IEEECK = 0
- RETURN
- END IF
-*
- IF( NAN3.EQ.NAN3 ) THEN
- IEEECK = 0
- RETURN
- END IF
-*
- IF( NAN4.EQ.NAN4 ) THEN
- IEEECK = 0
- RETURN
- END IF
-*
- IF( NAN5.EQ.NAN5 ) THEN
- IEEECK = 0
- RETURN
- END IF
-*
- IF( NAN6.EQ.NAN6 ) THEN
- IEEECK = 0
- RETURN
- END IF
-*
- RETURN
- END
- INTEGER FUNCTION ILAENV( ISPEC, NAME, OPTS, N1, N2, N3,
- $ N4 )
-*
-* -- LAPACK auxiliary routine (version 3.0) --
-* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
-* Courant Institute, Argonne National Lab, and Rice University
-* June 30, 1999
-*
-* .. Scalar Arguments ..
- CHARACTER*( * ) NAME, OPTS
- INTEGER ISPEC, N1, N2, N3, N4
-* ..
-*
-* Purpose
-* =======
-*
-* ILAENV is called from the LAPACK routines to choose problem-dependent
-* parameters for the local environment. See ISPEC for a description of
-* the parameters.
-*
-* This version provides a set of parameters which should give good,
-* but not optimal, performance on many of the currently available
-* computers. Users are encouraged to modify this subroutine to set
-* the tuning parameters for their particular machine using the option
-* and problem size information in the arguments.
-*
-* This routine will not function correctly if it is converted to all
-* lower case. Converting it to all upper case is allowed.
-*
-* Arguments
-* =========
-*
-* ISPEC (input) INTEGER
-* Specifies the parameter to be returned as the value of
-* ILAENV.
-* = 1: the optimal blocksize; if this value is 1, an unblocked
-* algorithm will give the best performance.
-* = 2: the minimum block size for which the block routine
-* should be used; if the usable block size is less than
-* this value, an unblocked routine should be used.
-* = 3: the crossover point (in a block routine, for N less
-* than this value, an unblocked routine should be used)
-* = 4: the number of shifts, used in the nonsymmetric
-* eigenvalue routines
-* = 5: the minimum column dimension for blocking to be used;
-* rectangular blocks must have dimension at least k by m,
-* where k is given by ILAENV(2,...) and m by ILAENV(5,...)
-* = 6: the crossover point for the SVD (when reducing an m by n
-* matrix to bidiagonal form, if max(m,n)/min(m,n) exceeds
-* this value, a QR factorization is used first to reduce
-* the matrix to a triangular form.)
-* = 7: the number of processors
-* = 8: the crossover point for the multishift QR and QZ methods
-* for nonsymmetric eigenvalue problems.
-* = 9: maximum size of the subproblems at the bottom of the
-* computation tree in the divide-and-conquer algorithm
-* (used by xGELSD and xGESDD)
-* =10: ieee NaN arithmetic can be trusted not to trap
-* =11: infinity arithmetic can be trusted not to trap
-*
-* NAME (input) CHARACTER*(*)
-* The name of the calling subroutine, in either upper case or
-* lower case.
-*
-* OPTS (input) CHARACTER*(*)
-* The character options to the subroutine NAME, concatenated
-* into a single character string. For example, UPLO = 'U',
-* TRANS = 'T', and DIAG = 'N' for a triangular routine would
-* be specified as OPTS = 'UTN'.
-*
-* N1 (input) INTEGER
-* N2 (input) INTEGER
-* N3 (input) INTEGER
-* N4 (input) INTEGER
-* Problem dimensions for the subroutine NAME; these may not all
-* be required.
-*
-* (ILAENV) (output) INTEGER
-* >= 0: the value of the parameter specified by ISPEC
-* < 0: if ILAENV = -k, the k-th argument had an illegal value.
-*
-* Further Details
-* ===============
-*
-* The following conventions have been used when calling ILAENV from the
-* LAPACK routines:
-* 1) OPTS is a concatenation of all of the character options to
-* subroutine NAME, in the same order that they appear in the
-* argument list for NAME, even if they are not used in determining
-* the value of the parameter specified by ISPEC.
-* 2) The problem dimensions N1, N2, N3, N4 are specified in the order
-* that they appear in the argument list for NAME. N1 is used
-* first, N2 second, and so on, and unused problem dimensions are
-* passed a value of -1.
-* 3) The parameter value returned by ILAENV is checked for validity in
-* the calling subroutine. For example, ILAENV is used to retrieve
-* the optimal blocksize for STRTRI as follows:
-*
-* NB = ILAENV( 1, 'STRTRI', UPLO // DIAG, N, -1, -1, -1 )
-* IF( NB.LE.1 ) NB = MAX( 1, N )
-*
-* =====================================================================
-*
-* .. Local Scalars ..
- LOGICAL CNAME, SNAME
- CHARACTER*1 C1
- CHARACTER*2 C2, C4
- CHARACTER*3 C3
- CHARACTER*6 SUBNAM
- INTEGER I, IC, IZ, NB, NBMIN, NX
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC CHAR, ICHAR, INT, MIN, REAL
-* ..
-* .. External Functions ..
- INTEGER IEEECK
- EXTERNAL IEEECK
-* ..
-* .. Executable Statements ..
-*
- GO TO ( 100, 100, 100, 400, 500, 600, 700, 800, 900, 1000,
- $ 1100 ) ISPEC
-*
-* Invalid value for ISPEC
-*
- ILAENV = -1
- RETURN
-*
- 100 CONTINUE
-*
-* Convert NAME to upper case if the first character is lower case.
-*
- ILAENV = 1
- SUBNAM = NAME
- IC = ICHAR( SUBNAM( 1:1 ) )
- IZ = ICHAR( 'Z' )
- IF( IZ.EQ.90 .OR. IZ.EQ.122 ) THEN
-*
-* ASCII character set
-*
- IF( IC.GE.97 .AND. IC.LE.122 ) THEN
- SUBNAM( 1:1 ) = CHAR( IC-32 )
- DO 10 I = 2, 6
- IC = ICHAR( SUBNAM( I:I ) )
- IF( IC.GE.97 .AND. IC.LE.122 )
- $ SUBNAM( I:I ) = CHAR( IC-32 )
- 10 CONTINUE
- END IF
-*
- ELSE IF( IZ.EQ.233 .OR. IZ.EQ.169 ) THEN
-*
-* EBCDIC character set
-*
- IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR.
- $ ( IC.GE.145 .AND. IC.LE.153 ) .OR.
- $ ( IC.GE.162 .AND. IC.LE.169 ) ) THEN
- SUBNAM( 1:1 ) = CHAR( IC+64 )
- DO 20 I = 2, 6
- IC = ICHAR( SUBNAM( I:I ) )
- IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR.
- $ ( IC.GE.145 .AND. IC.LE.153 ) .OR.
- $ ( IC.GE.162 .AND. IC.LE.169 ) )
- $ SUBNAM( I:I ) = CHAR( IC+64 )
- 20 CONTINUE
- END IF
-*
- ELSE IF( IZ.EQ.218 .OR. IZ.EQ.250 ) THEN
-*
-* Prime machines: ASCII+128
-*
- IF( IC.GE.225 .AND. IC.LE.250 ) THEN
- SUBNAM( 1:1 ) = CHAR( IC-32 )
- DO 30 I = 2, 6
- IC = ICHAR( SUBNAM( I:I ) )
- IF( IC.GE.225 .AND. IC.LE.250 )
- $ SUBNAM( I:I ) = CHAR( IC-32 )
- 30 CONTINUE
- END IF
- END IF
-*
- C1 = SUBNAM( 1:1 )
- SNAME = C1.EQ.'S' .OR. C1.EQ.'D'
- CNAME = C1.EQ.'C' .OR. C1.EQ.'Z'
- IF( .NOT.( CNAME .OR. SNAME ) )
- $ RETURN
- C2 = SUBNAM( 2:3 )
- C3 = SUBNAM( 4:6 )
- C4 = C3( 2:3 )
-*
- GO TO ( 110, 200, 300 ) ISPEC
-*
- 110 CONTINUE
-*
-* ISPEC = 1: block size
-*
-* In these examples, separate code is provided for setting NB for
-* real and complex. We assume that NB will take the same value in
-* single or double precision.
-*
- NB = 1
-*
- IF( C2.EQ.'GE' ) THEN
- IF( C3.EQ.'TRF' ) THEN
- IF( SNAME ) THEN
- NB = 64
- ELSE
- NB = 64
- END IF
- ELSE IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR.
- $ C3.EQ.'QLF' ) THEN
- IF( SNAME ) THEN
- NB = 32
- ELSE
- NB = 32
- END IF
- ELSE IF( C3.EQ.'HRD' ) THEN
- IF( SNAME ) THEN
- NB = 32
- ELSE
- NB = 32
- END IF
- ELSE IF( C3.EQ.'BRD' ) THEN
- IF( SNAME ) THEN
- NB = 32
- ELSE
- NB = 32
- END IF
- ELSE IF( C3.EQ.'TRI' ) THEN
- IF( SNAME ) THEN
- NB = 64
- ELSE
- NB = 64
- END IF
- END IF
- ELSE IF( C2.EQ.'PO' ) THEN
- IF( C3.EQ.'TRF' ) THEN
- IF( SNAME ) THEN
- NB = 64
- ELSE
- NB = 64
- END IF
- END IF
- ELSE IF( C2.EQ.'SY' ) THEN
- IF( C3.EQ.'TRF' ) THEN
- IF( SNAME ) THEN
- NB = 64
- ELSE
- NB = 64
- END IF
- ELSE IF( SNAME .AND. C3.EQ.'TRD' ) THEN
- NB = 32
- ELSE IF( SNAME .AND. C3.EQ.'GST' ) THEN
- NB = 64
- END IF
- ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN
- IF( C3.EQ.'TRF' ) THEN
- NB = 64
- ELSE IF( C3.EQ.'TRD' ) THEN
- NB = 32
- ELSE IF( C3.EQ.'GST' ) THEN
- NB = 64
- END IF
- ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN
- IF( C3( 1:1 ).EQ.'G' ) THEN
- IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR.
- $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR.
- $ C4.EQ.'BR' ) THEN
- NB = 32
- END IF
- ELSE IF( C3( 1:1 ).EQ.'M' ) THEN
- IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR.
- $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR.
- $ C4.EQ.'BR' ) THEN
- NB = 32
- END IF
- END IF
- ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN
- IF( C3( 1:1 ).EQ.'G' ) THEN
- IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR.
- $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR.
- $ C4.EQ.'BR' ) THEN
- NB = 32
- END IF
- ELSE IF( C3( 1:1 ).EQ.'M' ) THEN
- IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR.
- $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR.
- $ C4.EQ.'BR' ) THEN
- NB = 32
- END IF
- END IF
- ELSE IF( C2.EQ.'GB' ) THEN
- IF( C3.EQ.'TRF' ) THEN
- IF( SNAME ) THEN
- IF( N4.LE.64 ) THEN
- NB = 1
- ELSE
- NB = 32
- END IF
- ELSE
- IF( N4.LE.64 ) THEN
- NB = 1
- ELSE
- NB = 32
- END IF
- END IF
- END IF
- ELSE IF( C2.EQ.'PB' ) THEN
- IF( C3.EQ.'TRF' ) THEN
- IF( SNAME ) THEN
- IF( N2.LE.64 ) THEN
- NB = 1
- ELSE
- NB = 32
- END IF
- ELSE
- IF( N2.LE.64 ) THEN
- NB = 1
- ELSE
- NB = 32
- END IF
- END IF
- END IF
- ELSE IF( C2.EQ.'TR' ) THEN
- IF( C3.EQ.'TRI' ) THEN
- IF( SNAME ) THEN
- NB = 64
- ELSE
- NB = 64
- END IF
- END IF
- ELSE IF( C2.EQ.'LA' ) THEN
- IF( C3.EQ.'UUM' ) THEN
- IF( SNAME ) THEN
- NB = 64
- ELSE
- NB = 64
- END IF
- END IF
- ELSE IF( SNAME .AND. C2.EQ.'ST' ) THEN
- IF( C3.EQ.'EBZ' ) THEN
- NB = 1
- END IF
- END IF
- ILAENV = NB
- RETURN
-*
- 200 CONTINUE
-*
-* ISPEC = 2: minimum block size
-*
- NBMIN = 2
- IF( C2.EQ.'GE' ) THEN
- IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR.
- $ C3.EQ.'QLF' ) THEN
- IF( SNAME ) THEN
- NBMIN = 2
- ELSE
- NBMIN = 2
- END IF
- ELSE IF( C3.EQ.'HRD' ) THEN
- IF( SNAME ) THEN
- NBMIN = 2
- ELSE
- NBMIN = 2
- END IF
- ELSE IF( C3.EQ.'BRD' ) THEN
- IF( SNAME ) THEN
- NBMIN = 2
- ELSE
- NBMIN = 2
- END IF
- ELSE IF( C3.EQ.'TRI' ) THEN
- IF( SNAME ) THEN
- NBMIN = 2
- ELSE
- NBMIN = 2
- END IF
- END IF
- ELSE IF( C2.EQ.'SY' ) THEN
- IF( C3.EQ.'TRF' ) THEN
- IF( SNAME ) THEN
- NBMIN = 8
- ELSE
- NBMIN = 8
- END IF
- ELSE IF( SNAME .AND. C3.EQ.'TRD' ) THEN
- NBMIN = 2
- END IF
- ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN
- IF( C3.EQ.'TRD' ) THEN
- NBMIN = 2
- END IF
- ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN
- IF( C3( 1:1 ).EQ.'G' ) THEN
- IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR.
- $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR.
- $ C4.EQ.'BR' ) THEN
- NBMIN = 2
- END IF
- ELSE IF( C3( 1:1 ).EQ.'M' ) THEN
- IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR.
- $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR.
- $ C4.EQ.'BR' ) THEN
- NBMIN = 2
- END IF
- END IF
- ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN
- IF( C3( 1:1 ).EQ.'G' ) THEN
- IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR.
- $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR.
- $ C4.EQ.'BR' ) THEN
- NBMIN = 2
- END IF
- ELSE IF( C3( 1:1 ).EQ.'M' ) THEN
- IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR.
- $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR.
- $ C4.EQ.'BR' ) THEN
- NBMIN = 2
- END IF
- END IF
- END IF
- ILAENV = NBMIN
- RETURN
-*
- 300 CONTINUE
-*
-* ISPEC = 3: crossover point
-*
- NX = 0
- IF( C2.EQ.'GE' ) THEN
- IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR.
- $ C3.EQ.'QLF' ) THEN
- IF( SNAME ) THEN
- NX = 128
- ELSE
- NX = 128
- END IF
- ELSE IF( C3.EQ.'HRD' ) THEN
- IF( SNAME ) THEN
- NX = 128
- ELSE
- NX = 128
- END IF
- ELSE IF( C3.EQ.'BRD' ) THEN
- IF( SNAME ) THEN
- NX = 128
- ELSE
- NX = 128
- END IF
- END IF
- ELSE IF( C2.EQ.'SY' ) THEN
- IF( SNAME .AND. C3.EQ.'TRD' ) THEN
- NX = 32
- END IF
- ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN
- IF( C3.EQ.'TRD' ) THEN
- NX = 32
- END IF
- ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN
- IF( C3( 1:1 ).EQ.'G' ) THEN
- IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR.
- $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR.
- $ C4.EQ.'BR' ) THEN
- NX = 128
- END IF
- END IF
- ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN
- IF( C3( 1:1 ).EQ.'G' ) THEN
- IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR.
- $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR.
- $ C4.EQ.'BR' ) THEN
- NX = 128
- END IF
- END IF
- END IF
- ILAENV = NX
- RETURN
-*
- 400 CONTINUE
-*
-* ISPEC = 4: number of shifts (used by xHSEQR)
-*
- ILAENV = 6
- RETURN
-*
- 500 CONTINUE
-*
-* ISPEC = 5: minimum column dimension (not used)
-*
- ILAENV = 2
- RETURN
-*
- 600 CONTINUE
-*
-* ISPEC = 6: crossover point for SVD (used by xGELSS and xGESVD)
-*
- ILAENV = INT( REAL( MIN( N1, N2 ) )*1.6E0 )
- RETURN
-*
- 700 CONTINUE
-*
-* ISPEC = 7: number of processors (not used)
-*
- ILAENV = 1
- RETURN
-*
- 800 CONTINUE
-*
-* ISPEC = 8: crossover point for multishift (used by xHSEQR)
-*
- ILAENV = 50
- RETURN
-*
- 900 CONTINUE
-*
-* ISPEC = 9: maximum size of the subproblems at the bottom of the
-* computation tree in the divide-and-conquer algorithm
-* (used by xGELSD and xGESDD)
-*
- ILAENV = 25
- RETURN
-*
- 1000 CONTINUE
-*
-* ISPEC = 10: ieee NaN arithmetic can be trusted not to trap
-*
-C ILAENV = 0
- ILAENV = 1
- IF( ILAENV.EQ.1 ) THEN
- ILAENV = IEEECK( 0, 0.0, 1.0 )
- END IF
- RETURN
-*
- 1100 CONTINUE
-*
-* ISPEC = 11: infinity arithmetic can be trusted not to trap
-*
-C ILAENV = 0
- ILAENV = 1
- IF( ILAENV.EQ.1 ) THEN
- ILAENV = IEEECK( 1, 0.0, 1.0 )
- END IF
- RETURN
-*
-* End of ILAENV
-*
- END
diff --git a/src/LIB/RTTOV/src/mod_cparam.F90 b/src/LIB/RTTOV/src/mod_cparam.F90
deleted file mode 100644
index aa3b28f64ae7ebcd9a046e56e62bcdb5bbbc0fb3..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/mod_cparam.F90
+++ /dev/null
@@ -1,134 +0,0 @@
-!+ Parameters used in RTTOV-7 suite
-!
-MODULE MOD_CPARAM
- !
- ! This software was developed within the context of
- ! the EUMETSAT Satellite Application Facility on
- ! Numerical Weather Prediction (NWP SAF), under the
- ! Cooperation Agreement dated 25 November 1998, between
- ! EUMETSAT and the Met Office, UK, by one or more partners
- ! within the NWP SAF. The partners in the NWP SAF are
- ! the Met Office, ECMWF, KNMI and MeteoFrance.
- !
- ! Copyright 2002, EUMETSAT, All Rights Reserved.
- ! Description:
- ! Set up parameters that define the maximum dimension of some arrays
- ! used in the RTTOV suite.
- !
- ! Compatible with RTTOV8 library but only able to
- ! run with coefficients created on RTTOV7 43 pressure levels
- !
- ! Owner:
- ! SAF NWP
- !
- ! History:
- ! Version Date Comment
- ! 1 01/05/2000 Original code. .
- ! 2 21/08/2000 jpnssv increased from 1 to 6. Stephen English.
- ! 3 12/02/2001 fundamental constants added Roger Saunders
- ! 4 18/04/2001 new coefficient file Pascal Brunel
- ! 5 08/08/2001 updated to include AIRS Roger Saunders
- ! 6 20/09/2001 remove fileunit variable. Andrew Collard.
- ! 7 01/12/2002 New F90 code with structures (P Brunel A Smith)
- ! add pointer on coefficient structure
- !
- ! Code description:
- ! Language: Fortran 90.
- ! Software Standards: "European Standards for Writing and Documenting
- ! Exchangeable Fortran 90 code".
- !
- ! Imported Type Definitions:
- use rttov_types, only : & ! for coefficient structure
- rttov_coef
-
- Use parkind1, Only : jpim ,jprb
- IMPLICIT NONE
- !----------------------------------------------------------------------
- ! Global parameters which users may want to edit to optimise
- ! for their application
- Integer(Kind=jpim), PARAMETER :: jppf = 3 ! Max no. profiles per RTTOV call
- Integer(Kind=jpim), PARAMETER :: jpch = 2378 ! Max. no. of channels
- Integer(Kind=jpim), PARAMETER :: jpchus = 324 ! Max. no. of channels computed/call
- Integer(Kind=jpim), PARAMETER :: jpnsat = 30 ! Max no sensors to be used
- !----------------------------------------------------------------------
- !Global parameters normally not changed by users
- Integer(Kind=jpim), PARAMETER :: jplev = 43 ! No. of pressure levels
- Integer(Kind=jpim), PARAMETER :: jpnav = 4 ! No. of profile variables
- Integer(Kind=jpim), PARAMETER :: jpnsav = 5 ! No. of surface air variables
- Integer(Kind=jpim), PARAMETER :: jpnssv = 6 ! No. of skin variables
- Integer(Kind=jpim), PARAMETER :: jpncv = 2 ! No. of cloud variables
- Integer(Kind=jpim), PARAMETER :: jpchpf = jppf*jpchus ! Max no. of profs * chans used
- Integer(Kind=jpim), PARAMETER :: jpcofm = 15 ! Mixed gas coeffs (max
- Integer(Kind=jpim), PARAMETER :: jpcofw = 15 ! Water vapour coeffs (max
- Integer(Kind=jpim), PARAMETER :: jpcofo = 15 ! Ozone coeffs
- Integer(Kind=jpim), PARAMETER :: jpst = 10 ! Max no. of surface types
- Integer(Kind=jpim), PARAMETER :: iu1 = 10 ! Default Unit for rt coeff files
- Integer(Kind=jpim), PARAMETER :: nulout = 0 ! Unit for error messages
- Integer(Kind=jpim), PARAMETER :: jmwcldtop = 25 ! Upper level for lwp calcs
-
- Integer(Kind=jpim), parameter :: jpplat=15 ! No of platforms
- Integer(Kind=jpim), parameter :: jpinst=30 ! No of instruments (starting at 0)
- Integer(Kind=jpim), Parameter :: jpgas=3 ! No of different gases
- !
- !
- ! fundamental constants
- Real(Kind=jprb), PARAMETER :: pi = 3.1415926535_JPRB
- Real(Kind=jprb), PARAMETER :: deg2rad = PI/180.0_JPRB ! Degrees to radians conversion factor
- Real(Kind=jprb), PARAMETER :: rcnv = 6.03504E+5_JPRB ! kg/kg--> ppmv ozone
- Real(Kind=jprb), PARAMETER :: rcnw = 1.60771704E+6_JPRB ! kg/kg--> ppmv water vapour
- Real(Kind=jprb), PARAMETER :: gravity = 9.81_JPRB ! m/s^2
- Real(Kind=jprb), PARAMETER :: speedl = 29979245800.0_JPRB ! speed of light cm/sec
- Real(Kind=jprb), PARAMETER :: plcon1 = 1.1910659E-05_JPRB ! first plank constant mW/(m^2._JPRBster.cm^-4)
- Real(Kind=jprb), PARAMETER :: plcon2 = 1.438833_JPRB ! second plank constant K/cm^-1
- !
- Real(Kind=jprb), Parameter :: q_mixratio_to_ppmv = 1.60771704e+6_JPRB
- Real(Kind=jprb), Parameter :: q_ppmv_to_mixratio = 1.0_JPRB/1.60771704e+6_JPRB
- Real(Kind=jprb), Parameter :: o3_mixratio_to_ppmv = 6.03504e+5_JPRB
- Real(Kind=jprb), Parameter :: o3_ppmv_to_mixratio = 1.0_JPRB/6.03504e+5_JPRB
- !
- ! Module arguments:
-
- ! Global scalars:F
- Integer(Kind=jpim) :: njpnsat ! Total max sats to be used
- Integer(Kind=jpim) :: njplev ! No. of pressure levels
- Integer(Kind=jpim) :: njpnav ! No. of profile variables
- Integer(Kind=jpim) :: njpnsav ! No. of surface air variables
- Integer(Kind=jpim) :: njpnssv ! No. of skin variables
- Integer(Kind=jpim) :: njpncv ! No. of cloud variables
- Integer(Kind=jpim) :: njppf ! Max no. profiles
- Integer(Kind=jpim) :: njpch ! Max. no. of tovs channels
- Integer(Kind=jpim) :: njpchus ! Max. no. of channels used tovs
- Integer(Kind=jpim) :: njpchpf ! Max no. of profs * chans used
- Integer(Kind=jpim) :: njpcofm ! Mixed gas coeffs (max)
- Integer(Kind=jpim) :: njpcofw ! Water vapour coeffs (max)
- Integer(Kind=jpim) :: njpcofo ! Ozone coeffs (max)
- Integer(Kind=jpim) :: njpst ! Max no. of surface types
- Integer(Kind=jpim) :: nmwcldtop ! Upper level for lwp calcs
-
- ! list of allowed platforms
- Character (len=8), Dimension(jpplat) :: platform_name = &
- & (/ 'noaa ', 'dmsp ', 'meteosat', 'goes ', 'gms ', &
- & 'fy2 ', 'trmm ', 'ers ', 'eos ', 'metop ', &
- & 'envisat ', 'msg ', 'fy1 ', 'xxxxxxxx', 'xxxxxxxx' /)
-
- ! List of instruments !!!! HIRS is number 0
- Character (len=8), Dimension(0:jpinst-1) :: inst_name = &
- & (/ 'hirs ', 'msu ', 'ssu ', 'amsua ', 'amsub ', &
- & 'avhrr ', 'ssmi ', 'vtpr1 ', 'vtpr2 ', 'tmi ', &
- & 'ssmis ', 'airs ', 'hsb ', 'modis ', 'atsr ', &
- & 'mhs ', 'iasi ', 'xxxxxxxx', 'xxxxxxxx', 'xxxxxxxx', &
- & 'mviri ', 'seviri ', 'imager ', 'sounder ', 'imager ', &
- & 'vissr ', 'mvisr ', 'xxxxxxxx', 'xxxxxxxx', 'xxxxxxxx' /)
-
- ! List of gases
- Character (len=16), Dimension(jpgas) :: gas_name = &
- & (/ 'mixed_gases ',&
- & 'water_vapour ',&
- & 'ozone ' /)
- ! End of module arguments:
-
- type( rttov_coef ), target :: coef(jpnsat) ! coefficients
- !-----End of header----------------------------------------------------
-
-
-END MODULE MOD_CPARAM
diff --git a/src/LIB/RTTOV/src/mod_rttov_scatt_test.F90 b/src/LIB/RTTOV/src/mod_rttov_scatt_test.F90
deleted file mode 100644
index 856094199901aaa2b7ed1bbef0ac487ea085f253..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/mod_rttov_scatt_test.F90
+++ /dev/null
@@ -1,28 +0,0 @@
- module mod_rttov_scatt_test
-
- Use parkind1, only: jpim ,jprb
-
- Use rttov_types, only : rttov_coef, rttov_scatt_coef
-
- IMPLICIT NONE
-
- integer (kind=jpim), parameter :: nulout = 5
- integer (kind=jpim), parameter :: nulerr = 6
- integer (kind=jpim), parameter :: kproma = 3
- integer (kind=jpim), parameter :: kflevg = 60
-
- integer (kind=jpim), parameter :: ioin = 10
- integer (kind=jpim), parameter :: ioout = 20
-
- integer (kind=jpim), parameter :: inproc = 1
- integer (kind=jpim), parameter :: imyproc = 1
- integer (kind=jpim), parameter :: iioproc = 1
-
-
-!* from module /satrad/module/onedvar_const.F90
- real (kind=jprb), parameter :: fastem_land_coeff (5) = (/ 3.0_JPRB, 5.0_JPRB, 15.0_JPRB, 0.1_JPRB, 0.3_JPRB /)
- real (kind=jprb), parameter :: fastem_ocean = 0.0_JPRB
-
- real (kind=jprb) :: zenangle
-
- end module mod_rttov_scatt_test
diff --git a/src/LIB/RTTOV/src/mod_tstrad.F90 b/src/LIB/RTTOV/src/mod_tstrad.F90
deleted file mode 100644
index f8a6c98192696831148d61ff7317af572ed54b88..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/mod_tstrad.F90
+++ /dev/null
@@ -1,14 +0,0 @@
-Module mod_tstrad
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
- Real(Kind=jprb), pointer :: xkbav(:,:,:)
- Real(Kind=jprb), pointer :: xkradovu(:,:)
- Real(Kind=jprb), pointer :: xkradovd(:,:)
- Real(Kind=jprb), pointer :: xkradov1(:,:)
- Real(Kind=jprb), pointer :: xkradov2(:,:)
- Real(Kind=jprb), pointer :: xkbsav(:,:)
-
- Real(Kind=jprb), pointer :: xkbem(:)
-
-End Module mod_tstrad
diff --git a/src/LIB/RTTOV/src/parkind1.F90 b/src/LIB/RTTOV/src/parkind1.F90
deleted file mode 100644
index 88599b2016acbe731265cd390d3883f4414bafb5..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/parkind1.F90
+++ /dev/null
@@ -1,37 +0,0 @@
-MODULE PARKIND1
-!
-! *** Define usual kinds for strong typing ***
-!
-IMPLICIT NONE
-SAVE
-!
-! Integer Kinds
-! -------------
-!
-!JUAN
-INTEGER :: JINT_DEF
-!JUAN
-INTEGER, PARAMETER :: JPIT = SELECTED_INT_KIND(2)
-INTEGER, PARAMETER :: JPIS = SELECTED_INT_KIND(4)
-INTEGER, PARAMETER :: JPIM = KIND(JINT_DEF) ! SELECTED_INT_KIND(11) ! SELECTED_INT_KIND(9)
-INTEGER, PARAMETER :: JPIB = SELECTED_INT_KIND(12)
-
-!Special integer type to be used for sensative adress calculations
-!should be *8 for a machine with 8byte adressing for optimum performance
-!ifdef ADDRESS64
-INTEGER, PARAMETER :: JPIA = JPIB
-!#else
-!INTEGER, PARAMETER :: JPIA = JPIM
-!#endif
-
-!
-! Real Kinds
-! ----------
-!
-INTEGER, PARAMETER :: JPRT = SELECTED_REAL_KIND(2,1)
-INTEGER, PARAMETER :: JPRS = SELECTED_REAL_KIND(4,2)
-INTEGER, PARAMETER :: JPRM = SELECTED_REAL_KIND(6,37)
-REAL :: REAL_DEF_JPRB
-INTEGER, PARAMETER :: JPRB = KIND(REAL_DEF_JPRB) ! SELECTED_REAL_KIND(13,300)
-!
-END MODULE PARKIND1
diff --git a/src/LIB/RTTOV/src/rttov.F90 b/src/LIB/RTTOV/src/rttov.F90
deleted file mode 100644
index 05262dd43993f5263db0b10c6e2209275a62036d..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov.F90
+++ /dev/null
@@ -1,425 +0,0 @@
-!+ Fast radiative transfer model.
-!
-SUBROUTINE RTTOV &
- (knpf, klenpf, ppres, pangl, pangs, ksurf, ksat, knchpf, &
- kchan, kprof, pav, psav, pssv, pcv, pemis, ifail, prad, ptb, radov, &
- rado, tau, tausfc, lcloud)
-!
-! This software was developed within the context of
-! the EUMETSAT Satellite Application Facility on
-! Numerical Weather Prediction (NWP SAF), under the
-! Cooperation Agreement dated 25 November 1998, between
-! EUMETSAT and the Met Office, UK, by one or more partners
-! within the NWP SAF. The partners in the NWP SAF are
-! the Met Office, ECMWF, KNMI and MeteoFrance.
-!
-! Copyright 2002, EUMETSAT, All Rights Reserved.
-!
-! Description:
-! to compute multi-channel level to space transmittances,
-! top of atmosphere radiances and brightness
-! temperatures for many profiles and Ir/Mw sensors.
-! Compatible with RTTOV8 library but only able to
-! run with coefficients created on RTTOV7 43 pressure levels
-!
-! Method
-! see Matricardi et al QJ 2002
-! see Saunders et al QJ 1999
-! see: ECMWF Technical Memoranda 176/282/345 (Available from ECMWF)
-!
-! Current Code Owner: SAF NWP
-!
-! History:
-! Version Date Comment
-! ------- ---- -------
-! 13/8/92. For version 2.
-! ksat added to argument list; ssu included;
-! internal changes to move big arrays from commons to
-! arguments and to introduce taskcommons
-! 8/7/97 added ozone and extended water vapour in control vector
-! 01/05/2000 F90 code
-! 21/08/2000 Interface to rtint changed to include pref (surface reflectivity).
-! (Stephen English)
-! 31/01/2001 More cloud computations. stored in radov (F. Chevallier)
-! 6/2/2001 pgrody and knav etc arrays removed from call (R Saunders)
-! 18/01/2002 Thread safe (D.Salmond)
-! 01/12/2002 Keep compatibility with RTTOV8 (P Brunel)
-!
-! Code Description:
-! Language: Fortran 90.
-! Software Standards: "European Standards for Writing and
-! Documenting Exchangeable Fortran 90 Code".
-! 31/01/2001 More cloud computations. stored in radov (F. Chevallier)
-! Declarations:
-! Modules used:
-!
- Use rttov_const, only : &
- errorstatus_warning ,&
- errorstatus_fatal ,&
- sensor_id_mw ,&
- npolar_return, &
- npolar_compute
-
- Use rttov_types, only : &
- rttov_coef ,&
- profile_type ,&
- transmission_type ,&
- radiance_type
-
- USE MOD_CPARAM, ONLY : &
- ! Imported Scalar Variables with intent (in):
- njpnsat ,& ! Total max sats to be used
- njplev ,& ! No. of pressure levels
- njpnav ,& ! No. of profile variables
- njpnsav ,& ! No. of surface air variables
- njpnssv ,& ! No. of skin variables
- njpncv ,& ! No. of cloud variables
- q_mixratio_to_ppmv ,&
- o3_mixratio_to_ppmv ,&
- coef
-
- Use parkind1, Only : jpim ,jprb
- IMPLICIT NONE
-
-#include "rttov_errorreport.interface"
-#include "rttov_direct.interface"
-
- ! Subroutine arguments
- ! Scalar arguments with intent(in):
- Integer(Kind=jpim) , INTENT(in) :: knpf ! Number of profiles
- Integer(Kind=jpim) , INTENT(in) :: klenpf ! Length of input profile vectors
- Integer(Kind=jpim) , INTENT(in) :: ksat ! Satellite index (see rttvi)
- Integer(Kind=jpim) , INTENT(in) :: knchpf ! Number of output frequencies
- ! (= channels used * profiles)
- LOGICAL, INTENT(in) :: lcloud ! switch for cloud computations
-
- ! Array arguments with intent(in):
- Integer(Kind=jpim) , INTENT(in) :: kchan(knchpf) ! Channel indices
- Integer(Kind=jpim) , INTENT(in) :: kprof(knchpf) ! Profiles indices
- Integer(Kind=jpim) , INTENT(in) :: ksurf(knpf) ! Surface type index
- Real(Kind=jprb) , INTENT(in) :: ppres(njplev) ! Pressure levels (hpa) of
- ! atmospheric profile vectors
-
-
- Real(Kind=jprb) , INTENT(in) :: pangl(knpf) ! Satellite local zenith angle (deg)
- Real(Kind=jprb) , INTENT(in) :: pangs(knpf) ! Solar zenith angle at surface (deg)
- Real(Kind=jprb) , INTENT(in) :: pav(njplev,njpnav,knpf)! Atmosp. profile variables
- Real(Kind=jprb) , INTENT(in) :: psav(njpnsav,knpf) ! Surface air variables
- Real(Kind=jprb) , INTENT(in) :: pssv(njpnssv,knpf) ! Surface skin variables
- Real(Kind=jprb) , INTENT(in) :: pcv(njpncv,knpf) ! Cloud variables
-
- ! Array arguments with intent(inout):
- Real(Kind=jprb) , INTENT(inout) :: pemis(knchpf) ! surface emissivities
-
- ! Scalar arguments with intent(out):
-
- ! Array arguments with intent(out):
- Integer(Kind=jpim) , INTENT(out) :: ifail(knpf,njpnsat) ! return flag
- ! 0 = input profile OK
- ! 11-19 = outside profile limits
- ! 11 = temp profile
- ! 12 = specific humidity profile
- ! 13 = ozone profile
- ! 14 = surface temp profile
- ! 15 = surface specific humidity profile
- ! 16 = surface wind
- ! 20-29 = unphysical profile
- ! 20 = input pressure levels wrong
- ! 21 = temp profile
- ! 22 = specific humidity profile
- ! 23 = ozone profile
- ! 24 = surface temp profile
- ! 25 = surface specific humidity profile
- ! 26 = surface wind
- ! 27 = surface pressure
-
- Real(Kind=jprb) , INTENT(out) :: prad(knchpf) ! radiances (mw/cm-1/ster/sq.m)
- Real(Kind=jprb) , INTENT(out) :: ptb(knchpf) ! brightness temperatures (K)
- Real(Kind=jprb) , INTENT(out) :: rado(knchpf) ! overcast radiance at given
- ! cloud top in mw/m2/sr/cm-1
- Real(Kind=jprb) , INTENT(out) :: radov(knchpf,2*njplev+2)
- ! RT quantities for possible cloud computations outside RTTOV,
- ! in mw/m2/sr/cm-1 :
- ! radov (:,1:njplev) : overcast radiance at given cloud top
- ! radov (:,njplev+1,2*njplev) : contribution to radiance of
- ! downward cloud emission at given cloud top
- ! radov (:,2*njplev+1) : clear-sky radiance without reflection term
- ! radov (:,2*njplev+2) : reflected clear-sky downwelling radiance
-
- Real(Kind=jprb) , INTENT(out) :: tau(knchpf,njplev) ! transmittance from each
- ! standard pressure level
- Real(Kind=jprb) , INTENT(out) :: tausfc(knchpf) ! transmittance from surface
-
-
-
-! Local arrays:
- Real(Kind=jprb) :: panga(knpf) ! Satellite local azimuth angle (deg)
- integer(Kind=jpim) :: nbtout
- integer(Kind=jpim) :: nfrequencies
- Integer(Kind=jpim) :: nchannels
- Integer(Kind=jpim) :: nprofiles
- integer(Kind=jpim), Allocatable :: polarisations (:,:)
- !integer(Kind=jpim), Allocatable :: frequencies (:)
- Integer(Kind=jpim), Allocatable :: channels (:)
- Integer(Kind=jpim), Allocatable :: lprofiles (:)
- Real(Kind=jprb), Allocatable :: emissivity (:)
-
- type( rttov_coef ), pointer :: coef_pointer ! coefficients
- type(profile_type) :: profiles(knpf)
- type(radiance_type) :: radiance
- type(transmission_type) :: transmission
-
- logical, Allocatable :: calcemis (:)
-
- Integer(Kind=jpim) :: errorstatus(knpf)
- Integer(Kind=jpim) :: alloc_status(22)
- Character (len=80) :: errMessage
- Character (len=6) :: NameOfRoutine = 'rttov '
- Integer(Kind=jpim) :: j, jch, pol_id, ibtout, ichannels
- Integer(Kind=jpim) :: i, n, jpol
-!- End of header ------------------------------------------------------
-
- errorstatus(:) = 0
- alloc_status(:) = 0
- ! The terms "constant" and "variable" are employed here in the sense used
- ! in variational analysis, i.e. an input variable is a parameter with
- ! respect to which a gradient will be calculated in the associated
- ! tangent linear (TL) and adjoint (AD) routines.
- !
- coef_pointer => coef(ksat)
-
- If( coef_pointer % id_sensor /= sensor_id_mw) then
- nchannels = knchpf
- nfrequencies = knchpf
- nbtout = knchpf
- nchannels = knchpf
- nprofiles = knpf
- End If
- If( coef_pointer % id_sensor == sensor_id_mw) then
- nfrequencies = knchpf
- nprofiles = knpf
- ichannels = 0
- ibtout = 0
- do j = 1, nfrequencies
- pol_id = coef_pointer % fastem_polar(j) + 1
- ichannels=ichannels+npolar_compute(pol_id)
- ibtout=ibtout+npolar_return(pol_id)
- end do
- nchannels = ichannels
- nbtout = ibtout
- End If
-
- allocate( lprofiles ( nfrequencies ) ,stat= alloc_status(1))
- allocate( channels ( nfrequencies ) ,stat= alloc_status(2))
- allocate( polarisations(nchannels,3) ,stat= alloc_status(3))
- allocate( emissivity ( nchannels ) ,stat= alloc_status(4))
- allocate( calcemis ( nchannels ) ,stat= alloc_status(5))
- If( any(alloc_status /= 0) ) then
- ifail(:,:) = 20
- Write( errMessage, '( "mem allocation 1 error")' )
- Call Rttov_ErrorReport (errorstatus_fatal, errMessage, NameOfRoutine)
- Return
- End If
-
- If( coef_pointer % id_sensor /= sensor_id_mw) then
- lprofiles (:) = kprof(:)
- channels (:) = kchan(:)
- polarisations(:,1) = (/ (i, i=1,knchpf) /)
- polarisations(:,2) = (/ (i, i=1,knchpf) /)
- polarisations(:,3) = 1
- emissivity(:) = pemis(polarisations(:,2))
- End If
-
-
-
- If( coef_pointer % id_sensor == sensor_id_mw) then
- lprofiles (:) = kprof(:)
- channels (:) = kchan(:)
- ichannels = 0
- polarisations(:,:) = 0
- do j = 1, nfrequencies
- jch = kchan(j)
- pol_id = coef_pointer % fastem_polar(jch) + 1
- polarisations(j,1) = ichannels+1
- polarisations(j,3) = npolar_compute(pol_id)
- Do n = ichannels+1, ichannels+npolar_compute(pol_id)
- polarisations(n,2)=j
- End Do
- ichannels=ichannels+npolar_compute(pol_id)
- end do
- emissivity(:) = pemis(polarisations(:,2))
- End If
-
-! write(6,*)' nfreq=',nfrequencies,' nchannels=',nchannels,' nbtout=',nbtout
-! write(6,*)' Channels ',(channels(i),i=1,nfrequencies)
-! write(6,*)(polarisations(i,1),i=1,nchannels)
-! write(6,*)(polarisations(i,2),i=1,nchannels)
-! write(6,*)(polarisations(i,3),i=1,nchannels)
-
- do j = 1, knpf
- ! allocate model profiles atmospheric arrays with model levels dimension
- profiles(j) % nlevels = coef(ksat) % nlevels
- allocate( profiles(j) % p ( coef(ksat) % nlevels ) ,stat= alloc_status(1))
- allocate( profiles(j) % t ( coef(ksat) % nlevels ) ,stat= alloc_status(2))
- allocate( profiles(j) % q ( coef(ksat) % nlevels ) ,stat= alloc_status(3))
- allocate( profiles(j) % o3 ( coef(ksat) % nlevels ) ,stat= alloc_status(4))
- allocate( profiles(j) % clw( coef(ksat) % nlevels ) ,stat= alloc_status(5))
- If( any(alloc_status /= 0) ) then
- ifail(:,:) = 20
- Write( errMessage, '( "mem allocation 2 error")' )
- Call Rttov_ErrorReport (errorstatus_fatal, errMessage, NameOfRoutine)
- Return
- End If
-
- profiles(j) % p (:) = ppres(:)
- profiles(j) % t (:) = pav(:,1,j)
- profiles(j) % q (:) = pav(:,2,j) * q_mixratio_to_ppmv
- profiles(j) % o3 (:) = pav(:,3,j) * o3_mixratio_to_ppmv
- profiles(j) % clw (:) = pav(:,4,j)
- profiles(j) % ozone_data = .true.
- profiles(j) % co2_data = .false.
- profiles(j) % clw_data = profiles(j) % clw(1) > 0.0_JPRB
- profiles(j) % s2m % t = psav(1,j)
- profiles(j) % s2m % q = psav(2,j) * q_mixratio_to_ppmv
- profiles(j) % s2m % p = psav(3,j)
- profiles(j) % s2m % u = psav(4,j)
- profiles(j) % s2m % v = psav(5,j)
- profiles(j) % skin % t = pssv(1,j)
- profiles(j) % skin % fastem = pssv(2:6,j)
- profiles(j) % skin % surftype= ksurf(j)
- profiles(j) % ctp = pcv(1,j)
- profiles(j) % cfraction = pcv(2,j)
- profiles(j) % zenangle = pangl(j)
- profiles(j) % azangle = 0.0_JPRB
- end do
-
- allocate( transmission % tau_surf (nchannels ) ,stat= alloc_status(2))
- allocate( transmission % tau_layer (coef_pointer % nlevels , nchannels ) ,stat= alloc_status(3))
- allocate( transmission % od_singlelayer (coef_pointer % nlevels , nchannels ) ,stat= alloc_status(4))
- ! allocate radiance results arrays with number of channels
- allocate( radiance % clear ( nchannels ) ,stat= alloc_status(5))
- allocate( radiance % cloudy ( nchannels ) ,stat= alloc_status(6))
- allocate( radiance % total ( nchannels ) ,stat= alloc_status(7))
- allocate( radiance % bt ( nchannels ) ,stat= alloc_status(8))
- allocate( radiance % bt_clear ( nchannels ) ,stat= alloc_status(9))
- allocate( radiance % upclear ( nchannels ) ,stat= alloc_status(10))
- allocate( radiance % dnclear ( nchannels ) ,stat= alloc_status(11))
- allocate( radiance % reflclear( nchannels ) ,stat= alloc_status(12))
- allocate( radiance % overcast ( coef_pointer % nlevels, nchannels ) ,stat= alloc_status(13))
- allocate( radiance % downcld ( coef_pointer % nlevels, nchannels ) ,stat= alloc_status(14))
- allocate( radiance % out ( nbtout ) ,stat= alloc_status(15))
- allocate( radiance % out_clear( nbtout ) ,stat= alloc_status(16))
- allocate( radiance % total_out( nbtout ) ,stat= alloc_status(17))
- allocate( radiance % clear_out( nbtout ) ,stat= alloc_status(18))
- If( any(alloc_status /= 0) ) then
- ifail(:,:) = 20
- Write( errMessage, '( "mem allocation 3 error")' )
- Call Rttov_ErrorReport (errorstatus_fatal, errMessage, NameOfRoutine)
- Return
- End If
-
- ! initialise downwelling radiance in case of
- ! "not cloudy" calculation condition
- radiance % downcld(:,:) = 0._JPRB
-
- where ( emissivity(:) < 0.001_JPRB )
- calcemis(:) = .true.
- elsewhere
- calcemis(:) = .false.
- endwhere
-
-
- call rttov_direct( &
- errorstatus, & ! out
- nfrequencies, & ! in
- nchannels, & ! in
- nbtout, & ! in
- nprofiles, & ! in
- channels, & ! in
- polarisations,& ! in
- lprofiles, & ! in
- profiles, & ! in
- coef_pointer, & ! in
- lcloud, & ! in
- calcemis, & ! in
- emissivity, & ! inout
- transmission, & ! out
- radiance ) ! inout
-
- do j = 1, knpf
- If( errorstatus(j) == errorstatus_fatal ) then
- ifail(j,:) = 20 ! unphysical profile
- Else If( errorstatus(j) == errorstatus_warning ) then
- ifail(j,:) = 11 ! outside profile limits
- Else
- ifail(j,:) = 0
- End If
- End Do
-
- !
- prad(:) = radiance % total_out(:) ! radiance
- ptb(:) = radiance % out(:) ! BT
-
- do j = 1 , nchannels
- jpol = polarisations(j,2)
- pemis(jpol) = emissivity(j)
- tausfc(jpol) = transmission % tau_surf(j)
- rado(jpol) = radiance % cloudy(j)
- radov(jpol,2*njplev+1) = radiance % upclear (j)
- radov(jpol,2*njplev+2) = radiance % reflclear(j)
-
- tau(jpol,:) = transmission % tau_layer(:,j)
- radov(jpol,1:njplev) = radiance % overcast (:,j)
- radov(jpol,njplev+1:2*njplev) = radiance % downcld (:,j)
-
- enddo
-
-
- do j = 1, knpf
- deallocate( profiles(j) % p ,stat= alloc_status(1))
- deallocate( profiles(j) % t ,stat= alloc_status(2))
- deallocate( profiles(j) % q ,stat= alloc_status(3))
- deallocate( profiles(j) % o3 ,stat= alloc_status(4))
- deallocate( profiles(j) % clw,stat= alloc_status(5))
- If( any(alloc_status /= 0) ) then
- ifail(:,:) = 20
- Write( errMessage, '( "mem deallocation error")' )
- Call Rttov_ErrorReport (errorstatus_fatal, errMessage, NameOfRoutine)
- Return
- End If
- end do
-
- deallocate( lprofiles ,stat= alloc_status(1))
- deallocate( channels ,stat= alloc_status(2))
- deallocate( polarisations ,stat= alloc_status(3))
- deallocate( emissivity ,stat= alloc_status(4))
- deallocate( calcemis ,stat= alloc_status(5))
-
- deallocate( transmission % tau_surf ,stat= alloc_status(6))
- deallocate( transmission % tau_layer ,stat= alloc_status(7))
- deallocate( transmission % od_singlelayer ,stat= alloc_status(8))
- deallocate( radiance % clear ,stat= alloc_status(9))
- deallocate( radiance % cloudy ,stat= alloc_status(10))
- deallocate( radiance % total ,stat= alloc_status(11))
- deallocate( radiance % bt ,stat= alloc_status(12))
- deallocate( radiance % bt_clear ,stat= alloc_status(13))
- deallocate( radiance % upclear ,stat= alloc_status(14))
- deallocate( radiance % dnclear ,stat= alloc_status(15))
- deallocate( radiance % reflclear,stat= alloc_status(16))
- deallocate( radiance % overcast ,stat= alloc_status(17))
- deallocate( radiance % downcld ,stat= alloc_status(18))
- deallocate( radiance % out ,stat= alloc_status(19))
- deallocate( radiance % out_clear,stat= alloc_status(20))
- deallocate( radiance % total_out,stat= alloc_status(21))
- deallocate( radiance % clear_out,stat= alloc_status(22))
- If( any(alloc_status /= 0) ) then
- ifail(:,:) = 20
- Write( errMessage, '( "mem deallocation error")' )
- Call Rttov_ErrorReport (errorstatus_fatal, errMessage, NameOfRoutine)
- Return
- End If
-
- RETURN
-
-
-END SUBROUTINE RTTOV
diff --git a/src/LIB/RTTOV/src/rttov.interface b/src/LIB/RTTOV/src/rttov.interface
deleted file mode 100644
index c7087629c38d11f08a19ad53bf0aab6eb8e99340..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov.interface
+++ /dev/null
@@ -1,146 +0,0 @@
-Interface
-!+ Fast radiative transfer model.
-!
-SUBROUTINE RTTOV &
- (knpf, klenpf, ppres, pangl, pangs, ksurf, ksat, knchpf, &
- kchan, kprof, pav, psav, pssv, pcv, pemis, ifail, prad, ptb, radov, &
- rado, tau, tausfc, lcloud)
-!
-! This software was developed within the context of
-! the EUMETSAT Satellite Application Facility on
-! Numerical Weather Prediction (NWP SAF), under the
-! Cooperation Agreement dated 25 November 1998, between
-! EUMETSAT and the Met Office, UK, by one or more partners
-! within the NWP SAF. The partners in the NWP SAF are
-! the Met Office, ECMWF, KNMI and MeteoFrance.
-!
-! Copyright 2002, EUMETSAT, All Rights Reserved.
-!
-! Description:
-! to compute multi-channel level to space transmittances,
-! top of atmosphere radiances and brightness
-! temperatures for many profiles and Ir/Mw sensors.
-! Compatible with RTTOV8 library but only able to
-! run with coefficients created on RTTOV7 43 pressure levels
-!
-! Method
-! see Matricardi et al QJ 2002
-! see Saunders et al QJ 1999
-! see: ECMWF Technical Memoranda 176/282/345 (Available from ECMWF)
-!
-! Current Code Owner: SAF NWP
-!
-! History:
-! Version Date Comment
-! ------- ---- -------
-! 13/8/92. For version 2.
-! ksat added to argument list; ssu included;
-! internal changes to move big arrays from commons to
-! arguments and to introduce taskcommons
-! 8/7/97 added ozone and extended water vapour in control vector
-! 01/05/2000 F90 code
-! 21/08/2000 Interface to rtint changed to include pref (surface reflectivity).
-! (Stephen English)
-! 31/01/2001 More cloud computations. stored in radov (F. Chevallier)
-! 6/2/2001 pgrody and knav etc arrays removed from call (R Saunders)
-! 18/01/2002 Thread safe (D.Salmond)
-! 01/12/2002 Keep compatibility with RTTOV8 (P Brunel)
-!
-! Code Description:
-! Language: Fortran 90.
-! Software Standards: "European Standards for Writing and
-! Documenting Exchangeable Fortran 90 Code".
-! 31/01/2001 More cloud computations. stored in radov (F. Chevallier)
-! Declarations:
-! Modules used:
-!
-
- Use rttov_types, only : &
- rttov_coef ,&
- profile_type ,&
- transmission_type ,&
- radiance_type
-
- USE MOD_CPARAM, ONLY : &
- ! Imported Scalar Variables with intent (in):
- njpnsat ,& ! Total max sats to be used
- njplev ,& ! No. of pressure levels
- njpnav ,& ! No. of profile variables
- njpnsav ,& ! No. of surface air variables
- njpnssv ,& ! No. of skin variables
- njpncv ! No. of cloud variables
- !
- Use parkind1, Only : jpim ,jprb
- IMPLICIT NONE
-
- ! Subroutine arguments
- ! Scalar arguments with intent(in):
- Integer(Kind=jpim) , INTENT(in) :: knpf ! Number of profiles
- Integer(Kind=jpim) , INTENT(in) :: klenpf ! Length of input profile vectors
- Integer(Kind=jpim) , INTENT(in) :: ksat ! Satellite index (see rttvi)
- Integer(Kind=jpim) , INTENT(in) :: knchpf ! Number of output frequencies
- ! (= channels used * profiles)
- LOGICAL, INTENT(in) :: lcloud ! switch for cloud computations
-
- ! Array arguments with intent(in):
- Integer(Kind=jpim) , INTENT(in) :: kchan(knchpf) ! Channel indices
- Integer(Kind=jpim) , INTENT(in) :: kprof(knchpf) ! Profiles indices
- Integer(Kind=jpim) , INTENT(in) :: ksurf(knpf) ! Surface type index
- Real(Kind=jprb) , INTENT(in) :: ppres(njplev) ! Pressure levels (hpa) of
- ! atmospheric profile vectors
-
-
- Real(Kind=jprb) , INTENT(in) :: pangl(knpf) ! Satellite local zenith angle (deg)
- Real(Kind=jprb) , INTENT(in) :: pangs(knpf) ! Solar zenith angle at surface (deg)
- Real(Kind=jprb) , INTENT(in) :: pav(njplev,njpnav,knpf)! Atmosp. profile variables
- Real(Kind=jprb) , INTENT(in) :: psav(njpnsav,knpf) ! Surface air variables
- Real(Kind=jprb) , INTENT(in) :: pssv(njpnssv,knpf) ! Surface skin variables
- Real(Kind=jprb) , INTENT(in) :: pcv(njpncv,knpf) ! Cloud variables
-
- ! Array arguments with intent(inout):
- Real(Kind=jprb) , INTENT(inout) :: pemis(knchpf) ! surface emissivities
-
- ! Scalar arguments with intent(out):
-
- ! Array arguments with intent(out):
- Integer(Kind=jpim) , INTENT(out) :: ifail(knpf,njpnsat) ! return flag
- ! 0 = input profile OK
- ! 11-19 = outside profile limits
- ! 11 = temp profile
- ! 12 = specific humidity profile
- ! 13 = ozone profile
- ! 14 = surface temp profile
- ! 15 = surface specific humidity profile
- ! 16 = surface wind
- ! 20-29 = unphysical profile
- ! 20 = input pressure levels wrong
- ! 21 = temp profile
- ! 22 = specific humidity profile
- ! 23 = ozone profile
- ! 24 = surface temp profile
- ! 25 = surface specific humidity profile
- ! 26 = surface wind
- ! 27 = surface pressure
-
- Real(Kind=jprb) , INTENT(out) :: prad(knchpf) ! radiances (mw/cm-1/ster/sq.m)
- Real(Kind=jprb) , INTENT(out) :: ptb(knchpf) ! brightness temperatures (K)
- Real(Kind=jprb) , INTENT(out) :: rado(knchpf) ! overcast radiance at given
- ! cloud top in mw/m2/sr/cm-1
- Real(Kind=jprb) , INTENT(out) :: radov(knchpf,2*njplev+2)
- ! RT quantities for possible cloud computations outside RTTOV,
- ! in mw/m2/sr/cm-1 :
- ! radov (:,1:njplev) : overcast radiance at given cloud top
- ! radov (:,njplev+1,2*njplev) : contribution to radiance of
- ! downward cloud emission at given cloud top
- ! radov (:,2*njplev+1) : clear-sky radiance without reflection term
- ! radov (:,2*njplev+2) : reflected clear-sky downwelling radiance
-
- Real(Kind=jprb) , INTENT(out) :: tau(knchpf,njplev) ! transmittance from each
- ! standard pressure level
- Real(Kind=jprb) , INTENT(out) :: tausfc(knchpf) ! transmittance from surface
-
-
-
-
-END SUBROUTINE RTTOV
-End Interface
diff --git a/src/LIB/RTTOV/src/rttov_ad.F90 b/src/LIB/RTTOV/src/rttov_ad.F90
deleted file mode 100644
index c5b89a0c23d29dc4b070a2e08323759e4a544b84..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_ad.F90
+++ /dev/null
@@ -1,649 +0,0 @@
-Subroutine rttov_ad( &
- & errorstatus, &! out
- & nfrequencies, &! in
- & nchannels, &! in
- & nbtout, &! in
- & nprofiles, &! in
- & channels, &! in
- & polarisations, &! in
- & lprofiles, &! in
- & profiles, &! in
- & coef, &! in
- & addcloud, &! in
- & switchrad, &! in
- & calcemis, &! in
- & emissivity, &! inout direct model
- & profiles_ad, &! inout adjoint
- & emissivity_ad, &! inout adjoint
- & transmission, &! inout direct model
- & transmission_ad, &! inout adjoint input
- & radiancedata, &! inout direct model (input due to pointers alloc)
- & radiancedata_ad ) ! inout adjoint input (output if converstion Bt -> rad)
- !
- ! Description:
- ! Adjoint of rttov_direct
- ! to compute multi-channel level to space transmittances,
- ! top of atmosphere and level to space radiances and brightness
- ! temperatures and optionally surface emissivities, for many
- ! profiles in a single call, for satellite
- ! infrared or microwave sensors. The code requires a coefficient file
- ! for each sensor for which simulated radiances are requested.
- !
- ! Note that radiancedata_ad can be used for all its structure elements
- ! In normal case the element total or bt is the only one initialised but
- ! for some particular cases like for rttov_cld_ad some other elements
- ! have been already init.
- ! According to the argument switchrad the main input total or bt is used
- ! switchrad == true bt is the input, brightness temperature
- ! switchrad == false total is the input, radiance
- !
- ! The AD outputs profiles_ad and emissivity_ad should be allocated and
- ! initialised before calling the subroutine
- !
- ! Copyright:
- ! This software was developed within the context of
- ! the EUMETSAT Satellite Application Facility on
- ! Numerical Weather Prediction (NWP SAF), under the
- ! Cooperation Agreement dated 25 November 1998, between
- ! EUMETSAT and the Met Office, UK, by one or more partners
- ! within the NWP SAF. The partners in the NWP SAF are
- ! the Met Office, ECMWF, KNMI and MeteoFrance.
- !
- ! Copyright 2002, EUMETSAT, All Rights Reserved.
- !
- ! Method: The methodology is described in the following:
- !
- ! Eyre J.R. and H.M. Woolf 1988 Transmittance of atmospheric gases
- ! in the microwave region: a fast model. Applied Optics 27 3244-3249
- !
- ! Eyre J.R. 1991 A fast radiative transfer model for satellite sounding
- ! systems. ECMWF Research Dept. Tech. Memo. 176 (available from the
- ! librarian at ECMWF).
- !
- ! Saunders R.W., M. Matricardi and P. Brunel 1999 An Improved Fast Radiative
- ! Transfer Model for Assimilation of Satellite Radiance Observations.
- ! QJRMS, 125, 1407-1425.
- !
- ! Matricardi, M., F. Chevallier and S. Tjemkes 2001 An improved general
- ! fast radiative transfer model for the assimilation of radiance
- ! observations. ECMWF Research Dept. Tech. Memo. 345
- ! (available from the librarian at ECMWF).
- !
- ! Current Code Owner: SAF NWP
- !
- ! History:
- ! Version Date Comment
- ! ------- ---- -------
- ! 1.1 01/12/2002 New F90 code with structures (P Brunel A Smith)
- ! 1.2 02/01/2003 More comments added (R Saunders)
- ! 1.3 24/01/2003 Error return code by input profile (P Brunel)
- ! 1.4 Add WV Continuum and CO2 capability
- ! 1.5 04/12/2003 Optimisation (J Hague and D Salmond ECMWF)
- ! 1.6 02/06/2004 Change tests on id_comp_lvl == 7 by tests on fmv_model_ver (P. Brunel)
- !
- ! Code Description:
- ! Language: Fortran 90.
- ! Software Standards: "European Standards for Writing and
- ! Documenting Exchangeable Fortran 90 Code".
- ! A user guide and technical documentation is available at
- ! http://www.metoffice.com/research/interproj/nwpsaf/rtm/index.html
- !
- ! Declarations:
- ! Modules used:
- ! Imported Parameters:
- Use rttov_const, Only : &
- & errorstatus_success ,&
- & errorstatus_warning ,&
- & errorstatus_fatal ,&
- & max_optical_depth ,&
- & sensor_id_mw ,&
- & sensor_id_ir
-
- ! Imported Type Definitions:
- Use rttov_types, Only : &
- & rttov_coef ,&
- & profile_Type ,&
- & geometry_Type ,&
- & predictors_Type,&
- & profile_aux ,&
- & transmission_Type ,&
- & radiance_Type ,&
- & radiance_aux
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
-#include "rttov_checkinput.interface"
-#include "rttov_errorreport.interface"
-#include "rttov_profaux.interface"
-#include "rttov_setgeometry.interface"
-#include "rttov_setpredictors.interface"
-#include "rttov_setpredictors_8.interface"
-#include "rttov_transmit.interface"
-#include "rttov_calcemis_ir.interface"
-#include "rttov_calcemis_mw.interface"
-#include "rttov_integrate.interface"
-#include "rttov_profaux_ad.interface"
-#include "rttov_setpredictors_ad.interface"
-#include "rttov_setpredictors_8_ad.interface"
-#include "rttov_transmit_ad.interface"
-#include "rttov_calcemis_mw_ad.interface"
-#include "rttov_integrate_ad.interface"
-
- !subroutine arguments:
- Integer(Kind=jpim), Intent(in) :: nfrequencies
- Integer(Kind=jpim), Intent(in) :: nchannels
- Integer(Kind=jpim), Intent(in) :: nbtout
- Integer(Kind=jpim), Intent(in) :: nprofiles
- Integer(Kind=jpim), Intent(in) :: channels(nfrequencies)
- Integer(Kind=jpim), Intent(in) :: polarisations(nchannels,3)
- Integer(Kind=jpim), Intent(in) :: lprofiles(nfrequencies)
- Logical, Intent(in) :: addcloud
- Logical, Intent(in) :: switchrad ! true if input is BT
- Type(profile_Type), Intent(in) :: profiles(nprofiles)
- Type(rttov_coef), Intent(in) :: coef
- Logical, Intent(in) :: calcemis(nchannels)
- Integer(Kind=jpim), Intent(out) :: errorstatus(nprofiles)
- Real(Kind=jprb), Intent(inout) :: emissivity(nchannels)
- Type(transmission_Type), Intent(inout) :: transmission! in because of meme allocation
- Type(radiance_Type), Intent(inout) :: radiancedata! in because of meme allocation
-
-
- Type(profile_Type), Intent(inout) :: profiles_ad(nprofiles)
- Real(Kind=jprb), Intent(inout) :: emissivity_ad(nchannels)
- Type(transmission_Type), Intent(inout) :: transmission_ad ! in because of meme allocation
- Type(radiance_Type), Intent(inout) :: radiancedata_ad ! in because of meme allocation
-
- !local variables:
- Integer(Kind=jpim) :: i ! loop index
- Logical :: addcosmic ! switch for adding temp of cosmic background
- Real(Kind=jprb) :: reflectivity(nchannels) ! surface reflectivity
- Real(Kind=jprb) :: reflectivity_ad(nchannels) ! AD surface reflectivity
- Real(Kind=jprb) :: od_layer(coef%nlevels,nchannels) ! layer optical depth
- Real(Kind=jprb) :: opdp_ref(coef%nlevels,nfrequencies) ! layer optical depth before threshold
-
- Character (len=80) :: errMessage
- Character (len=8) :: NameOfRoutine = 'rttov_ad'
-
- Type(geometry_Type) :: angles(nprofiles) ! geometry angles
- Type(predictors_Type) :: predictors(nprofiles) ! predictors
- Type(profile_aux) :: aux_prof(nprofiles) ! auxillary profiles informations
-
- Type(predictors_Type) :: predictors_ad(nprofiles) ! AD of above predictors
- Type(profile_aux) :: aux_prof_ad(nprofiles) ! AD of above aux_prof
- Type(radiance_aux) :: auxrad
-
- Real(Kind=jprb), target :: zdeb (5,coef%nlevels,nprofiles)
- Real(Kind=jprb), target :: zdeb_ad(5,coef%nlevels,nprofiles)
- Real(Kind=jprb), target :: zmixed (coef%nmixed,coef%nlevels,nprofiles)
- Real(Kind=jprb), target :: zmixed_ad(coef%nmixed,coef%nlevels,nprofiles)
- Real(Kind=jprb), target :: zwater (coef%nwater,coef%nlevels,nprofiles)
- Real(Kind=jprb), target :: zwater_ad(coef%nwater,coef%nlevels,nprofiles)
- Real(Kind=jprb), target :: zlev (coef%nlevels,nprofiles)
- Real(Kind=jprb), target :: zlev_ad(coef%nlevels,nprofiles)
- Real(Kind=jprb), target :: zozone (coef%nozone,coef%nlevels,nprofiles)
- Real(Kind=jprb), target :: zozone_ad(coef%nozone,coef%nlevels,nprofiles)
- Real(Kind=jprb), target :: zwvcont (coef%nwvcont,coef%nlevels,nprofiles)
- Real(Kind=jprb), target :: zwvcont_ad(coef%nwvcont,coef%nlevels,nprofiles)
- Real(Kind=jprb), target :: zc02 (coef%nco2,coef%nlevels,nprofiles)
- Real(Kind=jprb), target :: zc02_ad(coef%nco2,coef%nlevels,nprofiles)
-
- Real(Kind=jprb), target :: layer(coef%nlevels,nchannels)
- Real(Kind=jprb), target :: surfair(nchannels)
- Real(Kind=jprb), target :: skin(nchannels)
- Real(Kind=jprb), target :: cosmic(nchannels)
- Real(Kind=jprb), target :: up(coef%nlevels,nchannels)
- Real(Kind=jprb), target :: down(coef%nlevels,nchannels)
- Real(Kind=jprb), target :: down_cloud(coef%nlevels,nchannels)
-
- Integer(Kind=jpim) :: jn
-
- !- End of header --------------------------------------------------------
-
- !-------------
- !0. initialize
- !-------------
-
- errorstatus(:) = errorstatus_success
-
- !------------------------------------------------------
- !1. check input data is within suitable physical limits
- !------------------------------------------------------
- Do i = 1, nprofiles
-
- Call rttov_checkinput( &
- & profiles( i ), &!in
- & coef, &!in
- & errorstatus(i) ) !out
-
- End Do
-
- ! 1.1 test check input return code
- !-----------------------------_---
- If ( any( errorstatus(:) == errorstatus_warning ) ) Then
- Do i = 1, nprofiles
- If ( errorstatus(i) == errorstatus_warning ) Then
- Write( errMessage, '( "checkinput warning error for profile",i4)' ) i
- Call Rttov_ErrorReport (errorstatus_warning, errMessage, NameOfRoutine)
- End If
- End Do
- End If
-
- If ( any( errorstatus(:) == errorstatus_fatal ) ) Then
- Do i = 1, nprofiles
- If ( errorstatus(i) == errorstatus_fatal ) Then
- ! Some unphysical values; Do not run RTTOV
- Write( errMessage, '( "checkinput fatal error for profile",i4)' ) i
- Call Rttov_ErrorReport (errorstatus_fatal, errMessage, NameOfRoutine)
- End If
- End Do
- ! nothing processed so all profiles get the fatal error code
- ! user will know which profile
- errorstatus(:) = errorstatus_fatal
- Return
- End If
-
-
- !-----------------------------------------
- !2. determine cloud top and surface levels
- !-----------------------------------------
- If( coef % id_sensor == sensor_id_mw ) Then
- jn=coef%nlevels
- Do i = 1, nprofiles
- aux_prof(i) % debye_prof => zdeb(1:5,1:jn,i)
- End Do
- Endif
- Do i = 1, nprofiles
- Call rttov_profaux( &
- & profiles(i), &! in
- & coef, &! in
- & aux_prof(i)) ! inout
- End Do
-
-
- !------------------------------------------------------------------
- !3. set up common geometric variables for transmittance calculation
- !------------------------------------------------------------------
-
- Do i = 1, nprofiles
- Call rttov_setgeometry( &
- & profiles(i), &! in
- & coef, &! in
- & angles(i) ) ! out
- End Do
-
- !------------------------------------------
- !5. calculate transmittance path predictors
- !------------------------------------------
-
- jn=coef%nlevels
- Do i = 1, nprofiles
- predictors(i) % nlevels = coef % nlevels
- predictors(i) % nmixed = coef % nmixed
- predictors(i) % nwater = coef % nwater
- predictors(i) % nozone = coef % nozone
- predictors(i) % nwvcont = coef % nwvcont
- predictors(i) % nco2 = coef % nco2
- predictors(i) % ncloud = 0 ! (can be set to 1 inside setpredictors)
-
- predictors(i) % mixedgas => zmixed(1:coef%nmixed, 1:jn, i)
- predictors(i) % watervapour => zwater(1:coef%nwater, 1:jn, i)
- predictors(i) % clw => zlev(1:jn, i)
- If( coef%nozone > 0 ) Then
- predictors(i) % ozone => zozone(1:coef%nozone, 1:jn, i)
- End If
- If( coef%nwvcont > 0 ) Then
- predictors(i) % wvcont => zwvcont(1:coef%nwvcont, 1:jn, i)
- End If
- If( coef%nco2 > 0 ) Then
- predictors(i) % co2 => zc02(1:coef%nco2, 1:jn, i)
- End If
-
- End Do ! Profile loop
-
- Do i = 1, nprofiles
- If (coef%fmv_model_ver == 7) Then
- Call rttov_setpredictors( &
- & profiles(i), &! in
- & angles(i), &! in
- & coef, &! in
- & predictors(i) ) ! inout (in because of mem allocation)
-
- Else If (coef%fmv_model_ver == 8) Then
- Call rttov_setpredictors_8( &
- & profiles(i), &! in
- & angles(i), &! in
- & coef, &! in
- & predictors(i) ) ! inout (in because of mem allocation)
-
- Else
- errorstatus(:) = errorstatus_fatal
- Write( errMessage,&
- & '( "Unexpected RTTOV compatibility version number" )' )
- Call Rttov_ErrorReport (errorstatus_fatal, errMessage, NameOfRoutine)
- Return
- End If
-
- End Do ! Profile loop
-
- !----------------------------------------------
- !6. calculate optical depths and transmittances
- !----------------------------------------------
-
- Call rttov_transmit( &
- & nfrequencies, &! in
- & nchannels, &! in
- & nprofiles, &! in
- & coef%nlevels, &! in
- & channels, &! in
- & polarisations, &! in
- & lprofiles, &! in
- & predictors, &! in
- & aux_prof, &! in
- & coef, &! in
- & transmission, &! inout
- & od_layer, &! out
- & opdp_ref) ! out
-
- !--------------------------------------
- !7. calculate channel emissivity values
- !--------------------------------------
-
- If ( Any(calcemis) ) Then
- ! calculate surface emissivity for selected channels
- ! and reflectivity
- If ( coef % id_sensor == sensor_id_ir ) Then
- !Infrared
- Call rttov_calcemis_ir( &
- & profiles, &! in
- & angles, &! in
- & coef, &! in
- & nfrequencies, &! in
- & nprofiles, &! in
- & channels, &! in
- & lprofiles, &! in
- & calcemis, &! in
- & emissivity ) ! inout
- reflectivity(:) = 1 - emissivity(:)
-
- Elseif ( coef % id_sensor == sensor_id_mw ) Then
- !Microwave
- Call rttov_calcemis_mw ( &
- & profiles, &! in
- & angles, &! in
- & coef, &! in
- & nfrequencies, &! in
- & nchannels, &! in
- & nprofiles, &! in
- & channels, &! in
- & polarisations, &! in
- & lprofiles, &! in
- & transmission, &! in
- & calcemis, &! in
- & emissivity, &! inout
- & reflectivity, &! out
- & errorstatus ) ! out
- If ( Any( errorstatus == errorstatus_fatal ) ) Then
- errorstatus(:) = errorstatus_fatal
- Return
- End If
- Else
- ! Hires
- Call rttov_calcemis_ir( &
- & profiles, &! in
- & angles, &! in
- & coef, &! in
- & nfrequencies, &! in
- & nprofiles, &! in
- & channels, &! in
- & lprofiles, &! in
- & calcemis, &! in
- & emissivity ) ! inout
- reflectivity(:) = 1 - emissivity(:)
- End If
-
- ! reflectivity for other channels
- Where( .Not. calcemis(:) )
- reflectivity(:) = 1 - emissivity(:)
- End Where
-
- Else
- ! reflectivity for all channels
- reflectivity(:) = 1 - emissivity(:)
- End If
-
-
- !--------------------------------------------
- !8. integrate the radiative transfer equation
- !--------------------------------------------
-
- auxrad % layer => layer(:,:)
- auxrad % surfair => surfair(:)
- auxrad % skin => skin(:)
- auxrad % cosmic => cosmic(:)
- auxrad % up => up(:,:)
- auxrad % down => down(:,:)
- If ( addcloud ) then
- auxrad % down_cloud => down_cloud(:,:)
- End If
-
- addcosmic = ( coef % id_sensor == sensor_id_mw )
- Call rttov_integrate( &
- & addcloud, &! in
- & addcosmic, &! in
- & nfrequencies, &! in
- & nchannels, &! in
- & nbtout, &! in
- & nprofiles, &! in
- & angles, &! in
- & channels, &! in
- & polarisations, &! in
- & lprofiles, &! in
- & emissivity, &! in
- & reflectivity, &! in
- & transmission, &! in
- & profiles, &! in
- & aux_prof, &! in
- & coef, &! in
- & radiancedata, &! inout
- & auxrad ) ! inout
-
-
- ! Adjoint
- !----------------
-
- !
- ! allocate memory for intermediate variables
- jn=coef%nlevels
- Do i = 1, nprofiles
- aux_prof_ad(i) % nearestlev_surf = 0 ! no meaning
- aux_prof_ad(i) % pfraction_surf = 0._JPRB ! calculated
- aux_prof_ad(i) % nearestlev_ctp = 0 ! no meaning
- aux_prof_ad(i) % pfraction_ctp = 0._JPRB ! calculated
- aux_prof_ad(i) % cfraction = 0._JPRB ! calculated
- If( coef % id_sensor == sensor_id_mw ) Then
- aux_prof_ad(i) % debye_prof => zdeb_ad(1:5,1:jn,i)
- Endif
- End Do
-
- Do i = 1, nprofiles
- If( coef % id_sensor == sensor_id_mw ) Then
- aux_prof_ad(i) % debye_prof(:,:) = 0._JPRB
- Endif
- End Do
-
-
- jn=coef%nlevels
- Do i = 1, nprofiles
- predictors_ad(i) % mixedgas => zmixed_ad(1:coef%nmixed, 1:jn, i)
- predictors_ad(i) % watervapour => zwater_ad(1:coef%nwater, 1:jn, i)
- predictors_ad(i) % clw => zlev_ad(1:jn, i)
-
- predictors_ad(i) % nlevels = predictors(i) % nlevels
- predictors_ad(i) % nmixed = predictors(i) % nmixed
- predictors_ad(i) % nwater = predictors(i) % nwater
- predictors_ad(i) % nozone = predictors(i) % nozone
- predictors_ad(i) % nwvcont = predictors(i) % nwvcont
- predictors_ad(i) % nco2 = predictors(i) % nco2
- predictors_ad(i) % ncloud = predictors(i) % ncloud
-
- If( predictors_ad(i) % nozone > 0 ) Then
- predictors_ad(i) % ozone => zozone_ad(1:coef%nozone, 1:jn, i)
- End If
-
- If( predictors_ad(i) % nwvcont > 0 ) Then
- predictors_ad(i) % wvcont => zwvcont_ad(1:coef%nwvcont, 1:jn, i)
- End If
-
- If( predictors_ad(i) % nco2 > 0 ) Then
- predictors_ad(i) % co2 => zc02_ad(1:coef%nco2, 1:jn, i)
- End If
- End Do
-
-
- Do i = 1, nprofiles
- predictors_ad(i) % mixedgas(:,:) = 0._JPRB
- predictors_ad(i) % watervapour(:,:) = 0._JPRB
- predictors_ad(i) % clw(:) = 0._JPRB
- If( predictors_ad(i) % nozone > 0 ) Then
- predictors_ad(i) % ozone(:,:) = 0._JPRB
- End If
- If( predictors_ad(i) % nwvcont > 0 ) Then
- predictors_ad(i) % wvcont(:,:) = 0._JPRB
- End If
- If( predictors_ad(i) % nco2 > 0 ) Then
- predictors_ad(i) % co2(:,:) = 0._JPRB
- End If
- End Do
-
- ! emissivity_ad is init before calling
- reflectivity_ad(:) = 0._JPRB
-
- !--------------------------------------------
- !8. integrate the radiative transfer equation
- !--------------------------------------------
-
- addcosmic = ( coef % id_sensor == sensor_id_mw )
- Call rttov_integrate_ad( &
- & addcloud, &! in
- & addcosmic, &! in
- & switchrad, &! in
- & nfrequencies, &! in
- & nchannels, &! in
- & nbtout, &! in
- & nprofiles, &! in
- & angles, &! in
- & channels, &! in
- & polarisations, &! in
- & lprofiles, &! in
- & emissivity, &! in
- & emissivity_ad, &! inout
- & reflectivity, &! in
- & reflectivity_ad, &! inout
- & transmission, &! in
- & transmission_ad, &! inout
- & profiles, &! in
- & profiles_ad, &! inout (input only due to mem alloc)
- & aux_prof, &! in
- & aux_prof_ad, &! inout
- & coef, &! in
- & radiancedata, &! in
- & auxrad , &! in
- & radiancedata_ad ) ! inout (output if converstion Bt -> rad)
-
- If ( Any(calcemis) ) Then
- ! calculate surface emissivity for selected channels
- ! and reflectivity
- If ( coef % id_sensor == sensor_id_ir ) Then
- !Infrared
- emissivity_ad(:) = -reflectivity_ad(:) + emissivity_ad(:)
-
- Elseif ( coef % id_sensor == sensor_id_mw ) Then
- !Microwave
- Call rttov_calcemis_mw_ad ( &
- & profiles, &! in
- & profiles_ad, &! inout
- & angles, &! in
- & coef, &! in
- & nfrequencies, &! in
- & nchannels, &! in
- & nprofiles, &! in
- & channels, &! in
- & polarisations, &! in
- & lprofiles, &! in
- & transmission, &! in
- & transmission_ad, &! inout
- & calcemis, &! in
- & emissivity_ad, &! inout
- & reflectivity_ad ) ! inout
- Else
- ! Hires
- emissivity_ad(:) = -reflectivity_ad(:) + emissivity_ad(:)
- End If
-
- ! reflectivity for other channels
- Where( .Not. calcemis(:) )
- emissivity_ad(:) = -reflectivity_ad(:) + emissivity_ad(:)
- End Where
-
- Else
- ! reflectivity for all channels
- emissivity_ad(:) = -reflectivity_ad(:) + emissivity_ad(:)
- End If
-
- !AD of optical depths and transmittances
-
- Call rttov_transmit_ad( &
- & nfrequencies, &! in
- & nchannels, &! in
- & nprofiles, &! in
- & coef%nlevels, &! in
- & channels, &! in
- & polarisations, &! in
- & lprofiles, &! in
- & predictors, &! in
- & predictors_ad, &! inout
- & aux_prof, &! in
- & aux_prof_ad, &! inout
- & coef, &! in
- & od_layer, &! in
- & opdp_ref, &! in
- & transmission, &! in
- & transmission_ad ) ! inout
-
- ! AD of Predictors RTTOV-7 RTTOV-8
- If (coef%fmv_model_ver == 7) Then
- Do i = 1, nprofiles
- Call rttov_setpredictors_ad( &
- & profiles(i), &! in
- & profiles_ad(i), &! inout
- & angles(i), &! in
- & coef, &! in
- & predictors(i), &! in
- & predictors_ad(i) ) ! in
- End Do
- Else If (coef%fmv_model_ver == 8) Then
- Do i = 1, nprofiles
- Call rttov_setpredictors_8_ad( &
- & profiles(i), &! in
- & profiles_ad(i), &! inout
- & angles(i), &! in
- & coef, &! in
- & predictors(i), &! in
- & predictors_ad(i) ) ! in
- End Do
- End If
-
- ! No AD on geometry
-
- Do i = 1, nprofiles
- Call rttov_profaux_ad( &
- & profiles(i), &! in
- & profiles_ad(i), &! inout
- & coef, &! in
- & aux_prof(i), &! in
- & aux_prof_ad(i)) ! inout
- End Do
-
-
-End Subroutine rttov_ad
diff --git a/src/LIB/RTTOV/src/rttov_ad.interface b/src/LIB/RTTOV/src/rttov_ad.interface
deleted file mode 100644
index 819a66e5da1eef45c0acd2a477a849d0c21ae8bb..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_ad.interface
+++ /dev/null
@@ -1,70 +0,0 @@
-Interface
-!
-Subroutine rttov_ad( &
- errorstatus, & ! out
- nfrequencies, & ! in
- nchannels, & ! in
- nbtout, & ! in
- nprofiles, & ! in
- channels, & ! in
- polarisations, & ! in
- lprofiles, & ! in
- profiles, & ! in
- coef, & ! in
- addcloud, & ! in
- switchrad, & ! in
- calcemis, & ! in
- emissivity, & ! inout direct model
- profiles_ad, & ! inout adjoint
- emissivity_ad, & ! inout adjoint
- transmission, & ! inout direct model
- transmission_ad,& ! inout adjoint input
- radiancedata, & ! inout direct model (input due to pointers alloc)
- radiancedata_ad ) ! inout adjoint input (output if converstion Bt -> rad)
- Use rttov_const, Only : &
- errorstatus_success ,&
- errorstatus_warning ,&
- errorstatus_fatal ,&
- max_optical_depth ,&
- sensor_id_mw ,&
- sensor_id_ir
-
- Use rttov_types, Only : &
- rttov_coef ,&
- profile_Type ,&
- geometry_Type ,&
- predictors_Type,&
- profile_aux ,&
- transmission_Type ,&
- radiance_Type ,&
- radiance_aux
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
- Integer(Kind=jpim), Intent(in) :: nfrequencies
- Integer(Kind=jpim), Intent(in) :: nchannels
- Integer(Kind=jpim), Intent(in) :: nbtout
- Integer(Kind=jpim), Intent(in) :: nprofiles
- Integer(Kind=jpim), Intent(in) :: channels(nfrequencies)
- Integer(Kind=jpim), Intent(in) :: polarisations(nchannels,3)
- Integer(Kind=jpim), Intent(in) :: lprofiles(nfrequencies)
- Logical, Intent(in) :: addcloud
- Logical, Intent(in) :: switchrad ! true if input is BT
- Type(profile_Type), Intent(in) :: profiles(nprofiles)
- Type(rttov_coef), Intent(in) :: coef
- Logical, Intent(in) :: calcemis(nchannels)
- Integer(Kind=jpim), Intent(out) :: errorstatus(nprofiles)
- Real(Kind=jprb), Intent(inout) :: emissivity(nchannels)
- Type(transmission_Type), Intent(inout) :: transmission! in because of meme allocation
- Type(radiance_Type), Intent(inout) :: radiancedata! in because of meme allocation
-
-
- Type(profile_Type), Intent(inout) :: profiles_ad(nprofiles)
- Real(Kind=jprb), Intent(inout) :: emissivity_ad(nchannels)
- Type(transmission_Type), Intent(inout) :: transmission_ad ! in because of meme allocation
- Type(radiance_Type), Intent(inout) :: radiancedata_ad ! in because of meme allocation
-
-
-End Subroutine rttov_ad
-End Interface
diff --git a/src/LIB/RTTOV/src/rttov_aitosu.F90 b/src/LIB/RTTOV/src/rttov_aitosu.F90
deleted file mode 100644
index d7cdf42749ebb984e8e05bfd96cb5931645498ee..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_aitosu.F90
+++ /dev/null
@@ -1,229 +0,0 @@
-!
-Subroutine rttov_aitosu ( &
- & nfrequencies, &! in
- & nchannels, &! in
- & nprofiles, &! in
- & nlevels, &! in
- & polarisations, &! in
- & lprofiles, &! in
- & overlap_scheme, &! in
- & profiles, &! in (cloud cover)
- & radiance) ! inout (cldemis input and
- ! cs_wtao, cs_wsurf, wtao, wsurf in output)
- ! Description:
- ! To compute the weights of the black-body-derived radiances
- !
- ! Copyright:
- ! This software was developed within the context of
- ! the EUMETSAT Satellite Application Facility on
- ! Numerical Weather Prediction (NWP SAF), under the
- ! Cooperation Agreement dated 25 November 1998, between
- ! EUMETSAT and the Met Office, UK, by one or more partners
- ! within the NWP SAF. The partners in the NWP SAF are
- ! the Met Office, ECMWF, KNMI and MeteoFrance.
- !
- ! Copyright 2002, EUMETSAT, All Rights Reserved.
- !
- ! Method:
- !
- ! Current Code Owner: SAF NWP
- !
- ! History:
- ! Version Date Comment
- ! ------- ---- -------
- ! 1 03/2000 Original code (F. Chevallier)
- ! 2 03/2001 Fortran 90 (F. Chevallier)
- ! 2.1 12/2002 New F90 code with structures (P Brunel A Smith)
- ! 3 24/2/04 Added polarimetry option
- !
- ! Code Description:
- ! Language: Fortran 90.
- ! Software Standards: "European Standards for Writing and
- ! Documenting Exchangeable Fortran 90 Code".
- !
- ! Declarations:
- ! Modules used:
- ! Imported Type Definitions:
- Use rttov_types, Only : &
- & profile_cloud_Type ,&
- & radiance_cloud_Type
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
- !subroutine arguments:
- Integer(Kind=jpim), Intent(in) :: nfrequencies
- Integer(Kind=jpim), Intent(in) :: nchannels
- Integer(Kind=jpim), Intent(in) :: nprofiles
- Integer(Kind=jpim), Intent(in) :: nlevels
- Integer(Kind=jpim), Intent(in) :: lprofiles(nfrequencies)
- Integer(Kind=jpim), Intent(in) :: polarisations(nchannels,3) ! Channel indices
- Integer(Kind=jpim), Intent(in) :: overlap_scheme
- Type(profile_cloud_Type), Intent(in) :: profiles(nprofiles)
- Type(radiance_cloud_Type), Intent(inout) :: radiance
-
-
-
- ! Local parameters:
- !
- Real(Kind=jprb) , Parameter :: repclc = 1.e-12_JPRB
- Real(Kind=jprb) , Parameter :: unity = 1.0_JPRB
- !
-
-
- ! Local scalars:
- !
- Integer(Kind=jpim) :: jk, jk1, jl, idp
- Integer(Kind=jpim) :: freq
- Real(Kind=jprb) :: zcadj, ztr1, ztr2
- !
-
-
- ! Local arrays:
- !
- Real(Kind=jprb), Dimension(nchannels) :: zclear, zcloud, zcont, zsum
-
- ! beware array shape zclm and zxxx is nchannels, nlevelsm+1
- Real(Kind=jprb) :: zclm (nlevels+1, nchannels)
- Real(Kind=jprb) :: zcldfr(nlevels, nchannels)
- Real(Kind=jprb) :: zcldem(nlevels, nchannels)
- Real(Kind=jprb) :: zeffem(nlevels, nchannels)
-
- !- End of header --------------------------------------------------------
-
- !All input NWP profiles have the same number of levels
-
- radiance % cs_wtoa(:) = 0._JPRB
- radiance % cs_wsurf(:) = 0._JPRB
- radiance % wtoa(:,:) = 0._JPRB
- radiance % wsurf(:,:) = 0._JPRB
-
-
- Do jk = 1, nlevels
- Do jl = 1, nchannels
- freq = polarisations(jl,2)
- idp = lprofiles(freq)
- zcldem(jk,jl)= Min( Max( radiance % cldemis(jk,jl),repclc ) ,unity-repclc )
- zcldfr(jk,jl)= Min( Max( profiles(idp)%cc(jk),repclc ) ,unity-repclc )
- zeffem(jk,jl)= radiance % cldemis(jk,jl) * profiles(idp)%cc(jk)
- zeffem(jk,jl)= Min( Max( zeffem(jk,jl),repclc) ,unity-repclc )
- End Do
- End Do
-
- !----------------------------------------
- !
- ! Effect of cloudiness on toa radiances
- !
- ! Cloud cover matrix
- !
- ! zclm(jk2) is the obscuration factor by cloud layers between
- ! half-levels jk1 and jk2 as seen from jk1
- ! jk1 is the top of the atmosphere (toa)
- !
-
- jk1 = 1 ! level of top of the atmosphere
-
- zclm(:,:) = 0._JPRB
- zclear(:) = 1._JPRB
- zcloud(:) = 0._JPRB
- zcont(:) = zeffem(jk1,:)
- zsum(:) = zcont(:)
- zclm(jk1+1,:) = zsum(:)
-
- If (overlap_scheme == 1) Then
- !* maximum-random (Geleyn and Hollingsworth 1979)
- Do jk = jk1 , nlevels ! layer loop
- Do jl = 1,nchannels
- zclear(jl) = zclear(jl)*(unity-Max(zeffem(jk,jl),zcloud(jl))) &
- & /(unity-Min(zcloud(jl),unity-repclc))
- zclm(jk+1,jl) = 1._JPRB - zclear(jl)
- zcloud(jl) = zeffem(jk,jl)
- End Do
- End Do
- Else If (overlap_scheme == 2) Then
- !* maximum-random (Raisanen 1998)
- Do jk = jk1 + 1 , nlevels ! layer loop
- Do jl = 1,nchannels
- ztr1 = zcont(jl)/zeffem(jk-1,jl)
- ztr2 = (1._JPRB-(zsum(jl)-zcont(jl))-ztr1*zcldfr(jk-1,jl)) &
- & /(1._JPRB-zcldfr(jk-1,jl))
- zcadj = Min(zcldfr(jk,jl),zcldfr(jk-1,jl))
- zcont(jl) = zcldem(jk,jl)*(zcadj*(1._JPRB-zcldem(jk-1,jl))*ztr1 &
- & +(zcldfr(jk,jl)-zcadj)*ztr2)
- zsum(jl) = zsum(jl) + zcont(jl)
- zclm(jk+1,jl) = zsum(jl)
- Enddo
- Enddo
- Endif
-
- ! Weight computation
- !
-
- ! Contribution from clear-sky fraction
- radiance % cs_wtoa(:) = 1._JPRB - zclm(nlevels+1,:)
-
- ! Contribution from cloudy layers
- Do jk = jk1, nlevels ! layer loop
- radiance % wtoa( jk, : ) = zclm(jk+1,:) - zclm(jk,:)
- End Do
-
-
- !----------------------------------------
- !
- ! Effect of cloudiness on surface radiances
- !
-
- !
- ! Cloud cover matrix
- !
- ! zclm(jk) is now the obscuration factor by cloud layers between
- ! surface and jk as seen from the surface
- !
-
- zclm(:,:) = 0._JPRB
- zcloud(:) = 0._JPRB
- zclear(:) = 1._JPRB
- zcont(:) = zeffem(nlevels,:)
- zsum(:) = zcont(:)
- zclm(nlevels,:) = zsum(:)
-
- If (overlap_scheme == 1) Then
- !* maximum-random (Geleyn and Hollingsworth 1979)
- Do jk = nlevels, 1, -1 ! layer loop
- Do jl = 1,nchannels
- zclear(jl)=zclear(jl)*(1._JPRB-Max(zeffem(jk,jl),zcloud(jl))) &
- & /(1._JPRB-Min(zcloud(jl),unity-repclc))
- zclm(jk,jl) = 1._JPRB - zclear(jl)
- zcloud(jl) = zeffem(jk,jl)
- End Do
- End Do
- Else If (overlap_scheme == 2) Then
- !* maximum-random (Raisanen 1998)
- Do jk = nlevels - 1, 1, -1 ! layer loop
- Do jl = 1,nchannels
- ztr1 = zcont(jl)/zeffem(jk+1,jl)
- ztr2 = (1._JPRB-(zsum(jl)-zcont(jl))-ztr1*zcldfr(jk+1,jl)) &
- & /(1._JPRB-zcldfr(jk+1,jl))
- zcadj = Min(zcldfr(jk,jl),zcldfr(jk+1,jl))
- zcont(jl) = zcldem(jk,jl)*(zcadj*(1._JPRB-zcldem(jk+1,jl))*ztr1 &
- & +(zcldfr(jk,jl)-zcadj)*ztr2)
- zsum(jl) = zsum(jl) + zcont(jl)
- zclm(jk,jl) = zsum(jl)
- End Do
- End Do
- End If
-
- ! Weight computation
- !
-
- ! Contribution from clear-sky fraction
-
- radiance % cs_wsurf(:) = 1._JPRB - zclm(1,:)
-
- ! Contribution from cloudy layers
-
- Do jk = 1, nlevels ! layer loop
- radiance % wsurf( jk, : ) = zclm(jk,:) - zclm(jk+1,:)
- Enddo
-
-End Subroutine rttov_aitosu
diff --git a/src/LIB/RTTOV/src/rttov_aitosu.interface b/src/LIB/RTTOV/src/rttov_aitosu.interface
deleted file mode 100644
index 85b1460208ec387ea8e7970e30b4d1d525a7a0d8..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_aitosu.interface
+++ /dev/null
@@ -1,34 +0,0 @@
-Interface
-!
-Subroutine rttov_aitosu ( &
- & nfrequencies, & ! in
- & nchannels, & ! in
- & nprofiles, & ! in
- & nlevels, & ! in
- & polarisations, & ! in
- & lprofiles, & ! in
- & overlap_scheme, & ! in
- & profiles, & ! in (cloud cover)
- & radiance) ! inout (cldemis input and
- ! cs_wtao, cs_wsurf, wtao, wsurf in output)
- Use rttov_types, Only : &
- profile_cloud_Type ,&
- radiance_cloud_Type
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
- Integer(Kind=jpim), Intent(in) :: nchannels
- Integer(Kind=jpim), Intent(in) :: nfrequencies
- Integer(Kind=jpim), Intent(in) :: nprofiles
- Integer(Kind=jpim), Intent(in) :: nlevels
- Integer(Kind=jpim), Intent(in) :: polarisations(nchannels,3)
- Integer(Kind=jpim), Intent(in) :: lprofiles(nfrequencies)
- Integer(Kind=jpim), Intent(in) :: overlap_scheme
- Type(profile_cloud_Type), Intent(in) :: profiles(nprofiles)
- Type(radiance_cloud_Type), Intent(inout) :: radiance
-
-
-
-End Subroutine rttov_aitosu
-End Interface
diff --git a/src/LIB/RTTOV/src/rttov_aitosu_ad.F90 b/src/LIB/RTTOV/src/rttov_aitosu_ad.F90
deleted file mode 100644
index 29a2165284fb71d85dbd039c1fdd56121b718111..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_aitosu_ad.F90
+++ /dev/null
@@ -1,658 +0,0 @@
-Subroutine rttov_aitosu_ad( &
- & nfrequencies, &! in
- & nchannels, &! in
- & nprofiles, &! in
- & nlevels, &! in
- & polarisations, &! in
- & lprofiles, &! in
- & overlap_scheme, &! in
- & profiles, &! in
- & profiles_ad, &! inout
- & radiance , &! inout
- & radiance_ad ) ! inout
- ! Description:
- ! AD of routine to compute the weights of the black-body-derived radiances
- !
- ! Copyright:
- ! This software was developed within the context of
- ! the EUMETSAT Satellite Application Facility on
- ! Numerical Weather Prediction (NWP SAF), under the
- ! Cooperation Agreement dated 25 November 1998, between
- ! EUMETSAT and the Met Office, UK, by one or more partners
- ! within the NWP SAF. The partners in the NWP SAF are
- ! the Met Office, ECMWF, KNMI and MeteoFrance.
- !
- ! Copyright 2002, EUMETSAT, All Rights Reserved.
- !
- ! Method:
- !
- ! Current Code Owner: SAF NWP
- !
- ! History:
- ! Version Date Comment
- ! ------- ---- -------
- ! 1 07/10/2004 Added history
- ! 1.1 29/03/2005 Add end of header comment (J. Cameron)
- !
- ! Code Description:
- ! Language: Fortran 90.
- ! Software Standards: "European Standards for Writing and
- ! Documenting Exchangeable Fortran 90 Code".
- !
- ! Declarations:
- ! Modules used:
- ! Imported Type Definitions:
-
- Use rttov_types, Only : &
- & profile_cloud_Type ,&
- & radiance_cloud_Type
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
- !subroutine arguments:
- Integer(Kind=jpim), Intent(in) :: nfrequencies
- Integer(Kind=jpim), Intent(in) :: nchannels
- Integer(Kind=jpim), Intent(in) :: nprofiles
- Integer(Kind=jpim), Intent(in) :: nlevels
- Integer(Kind=jpim), Intent(in) :: lprofiles(nfrequencies)
- Integer(Kind=jpim), Intent(in) :: polarisations(nchannels,3) ! Channel indices
- Integer(Kind=jpim), Intent(in) :: overlap_scheme
- Type(profile_cloud_Type), Intent(in) :: profiles(nprofiles)
- Type(radiance_cloud_Type), Intent(inout) :: radiance
-
- Type(profile_cloud_Type), Intent(inout) :: profiles_ad(nprofiles)
- Type(radiance_cloud_Type), Intent(inout) :: radiance_ad
-
-
-
- ! Local parameters:
- !
- Real(Kind=jprb) , Parameter :: repclc = 1.e-12_JPRB
- Real(Kind=jprb) , Parameter :: unity = 1.0_JPRB
- !
-
-
- ! Local scalars:
- !
- Integer(Kind=jpim) :: jk, jk1, jl, idp
- Integer(Kind=jpim) :: freq
- Real(Kind=jprb) :: zcadj_ad, ztr1_ad, ztr2_ad
- Real(Kind=jprb) :: znum_ad, zden_ad
- !
-
-
- ! Local arrays:
- !
- Real(Kind=jprb), Dimension(nchannels) :: zclear_ad, zcloud_ad, zcont_ad, zsum_ad
-
- ! beware array shape zclm and zxxx is nchannels, nlevelsm+1
- Real(Kind=jprb) :: zclm (nlevels+1, nchannels)
- Real(Kind=jprb) :: zcldfr(nlevels, nchannels)
- Real(Kind=jprb) :: zcldem(nlevels, nchannels)
- Real(Kind=jprb) :: zeffem(nlevels, nchannels)
-
- Real(Kind=jprb) :: zclm_ad (nlevels+1, nchannels)
- Real(Kind=jprb) :: zcldfr_ad(nlevels, nchannels)
- Real(Kind=jprb) :: zcldem_ad(nlevels, nchannels)
- Real(Kind=jprb) :: zeffem_ad(nlevels, nchannels)
-
- ! arrays for tracing forward model
- Real(Kind=jprb) :: zcadj(nlevels+1, nchannels)
- Real(Kind=jprb) :: ztr1(nlevels+1, nchannels)
- Real(Kind=jprb) :: ztr2(nlevels+1, nchannels)
- Real(Kind=jprb) :: zden(nlevels+1, nchannels)
- Real(Kind=jprb) :: znum(nlevels+1, nchannels)
- Real(Kind=jprb) :: zclear(0:nlevels+1, nchannels)
- Real(Kind=jprb) :: zcloud(0:nlevels+1, nchannels)
- Real(Kind=jprb) :: zcont(nlevels, nchannels)
- Real(Kind=jprb) :: zsum (nlevels, nchannels)
-
-
- Real(Kind=jprb) :: test_1(nlevels, nchannels)
- Real(Kind=jprb) :: test_2(nlevels, nchannels)
- Real(Kind=jprb) :: test_3(nlevels, nchannels)
-
- Real(Kind=jprb) :: value
-
- !- End of header --------------------------------------------------------
-
- !All input NWP profiles have the same number of levels
-
- radiance % cs_wtoa(:) = 0._JPRB
- radiance % cs_wsurf(:) = 0._JPRB
- radiance % wtoa(:,:) = 0._JPRB
- radiance % wsurf(:,:) = 0._JPRB
-
- ! Init AD variables
- zcldfr_ad(:,:) = 0._JPRB
- zcldem_ad(:,:) = 0._JPRB
- zeffem_ad(:,:) = 0._JPRB
-
- Do jk = 1, nlevels
- Do jl = 1, nchannels
- freq = polarisations(jl,2)
- idp = lprofiles(freq)
-
- value = radiance % cldemis(jk,jl)
- test_1(jk,jl) = value
- If( value > (unity-repclc) ) Then
- zcldem(jk,jl) = unity - repclc
- Else If( value < repclc ) Then
- zcldem(jk,jl) = repclc
- Else
- zcldem(jk,jl) = value
- Endif
-
-
- value = profiles(idp)%cc(jk)
- test_2(jk,jl) = value
- If( value > (unity-repclc) ) Then
- zcldfr(jk,jl) = unity - repclc
- Else If( value < repclc ) Then
- zcldfr(jk,jl) = repclc
- Else
- zcldfr(jk,jl) = value
- Endif
-
-
- value = radiance % cldemis(jk,jl) * profiles(idp)%cc(jk)
- test_3(jk,jl) = value
- If( value > (unity-repclc) ) Then
- zeffem(jk,jl) = unity - repclc
- Else If( value < repclc ) Then
- zeffem(jk,jl) = repclc
- Else
- zeffem(jk,jl) = value
- Endif
-
- End Do
- End Do
-
- !----------------------------------------
- !
- ! Effect of cloudiness on toa radiances
- !
- ! Cloud cover matrix
- !
- ! zclm(jk2) is the obscuration factor by cloud layers between
- ! half-levels jk1 and jk2 as seen from jk1
- ! jk1 is the top of the atmosphere (toa)
- !
-
- jk1 = 1 ! level of top of the atmosphere
-
- zclm(:,:) = 0._JPRB
- zclear(1,:) = 1._JPRB
- zcloud(:,:) = 0._JPRB
- zcont(1,:) = zeffem(jk1,:)
-
- zsum(1,:) = zcont(1,:)
- zclm(jk1+1,:) = zsum(1,:)
-
- If (overlap_scheme == 1) Then
- !* maximum-random (Geleyn and Hollingsworth 1979)
- Do jk = jk1 , nlevels ! layer loop
- Do jl = 1,nchannels
- If( zeffem(jk,jl) > zcloud(jk,jl) ) Then
- znum(jk,jl) = zclear(jk,jl) * (unity-zeffem(jk,jl))
- Else
- znum(jk,jl) = zclear(jk,jl) * (unity-zcloud(jk,jl))
- End If
- If ( zcloud(jk,jl) > unity-repclc ) Then
- zden(jk,jl) = repclc
- Else
- zden(jk,jl) = unity - zcloud(jk,jl)
- Endif
-
- zclear(jk+1,jl) = znum(jk,jl) / zden(jk,jl)
- zclm(jk+1,jl) = 1._JPRB - zclear(jk+1,jl)
- zcloud(jk+1,jl) = zeffem(jk,jl)
- End Do
- End Do
-
- Else If (overlap_scheme == 2) Then
- !* maximum-random (Raisanen 1998)
- Do jk = jk1 + 1 , nlevels ! layer loop
- Do jl = 1,nchannels
- zsum(jk,jl) = zsum(jk-1,jl)
- zcont(jk,jl) = zcont(jk-1,jl)
- ztr1(jk,jl) = zcont(jk,jl) / zeffem(jk-1,jl)
-
- znum(jk,jl) = 1._JPRB - (zsum(jk,jl)-zcont(jk,jl)) -&
- & ztr1(jk,jl)*zcldfr(jk-1,jl)
- zden(jk,jl) = (1._JPRB-zcldfr(jk-1,jl))
- ztr2(jk,jl) = znum(jk,jl) / zden(jk,jl)
-
- If( zcldfr(jk,jl) > zcldfr(jk-1,jl) ) Then
- zcadj(jk,jl) = zcldfr(jk-1,jl)
- Else
- zcadj(jk,jl) = zcldfr(jk,jl)
- End If
-
- zcont(jk,jl) = zcldem(jk,jl) * (zcadj(jk,jl) *&
- & (1._JPRB-zcldem(jk-1,jl))*ztr1(jk,jl) +&
- & (zcldfr(jk,jl)-zcadj(jk,jl)) * ztr2(jk,jl))
- zsum(jk,jl) = zsum(jk,jl) + zcont(jk,jl)
- zclm(jk+1,jl) = zsum(jk,jl)
- Enddo
- Enddo
- Endif
-
- ! Weight computation
- !
-
- ! Contribution from clear-sky fraction
- radiance % cs_wtoa(:) = 1._JPRB - zclm(nlevels+1,:)
-
-
- ! Contribution from cloudy layers
- Do jk = jk1, nlevels ! layer loop
- radiance % wtoa( jk, : ) = zclm(jk+1,:) - zclm(jk,:)
- End Do
-
-
-
-
- !----------------------------------------
- ! --- Adjoint computation for top of the atmosphere
- !----------------------------------------
-
- zclm_ad(:,:) = 0._JPRB
- zclear_ad(:) = 0._JPRB
- zcloud_ad(:) = 0._JPRB
- zcont_ad(:) = 0._JPRB
- zsum_ad(:) = 0
-
- ! Weight computation
- !
- ! Contribution from cloudy layers
- Do jk = nlevels, jk1, -1 ! layer loop
- zclm_ad(jk+1,:) = zclm_ad(jk+1,:) + radiance_ad % wtoa( jk,:)
- zclm_ad(jk,:) = zclm_ad(jk,:) - radiance_ad % wtoa( jk,:)
- radiance_ad % wtoa( jk, : ) = 0._JPRB
- End Do
-
- ! Contribution from clear-sky fraction
- zclm_ad(nlevels+1,:) = zclm_ad(nlevels+1,:) - radiance_ad % cs_wtoa(:)
- radiance_ad % cs_wtoa(:) = 0._JPRB
-
-
- !----------------------------------------
- !
- ! Effect of cloudiness on toa radiances
- !
- ! Cloud cover matrix
- !
- ! zclm(jk2) is the obscuration factor by cloud layers between
- ! half-levels jk1 and jk2 as seen from jk1
- ! jk1 is the top of the atmosphere (toa)
-
- jk1 = 1 ! level of top of the atmosphere
-
- If (overlap_scheme == 1) Then
- !* maximum-random (Geleyn and Hollingsworth 1979)
- Do jk = nlevels, jk1, -1 ! layer loop
- Do jl = 1,nchannels
- zeffem_ad(jk,jl) = zeffem_ad(jk,jl) + zcloud_ad(jl)
- zcloud_ad(jl) = 0._JPRB
-
- zclear_ad(jl) = zclear_ad(jl) - zclm_ad(jk+1,jl)
- zclm_ad(jk+1,jl) = 0._JPRB
-
- znum_ad = zclear_ad(jl) / zden(jk,jl)
- zden_ad =-zclear_ad(jl) * znum(jk,jl) / (zden(jk,jl)**2)
-
- If ( zcloud(jk,jl) > unity-repclc ) Then
- zden_ad = 0._JPRB
- Else
- zcloud_ad(jl) = zcloud_ad(jl) - zden_ad
- Endif
-
- If( zeffem(jk,jl) > zcloud(jk,jl) ) Then
- zclear_ad(jl) = zclear_ad(jl) + znum_ad *&
- & (unity-zeffem(jk,jl))
- zeffem_ad(jk,jl) = zeffem_ad(jk,jl) - znum_ad *&
- & zclear(jk,jl)
- Else
- zclear_ad(jl) = zclear_ad(jl) + znum_ad *&
- & (unity-zcloud(jk,jl))
- zcloud_ad(jl) = zcloud_ad(jl) + znum_ad *&
- & zclear(jk,jl)
- End If
- End Do
- End Do
-
- Else If (overlap_scheme == 2) Then
- !* maximum-random (Raisanen 1998)
- Do jk = nlevels, jk1+1, -1 ! layer loop
- Do jl = 1,nchannels
- znum_ad = 0._JPRB
- zden_ad = 0._JPRB
- ztr1_ad = 0._JPRB
- ztr2_ad = 0._JPRB
- zcadj_ad = 0._JPRB
-
- zsum_ad(jl) = zsum_ad(jl) + zclm_ad(jk+1,jl)
- zclm_ad(jk+1,jl) = 0._JPRB
-
- zcont_ad(jl) = zcont_ad(jl) + zsum_ad(jl)
-
-
- zcldem_ad(jk,jl) = zcldem_ad(jk,jl) + zcont_ad(jl) *&
- & (zcadj(jk,jl)*(1._JPRB-zcldem(jk-1,jl))*ztr1(jk,jl) + &
- & (zcldfr(jk,jl)-zcadj(jk,jl))*ztr2(jk,jl))
- zcadj_ad = zcadj_ad + zcont_ad(jl) *&
- & zcldem(jk,jl) * ( (1._JPRB-zcldem(jk-1,jl))*ztr1(jk,jl) - ztr2(jk,jl) )
- zcldem_ad(jk-1,jl) = zcldem_ad(jk-1,jl) - zcont_ad(jl) *&
- & zcldem(jk,jl) * zcadj(jk,jl) * ztr1(jk,jl)
-
- ztr1_ad = ztr1_ad + zcont_ad(jl) *&
- & zcldem(jk,jl) * zcadj(jk,jl) * (1._JPRB-zcldem(jk-1,jl))
- zcldfr_ad(jk,jl) = zcldfr_ad(jk,jl) + zcont_ad(jl) *&
- & zcldem(jk,jl) * ztr2(jk,jl)
- ztr2_ad = ztr2_ad + zcont_ad(jl) *&
- & zcldem(jk,jl) * (zcldfr(jk,jl) -zcadj(jk,jl) )
- zcont_ad(jl) = 0._JPRB
-
- If( zcldfr(jk,jl) < zcldfr(jk-1,jl) ) Then
- zcldfr_ad(jk,jl) = zcldfr_ad(jk,jl) + zcadj_ad
- Else
- zcldfr_ad(jk-1,jl) = zcldfr_ad(jk-1,jl) + zcadj_ad
- End If
-
- znum_ad = znum_ad + ztr2_ad / zden(jk,jl)
- zden_ad = zden_ad - ztr2_ad * znum(jk,jl) / zden(jk,jl)**2
-
- zcldfr_ad(jk-1,jl) = zcldfr_ad(jk-1,jl) - zden_ad
-
- zsum_ad(jl) = zsum_ad(jl) - znum_ad
- zcont_ad(jl) = zcont_ad(jl) + znum_ad
- ztr1_ad = ztr1_ad - znum_ad * zcldfr(jk-1,jl)
- zcldfr_ad(jk-1,jl) = zcldfr_ad(jk-1,jl) - znum_ad * ztr1(jk,jl)
-
-
- zcont_ad(jl) = zcont_ad(jl) + ztr1_ad / zeffem(jk-1,jl)
- zeffem_ad(jk-1,jl) = zeffem_ad(jk-1,jl) - ztr1_ad * &
- & zcont(jk-1,jl) / (zeffem(jk-1,jl)**2)
-
- Enddo
- Enddo
- Endif
-
- ! Cloud cover matrix
- !
- zsum_ad(:) = zsum_ad(:) + zclm_ad(jk1+1,:)
- zclm_ad(jk1+1,:) = 0._JPRB
- zcont_ad(:) = zcont_ad(:) + zsum_ad(:)
- zsum_ad(:) = 0._JPRB
- zeffem_ad(jk1,:) = zeffem_ad(jk1,:) + zcont_ad(:)
- zcont_ad(:) = 0._JPRB
-
-!! zclm_ad(:,:) = 0.
-!! zclear_ad(:) = 0.
-!! zcloud_ad(:) = 0.
-
- !----------------------------------------
- ! --- End of Adjoint computation for top of the atmosphere
- !----------------------------------------
-
-
-
- !----------------------------------------
- !
- ! Effect of cloudiness on surface radiances
- !
-
- !
- ! Cloud cover matrix
- !
- ! zclm(jk) is now the obscuration factor by cloud layers between
- ! surface and jk as seen from the surface
- !
- jk1 = nlevels ! surface level
-
- zclm(:,:) = 0._JPRB
- zcloud(:,:) = 0._JPRB
- zclear(:,:) = 1._JPRB
- zcont(nlevels,:) = zeffem(nlevels,:)
- zsum(nlevels,:) = zcont(nlevels,:)
- zclm(nlevels,:) = zsum(nlevels,:)
-
- If (overlap_scheme == 1) Then
- !* maximum-random (Geleyn and Hollingsworth 1979)
- Do jk = nlevels, 1, -1 ! layer loop
- Do jl = 1,nchannels
- If( zeffem(jk,jl) > zcloud(jk,jl) ) Then
- znum(jk,jl) = zclear(jk,jl)*(1._JPRB-zeffem(jk,jl))
- Else
- znum(jk,jl) = zclear(jk,jl)*(1._JPRB-zcloud(jk,jl))
- End If
-
- If ( zcloud(jk,jl) > unity-repclc ) Then
- zden(jk,jl) = repclc
- Else
- zden(jk,jl) = 1._JPRB - zcloud(jk,jl)
- End If
- zclear(jk-1,jl) = znum(jk,jl) / zden(jk,jl)
- zclm(jk,jl) = 1._JPRB - zclear(jk-1,jl)
- zcloud(jk-1,jl) = zeffem(jk,jl)
- End Do
- End Do
-
- Else If (overlap_scheme == 2) Then
- !* maximum-random (Raisanen 1998)
- Do jk = nlevels - 1, 1, -1 ! layer loop
- Do jl = 1,nchannels
- zcont(jk,jl) = zcont(jk+1,jl)
- zsum(jk,jl) = zsum(jk+1,jl)
- ztr1(jk,jl) = zcont(jk,jl) / zeffem(jk+1,jl)
-
- znum(jk,jl) = 1._JPRB-(zsum(jk,jl)-zcont(jk,jl))-ztr1(jk,jl)*zcldfr(jk+1,jl)
- zden(jk,jl) = (1._JPRB-zcldfr(jk+1,jl))
- ztr2(jk,jl) = znum(jk,jl) / zden(jk,jl)
-
- If( zcldfr(jk,jl) > zcldfr(jk+1,jl) ) Then
- zcadj(jk,jl) = zcldfr(jk+1,jl)
- Else
- zcadj(jk,jl) = zcldfr(jk,jl)
- End If
-
- zcont(jk,jl) = zcldem(jk,jl)*(zcadj(jk,jl)*(1._JPRB-zcldem(jk+1,jl))*ztr1(jk,jl) &
- & +(zcldfr(jk,jl)-zcadj(jk,jl))*ztr2(jk,jl))
- zsum(jk,jl) = zsum(jk,jl) + zcont(jk,jl)
- zclm(jk,jl) = zsum(jk,jl)
-
- End Do
- End Do
- End If
-
- ! Weight computation
- !
- ! Contribution from clear-sky fraction
-
- radiance % cs_wsurf(:) = 1._JPRB - zclm(1,:)
-
- ! Contribution from cloudy layers
-
- Do jk = 1, nlevels ! layer loop
- radiance % wsurf( jk, : ) = zclm(jk,:) - zclm(jk+1,:)
- Enddo
-
-
-!-----------------------------------------------
-! --- Adjoint computation for surface radiances
-!-----------------------------------------------
-
- zclm_ad(:,:) = 0._JPRB
- zclear_ad(:) = 0._JPRB
- zcloud_ad(:) = 0._JPRB
- zcont_ad(:) = 0._JPRB
- zsum_ad(:) = 0._JPRB
-
- ! Weight computation
- !
- ! Contribution from cloudy layers
- Do jk = nlevels, 1, -1 ! layer loop
- zclm_ad(jk,:) = zclm_ad(jk,:) + radiance_ad % wsurf( jk, : )
- zclm_ad(jk+1,:) = zclm_ad(jk+1,:) - radiance_ad % wsurf( jk, : )
- radiance_ad % wsurf( jk, : ) = 0._JPRB
- Enddo
-
- ! Contribution from clear-sky fraction
- zclm_ad(1,:) = zclm_ad(1,:) - radiance_ad % cs_wsurf(:)
- radiance_ad % cs_wsurf(:) = 0._JPRB
-
-
- If (overlap_scheme == 1) Then
- !* maximum-random (Geleyn and Hollingsworth 1979)
- Do jk = 1, nlevels ! layer loop
- Do jl = 1,nchannels
- znum_ad = 0._JPRB
- zden_ad = 0._JPRB
-
- zeffem_ad(jk,jl) = zeffem_ad(jk,jl) + zcloud_ad(jl)
- zcloud_ad(jl) = 0._JPRB
-
- zclear_ad(jl) = zclear_ad(jl) - zclm_ad(jk,jl)
- zclm_ad(jk,jl) = 0._JPRB
-
- znum_ad = znum_ad + zclear_ad(jl) * zclear(jk,jl)/zden(jk,jl)
- zden_ad = zden_ad - zclear_ad(jl) *&
- & zclear(jk,jl) * znum(jk,jl) / (zden(jk,jl)**2)
- zclear_ad(jl) = zclear_ad(jl) * znum(jk,jl) / zden(jk,jl)
-
- If ( zcloud(jk,jl) < unity-repclc ) Then
- zcloud_ad(jl) = zcloud_ad(jl) - zden_ad
- End If
-
- If( zeffem(jk,jl) > zcloud(jk,jl) ) Then
- zeffem_ad(jk,jl) = zeffem_ad(jk,jl) - znum_ad
- Else
- zcloud_ad(jl) = zcloud_ad(jl) - znum_ad
- End If
-
- End Do
- End Do
-
- Else If (overlap_scheme == 2) Then
- !* maximum-random (Raisanen 1998)
- Do jk = 1, nlevels - 1 ! layer loop
- Do jl = 1,nchannels
-
- znum_ad = 0._JPRB
- zden_ad = 0._JPRB
- ztr1_ad = 0._JPRB
- ztr2_ad = 0._JPRB
- zcadj_ad = 0._JPRB
-
- zsum_ad(jl) = zsum_ad(jl) + zclm_ad(jk,jl)
- zclm_ad(jk,jl) = 0._JPRB
-
- zcont_ad(jl) = zcont_ad(jl) + zsum_ad(jl)
-
- zcldem_ad(jk,jl) = zcldem_ad(jk,jl) + zcont_ad(jl) *&
- & (zcadj(jk,jl)*(1._JPRB-zcldem(jk+1,jl))*ztr1(jk,jl) + &
- & (zcldfr(jk,jl)-zcadj(jk,jl))*ztr2(jk,jl))
- zcadj_ad = zcadj_ad + zcont_ad(jl) *&
- & zcldem(jk,jl) * ( (1._JPRB-zcldem(jk+1,jl))*ztr1(jk,jl) - ztr2(jk,jl) )
- zcldem_ad(jk+1,jl) = zcldem_ad(jk+1,jl) - zcont_ad(jl) *&
- & zcldem(jk,jl) * zcadj(jk,jl) * ztr1(jk,jl)
- ztr1_ad = ztr1_ad + zcont_ad(jl) *&
- & zcldem(jk,jl) * zcadj(jk,jl) * (1._JPRB-zcldem(jk+1,jl))
- zcldfr_ad(jk,jl) = zcldfr_ad(jk,jl) + zcont_ad(jl) *&
- & zcldem(jk,jl) * ztr2(jk,jl)
- ztr2_ad = ztr2_ad + zcont_ad(jl) *&
- & zcldem(jk,jl) * (zcldfr(jk,jl) -zcadj(jk,jl) )
- zcont_ad(jl) = 0._JPRB
-
- If( zcldfr(jk,jl) < zcldfr(jk+1,jl) ) Then
- zcldfr_ad(jk,jl) = zcldfr_ad(jk,jl) + zcadj_ad
- Else
- zcldfr_ad(jk+1,jl) = zcldfr_ad(jk+1,jl) + zcadj_ad
- End If
-
- znum_ad = znum_ad + ztr2_ad / zden(jk,jl)
- zden_ad = zden_ad - ztr2_ad * znum(jk,jl) / zden(jk,jl)**2
-
- zcldfr_ad(jk+1,jl) = zcldfr_ad(jk+1,jl) - zden_ad
-
- zsum_ad(jl) = zsum_ad(jl) - znum_ad
- zcont_ad(jl) = zcont_ad(jl) + znum_ad
- ztr1_ad = ztr1_ad - znum_ad * zcldfr(jk+1,jl)
- zcldfr_ad(jk+1,jl) = zcldfr_ad(jk+1,jl) - znum_ad * ztr1(jk,jl)
-
-
- zcont_ad(jl) = zcont_ad(jl) + ztr1_ad / zeffem(jk+1,jl)
- zeffem_ad(jk+1,jl) = zeffem_ad(jk+1,jl) - ztr1_ad * &
- & zcont(jk+1,jl) / (zeffem(jk+1,jl)**2)
-
- End Do
- End Do
- End If
-
-
-! Cloud cover matrix
-!
- zsum_ad(:) = zsum_ad(:) + zclm_ad(jk1,:)
-
- zcont_ad(:) = zcont_ad(:) + zsum_ad(:)
-
- zeffem_ad(jk1,:) = zeffem_ad(jk1,:) + zcont_ad(:)
-
- zclm_ad(jk1,:) = 0._JPRB
- zclear_ad(:) = 0._JPRB
- zcloud_ad(:) = 0._JPRB
- zcont_ad(:) = 0._JPRB
- zsum_ad(:) = 0._JPRB
-
-!-----------------------------------------------
-! --- End of Adjoint computation for surface radiances
-!-----------------------------------------------
-
-
-! --- Adjoint computation for initialisations
-
- Do jk = nlevels, 1, -1
- Do jl = 1, nchannels
- freq = polarisations(jl,2)
- idp = lprofiles(freq)
-
- value = test_3(jk,jl)
- If( value > (unity-repclc) ) Then
- zeffem_ad(jk,jl) = 0._JPRB
- Else If( value < repclc ) Then
- zeffem_ad(jk,jl) = 0._JPRB
- Else
- radiance_ad % cldemis(jk,jl) = radiance_ad % cldemis(jk,jl) +&
- & zeffem_ad(jk,jl) * profiles(idp)%cc(jk)
- profiles_ad(idp)%cc(jk) = profiles_ad(idp)%cc(jk) +&
- & zeffem_ad(jk,jl) * radiance % cldemis(jk,jl)
- zeffem_ad(jk,jl) = 0._JPRB
- Endif
-
- value = test_2(jk,jl)
- If( value > (unity-repclc) ) Then
- zcldfr_ad(jk,jl) = 0._JPRB
- Else If( value < repclc ) Then
- zcldfr_ad(jk,jl) = 0._JPRB
- Else
- profiles_ad(idp)%cc(jk) = profiles_ad(idp)%cc(jk) + zcldfr_ad(jk,jl)
- zcldfr_ad(jk,jl) = 0._JPRB
- Endif
-
- value = test_1(jk,jl)
- If( value > (unity-repclc) ) Then
- zcldem_ad(jk,jl) = 0._JPRB
- Else If( value < repclc ) Then
- zcldem_ad(jk,jl) = 0._JPRB
- Else
- radiance_ad % cldemis(jk,jl) = radiance_ad % cldemis(jk,jl) +&
- & zcldem_ad(jk,jl)
- zcldem_ad(jk,jl) = 0._JPRB
- Endif
-
- End Do
- End Do
-
-End Subroutine Rttov_aitosu_ad
diff --git a/src/LIB/RTTOV/src/rttov_aitosu_ad.interface b/src/LIB/RTTOV/src/rttov_aitosu_ad.interface
deleted file mode 100644
index ad399a43b2079d3e926d4546a59cd762b959ae45..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_aitosu_ad.interface
+++ /dev/null
@@ -1,38 +0,0 @@
-Interface
-Subroutine rttov_aitosu_ad( &
- & nfrequencies, & ! in
- & nchannels, & ! in
- & nprofiles, & ! in
- & nlevels, & ! in
- & polarisations, & ! in
- & lprofiles, & ! in
- & overlap_scheme, & ! in
- & profiles, & ! in
- & profiles_ad, & ! inout
- & radiance , & ! inout
- & radiance_ad ) ! inout
-
- Use rttov_types, Only : &
- profile_cloud_Type ,&
- radiance_cloud_Type
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
- Integer(Kind=jpim), Intent(in) :: nchannels
- Integer(Kind=jpim), Intent(in) :: nfrequencies
- Integer(Kind=jpim), Intent(in) :: nprofiles
- Integer(Kind=jpim), Intent(in) :: nlevels
- Integer(Kind=jpim), Intent(in) :: lprofiles(nfrequencies)
- Integer(Kind=jpim), Intent(in) :: overlap_scheme
- Integer(Kind=jpim), Intent(in) :: polarisations(nchannels,3)
- Type(profile_cloud_Type), Intent(in) :: profiles(nprofiles)
- Type(radiance_cloud_Type), Intent(inout) :: radiance
-
- Type(profile_cloud_Type), Intent(inout) :: profiles_ad(nprofiles)
- Type(radiance_cloud_Type), Intent(inout) :: radiance_ad
-
-
-
-End Subroutine Rttov_aitosu_ad
-End Interface
diff --git a/src/LIB/RTTOV/src/rttov_aitosu_tl.F90 b/src/LIB/RTTOV/src/rttov_aitosu_tl.F90
deleted file mode 100644
index 5ea39c22d69359a10b427804f91e4ab785ce4d0f..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_aitosu_tl.F90
+++ /dev/null
@@ -1,417 +0,0 @@
-Subroutine rttov_aitosu_tl( &
- & nfrequencies, &! in
- & nchannels, &! in
- & nprofiles, &! in
- & nlevels, &! in
- & polarisations, &! in
- & lprofiles, &! in
- & overlap_scheme, &! in
- & profiles, &! in (cloud cover)
- & profiles_tl, &! in (cloud cover)
- & radiance , &! inout (cldemis input and
- & radiance_tl ) ! inout cs_wtao, cs_wsurf, wtao, wsurf in output)
- ! Description:
- ! AD of routine to compute the weights of the black-body-derived radiances
- !
- ! Copyright:
- ! This software was developed within the context of
- ! the EUMETSAT Satellite Application Facility on
- ! Numerical Weather Prediction (NWP SAF), under the
- ! Cooperation Agreement dated 25 November 1998, between
- ! EUMETSAT and the Met Office, UK, by one or more partners
- ! within the NWP SAF. The partners in the NWP SAF are
- ! the Met Office, ECMWF, KNMI and MeteoFrance.
- !
- ! Copyright 2002, EUMETSAT, All Rights Reserved.
- !
- ! Method:
- !
- ! Current Code Owner: SAF NWP
- !
- ! History:
- ! Version Date Comment
- ! ------- ---- -------
- ! 1 07/10/2004 Added history
- ! 1.1 29/03/2005 Add end of header comment (J. Cameron)
- !
- ! Code Description:
- ! Language: Fortran 90.
- ! Software Standards: "European Standards for Writing and
- ! Documenting Exchangeable Fortran 90 Code".
- !
- ! Declarations:
- ! Modules used:
- ! Imported Type Definitions:
-
- Use rttov_types, Only : &
- & profile_cloud_Type ,&
- & radiance_cloud_Type
-
- Use parkind1, Only : jpim ,jprb
- Implicit none
-
- !subroutine arguments:
- Integer(Kind=jpim), Intent(in) :: nfrequencies
- Integer(Kind=jpim), Intent(in) :: nchannels
- Integer(Kind=jpim), Intent(in) :: nprofiles
- Integer(Kind=jpim), Intent(in) :: nlevels
- Integer(Kind=jpim), Intent(in) :: lprofiles(nfrequencies)
- Integer(Kind=jpim), Intent(in) :: polarisations(nchannels,3) ! Channel indices
- Integer(Kind=jpim), Intent(in) :: overlap_scheme
- Type(profile_cloud_Type), Intent(in) :: profiles(nprofiles)
- Type(radiance_cloud_Type), Intent(inout) :: radiance
-
- Type(profile_cloud_Type), Intent(in) :: profiles_tl(nprofiles)
- Type(radiance_cloud_Type), Intent(inout) :: radiance_tl
-
-
-
- ! Local parameters:
- !
- Real(Kind=jprb) , Parameter :: repclc = 1.e-12_JPRB
- Real(Kind=jprb) , Parameter :: unity = 1.0_JPRB
- !
-
-
- ! Local scalars:
- !
- Integer(Kind=jpim) :: jk, jk1, jl, idp, freq
- Real(Kind=jprb) :: zcadj, ztr1, ztr2
- Real(Kind=jprb) :: zcadj_tl, ztr1_tl, ztr2_tl
- Real(Kind=jprb) :: znum, zden
- Real(Kind=jprb) :: znum_tl, zden_tl
- !
-
-
- ! Local arrays:
- !
- Real(Kind=jprb), Dimension(nchannels) :: zclear, zcloud, zcont, zsum
- Real(Kind=jprb), Dimension(nchannels) :: zclear_tl, zcloud_tl, zcont_tl, zsum_tl
-
- ! beware array shape zclm and zxxx is nchannels, nlevelsm+1
- Real(Kind=jprb) :: zclm (nlevels+1, nchannels)
- Real(Kind=jprb) :: zcldfr(nlevels, nchannels)
- Real(Kind=jprb) :: zcldem(nlevels, nchannels)
- Real(Kind=jprb) :: zeffem(nlevels, nchannels)
-
- Real(Kind=jprb) :: zclm_tl (nlevels+1, nchannels)
- Real(Kind=jprb) :: zcldfr_tl(nlevels, nchannels)
- Real(Kind=jprb) :: zcldem_tl(nlevels, nchannels)
- Real(Kind=jprb) :: zeffem_tl(nlevels, nchannels)
-
- Real(Kind=jprb) :: value
-
- !- End of header --------------------------------------------------------
-
- !All input NWP profiles have the same number of levels
-
- radiance % cs_wtoa(:) = 0._JPRB
- radiance % cs_wsurf(:) = 0._JPRB
- radiance % wtoa(:,:) = 0._JPRB
- radiance % wsurf(:,:) = 0._JPRB
- radiance_tl % cs_wtoa(:) = 0._JPRB
- radiance_tl % cs_wsurf(:) = 0._JPRB
- radiance_tl % wtoa(:,:) = 0._JPRB
- radiance_tl % wsurf(:,:) = 0._JPRB
-
-
- Do jk = 1, nlevels
- Do jl = 1, nchannels
- freq = polarisations(jl,2)
- idp = lprofiles(freq)
-
- value = radiance % cldemis(jk,jl)
- If( value > (unity-repclc) ) Then
- zcldem(jk,jl) = unity - repclc
- zcldem_tl(jk,jl) = 0._JPRB
- Else If( value < repclc ) Then
- zcldem(jk,jl) = repclc
- zcldem_tl(jk,jl) = 0._JPRB
- Else
- zcldem(jk,jl) = value
- zcldem_tl(jk,jl) = radiance_tl % cldemis(jk,jl)
- Endif
-
-
- value = profiles(idp)%cc(jk)
- If( value > (unity-repclc) ) Then
- zcldfr(jk,jl) = unity - repclc
- zcldfr_tl(jk,jl) = 0._JPRB
- Else If( value < repclc ) Then
- zcldfr(jk,jl) = repclc
- zcldfr_tl(jk,jl) = 0._JPRB
- Else
- zcldfr(jk,jl) = value
- zcldfr_tl(jk,jl) = profiles_tl(idp)%cc(jk)
- Endif
-
-
- value = radiance % cldemis(jk,jl) * profiles(idp)%cc(jk)
- If( value > (unity-repclc) ) Then
- zeffem(jk,jl) = unity - repclc
- zeffem_tl(jk,jl) = 0._JPRB
- Else If( value < repclc ) Then
- zeffem(jk,jl) = repclc
- zeffem_tl(jk,jl) = 0._JPRB
- Else
- zeffem(jk,jl) = value
- zeffem_tl(jk,jl) = radiance_tl % cldemis(jk,jl) * profiles(idp)%cc(jk) +&
- & radiance % cldemis(jk,jl) * profiles_tl(idp)%cc(jk)
- Endif
-
- End Do
- End Do
-
- !----------------------------------------
- !
- ! Effect of cloudiness on toa radiances
- !
- ! Cloud cover matrix
- !
- ! zclm(jk2) is the obscuration factor by cloud layers between
- ! half-levels jk1 and jk2 as seen from jk1
- ! jk1 is the top of the atmosphere (toa)
- !
-
- jk1 = 1 ! level of top of the atmosphere
-
- zclm(:,:) = 0._JPRB
- zclear(:) = 1._JPRB
- zcloud(:) = 0._JPRB
- zcont(:) = zeffem(jk1,:)
-
- zclm_tl(:,:) = 0._JPRB
- zclear_tl(:) = 0._JPRB
- zcloud_tl(:) = 0._JPRB
- zcont_tl(:) = zeffem_tl(jk1,:)
-
- zsum(:) = zcont(:)
- zclm(jk1+1,:) = zsum(:)
-
- zsum_tl(:) = zcont_tl(:)
- zclm_tl(jk1+1,:) = zsum_tl(:)
-
- If (overlap_scheme == 1) Then
- !* maximum-random (Geleyn and Hollingsworth 1979)
- Do jk = jk1 , nlevels ! layer loop
- Do jl = 1,nchannels
- If( zeffem(jk,jl) > zcloud(jl) ) Then
- znum = zclear(jl) * (unity-zeffem(jk,jl))
- znum_tl = zclear_tl(jl) * (unity-zeffem(jk,jl)) -&
- & zclear(jl) * zeffem_tl(jk,jl)
- Else
- znum = zclear(jl) * (unity-zcloud(jl))
- znum_tl = zclear_tl(jl) * (unity-zcloud(jl)) -&
- & zclear(jl) * zcloud_tl(jl)
- End If
- If ( zcloud(jl) > unity-repclc ) Then
- zden = repclc
- zden_tl = 0._JPRB
- Else
- zden = unity - zcloud(jl)
- zden_tl = -zcloud_tl(jl)
- Endif
-
- zclear(jl) = znum / zden
- zclear_tl(jl) = (znum_tl * zden - znum * zden_tl) / zden**2
-
- zclm(jk+1,jl) = 1._JPRB - zclear(jl)
- zclm_tl(jk+1,jl) = -zclear_tl(jl)
-
- zcloud(jl) = zeffem(jk,jl)
- zcloud_tl(jl) = zeffem_tl(jk,jl)
- End Do
- End Do
-
- Else If (overlap_scheme == 2) Then
- !* maximum-random (Raisanen 1998)
- Do jk = jk1 + 1 , nlevels ! layer loop
- Do jl = 1,nchannels
- znum = zcont(jl)
- znum_tl = zcont_tl(jl)
- zden = zeffem(jk-1,jl)
- zden_tl = zeffem_tl(jk-1,jl)
- ztr1 = znum / zden
- ztr1_tl = (znum_tl * zden - znum * zden_tl) / zden**2
-
- znum = 1._JPRB-(zsum(jl)-zcont(jl))-ztr1*zcldfr(jk-1,jl)
- znum_tl = -zsum_tl(jl) + zcont_tl(jl) - &
- & ztr1_tl*zcldfr(jk-1,jl) - ztr1*zcldfr_tl(jk-1,jl)
- zden = (1._JPRB-zcldfr(jk-1,jl))
- zden_tl = -zcldfr_tl(jk-1,jl)
- ztr2 = znum / zden
- ztr2_tl = (znum_tl * zden - znum * zden_tl) / zden**2
-
- If( zcldfr(jk,jl) > zcldfr(jk-1,jl) ) Then
- zcadj = zcldfr(jk-1,jl)
- zcadj_tl = zcldfr_tl(jk-1,jl)
- Else
- zcadj = zcldfr(jk,jl)
- zcadj_tl = zcldfr_tl(jk,jl)
- End If
-
- zcont(jl) = zcldem(jk,jl)*(zcadj*(1._JPRB-zcldem(jk-1,jl))*ztr1 &
- & +(zcldfr(jk,jl)-zcadj)*ztr2)
- zcont_tl(jl) =&
- & zcldem_tl(jk,jl)*(zcadj*(1._JPRB-zcldem(jk-1,jl))*ztr1 + &
- & (zcldfr(jk,jl)-zcadj)*ztr2) + &
- & zcldem(jk,jl)*&
- & ( zcadj_tl*(1._JPRB-zcldem(jk-1,jl))*ztr1 - &
- & zcadj * zcldem_tl(jk-1,jl) *ztr1 + &
- & zcadj *(1._JPRB-zcldem(jk-1,jl))*ztr1_tl + &
- & (zcldfr_tl(jk,jl)-zcadj_tl)*ztr2 + &
- & (zcldfr(jk,jl) -zcadj )*ztr2_tl )
-
- zsum(jl) = zsum(jl) + zcont(jl)
- zsum_tl(jl) = zsum_tl(jl) + zcont_tl(jl)
-
- zclm(jk+1,jl) = zsum(jl)
- zclm_tl(jk+1,jl) = zsum_tl(jl)
- Enddo
- Enddo
- Endif
-
- ! Weight computation
- !
-
- ! Contribution from clear-sky fraction
- radiance % cs_wtoa(:) = 1._JPRB - zclm(nlevels+1,:)
- radiance_tl % cs_wtoa(:) = - zclm_tl(nlevels+1,:)
-
-!!$ Do jl = 1,nchannels
-!!$ radiance % cs_wtoa(jl) = 1. - zclm(nlevels+1,jl)
-!!$ Enddo
-
- ! Contribution from cloudy layers
- Do jk = jk1, nlevels ! layer loop
- radiance % wtoa( jk, : ) = zclm(jk+1,:) - zclm(jk,:)
- radiance_tl % wtoa( jk, : ) = zclm_tl(jk+1,:) - zclm_tl(jk,:)
-!!$ Do jl = 1,nchannels
-!!$ radiance % wtoa( jk, jl ) = zclm(jk+1,jl) - zclm(jk,jl)
-!!$ End Do
- End Do
-
- !----------------------------------------
- !
- ! Effect of cloudiness on surface radiances
- !
-
- !
- ! Cloud cover matrix
- !
- ! zclm(jk) is now the obscuration factor by cloud layers between
- ! surface and jk as seen from the surface
- !
-
- zclm(:,:) = 0._JPRB
- zcloud(:) = 0._JPRB
- zclear(:) = 1._JPRB
- zcont(:) = zeffem(nlevels,:)
- zsum(:) = zcont(:)
- zclm(nlevels,:) = zsum(:)
-
- zclm_tl(:,:) = 0._JPRB
- zcloud_tl(:) = 0._JPRB
- zclear_tl(:) = 0._JPRB
- zcont_tl(:) = zeffem_tl(nlevels,:)
- zsum_tl(:) = zcont_tl(:)
- zclm_tl(nlevels,:) = zsum_tl(:)
-
- If (overlap_scheme == 1) Then
- !* maximum-random (Geleyn and Hollingsworth 1979)
- Do jk = nlevels, 1, -1 ! layer loop
- Do jl = 1,nchannels
- If( zeffem(jk,jl) > zcloud(jl) ) Then
- znum = zclear(jl)*(1._JPRB-zeffem(jk,jl))
- znum_tl = zclear_tl(jl) -zeffem_tl(jk,jl)
- Else
- znum = zclear(jl)*(1._JPRB-zcloud(jl))
- znum_tl = zclear_tl(jl) - zcloud(jl)
- End If
-
- If ( zcloud(jl) > unity-repclc ) Then
- zden = repclc
- zden_tl = 0._JPRB
- Else
- zden = 1._JPRB - zcloud(jl)
- zden_tl = - zcloud_tl(jl)
- End If
- zclear(jl) = znum / zden
- zclear_tl(jl) = (znum_tl * zden - znum * zden_tl) / zden**2
-
- zclm(jk,jl) = 1._JPRB - zclear(jl)
- zclm_tl(jk,jl) = - zclear_tl(jl)
-
- zcloud(jl) = zeffem(jk,jl)
- zcloud_tl(jl) = zeffem_tl(jk,jl)
- End Do
- End Do
-
- Else If (overlap_scheme == 2) Then
- !* maximum-random (Raisanen 1998)
- Do jk = nlevels - 1, 1, -1 ! layer loop
- Do jl = 1,nchannels
- znum = zcont(jl)
- znum_tl = zcont_tl(jl)
- zden = zeffem(jk+1,jl)
- zden_tl = zeffem_tl(jk+1,jl)
- ztr1 = znum / zden
- ztr1_tl = (znum_tl * zden - znum * zden_tl) / zden**2
-
-
-
- znum = 1._JPRB-(zsum(jl)-zcont(jl))-ztr1*zcldfr(jk+1,jl)
- znum_tl = -zsum_tl(jl) + zcont_tl(jl) - &
- & ztr1_tl*zcldfr(jk+1,jl) - ztr1*zcldfr_tl(jk+1,jl)
- zden = (1._JPRB-zcldfr(jk+1,jl))
- zden_tl = -zcldfr_tl(jk+1,jl)
- ztr2 = znum / zden
- ztr2_tl = (znum_tl * zden - znum * zden_tl) / zden**2
-
- If( zcldfr(jk,jl) > zcldfr(jk+1,jl) ) Then
- zcadj = zcldfr(jk+1,jl)
- zcadj_tl = zcldfr_tl(jk+1,jl)
- Else
- zcadj = zcldfr(jk,jl)
- zcadj_tl = zcldfr_tl(jk,jl)
- End If
-
- zcont(jl) = zcldem(jk,jl)*(zcadj*(1._JPRB-zcldem(jk+1,jl))*ztr1 &
- & +(zcldfr(jk,jl)-zcadj)*ztr2)
- zcont_tl(jl) =&
- & zcldem_tl(jk,jl)*(zcadj*(1._JPRB-zcldem(jk+1,jl))*ztr1 +&
- & (zcldfr(jk,jl)-zcadj)*ztr2) +&
- & zcldem(jk,jl)*&
- & ( zcadj_tl*(1._JPRB-zcldem(jk+1,jl))*ztr1 - &
- & zcadj * zcldem_tl(jk+1,jl) *ztr1 + &
- & zcadj *(1._JPRB-zcldem(jk+1,jl))*ztr1_tl + &
- & (zcldfr_tl(jk,jl)-zcadj_tl)*ztr2 + &
- & (zcldfr(jk,jl) -zcadj )*ztr2_tl )
-
-
- zsum(jl) = zsum(jl) + zcont(jl)
- zsum_tl(jl) = zsum_tl(jl) + zcont_tl(jl)
-
- zclm(jk,jl) = zsum(jl)
- zclm_tl(jk,jl) = zsum_tl(jl)
-
- End Do
- End Do
- End If
-
- ! Weight computation
- !
-
- ! Contribution from clear-sky fraction
-
- radiance % cs_wsurf(:) = 1._JPRB - zclm(1,:)
- radiance_tl % cs_wsurf(:) = - zclm_tl(1,:)
-
- ! Contribution from cloudy layers
-
- Do jk = 1, nlevels ! layer loop
- radiance % wsurf( jk, : ) = zclm(jk,:) - zclm(jk+1,:)
- radiance_tl % wsurf( jk, : ) = zclm_tl(jk,:) - zclm_tl(jk+1,:)
- Enddo
-
-End Subroutine Rttov_aitosu_tl
diff --git a/src/LIB/RTTOV/src/rttov_aitosu_tl.interface b/src/LIB/RTTOV/src/rttov_aitosu_tl.interface
deleted file mode 100644
index 167e8b7c2506b10bb4bd6e2e884bc04ab252a336..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_aitosu_tl.interface
+++ /dev/null
@@ -1,37 +0,0 @@
-Interface
-Subroutine rttov_aitosu_tl( &
- & nfrequencies, & ! in
- & nchannels, & ! in
- & nprofiles, & ! in
- & nlevels, & ! in
- & polarisations, & ! in
- & lprofiles, & ! in
- & overlap_scheme, & ! in
- & profiles, & ! in (cloud cover)
- & profiles_tl, & ! in (cloud cover)
- & radiance , & ! inout (cldemis input and
- & radiance_tl ) ! inout cs_wtao, cs_wsurf, wtao, wsurf in output)
-
- Use rttov_types, Only : &
- profile_cloud_Type ,&
- radiance_cloud_Type
-
- Use parkind1, Only : jpim ,jprb
- Implicit none
-
- Integer(Kind=jpim), Intent(in) :: nfrequencies
- Integer(Kind=jpim), Intent(in) :: nchannels
- Integer(Kind=jpim), Intent(in) :: nprofiles
- Integer(Kind=jpim), Intent(in) :: nlevels
- Integer(Kind=jpim), Intent(in) :: lprofiles(nfrequencies)
- Integer(Kind=jpim), Intent(in) :: polarisations(nchannels,3)
- Integer(Kind=jpim), Intent(in) :: overlap_scheme
- Type(profile_cloud_Type), Intent(in) :: profiles(nprofiles)
- Type(radiance_cloud_Type), Intent(inout) :: radiance
-
- Type(profile_cloud_Type), Intent(in) :: profiles_tl(nprofiles)
- Type(radiance_cloud_Type), Intent(inout) :: radiance_tl
-
-
-End Subroutine Rttov_aitosu_tl
-End Interface
diff --git a/src/LIB/RTTOV/src/rttov_ascii2bin_coef.F90 b/src/LIB/RTTOV/src/rttov_ascii2bin_coef.F90
deleted file mode 100644
index 3457b7dcb419a8fe279fe7883343c7673eed9357..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_ascii2bin_coef.F90
+++ /dev/null
@@ -1,104 +0,0 @@
-!
-Program rttov_ascii2bin_coef
- ! Description:
- ! converts an ascii RTTOV coefficient file to binary format
- !
- ! Copyright:
- ! This software was developed within the context of
- ! the EUMETSAT Satellite Application Facility on
- ! Numerical Weather Prediction (NWP SAF), under the
- ! Cooperation Agreement dated 25 November 1998, between
- ! EUMETSAT and the Met Office, UK, by one or more partners
- ! within the NWP SAF. The partners in the NWP SAF are
- ! the Met Office, ECMWF, KNMI and MeteoFrance.
- !
- ! Copyright 2002, EUMETSAT, All Rights Reserved.
- !
- ! Method:
- !
- ! Current Code Owner: SAF NWP
- !
- ! History:
- ! Version Date Comment
- ! ------- ---- -------
- ! 1.0 01/12/2002 New F90 code with structures (P Brunel A Smith)
- !
- ! Code Description:
- ! Language: Fortran 90.
- ! Software Standards: "European Standards for Writing and
- ! Documenting Exchangeable Fortran 90 Code".
- !
- ! Declarations:
- ! Modules used:
- ! Imported Type Definitions:
- Use rttov_types, Only : &
- & rttov_coef
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
-#include "rttov_coeffname.interface"
-#include "rttov_opencoeff.interface"
-#include "rttov_readcoeffs.interface"
-#include "rttov_initcoeffs.interface"
-#include "rttov_writecoef.interface"
-
- ! Local variables
- !-------------------
- ! coeffiecnt structure
- Type( rttov_coef ) :: coef ! coefficients
-
- ! Instrument triplet for "classical" creation of coefficient filename
- Integer(Kind=jpim) :: instrument(3)
- ! Logical units for input/output
- Integer(Kind=jpim) :: file_id
- ! error return code for subroutines
- Integer(Kind=jpim) :: errorstatus
- ! character string for file name
- Character(len=128) :: coeffname
- ! number of channels to prosess
- Integer(Kind=jpim) :: nchannels
- Integer(Kind=jpim), Pointer :: channels(:)
-
- !- End of header --------------------------------------------------------
-
- ! let the subroutine choose a logical unit for the file
- file_id = 0
-
- Write(*,*) 'enter platform, satid, instrument'
- Read(*,*) instrument
- Write(*,*) 'enter the number of channels (0 for all) '
- Read(*,*) nchannels
- If( nchannels /= 0 ) Then
- Write(*,*) 'enter a list of channels '
- Allocate ( channels( nchannels ) )
- Read(*,*) channels(:)
- Endif
-
- ! get the file name from instrument triplet
- Call rttov_coeffname ( errorstatus, instrument, coeffname)
- Write(*,*) 'ASCII coefficient file ',coeffname
- ! open the file in ASCII mode
- Call rttov_opencoeff (errorstatus, coeffname, file_id)
- ! read the coefficients for all channels
- If ( nchannels /= 0 ) Then
- Call rttov_readcoeffs (errorstatus, coef, file_id = file_id, channels = channels)
- Call rttov_initcoeffs (errorstatus, coef)
- Else
- Call rttov_readcoeffs (errorstatus, coef, file_id = file_id)
- Call rttov_initcoeffs (errorstatus, coef)
- Endif
- Close ( unit = file_id )
-
-
- ! get the binary file name from instrument triplet
- ! open, write and close
- Call rttov_coeffname ( errorstatus, instrument, coeffname, lbinary=.True.)
- Write(*,*) 'Binary coefficient file ',coeffname
- Call rttov_opencoeff (errorstatus, coeffname, file_id, for_output=.True., lbinary=.True.)
- Call Rttov_writecoef (errorstatus, coef, file_id, lbinary=.True.)
- Close ( unit = file_id )
-
-
- Stop
-End Program rttov_ascii2bin_coef
diff --git a/src/LIB/RTTOV/src/rttov_boundaryconditions.F90 b/src/LIB/RTTOV/src/rttov_boundaryconditions.F90
deleted file mode 100644
index e6bd44ff248bc531f2f80ffb69f626642d5a66e5..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_boundaryconditions.F90
+++ /dev/null
@@ -1,212 +0,0 @@
-!
-Subroutine rttov_boundaryconditions (&
- & nwp_levels, &! in
- & nchannels, &! in
- & nprofiles, &! in
- & lprofiles, &! in
- & scatt_aux, &! in
- & profiles , &! in
- & ftop, &! in
- & dp, &! out
- & dm) ! out
-
-
- ! Description:
- ! to compute boundary conditions for Eddington approximation to RT
- !
- ! Copyright:
- ! This software was developed within the context of
- ! the EUMETSAT Satellite Application Facility on
- ! Numerical Weather Prediction (NWP SAF), under the
- ! Cooperation Agreement dated 25 November 1998, between
- ! EUMETSAT and the Met Office, UK, by one or more partners
- ! within the NWP SAF. The partners in the NWP SAF are
- ! the Met Office, ECMWF, KNMI and MeteoFrance.
- !
- ! Copyright 2002, EUMETSAT, All Rights Reserved.
- !
- ! Method:
- ! - Bauer, P., 2002: Microwave radiative transfer modeling in clouds and precipitation.
- ! Part I: Model description.
- ! NWP SAF Report No. NWPSAF-EC-TR-005, 27 pp.
- ! - Chevallier, F., and P. Bauer, 2003:
- ! Model rain and clouds over oceans: comparison with SSM/I observations.
- ! Mon. Wea. Rev., 131, 1240-1255.
- ! - Moreau, E., P. Bauer and F. Chevallier, 2002: Microwave radiative transfer modeling in clouds and precipitation.
- ! Part II: Model evaluation.
- ! NWP SAF Report No. NWPSAF-EC-TR-006, 27 pp.
- !
- ! Current Code Owner: SAF NWP
- !
- ! History:
- ! Version Date Comment
- ! ------- ---- -------
- ! 1.0 09/2002 Initial version (P. Bauer, E. Moreau)
- ! 1.1 05/2003 RTTOV7.3 compatible (F. Chevallier)
- ! 1.2 03/2004 Added polarimetry (R. Saunders)
- ! 1.3 08/2004 Polarimetry fixes (U. O'Keefe)
- ! 1.4 11/2004 Clean-up (P. Bauer)
- !
- ! Code Description:
- ! Language: Fortran 90.
- ! Software Standards: "European Standards for Writing and
- ! Documenting Exchangeable Fortran 90 Code".
- !
- ! Declarations:
- ! Modules used:
- ! Imported Type Definitions:
-
- Use rttov_types, Only : &
- & profile_Type ,&
- & profile_scatt_aux
-
- Use parkind1, Only : jpim ,jprb
-
- Implicit none
-
-!* Subroutine arguments:
- Integer (Kind=jpim), Intent (in) :: nwp_levels ! Number of levels
- Integer (Kind=jpim), Intent (in) :: nprofiles ! Number of profiles
- Integer (Kind=jpim), Intent (in) :: nchannels ! Number of radiances
- Integer (Kind=jpim), Intent (in) :: lprofiles (nchannels) ! Profile indices
-
- Type (profile_scatt_aux), Intent (in) :: scatt_aux ! Auxiliary profile variables for RTTOV_SCATT
- Type (profile_Type) , Intent (in) :: profiles (nprofiles) ! Profiles on RTTOV levels
-
- Real (Kind=jprb), Intent (in), dimension (nchannels) :: ftop ! Downward radiances at cloud top
- Real (Kind=jprb), Intent (out), dimension (nchannels,nwp_levels) :: dp, dm ! Coefficients from boundary conditions
-
-!* Local variables
- Real (Kind=jprb), dimension (nchannels,nwp_levels) :: lh_p, lh_m, bh
- Real (Kind=jprb), allocatable :: a (:,:), b (:), dx (:)
- Real (Kind=jprb) :: ztmp
- Integer (Kind=jpim) :: ilayer, jlayer, klayer, ilin, icol
- Integer (Kind=jpim) :: ndim, iprof, ichan, jj, ii, mcly
-
-!* Lapack/ESSL
- Real (Kind=jprb), allocatable :: ab (:,:)
- Integer (Kind=jpim), allocatable :: ipiv (:)
- Integer (Kind=jpim) :: kl, ku, ldab, info, nrhs
- Character (len=1) :: trans
- Logical :: ll_essl
-
- !- End of header --------------------------------------------------------
-
-!* Init Math related variables
- ll_essl = .false.
-
- kl = 2
- ku = 2
- if (ll_essl) then
- ldab = 2 * kl + ku + 16
- else
- ldab = 2 * kl + ku + 1
- endif
- trans = 'N'
- nrhs = 1
- info = 0
-
-!* Reset
- dp (:,:) = 0.0_JPRB
- dm (:,:) = 0.0_JPRB
-
-!* Channels * Profiles
- do ichan = 1, nchannels
- iprof = lprofiles (ichan)
-
- bh (ichan,:) = scatt_aux % b1 (iprof,:) / scatt_aux % h (ichan,:)
- lh_p (ichan,:) = (1.0_JPRB + scatt_aux % lambda (ichan,:) / scatt_aux % h (ichan,:))
- lh_m (ichan,:) = (1.0_JPRB - scatt_aux % lambda (ichan,:) / scatt_aux % h (ichan,:))
-
- mcly = scatt_aux % mclayer (ichan)
-
- ndim = 2 * (nwp_levels - mcly + 1)
-
- allocate (a (ndim,ndim))
- allocate (b (ndim ))
- allocate (dx (ndim ))
- allocate (ab (ldab,ndim))
- allocate (ipiv (ndim ))
-
- a (:,:) = 0.0_JPRB
- b (: ) = 0.0_JPRB
- ab (:,:) = 0.0_JPRB
- ipiv (:) = 0
-
- do ilayer = 2, ndim - 2, 2
- jlayer = nwp_levels - ilayer / 2 + 1
- klayer = jlayer - 1
-
- ilin = ilayer
- icol = ilayer - 1
-
- ztmp = exp (scatt_aux % lambda (ichan,jlayer) * scatt_aux % dz (iprof,jlayer))
-
-!* From downward fluxes at i-th interface (@ level=dz for jlayer == level=0 for klayer)
- a (ilin ,icol ) = lh_p (ichan,jlayer) * ztmp
- a (ilin ,icol+1) = lh_m (ichan,jlayer) / ztmp
- a (ilin ,icol+2) = -1.0_JPRB * lh_p (ichan,klayer)
- a (ilin ,icol+3) = -1.0_JPRB * lh_m (ichan,klayer)
-
- b (ilin ) = bh (ichan,klayer) - bh (ichan,jlayer)
-
-!* From upward fluxes at i-th interface (@ level=dz for jlayer == level=0 for klayer)
- a (ilin+1,icol ) = lh_m (ichan,jlayer) * ztmp
- a (ilin+1,icol+1) = lh_p (ichan,jlayer) / ztmp
- a (ilin+1,icol+2) = -1.0_JPRB * lh_m (ichan,klayer)
- a (ilin+1,icol+3) = -1.0_JPRB * lh_p (ichan,klayer)
-
- b (ilin+1) = bh (ichan,jlayer) - bh (ichan,klayer)
- end do
-
-!* From boundary conditions at bottom of the atmosphere with r_sfc=1-e_sfc
- ztmp = (2.0_JPRB - scatt_aux % ems_bnd (ichan)) * scatt_aux % lambda (ichan,nwp_levels) / scatt_aux % h (ichan,nwp_levels)
-
- a (1,1) = scatt_aux % ems_bnd (ichan) - ztmp
- a (1,2) = scatt_aux % ems_bnd (ichan) + ztmp
-
- b (1) = scatt_aux % ems_bnd (ichan) * (profiles (iprof) % skin % t - scatt_aux % b0 (iprof,nwp_levels)) &
- & + (2.0_JPRB - scatt_aux % ems_bnd (ichan)) * bh (ichan,nwp_levels)
-
-!* From boundary conditions at top of the atmosphere
- ztmp = exp (scatt_aux % lambda (ichan,mcly) * scatt_aux % dz (iprof,mcly))
-
- a (ndim,ndim-1) = lh_p (ichan,mcly) * ztmp
- a (ndim,ndim ) = lh_m (ichan,mcly) / ztmp
-
- b (ndim) = ftop (ichan) - scatt_aux % bn (iprof,mcly) - bh (ichan,mcly)
-
-!* Solve equations A * DX = B
- do jj = 1, ndim
- do ii = max(1,jj-ku), min(ndim,jj+kl)
- ab (kl+ku+ii-jj+1,jj) = a (ii,jj)
- end do
- end do
-
-! if (ll_essl) then
-! call dgbf (ab, ldab, ndim, kl, ku, ipiv)
-! else
- call dgbtrf (ndim, ndim, kl, ku, ab, ldab, ipiv, info)
-! endif
- if (info /= 0) write (*,*) ' DGBTRF boundary_conditions: ', info
-
- dx (:) = b (:)
-! if (ll_essl) then
-! call dgbs (ab, ldab, ndim, kl, ku, ipiv, dx)
-! else
- call dgbtrs (trans, ndim, kl, ku, nrhs, ab, ldab, ipiv, dx, ndim, info)
-! endif
- if (info /= 0) write (*,*) ' DGBTRS boundary_conditions: ', info
-
-!* Decompose D+ and D-
- do ilayer = 2, ndim, 2
- jlayer = nwp_levels - ilayer / 2 + 1
-
- dp (ichan,jlayer) = dx (ilayer-1)
- dm (ichan,jlayer) = dx (ilayer )
- end do
-
- deallocate (a, b, dx, ab, ipiv)
- end do
-
-End subroutine rttov_boundaryconditions
diff --git a/src/LIB/RTTOV/src/rttov_boundaryconditions.interface b/src/LIB/RTTOV/src/rttov_boundaryconditions.interface
deleted file mode 100644
index ffc2965906f9361ed8e98a5c3176907f999cd2e8..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_boundaryconditions.interface
+++ /dev/null
@@ -1,25 +0,0 @@
-INTERFACE
-Subroutine rttov_boundaryconditions (&
- & nwp_levels,&
- & nchannels,&
- & nprofiles,&
- & lprofiles,&
- & scatt_aux,&
- & profiles ,&
- & ftop,&
- & dp,&
- & dm)
- Use rttov_types, Only :&
- & profile_Type ,&
- & profile_scatt_aux
- Use parkind1, Only : jpim ,jprb
- Integer (Kind=jpim), Intent (in) :: nwp_levels
- Integer (Kind=jpim), Intent (in) :: nprofiles
- Integer (Kind=jpim), Intent (in) :: nchannels
- Integer (Kind=jpim), Intent (in) :: lprofiles (nchannels)
- Type (profile_scatt_aux), Intent (in) :: scatt_aux
- Type (profile_Type) , Intent (in) :: profiles (nprofiles)
- Real (Kind=jprb), Intent (in), dimension (nchannels) :: ftop
- Real (Kind=jprb), Intent (out), dimension (nchannels,nwp_levels) :: dp, dm
-End subroutine rttov_boundaryconditions
-END INTERFACE
diff --git a/src/LIB/RTTOV/src/rttov_boundaryconditions_ad.F90 b/src/LIB/RTTOV/src/rttov_boundaryconditions_ad.F90
deleted file mode 100644
index 05812dbed5962f41b657b2bd1405ce89340d45da..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_boundaryconditions_ad.F90
+++ /dev/null
@@ -1,403 +0,0 @@
-!
-Subroutine rttov_boundaryconditions_ad (&
- & nwp_levels, &! in
- & nchannels, &! in
- & nprofiles, &! in
- & lprofiles, &! in
- & scatt_aux, &! in
- & scatt_aux_ad, &! inout
- & profiles , &! in
- & profiles_ad , &! inout
- & ftop, &! in
- & ftop_ad, &! inout
- & dp, &! out
- & dp_ad, &! inout
- & dm, &! out
- & dm_ad) ! inout
-
-
- ! Description:
- ! to compute boundary conditions for Eddington approximation to RT
- !
- ! Copyright:
- ! This software was developed within the context of
- ! the EUMETSAT Satellite Application Facility on
- ! Numerical Weather Prediction (NWP SAF), under the
- ! Cooperation Agreement dated 25 November 1998, between
- ! EUMETSAT and the Met Office, UK, by one or more partners
- ! within the NWP SAF. The partners in the NWP SAF are
- ! the Met Office, ECMWF, KNMI and MeteoFrance.
- !
- ! Copyright 2002, EUMETSAT, All Rights Reserved.
- !
- ! Method:
- ! - Bauer, P., 2002: Microwave radiative transfer modeling in clouds and precipitation.
- ! Part I: Model description.
- ! NWP SAF Report No. NWPSAF-EC-TR-005, 27 pp.
- ! - Chevallier, F., and P. Bauer, 2003:
- ! Model rain and clouds over oceans: comparison with SSM/I observations.
- ! Mon. Wea. Rev., 131, 1240-1255.
- ! - Moreau, E., P. Bauer and F. Chevallier, 2002: Microwave radiative transfer modeling in clouds and precipitation.
- ! Part II: Model evaluation.
- ! NWP SAF Report No. NWPSAF-EC-TR-006, 27 pp.
- !
- ! Current Code Owner: SAF NWP
- !
- ! History:
- ! Version Date Comment
- ! ------- ---- -------
- ! 1.0 09/2002 Initial version (E. Moreau)
- ! 1.1 05/2003 RTTOV7.3 compatible (F. Chevallier)
- ! 1.2 03/2004 Added polarimetry (R. Saunders)
- ! 1.3 08/2004 Polarimetry fixes (U. O'Keefe)
- ! 1.4 11/2004 Clean-up (P. Bauer)
- !
- ! Code Description:
- ! Language: Fortran 90.
- ! Software Standards: "European Standards for Writing and
- ! Documenting Exchangeable Fortran 90 Code".
- !
- ! Declarationsta:
- ! Modules used:
- ! Imported Type Definitions:
-
- Use rttov_types, Only : &
- & profile_Type ,&
- & profile_scatt_aux
-
- Use parkind1, Only : jpim ,jprb
-
- Implicit none
-
-!* Subroutine arguments:
- Integer (Kind=jpim), Intent (in) :: nwp_levels ! Number of levels
- Integer (Kind=jpim), Intent (in) :: nprofiles ! Number of profiles
- Integer (Kind=jpim), Intent (in) :: nchannels ! Number of radiances
- Integer (Kind=jpim), Intent (in) :: lprofiles (nchannels) ! Profile indices
-
- Type (profile_scatt_aux), Intent (in) :: scatt_aux ! Auxiliary profile variables for RTTOV_SCATT
- Type (profile_scatt_aux), Intent (inout) :: scatt_aux_ad ! Auxiliary profile variables for RTTOV_SCATT
- Type (profile_Type), Intent (in) :: profiles (nprofiles) ! Profiles on RTTOV levels
- Type (profile_Type), Intent (inout) :: profiles_ad (nprofiles) ! Profiles on RTTOV levels
-
- Real (Kind=jprb), Intent (in), dimension (nchannels) :: ftop
- Real (Kind=jprb), Intent (inout), dimension (nchannels) :: ftop_ad
- Real (Kind=jprb), Intent (out), dimension (nchannels,nwp_levels) :: dp , dm
- Real (Kind=jprb), Intent (inout), dimension (nchannels,nwp_levels) :: dp_ad, dm_ad
-
-!* Local variables
- Real (Kind=jprb), dimension (nchannels,nwp_levels) :: lh_p , lh_m , bh
- Real (Kind=jprb), dimension (nchannels,nwp_levels) :: lh_p_ad, lh_m_ad, bh_ad
- Real (Kind=jprb), allocatable :: a (:,:), b (:), dx (:), ta(:,:)
- Real (Kind=jprb), allocatable :: a_ad (:,:), b_ad (:), dx_ad (:)
- Real (Kind=jprb) :: ztmp, ztmp_ad
- Integer (Kind=jpim) :: ilayer, jlayer, klayer, ilin, icol
- Integer (Kind=jpim) :: ndim, iprof, ichan, jj, ii, mcly
-
-!* Lapack/ESSL
- Real (Kind=jprb), allocatable :: ab (:,:)
- Integer (Kind=jpim), allocatable :: ipiv (:)
- Integer (Kind=jpim) :: kl, ku, ldab, info, nrhs
- Character (len=1) :: trans
- Logical :: ll_essl
-
- !- End of header --------------------------------------------------------
-
-!* Init Math related variables
- ll_essl = .false.
-
- kl = 2
- ku = 2
- if (ll_essl) then
- ldab = 2 * kl + ku + 16
- else
- ldab = 2 * kl + ku + 1
- endif
- trans = 'N'
- nrhs = 1
- info = 0
-
-!* FORWARD PART
-!* Reset
- dp (:,:) = 0.0_JPRB
- dm (:,:) = 0.0_JPRB
-
- lh_p_ad = 0.0_JPRB
- lh_m_ad = 0.0_JPRB
- bh_ad = 0.0_JPRB
-
-!* Channels * Profiles
- do ichan = 1, nchannels
- iprof = lprofiles (ichan)
-
- bh (ichan,:) = scatt_aux % b1 (iprof,:) / scatt_aux % h (ichan,:)
- lh_p (ichan,:) = (1.0_JPRB + scatt_aux % lambda (ichan,:) / scatt_aux % h (ichan,:))
- lh_m (ichan,:) = (1.0_JPRB - scatt_aux % lambda (ichan,:) / scatt_aux % h (ichan,:))
-
- mcly = scatt_aux % mclayer (ichan)
-
- ndim = 2 * (nwp_levels - mcly + 1)
-
- allocate (a (ndim,ndim))
- allocate (b (ndim ))
- allocate (dx (ndim ))
- allocate (ta (ndim,ndim))
- allocate (ab (ldab,ndim))
- allocate (ipiv (ndim ))
-
- a (:,:) = 0.0_JPRB
- b (: ) = 0.0_JPRB
- ab (:,:) = 0.0_JPRB
- ta (:,:) = 0.0_JPRB
- ipiv (:) = 0
-
- do ilayer = 2, ndim - 2, 2
- jlayer = nwp_levels - ilayer / 2 + 1
- klayer = jlayer - 1
-
- ilin = ilayer
- icol = (ilayer - 1)
-
- ztmp = exp (scatt_aux % lambda (ichan,jlayer) * scatt_aux % dz (iprof,jlayer))
-
-!* From downward fluxes at i-th interface (@ level=dz for jlayer == level=0 for klayer)
- a (ilin ,icol ) = lh_p (ichan,jlayer) * ztmp
- a (ilin ,icol+1) = lh_m (ichan,jlayer) / ztmp
- a (ilin ,icol+2) = -1.0_JPRB * lh_p (ichan,klayer)
- a (ilin ,icol+3) = -1.0_JPRB * lh_m (ichan,klayer)
-
- b (ilin ) = bh (ichan,klayer) - bh (ichan,jlayer)
-
-!* From upward fluxes at i-th interface (@ level=dz for jlayer == level=0 for klayer)
- a (ilin+1,icol ) = lh_m (ichan,jlayer) * ztmp
- a (ilin+1,icol+1) = lh_p (ichan,jlayer) / ztmp
- a (ilin+1,icol+2) = -1.0_JPRB * lh_m (ichan,klayer)
- a (ilin+1,icol+3) = -1.0_JPRB * lh_p (ichan,klayer)
-
- b (ilin+1) = bh (ichan,jlayer) - bh (ichan,klayer)
- end do
-
-!* From boundary conditions at bottom of the atmosphere with r_sfc=1-e_sfc
- ztmp = (2.0_JPRB - scatt_aux % ems_bnd (ichan)) * scatt_aux % lambda (ichan,nwp_levels) / scatt_aux % h (ichan,nwp_levels)
-
- a (1,1) = scatt_aux % ems_bnd(ichan) - ztmp
- a (1,2) = scatt_aux % ems_bnd(ichan) + ztmp
-
- b (1) = scatt_aux % ems_bnd(ichan) * (profiles (iprof) % skin % t - scatt_aux % b0 (iprof,nwp_levels)) + &
- & (2.0_JPRB - scatt_aux % ems_bnd (ichan)) * bh (ichan,nwp_levels)
-
-!* From boundary conditions at top of the atmosphere
- ztmp = exp (scatt_aux % lambda (ichan,mcly) * scatt_aux % dz (iprof,mcly))
-
- a (ndim,ndim-1) = lh_p (ichan,mcly) * ztmp
- a (ndim,ndim ) = lh_m (ichan,mcly) / ztmp
-
- b (ndim) = ftop (ichan) - scatt_aux % bn (iprof,mcly) - bh (ichan,mcly)
-
-!* Solve equations A * DX = B
- do jj = 1, ndim
- do ii = max(1,jj-ku), min(ndim,jj+kl)
- ab (kl+ku+ii-jj+1,jj) = a (ii,jj)
- end do
- end do
-
-! if (ll_essl) then
-! call dgbf (ab, ldab, ndim, kl, ku, ipiv)
-! else
- call dgbtrf (ndim, ndim, kl, ku, ab, ldab, ipiv, info)
-! endif
- if (info /= 0) write (*,*) ' DGBTRF boundary_conditions: ', info
-
- dx (:) = b (:)
-! if (ll_essl) then
-! call dgbs (ab, ldab, ndim, kl, ku, ipiv, dx)
-! else
- call dgbtrs (trans, ndim, kl, ku, nrhs, ab, ldab, ipiv, dx, ndim, info)
-! endif
- if (info /= 0) write (*,*) ' DGBTRS boundary_conditions: ', info
-
-!* Decompose D+ and D-
- do ilayer = 2, ndim, 2
- jlayer = nwp_levels - ilayer / 2 + 1
-
- dp (ichan,jlayer) = dx (ilayer-1)
- dm (ichan,jlayer) = dx (ilayer )
- end do
-
-!* ADJOINT PART
- allocate (dx_ad (ndim ))
- dx_ad = 0.0_JPRB
- allocate (a_ad (ndim,ndim))
- a_ad = 0.0_JPRB
- allocate (b_ad (ndim ))
- b_ad = 0.0_JPRB
-
-!* Decompose D+ and D-
- do ilayer = 2, ndim, 2
- jlayer = nwp_levels - ilayer / 2 + 1
-
- dx_ad (ilayer ) = dx_ad (ilayer ) + dm_ad (ichan,jlayer)
- dx_ad (ilayer-1) = dx_ad (ilayer-1) + dp_ad (ichan,jlayer)
-
- dm_ad (ichan,jlayer) = 0.0_JPRB
- dp_ad (ichan,jlayer) = 0.0_JPRB
- end do
-
-!* Solve equations A * DX = B
- ta (1:ndim,1:ndim) = transpose (a (1:ndim,1:ndim))
- ab (:,:) = 0._JPRB
- ipiv (:) = 0
-
- do jj = 1, ndim
- do ii = max(1,jj-ku), min(ndim,jj+kl)
- ab (kl+ku+ii-jj+1,jj) = ta (ii,jj)
- end do
- end do
-
-! if (ll_essl) then
-! call dgbf (ab, ldab, ndim, kl, ku, ipiv)
-! else
- call dgbtrf (ndim, ndim, kl, ku, ab, ldab, ipiv, info)
-! endif
- if (info /= 0) write (*,*) ' DGBTRF boundary_conditions_ad_ad: ', info
-
- b_ad (:) = dx_ad (:)
-
-! if (ll_essl) then
-! call dgbs (ab, ldab, ndim, kl, ku, ipiv, b_ad)
-! else
- call dgbtrs (trans, ndim, kl, ku, nrhs, ab, ldab, ipiv, b_ad, ndim, info)
-! endif
- if (info /= 0) write (*,*) ' DGBTRS boundary_conditions:_ad_ad ', info
-
- deallocate (ab, ipiv)
-
- do ilayer = 1, ndim
- do jlayer = 1, ndim
- a_ad (ilayer,jlayer) = -1.0_JPRB * b_ad (ilayer) * dx (jlayer)
- enddo
- enddo
-
-!* From boundary conditions at top of the atmosphere
- ftop_ad (ichan) = ftop_ad (ichan) + b_ad (ndim)
- scatt_aux_ad % bn (iprof,mcly) = scatt_aux_ad % bn (iprof,mcly) - b_ad (ndim)
- bh_ad (ichan,mcly) = bh_ad (ichan,mcly) - b_ad (ndim)
- b_ad (ndim) = 0.0_JPRB
-
- ztmp_ad = -1.0_JPRB * a_ad(ndim,ndim) * lh_m (ichan,mcly) / ztmp / ztmp
- lh_m_ad (ichan,mcly) = lh_m_ad (ichan,mcly) + a_ad (ndim,ndim) / ztmp
- a_ad (ndim,ndim) = 0.0_JPRB
-
- ztmp_ad = ztmp_ad + a_ad (ndim,ndim-1) * lh_p (ichan,mcly)
- lh_p_ad (ichan,mcly) = lh_p_ad (ichan,mcly) + a_ad (ndim,ndim-1) * ztmp
- a_ad (ndim,ndim-1) = 0.0_JPRB
-
- scatt_aux_ad % lambda (ichan,mcly) = scatt_aux_ad % lambda (ichan,mcly) + ztmp_ad * scatt_aux % dz (iprof,mcly) * ztmp
- scatt_aux_ad % dz (iprof,mcly) = scatt_aux_ad % dz (iprof,mcly) + ztmp_ad * scatt_aux % lambda (ichan,mcly) * ztmp
- ztmp_ad = 0.0_JPRB
-
-!* From boundary conditions at bottom of the atmosphere with r_sfc=1-e_sfc
- scatt_aux_ad % ems_bnd (ichan) = scatt_aux_ad % ems_bnd (ichan) + b_ad (1) * (profiles (iprof) % skin % t &
- & - scatt_aux % b0 (iprof,nwp_levels)) - b_ad (1) * bh (ichan,nwp_levels)
- profiles_ad (iprof) % skin % t = profiles_ad (iprof) % skin % t + b_ad (1) * scatt_aux % ems_bnd (ichan)
- scatt_aux_ad % b0 (iprof,nwp_levels) = scatt_aux_ad % b0 (iprof,nwp_levels) - b_ad (1) * scatt_aux % ems_bnd (ichan)
- bh_ad (ichan,nwp_levels) = bh_ad (ichan,nwp_levels) + b_ad (1) * (2.0_JPRB - scatt_aux % ems_bnd (ichan))
- b_ad (1) = 0.0_JPRB
-
- ztmp = (2.0_JPRB - scatt_aux % ems_bnd (ichan)) * scatt_aux % lambda (ichan,nwp_levels) / scatt_aux % h (ichan,nwp_levels)
-
- scatt_aux_ad % ems_bnd (ichan) = scatt_aux_ad % ems_bnd (ichan) + a_ad (1,2)
- ztmp_ad = a_ad (1,2)
- a_ad (1,2) = 0.0_JPRB
-
- scatt_aux_ad % ems_bnd (ichan) = scatt_aux_ad % ems_bnd (ichan) + a_ad (1,1)
- ztmp_ad = ztmp_ad - a_ad (1,1)
- a_ad (1,1) = 0.0_JPRB
-
- scatt_aux_ad % ems_bnd (ichan) = scatt_aux_ad % ems_bnd (ichan) - ztmp_ad * scatt_aux % lambda (ichan,nwp_levels) &
- & / scatt_aux % h (ichan,nwp_levels)
- scatt_aux_ad % lambda (ichan,nwp_levels) = scatt_aux_ad % lambda (ichan,nwp_levels) + ztmp_ad &
- & * (2.0_JPRB - scatt_aux % ems_bnd(ichan)) / scatt_aux % h (ichan,nwp_levels)
- scatt_aux_ad % h (ichan,nwp_levels) = scatt_aux_ad % h (ichan,nwp_levels) &
- & - ztmp_ad * (2.0_JPRB - scatt_aux % ems_bnd (ichan)) * scatt_aux % lambda (ichan,nwp_levels) &
- & / scatt_aux % h (ichan,nwp_levels) / scatt_aux % h (ichan,nwp_levels)
- ztmp_ad = 0.0_JPRB
-
- do ilayer = ndim - 2, 2, -2
- jlayer = nwp_levels - ilayer / 2 + 1
- klayer = jlayer - 1
-
- ilin = ilayer
- icol = (ilayer - 1)
-
- ztmp = exp (scatt_aux % lambda (ichan,jlayer) * scatt_aux % dz (iprof,jlayer))
-
-!* From upward fluxes at i-th interface (@ level=dz for jlayer == level=0 for klayer)
- bh_ad (ichan,jlayer) = bh_ad (ichan,jlayer) + b_ad (ilin+1)
- bh_ad (ichan,klayer) = bh_ad (ichan,klayer) - b_ad (ilin+1)
- b_ad (ilin+1) = 0.0_JPRB
-
- lh_p_ad (ichan,klayer) = lh_p_ad (ichan,klayer) - a_ad (ilin+1,icol+3)
- a_ad (ilin+1,icol+3) = 0.0_JPRB
-
- lh_m_ad (ichan,klayer) = lh_m_ad (ichan,klayer) - a_ad (ilin+1,icol+2)
- a_ad (ilin+1,icol+2) = 0.0_JPRB
-
- lh_p_ad (ichan,jlayer) = lh_p_ad (ichan,jlayer) + a_ad (ilin+1,icol+1) / ztmp
- ztmp_ad = -1.0_JPRB * a_ad (ilin+1,icol+1) * lh_p (ichan,jlayer) / ztmp / ztmp
- a_ad (ilin+1,icol+1) = 0.0_JPRB
-
- lh_m_ad (ichan,jlayer) = lh_m_ad (ichan,jlayer) + a_ad (ilin+1,icol) * ztmp
- ztmp_ad = ztmp_ad + a_ad (ilin+1,icol) * lh_m (ichan,jlayer)
- a_ad (ilin+1,icol ) = 0.0_JPRB
-
-!* From downward fluxes at i-th interface (@ level=dz for jlayer == level=0 for klayer)
- bh_ad (ichan,klayer) = bh_ad (ichan,klayer) + b_ad (ilin )
- bh_ad (ichan,jlayer) = bh_ad (ichan,jlayer) - b_ad (ilin )
- b_ad (ilin ) = 0.0_JPRB
-
- lh_m_ad (ichan,klayer) = lh_m_ad (ichan,klayer) - a_ad (ilin ,icol+3)
- a_ad (ilin ,icol+3) = 0.0_JPRB
-
- lh_p_ad (ichan,klayer) = lh_p_ad (ichan,klayer) - a_ad (ilin ,icol+2)
- a_ad (ilin ,icol+2) = 00._JPRB
-
- lh_m_ad (ichan,jlayer) = lh_m_ad (ichan,jlayer) + a_ad (ilin ,icol+1) / ztmp
- ztmp_ad = ztmp_ad - a_ad (ilin ,icol+1) * lh_m (ichan,jlayer) / ztmp / ztmp
- a_ad (ilin ,icol+1) = 0.0_JPRB
-
- lh_p_ad (ichan,jlayer) = lh_p_ad (ichan,jlayer) + a_ad (ilin ,icol) * ztmp
- ztmp_ad = ztmp_ad + a_ad (ilin ,icol ) * lh_p (ichan,jlayer)
- a_ad (ilin ,icol ) = 0.0_JPRB
-
- scatt_aux_ad % lambda (ichan,jlayer) = scatt_aux_ad % lambda (ichan,jlayer) &
- & + ztmp_ad * ztmp * scatt_aux % dz (iprof,jlayer)
- scatt_aux_ad % dz (iprof,jlayer) = scatt_aux_ad % dz (iprof,jlayer) &
- & + ztmp_ad * ztmp * scatt_aux % lambda (ichan,jlayer)
- ztmp_ad = 0._JPRB
- enddo
-
- deallocate (a , b , dx , ta)
- deallocate (a_ad, b_ad, dx_ad)
-
- scatt_aux_ad % lambda (ichan,:) = scatt_aux_ad % lambda (ichan,:) - lh_m_ad (ichan,:) / scatt_aux % h (ichan,:)
- scatt_aux_ad % h (ichan,:) = scatt_aux_ad % h (ichan,:) + lh_m_ad (ichan,:) * scatt_aux % lambda (ichan,:)&
- / scatt_aux % h (ichan,:) / scatt_aux % h (ichan,:)
- lh_m_ad (ichan,:) = 0.0_JPRB
-
- scatt_aux_ad % lambda (ichan,:) = scatt_aux_ad % lambda (ichan,:) + lh_p_ad (ichan,:) / scatt_aux % h (ichan,:)
- scatt_aux_ad % h (ichan,:) = scatt_aux_ad % h (ichan,:) - lh_p_ad (ichan,:) * scatt_aux % lambda (ichan,:) &
- & / scatt_aux % h (ichan,:) / scatt_aux % h (ichan,:)
- lh_p_ad (ichan,:) = 0.0_JPRB
-
- scatt_aux_ad % b1 (iprof,:) = scatt_aux_ad % b1 (iprof,:) + bh_ad (ichan,:) / scatt_aux % h (ichan,:)
- scatt_aux_ad % h (ichan,:) = scatt_aux_ad % h (ichan,:) - bh_ad (ichan,:) * scatt_aux % b1 (iprof,:) &
- & / scatt_aux % h (ichan,:) / scatt_aux % h (ichan,:)
- bh_ad (ichan,:) = 0.0_JPRB
- end do
-
-!* Reset
- dp_ad (:,:) = 0.0_JPRB
- dm_ad (:,:) = 0.0_JPRB
-
-End subroutine rttov_boundaryconditions_ad
diff --git a/src/LIB/RTTOV/src/rttov_boundaryconditions_ad.interface b/src/LIB/RTTOV/src/rttov_boundaryconditions_ad.interface
deleted file mode 100644
index f9f6eee66b6d1bc445a75a9845fc97b8a413c0f8..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_boundaryconditions_ad.interface
+++ /dev/null
@@ -1,34 +0,0 @@
-INTERFACE
-Subroutine rttov_boundaryconditions_ad (&
- & nwp_levels,&
- & nchannels,&
- & nprofiles,&
- & lprofiles,&
- & scatt_aux,&
- & scatt_aux_ad,&
- & profiles ,&
- & profiles_ad ,&
- & ftop,&
- & ftop_ad,&
- & dp,&
- & dp_ad,&
- & dm,&
- & dm_ad)
- Use rttov_types, Only :&
- & profile_Type ,&
- & profile_scatt_aux
- Use parkind1, Only : jpim ,jprb
- Integer (Kind=jpim), Intent (in) :: nwp_levels
- Integer (Kind=jpim), Intent (in) :: nprofiles
- Integer (Kind=jpim), Intent (in) :: nchannels
- Integer (Kind=jpim), Intent (in) :: lprofiles (nchannels)
- Type (profile_scatt_aux), Intent (in) :: scatt_aux
- Type (profile_scatt_aux), Intent (inout) :: scatt_aux_ad
- Type (profile_Type), Intent (in) :: profiles (nprofiles)
- Type (profile_Type), Intent (inout) :: profiles_ad (nprofiles)
- Real (Kind=jprb), Intent (in), dimension (nchannels) :: ftop
- Real (Kind=jprb), Intent (inout), dimension (nchannels) :: ftop_ad
- Real (Kind=jprb), Intent (out), dimension (nchannels,nwp_levels) :: dp , dm
- Real (Kind=jprb), Intent (inout), dimension (nchannels,nwp_levels) :: dp_ad, dm_ad
-End subroutine rttov_boundaryconditions_ad
-END INTERFACE
diff --git a/src/LIB/RTTOV/src/rttov_boundaryconditions_k.F90 b/src/LIB/RTTOV/src/rttov_boundaryconditions_k.F90
deleted file mode 100644
index 41ca295a51472b8f34edb0b5d49f96c1a5af737c..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_boundaryconditions_k.F90
+++ /dev/null
@@ -1,404 +0,0 @@
-!
-Subroutine rttov_boundaryconditions_k (&
- & nwp_levels, &! in
- & nchannels, &! in
- & nprofiles, &! in
- & lprofiles, &! in
- & scatt_aux, &! in
- & scatt_aux_k, &! inout
- & profiles , &! in
- & profiles_k , &! inout
- & ftop, &! in
- & ftop_k, &! inout
- & dp, &! out
- & dp_k, &! inout
- & dm, &! out
- & dm_k) ! inout
-
-
- ! Description:
- ! to compute boundary conditions for Eddington approximation to RT
- !
- ! Copyright:
- ! This software was developed within the context of
- ! the EUMETSAT Satellite Application Facility on
- ! Numerical Weather Prediction (NWP SAF), under the
- ! Cooperation Agreement dated 25 November 1998, between
- ! EUMETSAT and the Met Office, UK, by one or more partners
- ! within the NWP SAF. The partners in the NWP SAF are
- ! the Met Office, ECMWF, KNMI and MeteoFrance.
- !
- ! Copyright 2002, EUMETSAT, All Rights Reserved.
- !
- ! Method:
- ! - Bauer, P., 2002: Microwave radiative transfer modeling in clouds and precipitation.
- ! Part I: Model description.
- ! NWP SAF Report No. NWPSAF-EC-TR-005, 27 pp.
- ! - Chevallier, F., and P. Bauer, 2003:
- ! Model rain and clouds over oceans: comparison with SSM/I observations.
- ! Mon. Wea. Rev., 131, 1240-1255.
- ! - Moreau, E., P. Bauer and F. Chevallier, 2002: Microwave radiative transfer modeling in clouds and precipitation.
- ! Part II: Model evaluation.
- ! NWP SAF Report No. NWPSAF-EC-TR-006, 27 pp.
- !
- ! Current Code Owner: SAF NWP
- !
- ! History:
- ! Version Date Comment
- ! ------- ---- -------
- ! 1.0 09/2002 Initial version (E. Moreau)
- ! 1.1 05/2003 RTTOV7.3 compatible (F. Chevallier)
- ! 1.2 03/2004 Added polarimetry (R. Saunders)
- ! 1.3 08/2004 Polarimetry fixes (U. O'Keefe)
- ! 1.4 11/2004 Clean-up (P. Bauer)
- ! 1.5 02/2005 K-code (A. Collard)
- !
- ! Code Description:
- ! Language: Fortran 90.
- ! Software Standards: "European Standards for Writing and
- ! Documenting Exchangeable Fortran 90 Code".
- !
- ! Declarationsta:
- ! Modules used:
- ! Imported Type Definitions:
-
- Use rttov_types, Only : &
- & profile_Type ,&
- & profile_scatt_aux
-
- Use parkind1, Only : jpim ,jprb
-
- Implicit none
-
-!* Subroutine arguments:
- Integer (Kind=jpim), Intent (in) :: nwp_levels ! Number of levels
- Integer (Kind=jpim), Intent (in) :: nprofiles ! Number of profiles
- Integer (Kind=jpim), Intent (in) :: nchannels ! Number of radiances
- Integer (Kind=jpim), Intent (in) :: lprofiles (nchannels) ! Profile indices
-
- Type (profile_scatt_aux), Intent (in) :: scatt_aux ! Auxiliary profile variables for RTTOV_SCATT
- Type (profile_scatt_aux), Intent (inout) :: scatt_aux_k ! Auxiliary profile variables for RTTOV_SCATT
- Type (profile_Type), Intent (in) :: profiles (nprofiles) ! Profiles on RTTOV levels
- Type (profile_Type), Intent (inout) :: profiles_k (nchannels) ! Profiles on RTTOV levels
-
- Real (Kind=jprb), Intent (in), dimension (nchannels) :: ftop
- Real (Kind=jprb), Intent (inout), dimension (nchannels) :: ftop_k
- Real (Kind=jprb), Intent (out), dimension (nchannels,nwp_levels) :: dp , dm
- Real (Kind=jprb), Intent (inout), dimension (nchannels,nwp_levels) :: dp_k, dm_k
-
-!* Local variables
- Real (Kind=jprb), dimension (nchannels,nwp_levels) :: lh_p , lh_m , bh
- Real (Kind=jprb), dimension (nchannels,nwp_levels) :: lh_p_k, lh_m_k, bh_k
- Real (Kind=jprb), allocatable :: a (:,:), b (:), dx (:), ta(:,:)
- Real (Kind=jprb), allocatable :: a_k (:,:), b_k (:), dx_k (:)
- Real (Kind=jprb) :: ztmp, ztmp_k
- Integer (Kind=jpim) :: ilayer, jlayer, klayer, ilin, icol
- Integer (Kind=jpim) :: ndim, iprof, ichan, jj, ii, mcly
-
-!* Lapack/ESSL
- Real (Kind=jprb), allocatable :: ab (:,:)
- Integer (Kind=jpim), allocatable :: ipiv (:)
- Integer (Kind=jpim) :: kl, ku, ldab, info, nrhs
- Character (len=1) :: trans
- Logical :: ll_essl
-
- !- End of header --------------------------------------------------------
-
-!* Init Math related variables
- ll_essl = .false.
-
- kl = 2
- ku = 2
- if (ll_essl) then
- ldab = 2 * kl + ku + 16
- else
- ldab = 2 * kl + ku + 1
- endif
- trans = 'N'
- nrhs = 1
- info = 0
-
-!* FORWARD PART
-!* Reset
- dp (:,:) = 0.0_JPRB
- dm (:,:) = 0.0_JPRB
-
- lh_p_k = 0.0_JPRB
- lh_m_k = 0.0_JPRB
- bh_k = 0.0_JPRB
-
-!* Channels * Profiles
- do ichan = 1, nchannels
- iprof = lprofiles (ichan)
-
- bh (ichan,:) = scatt_aux % b1 (iprof,:) / scatt_aux % h (ichan,:)
- lh_p (ichan,:) = (1.0_JPRB + scatt_aux % lambda (ichan,:) / scatt_aux % h (ichan,:))
- lh_m (ichan,:) = (1.0_JPRB - scatt_aux % lambda (ichan,:) / scatt_aux % h (ichan,:))
-
- mcly = scatt_aux % mclayer (ichan)
-
- ndim = 2 * (nwp_levels - mcly + 1)
-
- allocate (a (ndim,ndim))
- allocate (b (ndim ))
- allocate (dx (ndim ))
- allocate (ta (ndim,ndim))
- allocate (ab (ldab,ndim))
- allocate (ipiv (ndim ))
-
- a (:,:) = 0.0_JPRB
- b (: ) = 0.0_JPRB
- ab (:,:) = 0.0_JPRB
- ta (:,:) = 0.0_JPRB
- ipiv (:) = 0
-
- do ilayer = 2, ndim - 2, 2
- jlayer = nwp_levels - ilayer / 2 + 1
- klayer = jlayer - 1
-
- ilin = ilayer
- icol = (ilayer - 1)
-
- ztmp = exp (scatt_aux % lambda (ichan,jlayer) * scatt_aux % dz (iprof,jlayer))
-
-!* From downward fluxes at i-th interface (@ level=dz for jlayer == level=0 for klayer)
- a (ilin ,icol ) = lh_p (ichan,jlayer) * ztmp
- a (ilin ,icol+1) = lh_m (ichan,jlayer) / ztmp
- a (ilin ,icol+2) = -1.0_JPRB * lh_p (ichan,klayer)
- a (ilin ,icol+3) = -1.0_JPRB * lh_m (ichan,klayer)
-
- b (ilin ) = bh (ichan,klayer) - bh (ichan,jlayer)
-
-!* From upward fluxes at i-th interface (@ level=dz for jlayer == level=0 for klayer)
- a (ilin+1,icol ) = lh_m (ichan,jlayer) * ztmp
- a (ilin+1,icol+1) = lh_p (ichan,jlayer) / ztmp
- a (ilin+1,icol+2) = -1.0_JPRB * lh_m (ichan,klayer)
- a (ilin+1,icol+3) = -1.0_JPRB * lh_p (ichan,klayer)
-
- b (ilin+1) = bh (ichan,jlayer) - bh (ichan,klayer)
- end do
-
-!* From boundary conditions at bottom of the atmosphere with r_sfc=1-e_sfc
- ztmp = (2.0_JPRB - scatt_aux % ems_bnd (ichan)) * scatt_aux % lambda (ichan,nwp_levels) / scatt_aux % h (ichan,nwp_levels)
-
- a (1,1) = scatt_aux % ems_bnd(ichan) - ztmp
- a (1,2) = scatt_aux % ems_bnd(ichan) + ztmp
-
- b (1) = scatt_aux % ems_bnd(ichan) * (profiles (iprof) % skin % t - scatt_aux % b0 (iprof,nwp_levels)) + &
- & (2.0_JPRB - scatt_aux % ems_bnd (ichan)) * bh (ichan,nwp_levels)
-
-!* From boundary conditions at top of the atmosphere
- ztmp = exp (scatt_aux % lambda (ichan,mcly) * scatt_aux % dz (iprof,mcly))
-
- a (ndim,ndim-1) = lh_p (ichan,mcly) * ztmp
- a (ndim,ndim ) = lh_m (ichan,mcly) / ztmp
-
- b (ndim) = ftop (ichan) - scatt_aux % bn (iprof,mcly) - bh (ichan,mcly)
-
-!* Solve equations A * DX = B
- do jj = 1, ndim
- do ii = max(1,jj-ku), min(ndim,jj+kl)
- ab (kl+ku+ii-jj+1,jj) = a (ii,jj)
- end do
- end do
-
-! if (ll_essl) then
-! call dgbf (ab, ldab, ndim, kl, ku, ipiv)
-! else
- call dgbtrf (ndim, ndim, kl, ku, ab, ldab, ipiv, info)
-! endif
- if (info /= 0) write (*,*) ' DGBTRF boundary_conditions: ', info
-
- dx (:) = b (:)
-! if (ll_essl) then
-! call dgbs (ab, ldab, ndim, kl, ku, ipiv, dx)
-! else
- call dgbtrs (trans, ndim, kl, ku, nrhs, ab, ldab, ipiv, dx, ndim, info)
-! endif
- if (info /= 0) write (*,*) ' DGBTRS boundary_conditions: ', info
-
-!* Decompose D+ and D-
- do ilayer = 2, ndim, 2
- jlayer = nwp_levels - ilayer / 2 + 1
-
- dp (ichan,jlayer) = dx (ilayer-1)
- dm (ichan,jlayer) = dx (ilayer )
- end do
-
-!* ADJOINT PART
- allocate (dx_k (ndim ))
- dx_k = 0.0_JPRB
- allocate (a_k (ndim,ndim))
- a_k = 0.0_JPRB
- allocate (b_k (ndim ))
- b_k = 0.0_JPRB
-
-!* Decompose D+ and D-
- do ilayer = 2, ndim, 2
- jlayer = nwp_levels - ilayer / 2 + 1
-
- dx_k (ilayer ) = dx_k (ilayer ) + dm_k (ichan,jlayer)
- dx_k (ilayer-1) = dx_k (ilayer-1) + dp_k (ichan,jlayer)
-
- dm_k (ichan,jlayer) = 0.0_JPRB
- dp_k (ichan,jlayer) = 0.0_JPRB
- end do
-
-!* Solve equations A * DX = B
- ta (1:ndim,1:ndim) = transpose (a (1:ndim,1:ndim))
- ab (:,:) = 0._JPRB
- ipiv (:) = 0
-
- do jj = 1, ndim
- do ii = max(1,jj-ku), min(ndim,jj+kl)
- ab (kl+ku+ii-jj+1,jj) = ta (ii,jj)
- end do
- end do
-
-! if (ll_essl) then
-! call dgbf (ab, ldab, ndim, kl, ku, ipiv)
-! else
- call dgbtrf (ndim, ndim, kl, ku, ab, ldab, ipiv, info)
-! endif
- if (info /= 0) write (*,*) ' DGBTRF boundary_conditions_k_k: ', info
-
- b_k (:) = dx_k (:)
-
-! if (ll_essl) then
-! call dgbs (ab, ldab, ndim, kl, ku, ipiv, b_k)
-! else
- call dgbtrs (trans, ndim, kl, ku, nrhs, ab, ldab, ipiv, b_k, ndim, info)
-! endif
- if (info /= 0) write (*,*) ' DGBTRS boundary_conditions:_k_k ', info
-
- deallocate (ab, ipiv)
-
- do ilayer = 1, ndim
- do jlayer = 1, ndim
- a_k (ilayer,jlayer) = -1.0_JPRB * b_k (ilayer) * dx (jlayer)
- enddo
- enddo
-
-!* From boundary conditions at top of the atmosphere
- ftop_k (ichan) = ftop_k (ichan) + b_k (ndim)
- scatt_aux_k % bn (ichan,mcly) = scatt_aux_k % bn (ichan,mcly) - b_k (ndim)
- bh_k (ichan,mcly) = bh_k (ichan,mcly) - b_k (ndim)
- b_k (ndim) = 0.0_JPRB
-
- ztmp_k = -1.0_JPRB * a_k(ndim,ndim) * lh_m (ichan,mcly) / ztmp / ztmp
- lh_m_k (ichan,mcly) = lh_m_k (ichan,mcly) + a_k (ndim,ndim) / ztmp
- a_k (ndim,ndim) = 0.0_JPRB
-
- ztmp_k = ztmp_k + a_k (ndim,ndim-1) * lh_p (ichan,mcly)
- lh_p_k (ichan,mcly) = lh_p_k (ichan,mcly) + a_k (ndim,ndim-1) * ztmp
- a_k (ndim,ndim-1) = 0.0_JPRB
-
- scatt_aux_k % lambda (ichan,mcly) = scatt_aux_k % lambda (ichan,mcly) + ztmp_k * scatt_aux % dz (iprof,mcly) * ztmp
- scatt_aux_k % dz (ichan,mcly) = scatt_aux_k % dz (ichan,mcly) + ztmp_k * scatt_aux % lambda (ichan,mcly) * ztmp
- ztmp_k = 0.0_JPRB
-
-!* From boundary conditions at bottom of the atmosphere with r_sfc=1-e_sfc
- scatt_aux_k % ems_bnd (ichan) = scatt_aux_k % ems_bnd (ichan) + b_k (1) * (profiles (iprof) % skin % t &
- & - scatt_aux % b0 (iprof,nwp_levels)) - b_k (1) * bh (ichan,nwp_levels)
- profiles_k (ichan) % skin % t = profiles_k (ichan) % skin % t + b_k (1) * scatt_aux % ems_bnd (ichan)
- scatt_aux_k % b0 (ichan,nwp_levels) = scatt_aux_k % b0 (ichan,nwp_levels) - b_k (1) * scatt_aux % ems_bnd (ichan)
- bh_k (ichan,nwp_levels) = bh_k (ichan,nwp_levels) + b_k (1) * (2.0_JPRB - scatt_aux % ems_bnd (ichan))
- b_k (1) = 0.0_JPRB
-
- ztmp = (2.0_JPRB - scatt_aux % ems_bnd (ichan)) * scatt_aux % lambda (ichan,nwp_levels) / scatt_aux % h (ichan,nwp_levels)
-
- scatt_aux_k % ems_bnd (ichan) = scatt_aux_k % ems_bnd (ichan) + a_k (1,2)
- ztmp_k = a_k (1,2)
- a_k (1,2) = 0.0_JPRB
-
- scatt_aux_k % ems_bnd (ichan) = scatt_aux_k % ems_bnd (ichan) + a_k (1,1)
- ztmp_k = ztmp_k - a_k (1,1)
- a_k (1,1) = 0.0_JPRB
-
- scatt_aux_k % ems_bnd (ichan) = scatt_aux_k % ems_bnd (ichan) - ztmp_k * scatt_aux % lambda (ichan,nwp_levels) &
- & / scatt_aux % h (ichan,nwp_levels)
- scatt_aux_k % lambda (ichan,nwp_levels) = scatt_aux_k % lambda (ichan,nwp_levels) + ztmp_k &
- & * (2.0_JPRB - scatt_aux % ems_bnd(ichan)) / scatt_aux % h (ichan,nwp_levels)
- scatt_aux_k % h (ichan,nwp_levels) = scatt_aux_k % h (ichan,nwp_levels) &
- & - ztmp_k * (2.0_JPRB - scatt_aux % ems_bnd (ichan)) * scatt_aux % lambda (ichan,nwp_levels) &
- & / scatt_aux % h (ichan,nwp_levels) / scatt_aux % h (ichan,nwp_levels)
- ztmp_k = 0.0_JPRB
-
- do ilayer = ndim - 2, 2, -2
- jlayer = nwp_levels - ilayer / 2 + 1
- klayer = jlayer - 1
-
- ilin = ilayer
- icol = (ilayer - 1)
-
- ztmp = exp (scatt_aux % lambda (ichan,jlayer) * scatt_aux % dz (iprof,jlayer))
-
-!* From upward fluxes at i-th interface (@ level=dz for jlayer == level=0 for klayer)
- bh_k (ichan,jlayer) = bh_k (ichan,jlayer) + b_k (ilin+1)
- bh_k (ichan,klayer) = bh_k (ichan,klayer) - b_k (ilin+1)
- b_k (ilin+1) = 0.0_JPRB
-
- lh_p_k (ichan,klayer) = lh_p_k (ichan,klayer) - a_k (ilin+1,icol+3)
- a_k (ilin+1,icol+3) = 0.0_JPRB
-
- lh_m_k (ichan,klayer) = lh_m_k (ichan,klayer) - a_k (ilin+1,icol+2)
- a_k (ilin+1,icol+2) = 0.0_JPRB
-
- lh_p_k (ichan,jlayer) = lh_p_k (ichan,jlayer) + a_k (ilin+1,icol+1) / ztmp
- ztmp_k = -1.0_JPRB * a_k (ilin+1,icol+1) * lh_p (ichan,jlayer) / ztmp / ztmp
- a_k (ilin+1,icol+1) = 0.0_JPRB
-
- lh_m_k (ichan,jlayer) = lh_m_k (ichan,jlayer) + a_k (ilin+1,icol) * ztmp
- ztmp_k = ztmp_k + a_k (ilin+1,icol) * lh_m (ichan,jlayer)
- a_k (ilin+1,icol ) = 0.0_JPRB
-
-!* From downward fluxes at i-th interface (@ level=dz for jlayer == level=0 for klayer)
- bh_k (ichan,klayer) = bh_k (ichan,klayer) + b_k (ilin )
- bh_k (ichan,jlayer) = bh_k (ichan,jlayer) - b_k (ilin )
- b_k (ilin ) = 0.0_JPRB
-
- lh_m_k (ichan,klayer) = lh_m_k (ichan,klayer) - a_k (ilin ,icol+3)
- a_k (ilin ,icol+3) = 0.0_JPRB
-
- lh_p_k (ichan,klayer) = lh_p_k (ichan,klayer) - a_k (ilin ,icol+2)
- a_k (ilin ,icol+2) = 00._JPRB
-
- lh_m_k (ichan,jlayer) = lh_m_k (ichan,jlayer) + a_k (ilin ,icol+1) / ztmp
- ztmp_k = ztmp_k - a_k (ilin ,icol+1) * lh_m (ichan,jlayer) / ztmp / ztmp
- a_k (ilin ,icol+1) = 0.0_JPRB
-
- lh_p_k (ichan,jlayer) = lh_p_k (ichan,jlayer) + a_k (ilin ,icol) * ztmp
- ztmp_k = ztmp_k + a_k (ilin ,icol ) * lh_p (ichan,jlayer)
- a_k (ilin ,icol ) = 0.0_JPRB
-
- scatt_aux_k % lambda (ichan,jlayer) = scatt_aux_k % lambda (ichan,jlayer) &
- & + ztmp_k * ztmp * scatt_aux % dz (iprof,jlayer)
- scatt_aux_k % dz (ichan,jlayer) = scatt_aux_k % dz (ichan,jlayer) &
- & + ztmp_k * ztmp * scatt_aux % lambda (ichan,jlayer)
- ztmp_k = 0._JPRB
- enddo
-
- deallocate (a , b , dx , ta)
- deallocate (a_k, b_k, dx_k)
-
- scatt_aux_k % lambda (ichan,:) = scatt_aux_k % lambda (ichan,:) - lh_m_k (ichan,:) / scatt_aux % h (ichan,:)
- scatt_aux_k % h (ichan,:) = scatt_aux_k % h (ichan,:) + lh_m_k (ichan,:) * scatt_aux % lambda (ichan,:)&
- / scatt_aux % h (ichan,:) / scatt_aux % h (ichan,:)
- lh_m_k (ichan,:) = 0.0_JPRB
-
- scatt_aux_k % lambda (ichan,:) = scatt_aux_k % lambda (ichan,:) + lh_p_k (ichan,:) / scatt_aux % h (ichan,:)
- scatt_aux_k % h (ichan,:) = scatt_aux_k % h (ichan,:) - lh_p_k (ichan,:) * scatt_aux % lambda (ichan,:) &
- & / scatt_aux % h (ichan,:) / scatt_aux % h (ichan,:)
- lh_p_k (ichan,:) = 0.0_JPRB
-
- scatt_aux_k % b1 (ichan,:) = scatt_aux_k % b1 (ichan,:) + bh_k (ichan,:) / scatt_aux % h (ichan,:)
- scatt_aux_k % h (ichan,:) = scatt_aux_k % h (ichan,:) - bh_k (ichan,:) * scatt_aux % b1 (iprof,:) &
- & / scatt_aux % h (ichan,:) / scatt_aux % h (ichan,:)
- bh_k (ichan,:) = 0.0_JPRB
- end do
-
-!* Reset
- dp_k (:,:) = 0.0_JPRB
- dm_k (:,:) = 0.0_JPRB
-
-End subroutine rttov_boundaryconditions_k
diff --git a/src/LIB/RTTOV/src/rttov_boundaryconditions_k.interface b/src/LIB/RTTOV/src/rttov_boundaryconditions_k.interface
deleted file mode 100644
index 53295c929af2f4f3c9605e4512cafefbbcf3d158..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_boundaryconditions_k.interface
+++ /dev/null
@@ -1,34 +0,0 @@
-INTERFACE
-Subroutine rttov_boundaryconditions_k (&
- & nwp_levels,&
- & nchannels,&
- & nprofiles,&
- & lprofiles,&
- & scatt_aux,&
- & scatt_aux_k,&
- & profiles ,&
- & profiles_k ,&
- & ftop,&
- & ftop_k,&
- & dp,&
- & dp_k,&
- & dm,&
- & dm_k)
- Use rttov_types, Only :&
- & profile_Type ,&
- & profile_scatt_aux
- Use parkind1, Only : jpim ,jprb
- Integer (Kind=jpim), Intent (in) :: nwp_levels
- Integer (Kind=jpim), Intent (in) :: nprofiles
- Integer (Kind=jpim), Intent (in) :: nchannels
- Integer (Kind=jpim), Intent (in) :: lprofiles (nchannels)
- Type (profile_scatt_aux), Intent (in) :: scatt_aux
- Type (profile_scatt_aux), Intent (inout) :: scatt_aux_k
- Type (profile_Type), Intent (in) :: profiles (nprofiles)
- Type (profile_Type), Intent (inout) :: profiles_k (nchannels)
- Real (Kind=jprb), Intent (in), dimension (nchannels) :: ftop
- Real (Kind=jprb), Intent (inout), dimension (nchannels) :: ftop_k
- Real (Kind=jprb), Intent (out), dimension (nchannels,nwp_levels) :: dp , dm
- Real (Kind=jprb), Intent (inout), dimension (nchannels,nwp_levels) :: dp_k, dm_k
-End subroutine rttov_boundaryconditions_k
-END INTERFACE
diff --git a/src/LIB/RTTOV/src/rttov_boundaryconditions_tl.F90 b/src/LIB/RTTOV/src/rttov_boundaryconditions_tl.F90
deleted file mode 100644
index deb37d4bb37a990c7f61b2d4eea6f7d57144b6d8..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_boundaryconditions_tl.F90
+++ /dev/null
@@ -1,286 +0,0 @@
-!
-Subroutine rttov_boundaryconditions_tl (&
- & nwp_levels, &! in
- & nchannels, &! in
- & nprofiles, &! in
- & lprofiles, &! in
- & scatt_aux, &! in
- & scatt_aux_tl, &! in
- & profiles , &! in
- & profiles_tl , &! in
- & ftop, &! in
- & ftop_tl, &! in
- & dp, &! out
- & dp_tl, &! out
- & dm, &! out
- & dm_tl) ! out
-
-
- ! Description:
- ! to compute boundary conditions for Eddington approximation to RT
- !
- ! Copyright:
- ! This software was developed within the context of
- ! the EUMETSAT Satellite Application Facility on
- ! Numerical Weather Prediction (NWP SAF), under the
- ! Cooperation Agreement dated 25 November 1998, between
- ! EUMETSAT and the Met Office, UK, by one or more partners
- ! within the NWP SAF. The partners in the NWP SAF are
- ! the Met Office, ECMWF, KNMI and MeteoFrance.
- !
- ! Copyright 2002, EUMETSAT, All Rights Reserved.
- !
- ! Method:
- ! - Bauer, P., 2002: Microwave radiative transfer modeling in clouds and precipitation.
- ! Part I: Model description.
- ! NWP SAF Report No. NWPSAF-EC-TR-005, 27 pp.
- ! - Chevallier, F., and P. Bauer, 2003:
- ! Model rain and clouds over oceans: comparison with SSM/I observations.
- ! Mon. Wea. Rev., 131, 1240-1255.
- ! - Moreau, E., P. Bauer and F. Chevallier, 2002: Microwave radiative transfer modeling in clouds and precipitation.
- ! Part II: Model evaluation.
- ! NWP SAF Report No. NWPSAF-EC-TR-006, 27 pp.
- !
- ! Current Code Owner: SAF NWP
- !
- ! History:
- ! Version Date Comment
- ! ------- ---- -------
- ! 1.0 09/2002 Initial version (E. Moreau)
- ! 1.1 05/2003 RTTOV7.3 compatible (F. Chevallier)
- ! 1.2 03/2004 Included polarimetry (R. Saunders)
- ! 1.3 11/2004 Clean-up (P. Bauer)
- !
- ! Code Description:
- ! Language: Fortran 90.
- ! Software Standards: "European Standards for Writing and
- ! Documenting Exchangeable Fortran 90 Code".
- !
- ! Declarations:
- ! Modules used:
- ! Imported Type Definitions:
-
- Use rttov_types, Only : &
- & profile_Type ,&
- & profile_scatt_aux
-
- Use parkind1, Only : jpim ,jprb
-
- Implicit none
-
-!* Subroutine arguments:
- Integer (Kind=jpim), Intent (in) :: nwp_levels ! Number of levels
- Integer (Kind=jpim), Intent (in) :: nprofiles ! Number of profiles
- Integer (Kind=jpim), Intent (in) :: nchannels ! Number of radiances
- Integer (Kind=jpim), Intent (in) :: lprofiles (nchannels) ! Profile indices
-
- Type (profile_scatt_aux), Intent (in) :: scatt_aux ! Auxiliary profile variables for RTTOV_SCATT
- Type (profile_scatt_aux), Intent (in) :: scatt_aux_tl ! Auxiliary profile variables for RTTOV_SCATT
- Type (profile_Type), Intent (in) :: profiles (nprofiles) ! Profiles on RTTOV levels
- Type (profile_Type), Intent (in) :: profiles_tl (nprofiles) ! Profiles on RTTOV levels
-
- Real (Kind=jprb), Intent (in), dimension (nchannels) :: ftop
- Real (Kind=jprb), Intent (in), dimension (nchannels) :: ftop_tl
- Real (Kind=jprb), Intent (out), dimension (nchannels,nwp_levels) :: dp , dm
- Real (Kind=jprb), Intent (out), dimension (nchannels,nwp_levels) :: dp_tl, dm_tl
-
-!* Local variables
- Real (Kind=jprb), dimension (nchannels,nwp_levels) :: lh_p , lh_m , bh
- Real (Kind=jprb), dimension (nchannels,nwp_levels) :: lh_p_tl, lh_m_tl, bh_tl
- Real (Kind=jprb), allocatable :: a (:,:), b (:), dx (:)
- Real (Kind=jprb), allocatable :: a_tl (:,:), b_tl (:), dx_tl (:)
- Real (Kind=jprb) :: ztmp, ztmp_tl
- Integer (Kind=jpim) :: ilayer, jlayer, klayer, ilin, icol
- Integer (Kind=jpim) :: ndim, iprof, ichan, jj, ii, mcly
-
-!* Lapack/ESSL
- Real (Kind=jprb), allocatable :: ab (:,:)
- Integer (Kind=jpim), allocatable :: ipiv (:)
- Integer (Kind=jpim) :: kl, ku, ldab, info, nrhs
- Character (len=1) :: trans
- Logical :: ll_essl
-
- !- End of header --------------------------------------------------------
-!* Init Math related variables
- ll_essl = .false.
-
- kl = 2
- ku = 2
- if (ll_essl) then
- ldab = 2 * kl + ku + 16
- else
- ldab = 2 * kl + ku + 1
- endif
- trans = 'N'
- nrhs = 1
- info = 0
-
-!* Reset
- dp_tl (:,:) = 0.0_JPRB
- dm_tl (:,:) = 0.0_JPRB
- dp (:,:) = 0.0_JPRB
- dm (:,:) = 0.0_JPRB
-
-!* Channels * Profiles
- do ichan = 1, nchannels
- iprof = lprofiles (ichan)
-
- bh_tl (ichan,:) = scatt_aux_tl % b1 (iprof,:) / scatt_aux % h (ichan,:) &
- & - scatt_aux % b1 (iprof,:) * scatt_aux_tl % h (ichan,:) &
- & / scatt_aux % h (ichan,:) / scatt_aux % h (ichan,:)
- bh (ichan,:) = scatt_aux % b1 (iprof,:) / scatt_aux % h (ichan,:)
-
- lh_p_tl (ichan,:) = scatt_aux_tl % lambda (ichan,:) / scatt_aux % h (ichan,:) &
- & - scatt_aux % lambda (ichan,:) * scatt_aux_tl % h (ichan,:) &
- & / scatt_aux % h (ichan,:) / scatt_aux % h (ichan,:)
- lh_p (ichan,:) = (1.0_JPRB + scatt_aux % lambda (ichan,:) / scatt_aux % h (ichan,:))
-
- lh_m_tl (ichan,:) = - 1.0_JPRB * lh_p_tl (ichan,:)
- lh_m (ichan,:) = (1.0_JPRB - scatt_aux % lambda (ichan,:) / scatt_aux % h (ichan,:))
-
- mcly = scatt_aux % mclayer (ichan)
- ndim = 2 * (nwp_levels - mcly + 1)
-
- allocate (a_tl (ndim,ndim))
- allocate (b_tl (ndim ))
- allocate (dx_tl (ndim ))
- allocate (a (ndim,ndim))
- allocate (b (ndim ))
- allocate (ab (ldab,ndim))
- allocate (ipiv (ndim ))
- allocate (dx (ndim ))
-
- a_tl (:,:) = 0.0_JPRB
- b_tl (: ) = 0.0_JPRB
- a (:,:) = 0.0_JPRB
- b (: ) = 0.0_JPRB
- ab (:,:) = 0.0_JPRB
- ipiv (:) = 0
-
- do ilayer = 2, ndim - 2, 2
- jlayer = nwp_levels - ilayer / 2 + 1
- klayer = jlayer - 1
-
- ilin = ilayer
- icol = (ilayer - 1)
-
- ztmp = exp (scatt_aux % lambda (ichan,jlayer) * scatt_aux % dz (iprof,jlayer))
- ztmp_tl = (scatt_aux_tl % lambda (ichan,jlayer) * scatt_aux % dz (iprof,jlayer) + &
- & scatt_aux % lambda (ichan,jlayer) * scatt_aux_tl % dz (iprof,jlayer)) * ztmp
-
-!* From downward fluxes at i-th interface (@ level=dz for jlayer == level=0 for klayer)
- a_tl (ilin ,icol ) = lh_p_tl (ichan,jlayer) * ztmp + lh_p (ichan,jlayer) * ztmp_tl
- a (ilin ,icol ) = lh_p (ichan,jlayer) * ztmp
-
- a_tl (ilin ,icol+1) = lh_m_tl (ichan,jlayer) / ztmp - lh_m (ichan,jlayer) * ztmp_tl / ztmp / ztmp
- a (ilin ,icol+1) = lh_m (ichan,jlayer) / ztmp
-
- a_tl (ilin ,icol+2) = -1.0_JPRB * lh_p_tl (ichan,klayer)
- a (ilin ,icol+2) = -1.0_JPRB * lh_p (ichan,klayer)
-
- a_tl (ilin ,icol+3) = -1.0_JPRB * lh_m_tl (ichan,klayer)
- a (ilin ,icol+3) = -1.0_JPRB * lh_m (ichan,klayer)
-
- b_tl (ilin ) = bh_tl (ichan,klayer) - bh_tl (ichan,jlayer)
- b (ilin ) = bh (ichan,klayer) - bh (ichan,jlayer)
-
-!* From upward fluxes at i-th interface (@ level=dz for jlayer == level=0 for klayer)
- a_tl (ilin+1,icol ) = lh_m_tl (ichan,jlayer) * ztmp + lh_m (ichan,jlayer) * ztmp_tl
- a (ilin+1,icol ) = lh_m (ichan,jlayer) * ztmp
-
- a_tl (ilin+1,icol+1) = lh_p_tl (ichan,jlayer) / ztmp - lh_p (ichan,jlayer) * ztmp_tl / ztmp / ztmp
- a (ilin+1,icol+1) = lh_p (ichan,jlayer) / ztmp
-
- a_tl (ilin+1,icol+2) = -1.0_JPRB * lh_m_tl (ichan,klayer)
- a (ilin+1,icol+2) = -1.0_JPRB * lh_m (ichan,klayer)
-
- a_tl (ilin+1,icol+3) = -1.0_JPRB * lh_p_tl (ichan,klayer)
- a (ilin+1,icol+3) = -1.0_JPRB * lh_p (ichan,klayer)
-
- b_tl (ilin+1) = bh_tl (ichan,jlayer) - bh_tl (ichan,klayer)
- b (ilin+1) = bh (ichan,jlayer) - bh (ichan,klayer)
- end do
-
-!* From boundary conditions at bottom of the atmosphere with r_sfc=1-e_sfc
- ztmp = (2.0_JPRB - scatt_aux % ems_bnd (ichan)) * scatt_aux % lambda (ichan,nwp_levels) / scatt_aux % h (ichan,nwp_levels)
- ztmp_tl = -1.0_JPRB * scatt_aux_tl % ems_bnd (ichan) * scatt_aux % lambda (ichan,nwp_levels) &
- & / scatt_aux % h (ichan,nwp_levels) &
- & + (2.0_JPRB - scatt_aux % ems_bnd (ichan)) * scatt_aux_tl % lambda (ichan,nwp_levels) &
- & / scatt_aux % h (ichan,nwp_levels) &
- & - (2.0_JPRB - scatt_aux % ems_bnd (ichan)) * scatt_aux % lambda (ichan,nwp_levels) &
- & * scatt_aux_tl % h (ichan,nwp_levels) &
- & / scatt_aux % h (ichan,nwp_levels) / scatt_aux % h (ichan,nwp_levels)
-
- a_tl (1,1) = scatt_aux_tl % ems_bnd (ichan) - ztmp_tl
- a (1,1) = scatt_aux % ems_bnd (ichan) - ztmp
-
- a_tl (1,2) = scatt_aux_tl % ems_bnd (ichan) + ztmp_tl
- a (1,2) = scatt_aux % ems_bnd (ichan) + ztmp
-
- b_tl (1) = scatt_aux_tl % ems_bnd (ichan) * (profiles (iprof) % skin % t - scatt_aux % b0 (iprof,nwp_levels)) &
- & + scatt_aux % ems_bnd (ichan) * (profiles_tl (iprof) % skin % t - scatt_aux_tl % b0 (iprof,nwp_levels)) &
- & - scatt_aux_tl % ems_bnd (ichan) * bh (ichan,nwp_levels) &
- & + (2.0_JPRB - scatt_aux % ems_bnd (ichan)) * bh_tl (ichan,nwp_levels)
- b (1) = scatt_aux % ems_bnd (ichan) * (profiles (iprof) % skin % t - scatt_aux % b0 (iprof,nwp_levels)) &
- & + (2.0_JPRB - scatt_aux % ems_bnd (ichan)) * bh (ichan,nwp_levels)
-
-!* From boundary conditions at top of the atmosphere
- ztmp = exp (scatt_aux % lambda (ichan,mcly) * scatt_aux % dz (iprof,mcly))
- ztmp_tl = (scatt_aux_tl % lambda (ichan,mcly) * scatt_aux % dz (iprof,mcly) &
- & + scatt_aux % lambda (ichan,mcly) * scatt_aux_tl % dz (iprof,mcly)) * ztmp
-
- a_tl (ndim,ndim-1) = lh_p_tl (ichan,mcly) * ztmp + lh_p (ichan,mcly) * ztmp_tl
- a (ndim,ndim-1) = lh_p (ichan,mcly) * ztmp
-
- a_tl (ndim,ndim ) = lh_m_tl (ichan,mcly) / ztmp - lh_m (ichan,mcly) * ztmp_tl / ztmp / ztmp
- a (ndim,ndim ) = lh_m (ichan,mcly) / ztmp
-
- b_tl (ndim) = ftop_tl (ichan) - scatt_aux_tl % bn (iprof,mcly) - bh_tl (ichan,mcly)
- b (ndim) = ftop (ichan) - scatt_aux % bn (iprof,mcly) - bh (ichan,mcly)
-
-!* Solve equations A * DX = B, forward
- do jj = 1, ndim
- do ii = max(1,jj-ku), min(ndim,jj+kl)
- ab (kl+ku+ii-jj+1,jj) = a (ii,jj)
- end do
- end do
-
-! if (ll_essl) then
-! call dgbf (ab, ldab, ndim, kl, ku, ipiv)
-! else
- call dgbtrf (ndim, ndim, kl, ku, ab, ldab, ipiv, info)
-! endif
- if (info /= 0) write (*,*) ' DGBTRF boundary_conditions: ', info
-
- dx (:) = b (:)
-! if (ll_essl) then
-! call dgbs (ab, ldab, ndim, kl, ku, ipiv, dx)
-! else
- call dgbtrs (trans, ndim, kl, ku, nrhs, ab, ldab, ipiv, dx, ndim, info)
-! endif
- if (info /= 0) write (*,*) ' DGBTRS boundary_conditions: ', info
-
-!* Solve equations A * DX = B, tangent-linear
- dx_tl (:) = b_tl (:) - matmul (a_tl, dx)
-
-! if (ll_essl) then
-! call dgbs (ab, ldab, ndim, kl, ku, ipiv, dx_tl)
-! else
- call dgbtrs (trans, ndim, kl, ku, nrhs, ab, ldab, ipiv, dx_tl, ndim, info)
-! endif
- if (info /= 0) write (*,*) ' DGBTRS boundary_conditions: ', info
-
-!* Decompose D+ and D-
- do ilayer = 2, ndim, 2
- jlayer = nwp_levels - ilayer / 2 + 1
-
- dp_tl (ichan,jlayer) = dx_tl (ilayer-1)
- dp (ichan,jlayer) = dx (ilayer-1)
- dm_tl (ichan,jlayer) = dx_tl (ilayer )
- dm (ichan,jlayer) = dx (ilayer )
- end do
-
- deallocate (a, b, dx, a_tl, b_tl, dx_tl, ab, ipiv)
- end do
-
-End subroutine rttov_boundaryconditions_tl
diff --git a/src/LIB/RTTOV/src/rttov_boundaryconditions_tl.interface b/src/LIB/RTTOV/src/rttov_boundaryconditions_tl.interface
deleted file mode 100644
index 36d9f61e486fb264ef43d446cc7c521b201bc915..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_boundaryconditions_tl.interface
+++ /dev/null
@@ -1,34 +0,0 @@
-INTERFACE
-Subroutine rttov_boundaryconditions_tl (&
- & nwp_levels,&
- & nchannels,&
- & nprofiles,&
- & lprofiles,&
- & scatt_aux,&
- & scatt_aux_tl,&
- & profiles ,&
- & profiles_tl ,&
- & ftop,&
- & ftop_tl,&
- & dp,&
- & dp_tl,&
- & dm,&
- & dm_tl)
- Use rttov_types, Only :&
- & profile_Type ,&
- & profile_scatt_aux
- Use parkind1, Only : jpim ,jprb
- Integer (Kind=jpim), Intent (in) :: nwp_levels
- Integer (Kind=jpim), Intent (in) :: nprofiles
- Integer (Kind=jpim), Intent (in) :: nchannels
- Integer (Kind=jpim), Intent (in) :: lprofiles (nchannels)
- Type (profile_scatt_aux), Intent (in) :: scatt_aux
- Type (profile_scatt_aux), Intent (in) :: scatt_aux_tl
- Type (profile_Type), Intent (in) :: profiles (nprofiles)
- Type (profile_Type), Intent (in) :: profiles_tl (nprofiles)
- Real (Kind=jprb), Intent (in), dimension (nchannels) :: ftop
- Real (Kind=jprb), Intent (in), dimension (nchannels) :: ftop_tl
- Real (Kind=jprb), Intent (out), dimension (nchannels,nwp_levels) :: dp , dm
- Real (Kind=jprb), Intent (out), dimension (nchannels,nwp_levels) :: dp_tl, dm_tl
-End subroutine rttov_boundaryconditions_tl
-END INTERFACE
diff --git a/src/LIB/RTTOV/src/rttov_calcbt.F90 b/src/LIB/RTTOV/src/rttov_calcbt.F90
deleted file mode 100644
index 16cd23bf8678f6c011ddee7fd32fe2856a4cc3d8..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_calcbt.F90
+++ /dev/null
@@ -1,101 +0,0 @@
-!
-Subroutine rttov_calcbt( &
- & nfrequencies, &! in
- & nchannels, &! in
- & channels, &! in
- & polarisations, &! in
- & coeffs, &! in
- & rad ) ! inout
- ! Description:
- ! To convert an array of radiances in many channels
- ! to equivalent black body brightness temperatures.
- ! Planck function is applied with a "central wave number"
- ! Temperature is corrected by "band corrections" coefficients
- !
- ! Copyright:
- ! This software was developed within the context of
- ! the EUMETSAT Satellite Application Facility on
- ! Numerical Weather Prediction (NWP SAF), under the
- ! Cooperation Agreement dated 25 November 1998, between
- ! EUMETSAT and the Met Office, UK, by one or more partners
- ! within the NWP SAF. The partners in the NWP SAF are
- ! the Met Office, ECMWF, KNMI and MeteoFrance.
- !
- ! Copyright 2002, EUMETSAT, All Rights Reserved.
- !
- ! Method: Uses band correction coefficients for each channel
- ! read in from RT coefficient file.
- !
- ! Current Code Owner: SAF NWP
- !
- ! History:
- ! Version Date Comment
- ! ------- ---- -------
- ! 1.0 01/12/2002 New F90 code with structures (P Brunel A Smith)
- ! based on BRIGV of previous RTTOV versions
- ! 1.1 02/01/2003 Comments added (R Saunders)
- ! 1.2 08/01/2004 Polarisation added (S English)
- ! 1.3 28/02/2004 Improved vectorisation (D Dent)
- !
- ! Code Description:
- ! Language: Fortran 90.
- ! Software Standards: "European Standards for Writing and
- ! Documenting Exchangeable Fortran 90 Code".
- !
- ! Declarations:
- ! Modules used:
- ! Imported Type Definitions:
- Use rttov_types, Only : &
- & rttov_coef ,&
- & radiance_Type
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
- !subroutine arguments:
- Integer(Kind=jpim), Intent(in) :: nchannels ! Number of processed radiances
- Integer(Kind=jpim), Intent(in) :: nfrequencies ! Number of processed radiances
- Integer(Kind=jpim), Intent(in) :: channels(nfrequencies)! Array of channel indices.
- Integer(Kind=jpim), Intent(in) :: polarisations(nchannels, 3)! Array of channel indices.
-
- Type(rttov_coef), Intent(in) :: coeffs ! Coefficients
- Type(radiance_Type), Intent(inout) :: rad ! input radiances and output BT
-
- ! radiances are expressed in mw/cm-1/ster/sq.m
- ! and temperatures in Kelvin
-
- !local variables:
- Real(Kind=jprb) :: tstore1,tstore2
- Real(Kind=jprb) :: radtotal, radclear
- Integer(Kind=jpim) :: chan,i,ipol,ipz,npol,signrad
-
- !- End of header ------------------------------------------------------
-
- Do i = 1, nfrequencies
- chan = channels(i)
- ipol = polarisations(i, 1)
- npol = polarisations(i, 3)
- !total
- !Note we must add average of 1st two elements of Stokes vector to differences in 3rd/4th before conversion and remove afterwards.
-!cdir nodep
-!cdir novector
- Do ipz = 1, npol
- radtotal = rad%total(ipol+ipz-1)
- !clear
- radclear = rad%clear(ipol+ipz-1)
- if (ipz > 2) then
- radtotal = radtotal + 0.5*(rad%total(ipol) + rad%total(ipol+1))
- radclear = radclear + 0.5*(rad%clear(ipol) + rad%clear(ipol+1))
- End If
- tstore1 = coeffs%planck2(chan) / Log( 1+coeffs%planck1(chan)/radtotal )
- tstore2 = coeffs%planck2(chan) / Log( 1+coeffs%planck1(chan)/radclear )
- rad%bt(ipol+ipz-1) = ( tstore1 - coeffs%ff_bco(chan) ) / coeffs%ff_bcs(chan)
- rad%bt_clear(ipol+ipz-1) = ( tstore2-coeffs%ff_bco(chan) ) / coeffs%ff_bcs(chan)
- if (ipz > 2) then
- rad%bt(ipol+ipz-1) = rad%bt(ipol+ipz-1) - 0.5*(rad%bt(ipol) + rad%bt(ipol+1))
- rad%bt_clear(ipol+ipz-1) = rad%bt_clear(ipol+ipz-1) - 0.5*(rad%bt_clear(ipol) + rad%bt_clear(ipol+1))
- EndIf
- End Do
- End Do
-
-End Subroutine rttov_calcbt
diff --git a/src/LIB/RTTOV/src/rttov_calcbt.interface b/src/LIB/RTTOV/src/rttov_calcbt.interface
deleted file mode 100644
index b6513796e3798cd838419375a7323002ba3a9160..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_calcbt.interface
+++ /dev/null
@@ -1,25 +0,0 @@
-Interface
-!
-Subroutine rttov_calcbt( &
- nfrequencies, & ! in
- nchannels, & ! in
- channels, & ! in
- polarisations, & ! in
- coeffs, & ! in
- rad ) ! inout
-
- Use rttov_types, Only : &
- rttov_coef ,&
- radiance_Type
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
- Integer(Kind=jpim), Intent(in) :: nfrequencies
- Integer(Kind=jpim), Intent(in) :: nchannels
- Integer(Kind=jpim), Intent(in) :: channels(nfrequencies)
- Integer(Kind=jpim), Intent(in) :: polarisations(nchannels,3)
- Type(rttov_coef), Intent(in) :: coeffs ! Coefficients
- Type(radiance_Type), Intent(inout) :: rad ! input radiances and output BT
-
-End Subroutine rttov_calcbt
-End Interface
diff --git a/src/LIB/RTTOV/src/rttov_calcbt_ad.F90 b/src/LIB/RTTOV/src/rttov_calcbt_ad.F90
deleted file mode 100644
index df537b4bc54d65a6f4e252e892b5ff236c0f8a41..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_calcbt_ad.F90
+++ /dev/null
@@ -1,117 +0,0 @@
-Subroutine rttov_calcbt_ad( &
- & nfrequencies, &! in
- & nchannels, &! in
- & channels, &! in
- & polarisations, &! in
- & coeffs, &! in
- & rad, &! in
- & rad_ad ) ! inout
- !
- ! Description:
- ! To convert an array of radiances in many channels
- ! to equivalent black body brightness temperatures.
- ! Planck function is applied with a "central wave number"
- ! Temperature is corrected by "band corrections" coefficients
- ! derivative of inverse Planck function with respect to radiance is
- !
- ! C1 * C2 * Nu**4
- ! B-1'(R,Nu) = --------------------------------------------- dR
- ! ( C1 * Nu**3) ( C1 * Nu**3 )**2
- ! R**2 *(1 + ----------) ( Ln( ---------- )
- ! ( R ) ( R )
- !
- ! which can be reduced to the following, with
- ! C1 = C1 * Nu**3
- ! C2 = C2 * Nu
- !
- ! C1 * B-1(R,Nu)**2
- ! B-1'(R,Nu) = ----------------------- dR
- ! C2 * R * (R + C1)
- !
- ! Copyright:
- ! This software was developed within the context of
- ! the EUMETSAT Satellite Application Facility on
- ! Numerical Weather Prediction (NWP SAF), under the
- ! Cooperation Agreement dated 25 November 1998, between
- ! EUMETSAT and the Met Office, UK, by one or more partners
- ! within the NWP SAF. The partners in the NWP SAF are
- ! the Met Office, ECMWF, KNMI and MeteoFrance.
- !
- ! Copyright 2002, EUMETSAT, All Rights Reserved.
- !
- ! Method: Uses band correction coefficients for each channel
- ! read in from RT coefficient file.
- !
- ! Current Code Owner: SAF NWP
- !
- ! History:
- ! Version Date Comment
- ! ------- ---- -------
- ! 1.0 01/12/2002 New F90 code with structures (P Brunel A Smith)
- ! based on BRIGV of previous RTTOV versions
- ! 1.1 02/01/2003 Comments added (R Saunders)
- ! 1.2 08/01/2004 Polarisation added (S English)
- ! 1.3 29/03/2005 Add end of header comment (J. Cameron)
- !
- ! Code Description:
- ! Language: Fortran 90.
- ! Software Standards: "European Standards for Writing and
- ! Documenting Exchangeable Fortran 90 Code".
- !
- ! Declarations:
- ! Modules used:
- ! Imported Type Definitions:
-
- Use rttov_types, only : &
- & rttov_coef ,&
- & radiance_type
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
- !subroutine arguments:
- Integer(Kind=jpim), Intent(in) :: nfrequencies
- Integer(Kind=jpim), Intent(in) :: nchannels
- Integer(Kind=jpim), Intent(in) :: channels(nfrequencies)
- Integer(Kind=jpim), Intent(in) :: polarisations(nchannels,3)
- Type(rttov_coef), Intent(in) :: coeffs
- Type(radiance_Type), Intent(in) :: rad ! rad%total rad%clear
- Type(radiance_Type), Intent(inout) :: rad_ad
- ! output rad_ad%total only
- ! input rad_ad%bt
- ! Clear BT and Rad are ignored in AD
-
-
-
- !local variables:
- Real(Kind=jprb) :: tstar
- Real(Kind=jprb) :: tstar_ad
- Real(Kind=jprb) :: radtotal
- Integer(Kind=jpim) :: chan,i,npol,ipol,ipz
-
- !- End of header --------------------------------------------------------
-
- Do i = 1, nfrequencies
- ipol = polarisations(i, 1)
- npol = polarisations(i, 3)
- chan = channels(i)
- !total
- Do ipz = 1, npol
- ! total radiance
- ! T star for direct model
- tstar = coeffs%ff_bco(chan) + coeffs%ff_bcs(chan) * rad%bt(ipol+ipz-1)
- radtotal = rad%total(ipol+ipz-1)
- if (ipz > 2) then
- tstar = tstar + coeffs%ff_bcs(chan) * 0.5*(rad%bt(ipol) + rad%bt(ipol+1))
- radtotal = radtotal + 0.5*(rad%total(ipol) + rad%total(ipol+1))
- EndIf
- ! AD
- tstar_ad = rad_ad%bt(ipol+ipz-1) / coeffs%ff_bcs(chan)
- rad_ad%total(ipol+ipz-1) = coeffs%planck1(chan) * tstar**2 /&
- & ( coeffs%planck2(chan) * radtotal * &
- & ( radtotal + coeffs%planck1(chan) ) )&
- & * tstar_ad
- End Do
- End Do
-
-End Subroutine rttov_calcbt_ad
diff --git a/src/LIB/RTTOV/src/rttov_calcbt_ad.interface b/src/LIB/RTTOV/src/rttov_calcbt_ad.interface
deleted file mode 100644
index 1da2f199ca5d398a70ae5c647aadac9c9369b30a..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_calcbt_ad.interface
+++ /dev/null
@@ -1,32 +0,0 @@
-Interface
-Subroutine rttov_calcbt_ad( &
- nfrequencies, & ! in
- nchannels, & ! in
- channels, & ! in
- polarisations, & ! in
- coeffs, & ! in
- rad, & ! in
- rad_ad ) ! inout
-
- Use rttov_types, only : &
- rttov_coef ,&
- radiance_type
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
- Integer(Kind=jpim), Intent(in) :: nfrequencies
- Integer(Kind=jpim), Intent(in) :: nchannels
- Integer(Kind=jpim), Intent(in) :: channels(nfrequencies)
- Integer(Kind=jpim), Intent(in) :: polarisations(nchannels,3)
- Type(rttov_coef), Intent(in) :: coeffs
- Type(radiance_Type), Intent(in) :: rad ! rad%total rad%clear
- Type(radiance_Type), Intent(inout) :: rad_ad
- ! output rad_ad%total only
- ! input rad_ad%bt
- ! Clear BT and Rad are ignored in AD
-
-
-
-End Subroutine rttov_calcbt_ad
-End Interface
diff --git a/src/LIB/RTTOV/src/rttov_calcbt_tl.F90 b/src/LIB/RTTOV/src/rttov_calcbt_tl.F90
deleted file mode 100644
index 4c6a957c889f9868f0c9160363aee974bbdad05c..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_calcbt_tl.F90
+++ /dev/null
@@ -1,127 +0,0 @@
-Subroutine rttov_calcbt_tl( &
- & nfrequencies, &! in
- & nchannels, &! in
- & channels, &! in
- & polarisations, &! in
- & coeffs, &! in
- & rad, &! in
- & rad_tl )
- !
- ! Description:
- ! To convert an array of radiances in many channels
- ! to equivalent black body brightness temperatures.
- ! Planck function is applied with a "central wave number"
- ! Temperature is corrected by "band corrections" coefficients
- ! derivative of inverse Planck function with respect to radiance is
- !
- ! C1 * C2 * Nu**4
- ! B-1'(R,Nu) = --------------------------------------------- dR
- ! ( C1 * Nu**3) ( C1 * Nu**3 )**2
- ! R**2 *(1 + ----------) ( Ln( ---------- )
- ! ( R ) ( R )
- !
- ! which can be reduced to the following, with
- ! C1 = C1 * Nu**3
- ! C2 = C2 * Nu
- !
- ! C1 * B-1(R,Nu)**2
- ! B-1'(R,Nu) = ----------------------- dR
- ! C2 * R * (R + C1)
- !
- ! Copyright:
- ! This software was developed within the context of
- ! the EUMETSAT Satellite Application Facility on
- ! Numerical Weather Prediction (NWP SAF), under the
- ! Cooperation Agreement dated 25 November 1998, between
- ! EUMETSAT and the Met Office, UK, by one or more partners
- ! within the NWP SAF. The partners in the NWP SAF are
- ! the Met Office, ECMWF, KNMI and MeteoFrance.
- !
- ! Copyright 2002, EUMETSAT, All Rights Reserved.
- !
- ! Method: Uses band correction coefficients for each channel
- ! read in from RT coefficient file.
- !
- ! Current Code Owner: SAF NWP
- !
- ! History:
- ! Version Date Comment
- ! ------- ---- -------
- ! 1.0 01/12/2002 New F90 code with structures (P Brunel A Smith)
- ! based on BRIGV of previous RTTOV versions
- ! 1.1 02/01/2003 Comments added (R Saunders)
- ! 1.2 08/01/2004 Polarisation added (S English)
- ! 1.3 29/03/2005 Add end of header comment (J. Cameron)
- !
- ! Code Description:
- ! Language: Fortran 90.
- ! Software Standards: "European Standards for Writing and
- ! Documenting Exchangeable Fortran 90 Code".
- !
- ! Declarations:
- ! Modules used:
- ! Imported Type Definitions:
-
- Use rttov_types, only : &
- & rttov_coef ,&
- & radiance_type
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
- !subroutine arguments:
- Integer(Kind=jpim), Intent(in) :: nfrequencies
- Integer(Kind=jpim), Intent(in) :: nchannels
- Integer(Kind=jpim), Intent(in) :: channels(nfrequencies)
- Integer(Kind=jpim), Intent(in) :: polarisations(nchannels,3)
- Type(rttov_coef), Intent(in) :: coeffs
- Type(radiance_Type), Intent(in) :: rad ! rad%total rad%clear
- Type(radiance_Type), Intent(inout) :: rad_tl
- ! input rad_tl%total and rad_tl%clear
- ! output rad_tl%bt and rad_tl%bt_clear
-
- !local variables:
- Real(Kind=jprb) :: tstar
- Real(Kind=jprb) :: tstar_tl
- Real(Kind=jprb) :: radtotal, radclear
- Integer(Kind=jpim) :: chan,i,npol,ipol,ipz
-
- !- End of header --------------------------------------------------------
-
- Do i = 1, nfrequencies
- chan = channels(i)
- ipol = polarisations(i, 1)
- npol = polarisations(i, 3)
-
- Do ipz = 1, npol
- ! total radiance
- ! T star for direct model
- tstar = coeffs%ff_bco(chan) + coeffs%ff_bcs(chan) * rad%bt(ipol+ipz-1)
- radtotal = rad%total(ipol+ipz-1)
- if (ipz > 2) then
- tstar = tstar + coeffs%ff_bcs(chan) * 0.5*(rad%bt(ipol) + rad%bt(ipol+1))
- radtotal = radtotal + 0.5*(rad%total(ipol) + rad%total(ipol+1))
- EndIf
- ! TL
- tstar_tl = coeffs%planck1(chan) * tstar**2 /&
- & ( coeffs%planck2(chan) * radtotal * ( radtotal + coeffs%planck1(chan) ))&
- & * rad_tl%total(ipol+ipz-1)
- rad_tl%bt(ipol+ipz-1) = tstar_tl / coeffs%ff_bcs(chan)
-
- !clear radiance
- ! T star for direct model
- tstar = coeffs%ff_bco(chan) + coeffs%ff_bcs(chan) * rad%bt_clear(ipol+ipz-1)
- radclear = rad%clear(ipol+ipz-1)
- if (ipz > 2) then
- tstar = tstar + coeffs%ff_bcs(chan) * 0.5*(rad%bt_clear(ipol) + rad%bt_clear(ipol+1))
- radclear = radclear + 0.5*(rad%clear(ipol) + rad%clear(ipol+1))
- EndIf
- ! TL
- tstar_tl = coeffs%planck1(chan) * tstar**2 /&
- & ( coeffs%planck2(chan) * radclear * ( radclear + coeffs%planck1(chan) ))&
- & * rad_tl%clear(ipol+ipz-1)
- rad_tl%bt_clear(ipol+ipz-1) = tstar_tl / coeffs%ff_bcs(chan)
- End Do
- End Do
-
-End Subroutine rttov_calcbt_tl
diff --git a/src/LIB/RTTOV/src/rttov_calcbt_tl.interface b/src/LIB/RTTOV/src/rttov_calcbt_tl.interface
deleted file mode 100644
index 630c69887fc45e5df1d48d4c7b57b81eeaa895b3..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_calcbt_tl.interface
+++ /dev/null
@@ -1,30 +0,0 @@
-Interface
-Subroutine rttov_calcbt_tl( &
- nfrequencies, & ! in
- nchannels, & ! in
- channels, & ! in
- polarisations, & ! in
- coeffs, & ! in
- rad, & ! in
- rad_tl ) ! inout
-
- Use rttov_types, only : &
- rttov_coef ,&
- radiance_type
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
- Integer(Kind=jpim), Intent(in) :: nfrequencies
- Integer(Kind=jpim), Intent(in) :: nchannels
- Integer(Kind=jpim), Intent(in) :: channels(nfrequencies)
- Integer(Kind=jpim), Intent(in) :: polarisations(nchannels,3)
- Type(rttov_coef), Intent(in) :: coeffs
- Type(radiance_Type), Intent(in) :: rad ! rad%total rad%clear
- Type(radiance_Type), Intent(inout) :: rad_tl
- ! input rad_tl%total and rad_tl%clear
- ! output rad_tl%bt and rad_tl%bt_clear
-
-
-
-End Subroutine rttov_calcbt_tl
-End Interface
diff --git a/src/LIB/RTTOV/src/rttov_calcemis_ir.F90 b/src/LIB/RTTOV/src/rttov_calcemis_ir.F90
deleted file mode 100644
index 375b33f437834ee9c8f1760438e9cdb94a478d6e..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_calcemis_ir.F90
+++ /dev/null
@@ -1,118 +0,0 @@
-!
-Subroutine rttov_calcemis_ir( &
- & profiles, &! in
- & geometry, &! in
- & coef, &! in
- & nchannels, &! in
- & nprofiles, &! in
- & channels, &! in
- & lprofiles, &! in
- & calcemis, &! in
- & emissivity ) ! inout
- ! Description:
- ! To compute IR surface emissivities for all channels and all
- ! profiles if desired
- !
- ! Copyright:
- ! This software was developed within the context of
- ! the EUMETSAT Satellite Application Facility on
- ! Numerical Weather Prediction (NWP SAF), under the
- ! Cooperation Agreement dated 25 November 1998, between
- ! EUMETSAT and the Met Office, UK, by one or more partners
- ! within the NWP SAF. The partners in the NWP SAF are
- ! the Met Office, ECMWF, KNMI and MeteoFrance.
- !
- ! Copyright 2002, EUMETSAT, All Rights Reserved.
- !
- ! Method:
- ! RTTOV-6 IR surface emissivity report, V. Sherlock at:
- ! http://www.metoffice.com/research/interproj/nwpsaf/rtm/papers/isem6.pdf
- !
- ! Current Code Owner: SAF NWP
- !
- ! History:
- ! Version Date Comment
- ! ------- ---- -------
- ! 1.0 01/12/2002 New F90 code with structures (P Brunel A Smith)
- ! 1.1 02/01/2003 Comments added (R Saunders)
- ! 1.2 29/03/2005 Add end of header comment (J. Cameron)
- !
- ! Code Description:
- ! Language: Fortran 90.
- ! Software Standards: "European Standards for Writing and
- ! Documenting Exchangeable Fortran 90 Code".
- !
- ! Declarations:
- ! Modules used:
-
- ! Imported Parameters:
- Use rttov_const, Only : &
- & surftype_land, &
- & surftype_seaice
-
- ! Imported Type Definitions:
- Use rttov_types, Only : &
- & rttov_coef ,&
- & profile_Type ,&
- & geometry_Type
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
- !subroutine arguments:
- Integer(Kind=jpim), Intent(in) :: nprofiles
- Type(profile_Type), Intent(in) ,Target :: profiles(nprofiles)
- Type(geometry_Type), Intent(in) ,Target :: geometry(nprofiles)
- Type(rttov_coef), Intent(in) :: coef
- Integer(Kind=jpim), Intent(in) :: nchannels
- Integer(Kind=jpim), Intent(in) :: channels(nchannels)
- Integer(Kind=jpim), Intent(in) :: lprofiles(nchannels)
- Logical, Intent(in) :: calcemis(nchannels)
- Real(Kind=jprb), Intent(inout) :: emissivity(nchannels)
-
-
-
- !local variables:
- Type(profile_Type), Pointer :: prof
- Type(geometry_Type), Pointer :: geom
-
- Integer(Kind=jpim) :: j, chan
-
- !- End of header --------------------------------------------------------
-
- ! Loop on all channels
- Do j = 1, nchannels
- If ( .Not. calcemis(j) ) Cycle
-
- chan = channels(j)
-
- ! point to corresponding profile and geometry structures
- prof => profiles( lprofiles(j) )
- geom => geometry( lprofiles(j) )
-
- !-----------------------------------------
- !1. Use a fixed value over land and seaice
- !-----------------------------------------
- If ( prof % skin % surftype == surftype_land ) Then
- emissivity(j) = 0.98_JPRB
- Else If ( prof % skin % surftype == surftype_seaice ) Then
- emissivity(j) = 0.99_JPRB
- Else
-
- !------------------------------------------------------------------
- !2. Over sea, emissivity is a polynomial in normalized zenith angle
- ! ISEM6 model
- !------------------------------------------------------------------
-
- emissivity(j) = coef % ssirem_a0 (chan) - &
- & coef % ssirem_a1 (chan) * &
- & geom % normzen ** coef % ssirem_xzn1(chan) - &
- & coef % ssirem_a2 (chan) * &
- & geom % normzen ** coef % ssirem_xzn2(chan)
-
- End If
- End Do
-
-
-
-End Subroutine rttov_calcemis_ir
diff --git a/src/LIB/RTTOV/src/rttov_calcemis_ir.interface b/src/LIB/RTTOV/src/rttov_calcemis_ir.interface
deleted file mode 100644
index a6485c8a6a53d9100488bd1d236faddbae43c7da..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_calcemis_ir.interface
+++ /dev/null
@@ -1,38 +0,0 @@
-Interface
-!
-Subroutine rttov_calcemis_ir( &
- profiles, & ! in
- geometry, & ! in
- coef, & ! in
- nchannels, & ! in
- nprofiles, & ! in
- channels, & ! in
- lprofiles, & ! in
- calcemis, & ! in
- emissivity ) ! inout
-
- Use rttov_const, Only : &
- surftype_land, &
- surftype_seaice
-
- Use rttov_types, Only : &
- rttov_coef ,&
- profile_Type ,&
- geometry_Type
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
- Integer(Kind=jpim), Intent(in) :: nprofiles
- Type(profile_Type), Intent(in) ,Target :: profiles(nprofiles)
- Type(geometry_Type), Intent(in) ,Target :: geometry(nprofiles)
- Type(rttov_coef), Intent(in) :: coef
- Integer(Kind=jpim), Intent(in) :: nchannels
- Integer(Kind=jpim), Intent(in) :: channels(nchannels)
- Integer(Kind=jpim), Intent(in) :: lprofiles(nchannels)
- Logical, Intent(in) :: calcemis(nchannels)
- Real(Kind=jprb), Intent(inout) :: emissivity(nchannels)
-
-
-End Subroutine rttov_calcemis_ir
-End Interface
diff --git a/src/LIB/RTTOV/src/rttov_calcemis_mw.F90 b/src/LIB/RTTOV/src/rttov_calcemis_mw.F90
deleted file mode 100644
index 5e4d4478d0dddebd9a6930f0eff94087d3d7d7cf..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_calcemis_mw.F90
+++ /dev/null
@@ -1,540 +0,0 @@
-!
-Subroutine rttov_calcemis_mw ( &
- & profiles, &! in
- & geometry, &! in
- & coef, &! in
- & nfrequencies, &! in
- & nchannels, &! in
- & nprofiles, &! in
- & channels, &! in
- & polarisations, &! in
- & lprofiles, &! in
- & transmission, &! in
- & calcemis, &! in
- & emissivity, &! inout
- & reflectivity, &! out
- & errorstatus ) ! inout
- !
- ! Description:
- ! To compute MW surface emissivities for all channels and all
- ! profiles if desired
- !
- ! Copyright:
- ! This software was developed within the context of
- ! the EUMETSAT Satellite Application Facility on
- ! Numerical Weather Prediction (NWP SAF), under the
- ! Cooperation Agreement dated 25 November 1998, between
- ! EUMETSAT and the Met Office, UK, by one or more partners
- ! within the NWP SAF. The partners in the NWP SAF are
- ! the Met Office, ECMWF, KNMI and MeteoFrance.
- !
- ! Copyright 2002, EUMETSAT, All Rights Reserved.
- !
- ! Method:
- ! FASTEM-1 English and Hewison 1998.
- ! FASTEM-2 Deblonde and English 2001.
- ! FASTEM-3 English 2003.
- ! http://www.metoffice.com/research/interproj/nwpsaf/rtm/evalfastems.pdf
- ! Current Code Owner: SAF NWP
- !
- ! History:
- ! Version Date Comment
- ! ------- ---- -------
- ! 1.0 01/12/2002 New F90 code with structures (P Brunel A Smith)
- ! 1.1 02/01/2003 Comments added (R Saunders)
- ! 1.2 24/01/2003 error return code changed to array size (P Brunel)
- ! No more test on negative values for emissivity input
- ! 1.3 26/09/2003 Added polarimetric code and Fastem-3 (S English)
- ! 1.4 14/10/2005 Bug fix to wind10_direction calculation (J Cameron)
- !
- ! Code Description:
- ! Language: Fortran 90.
- ! Software Standards: "European Standards for Writing and
- ! Documenting Exchangeable Fortran 90 Code".
- !
- ! Declarations:
- ! Modules used:
- !
- ! Imported Parameters:
- Use rttov_const, Only : &
- & pi ,&
- & surftype_sea ,&
- & errorstatus_fatal
-
- ! Imported Type Definitions:
- Use rttov_types, Only : &
- & rttov_coef ,&
- & profile_Type ,&
- & transmission_Type ,&
- & geometry_Type
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
-#include "rttov_errorreport.interface"
-
- !subroutine arguments:
- Integer(Kind=jpim), Intent(in) :: nprofiles
- Type(profile_Type), Intent(in) ,Target :: profiles(nprofiles)
- Type(geometry_Type), Intent(in) ,Target :: geometry(nprofiles)
- Type(rttov_coef), Intent(in) :: coef
- Integer(Kind=jpim), Intent(in) :: nchannels
- Integer(Kind=jpim), Intent(in) :: nfrequencies
- Integer(Kind=jpim), Intent(in) :: channels(nfrequencies)
- Integer(Kind=jpim), Intent(in) :: polarisations(nchannels,3)
- Integer(Kind=jpim), Intent(in) :: lprofiles(nfrequencies)
- Type(transmission_Type), Intent(in):: transmission
- Logical, Intent(in) :: calcemis(nchannels)
- Real(Kind=jprb), Intent(inout) :: emissivity(nchannels)
- Real(Kind=jprb), Intent(out) :: reflectivity(nchannels)
- Integer(Kind=jpim), Intent(inout) :: errorstatus(nprofiles)
-
- !local constants:
- Real(Kind=jprb), Parameter :: quadcof(4,2) = Reshape( &
- & (/ 0.0_JPRB, 1.0_JPRB, 1.0_JPRB, 2.0_JPRB, &
- & 1.0_JPRB, -1.0_JPRB, 1.0_JPRB, -1.0_JPRB /), (/4,2/) )
- Real(Kind=jprb), Parameter :: freqfixed(4) = Reshape( &
- & (/ 7.0_JPRB, 10.0_JPRB, 19.0_JPRB, 37.0_JPRB /), (/4/) )
-
- !local variables:
- Character (len=80) :: errMessage
- Character (len=18) :: NameOfRoutine = 'rttov_calcemis_mw '
- Real(Kind=jprb) :: tcelsius
- Real(Kind=jprb) :: tcelsius_sq
- Real(Kind=jprb) :: tcelsius_cu
- Real(Kind=jprb) :: einf ! Debye parameter Epsilon infinity
- Real(Kind=jprb) :: fen,fen_sq ! intermediate Debye variable
- Real(Kind=jprb) :: del1,del2 ! intermediate Debye variable
- Real(Kind=jprb) :: den1,den2 ! intermediate Debye variable
- Real(Kind=jprb) :: f1,f2 ! intermediate Debye variable
- Real(Kind=jprb) :: perm_free ! permittivity (space)
- Real(Kind=jprb) :: sigma ! saline water conductivity
- Real(Kind=jprb) :: perm_real1,perm_real2 ! permittivity (real part)
- Real(Kind=jprb) :: perm_imag1,perm_imag2,perm_imag3 ! .... imaginary part
- Real(Kind=jprb) :: perm_Real,perm_imag ! permittivity (real, imaginary part)
- Real(Kind=jprb) :: perm_static ! static land permittivity
- Real(Kind=jprb) :: perm_infinite ! infinite frequency land permittivity
- Real(Kind=jprb) :: freq_ghz,freq_ghz_sq ! frequency in GHz , and squared
- Real(Kind=jprb) :: fresnel_v_Real,fresnel_v_imag
- Real(Kind=jprb) :: fresnel_h_Real,fresnel_h_imag
- Real(Kind=jprb) :: fresnel_v,fresnel_h
- Real(Kind=jprb) :: small_rough_cor,foam_cor
- Real(Kind=jprb) :: large_rough_cor(2)
- Real(Kind=jprb) :: small_rough,large_rough ! small and large scale roughness
- Real(Kind=jprb) :: emissstokes(nfrequencies,4)
- Real(Kind=jprb) :: reflectstokes(nfrequencies,4)
- Real(Kind=jprb) :: variance,varm
- Real(Kind=jprb) :: wind10
- Real(Kind=jprb) :: wind10_sq,windsec, windratio
- Real(Kind=jprb) :: wind10_direction, windangle ! Note wind azimuth is in radians
- Real(Kind=jprb) :: opdpsfc,freqr
- Real(Kind=jprb) :: zrough_v,zrough_h
- Real(Kind=jprb) :: zreflmod_v,zreflmod_h
- Real(Kind=jprb) :: delta,delta2
- Real(Kind=jprb) :: qdepol,emissfactor
- Real(Kind=jprb) :: emissfactor_v,emissfactor_h
- Real(Kind=jprb) :: zc(12) ! large scale correction
- Real(Kind=jprb) :: zx(9) ! effective path coefficients
- Real(Kind=jprb) :: azimuthal_emiss,u19,phi,dfreq
- Real(Kind=jprb) :: tbfixed(4,4,3) ! Surface brightness temperature azimuthal variation terms for 37, 19, 10, 7 GHz
- Real(Kind=jprb) :: efixed(4,4,3) ! Emissivity azimuthal variation terms for 7, 10, 19, 37 GHz
- Real(Kind=jprb) :: einterpolated(4,3) ! Emissivity azimuthal variation terms for interpolated to required frequency
- Real(Kind=jprb) :: a1e,a2e,a3e ! coefficients used in azimuthal emissivity model
- Real(Kind=jprb), Pointer :: c(:) ! pointer to FASTEM coefs
- Complex(Kind=jprb) :: perm1,perm2 ! permittivity
- Complex(Kind=jprb) :: rhth,rvth ! Fresnel reflectivity complex variables
- Complex(Kind=jprb) :: permittivity ! permittivity
- Integer(Kind=jpim) :: i,j,chan,istokes,ifreq,m
- Integer(Kind=jpim) :: iquadrant ! Determines which quadrant (NE, SE, SW, NW) the wind is blowing to
- Integer(Kind=jpim) :: pol_id ! polarisation indice
- Integer(Kind=jpim) :: i_freq,j_stokes,ich,ichannel ! indices used in azimuthal emissivity model
- ! == pol_id +1
- ! 1 average of vertical and horizontal
- ! 2 nominal vertical at nadir, rotating
- ! with view angle
- ! 3 nominal horizontal at nadir, rotating
- ! with view angle
- ! 4 vertical
- ! 5 horizontal
- ! 6 vertical and horizontal
- ! 7 full stokes vector
- Integer(Kind=jpim) :: jcof,jcofm1
- Type(profile_Type), Pointer :: prof
- Type(geometry_Type), Pointer :: geom
- Integer(Kind=jpim) :: wanted_fastem_ver ! user fastem version request
- !- End of header --------------------------------------------------------
-
- ! If the coefficent file contains FASTEM 2 it contains also FASTEM 1 but
- ! the version choosen is given by coef % fastem_ver value
- wanted_fastem_ver = coef % fastem_ver
-
- !Loop over channels
-
- Do i = 1, nfrequencies
- ichannel=polarisations(i,1)
- If ( .Not. calcemis(ichannel) ) Cycle
- chan = channels(i)
- prof => profiles( lprofiles(i) )
- geom => geometry( lprofiles(i) )
- pol_id = coef % fastem_polar(chan) + 1_jpim
- !-------------------------------
- !0. Point to fastem coefficients
- !-------------------------------
-
- c => coef % fastem_coef
-
- !---------------
- !1. Sea surfaces
- !---------------
-
- If ( prof % skin % surftype == surftype_sea ) Then
-
- !-------------------------------------------
- !1.1 Calculate channel independent variables
- !-------------------------------------------
- wind10_sq = prof % s2m % u * prof % s2m % u +&
- & prof % s2m % v * prof % s2m % v
- wind10 = Sqrt( wind10_sq )
- if (prof % s2m % u >= 0.0_JPRB .AND. prof % s2m % v >= 0.0_JPRB) iquadrant=1
- if (prof % s2m % u >= 0.0_JPRB .AND. prof % s2m % v < 0.0_JPRB) iquadrant=2
- if (prof % s2m % u < 0.0_JPRB .AND. prof % s2m % v >= 0.0_JPRB) iquadrant=4
- if (prof % s2m % u < 0.0_JPRB .AND. prof % s2m % v < 0.0_JPRB) iquadrant=3
- if (abs(prof % s2m % v) >= 0.0001_JPRB) then
- windratio=prof % s2m % u/prof % s2m % v
- else
- windratio=0.0
- if (abs(prof % s2m % u) > 0.0001_JPRB) then
- windratio=999999.0*prof % s2m % u
- endif
- endif
- windangle=atan(windratio)
- wind10_direction = quadcof(iquadrant,1)*pi+windangle*quadcof(iquadrant,2)
- windsec = wind10 * geom%seczen
-
- !Set values for temperature polynomials (convert from kelvin to celsius)
- tcelsius = prof % skin % t - 273.15_JPRB
- tcelsius_sq = tcelsius * tcelsius !quadratic
- tcelsius_cu = tcelsius_sq * tcelsius !cubic
-
- !Define two relaxation frequencies, f1 and f2
- f1 = c(1) + c(2) * tcelsius + c(3) * tcelsius_sq
- f2 = c(4) + c(5) * tcelsius + c(6) * tcelsius_sq + c(7) * tcelsius_cu
-
- !Static permittivity estatic = del1+del2+einf
- del1 = c(8) + c(9) * tcelsius + c(10) * tcelsius_sq + c(11) * tcelsius_cu
- del2 = c(12) + c(13) * tcelsius + c(14) * tcelsius_sq + c(15) * tcelsius_cu
- einf = c(18) + c(19) * tcelsius
-
-
- freq_ghz = coef % frequency_ghz(chan)
- freq_ghz_sq = freq_ghz * freq_ghz
-
- !-----------------------------------------------------
- !1.2 calculate permittivity using double-debye formula
- !-----------------------------------------------------
-
- fen = 2.0_JPRB * c(20) * freq_ghz * 0.001_JPRB
- fen_sq = fen*fen
- den1 = 1.0_JPRB + fen_sq * f1 * f1
- den2 = 1.0_JPRB + fen_sq * f2 * f2
- perm_real1 = del1 / den1
- perm_real2 = del2 / den2
- perm_imag1 = del1 * fen * f1 / den1
- perm_imag2 = del2 * fen * f2 / den2
- ! perm_free = 8.854E-3_JPRB not 8.854E-12 as multiplied by 1E9 for GHz
- perm_free = 8.854E-3_JPRB
- sigma = 2.906_JPRB + 0.09437_JPRB * tcelsius
- perm_imag3 = sigma / (2.0_JPRB * c(20) * perm_free * freq_ghz)
- perm_Real = perm_real1 + perm_real2 + einf
- perm_imag = perm_imag1 + perm_imag2 + perm_imag3
- permittivity = Cmplx(perm_Real,perm_imag,jprb)
-
-
- !-------------------------------------------------------------
- !1.3 calculate complex reflection coefficients and corrections
- !-------------------------------------------------------------
-
-
- !1.3.1) Fresnel reflection coefficients
- !------
-
- perm1 = sqrt(permittivity - geom%sinzen_sq)
- perm2 = permittivity * geom%coszen
- rhth = (geom%coszen-perm1) / (geom%coszen+perm1)
- rvth = (perm2-perm1) / (perm2+perm1)
- fresnel_v_Real = Dble(rvth)
- fresnel_v_imag = Aimag(rvth)
- fresnel_v = fresnel_v_Real * fresnel_v_Real + &
- & fresnel_v_imag * fresnel_v_imag
- fresnel_h_Real = Dble(rhth)
- fresnel_h_imag = Aimag(rhth)
- fresnel_h = fresnel_h_Real * fresnel_h_Real + &
- & fresnel_h_imag * fresnel_h_imag
-
-
- !1.3.2) Small scale correction to reflection coefficients
- !------
-
- If (freq_ghz >= 15.0_jprb) Then
- small_rough_cor = Exp( c(21) * wind10 * geom % coszen_sq / (freq_ghz_sq) )
- Else
- small_rough_cor = 1.0_jprb
- End If
-
- !1.3.3) Large scale geometric correction
- !------
-
- !Point to correct coefficients for this version. There are 36 altogether.
- !Those for FASTEM-2 are stored in section 24:59 of the array, those for
- !FASTEM1 in section 60:95.
- If ( wanted_fastem_ver == 2 ) Then
- c => coef%fastem_coef(24:59)
- Else
- c => coef%fastem_coef(60:95)
- End If
- Do j = 1, 12
- zc(j) = c(j*3-2) + c(j*3-1)*freq_ghz + c(j*3)*freq_ghz_sq
- End Do
- !Point back to all coefficients again
- c => coef%fastem_coef
-
- large_rough_cor(1) = &
- & zc(1) + &
- & zc(2) * geom%seczen + &
- & zc(3) * geom%seczen_sq + &
- & zc(4) * wind10 + &
- & zc(5) * wind10_sq + &
- & zc(6) * windsec
- large_rough_cor(2) = &
- & zc(7) + &
- & zc(8) * geom%seczen + &
- & zc(9) * geom%seczen_sq + &
- & zc(10) * wind10 + &
- & zc(11) * wind10_sq + &
- & zc(12) * windsec
- large_rough_cor(:) = large_rough_cor(:) * 0.01_JPRB
-
- ! For Fastem-3 do not compute rough surface effects if theta > 60 degrees
- If (wanted_fastem_ver <= 2.0_JPRB .or. (wanted_fastem_ver == 3 .And. geom%seczen <= 2.0_JPRB)) Then
- emissstokes(i,1) = 1.0_JPRB - fresnel_v * small_rough_cor + large_rough_cor(1)
- emissstokes(i,2) = 1.0_JPRB - fresnel_h * small_rough_cor + large_rough_cor(2)
- Else
- emissstokes(i,1) = 1.0_JPRB - fresnel_v
- emissstokes(i,2) = 1.0_JPRB - fresnel_h
- End If
-
- emissstokes(i,3) = 0.0_JPRB
- emissstokes(i,4) = 0.0_JPRB
-
- !Apply foam correction
- foam_cor = c(22) * ( wind10 ** c(23) )
- emissstokes(i,1) = emissstokes(i,1) - foam_cor*emissstokes(i,1) + foam_cor
- emissstokes(i,2) = emissstokes(i,2) - foam_cor*emissstokes(i,2) + foam_cor
-
- If ( wanted_fastem_ver == 3) then
- ! Add azimuthal component from Fuzhong Weng (NOAA/NESDIS) based on work by Dr. Gene Poe (NRL)
- ! Angle between wind direction and satellite azimuthal view angle
-
- phi = pi-(wind10_direction-prof % azangle*pi/180.0_JPRB)
- ! Assume 19m wind = 10m wind for now (fix later).
- u19=wind10
- Do ich = 0,15
- a1e = c(141+ich*12) + u19*(c(142+ich*12)+ u19*(c(143+ich*12)+u19*c(144+ich*12)))
- a2e = c(145+ich*12) + u19*(c(146+ich*12)+ u19*(c(147+ich*12)+u19*c(148+ich*12)))
- a3e = c(149+ich*12) + u19*(c(150+ich*12)+ u19*(c(151+ich*12)+u19*c(152+ich*12)))
- i_freq = int(ich/4_jpim) + 1 ! 37, 19, 10, 7 GHz
- j_stokes = mod(ich,4_jpim) + 1
- tbfixed(j_stokes,i_freq,1) = a1e !* prof % skin % t
- tbfixed(j_stokes,i_freq,2) = a2e !* prof % skin % t
- tbfixed(j_stokes,i_freq,3) = a3e !* prof % skin % t
- End Do
-
- Do M=1,3
- Do istokes=1,4
- efixed(1,istokes,M)= tbfixed(istokes,4,M) !/prof % skin % t ! 7 GHz
- efixed(2,istokes,M)= tbfixed(istokes,3,M) !/prof % skin % t ! 10 GHz
- efixed(3,istokes,M)= tbfixed(istokes,2,M) !/prof % skin % t ! 19 GHz
- efixed(4,istokes,M)= tbfixed(istokes,1,M) !/prof % skin % t ! 37 GHz
- End Do
-
- ! Interpolate results to required frequency based on 7, 10, 19, 37 GHz
-
- If (freq_ghz.le.freqfixed(1)) Then
- Do istokes=1,4
- einterpolated(istokes,M)=efixed(1,istokes,M)
- End Do
- Else If(freq_ghz.ge.freqfixed(4)) then
- Do istokes=1,4
- einterpolated(istokes,M)=efixed(4,istokes,M)
- End Do
- Else
- If(freq_ghz.lt.freqfixed(2)) ifreq=2
- If(freq_ghz.lt.freqfixed(3).and.freq_ghz.ge.freqfixed(2)) ifreq=3
- If(freq_ghz.ge.freqfixed(3)) ifreq=4
- dfreq=(freq_ghz-freqfixed(ifreq-1))/(freqfixed(ifreq)-freqfixed(ifreq-1))
- Do istokes=1,4
- einterpolated(istokes,M)=efixed(ifreq-1,istokes,M)+dfreq*(efixed(ifreq,istokes,M)-efixed(ifreq-1,istokes,M))
- End Do
- End If
- End Do
- Do istokes = 1,4
- azimuthal_emiss=0.0_JPRB
- Do M=1,3
- If(istokes.le.2) Then
- azimuthal_emiss=azimuthal_emiss+einterpolated(istokes,M)*cos(m*phi)*(1.0_JPRB-geom%coszen)&
- & /(1.0_JPRB - 0.6018_JPRB)
- Else
- azimuthal_emiss=azimuthal_emiss+einterpolated(istokes,M)*sin(m*phi)*(1.0_JPRB-geom%coszen)&
- & /(1.0_JPRB - 0.6018_JPRB)
- End If
- End Do
- emissstokes(i,istokes)=emissstokes(i,istokes)+azimuthal_emiss
- End Do
- End If
-
- ! Only apply non-specular correction for Fastem-3 if theta < 60 degrees
- If ((wanted_fastem_ver == 2 .or. (wanted_fastem_ver == 3 .And. geom%seczen <= 2.0_JPRB)) .And. &
- & transmission % tau_surf(ichannel) < 0.9999_JPRB .And. &
- & transmission % tau_surf(ichannel) > 0.00001_JPRB ) Then
-
- !Convert windspeed to slope variance using the Cox and Munk model
- variance = 0.00512_JPRB * wind10 + 0.0030_JPRB
- varm = variance * c(138)
- variance = varm * ( c(139) * freq_ghz + c(140) )
- If ( variance > varm ) variance = varm
- If ( variance < 0.0_JPRB ) variance = 0.0_JPRB
-
- !Compute surface to space optical depth
- opdpsfc = -log(transmission % tau_surf(ichannel)) / geom%seczen
-
- !Define nine predictors for the effective angle calculation
- zx(1) = 1.0_JPRB
- zx(2) = variance
- zx(4) = 1.0_JPRB / geom%coszen
- zx(3) = zx(2) * zx(4)
- zx(5) = zx(3) * zx(3)
- zx(6) = zx(4) * zx(4)
- zx(7) = zx(2) * zx(2)
- zx(8) = log(opdpsfc)
- zx(9) = zx(8) * zx(8)
-
- zrough_v = 1.0_JPRB
- zrough_h = 1.0_JPRB
- Do jcof = 1,7
- jcofm1 = jcof-1
- !Switched h to v Deblonde SSMIS june 7, 2001
- zrough_h = zrough_h + &
- & zx(jcof) * ( c(96+jcofm1*3) &
- & + zx(8) * c(97+jcofm1*3) &
- & + zx(9) * c(98+jcofm1*3) )
- zrough_v = zrough_v + &
- & zx(jcof) * ( c(117+jcofm1*3) &
- & + zx(8) * c(118+jcofm1*3) &
- & + zx(9) * c(119+jcofm1*3) )
- End Do
-
- zreflmod_v = (1.0_JPRB-transmission %tau_surf(ichannel)**zrough_v)&
- & / (1.0_JPRB-transmission % tau_surf(ichannel))
- zreflmod_h = (1.0_JPRB-transmission % tau_surf(ichannel)**zrough_h)&
- & / (1.0_JPRB-transmission % tau_surf(ichannel))
- reflectstokes(i,1) = zreflmod_v * (1.0_JPRB-emissstokes(i,1))
- reflectstokes(i,2) = zreflmod_h * (1.0_JPRB-emissstokes(i,2))
- reflectstokes(i,3) = -0.5_JPRB * (zreflmod_v + zreflmod_h) * emissstokes(i,3)
- reflectstokes(i,4) = -0.5_JPRB * (zreflmod_v + zreflmod_h) * emissstokes(i,4)
- Else
- reflectstokes(i,1) = 1.0_JPRB - emissstokes(i,1)
- reflectstokes(i,2) = 1.0_JPRB - emissstokes(i,2)
- reflectstokes(i,3) = 0.0_JPRB
- reflectstokes(i,4) = 0.0_JPRB
- End If
-
- !--------------------
- !2. Land/ice surfaces
- !--------------------
-
- Else
-
-! If ( Any( c == 0.0_JPRB ) ) Then
-! Write( errMessage, '( "some fastem coefs are 0.0 " )' )
-! Call Rttov_ErrorReport (errorstatus_fatal, errMessage, NameOfRoutine)
-! errorstatus(:) = errorstatus_fatal
-! Return
-! End If
-
- ! Test input FASTEM land coefficients
- ! only coefs 1-3 are checked
- If ( Any( prof % skin % fastem(1:3) == 0.0_JPRB ) ) Then
- Write( errMessage, '( "some profile fastem(1:3) values are 0.0 " )' )
- Call Rttov_ErrorReport (errorstatus_fatal, errMessage, NameOfRoutine)
- errorstatus(:) = errorstatus_fatal
- Return
- End If
-
- !Coherent surface scattering model coefficients (input with the profile)
- perm_static = prof % skin % fastem(1)
- perm_infinite = prof % skin % fastem(2)
- freqr = prof % skin % fastem(3)
- small_rough = prof % skin % fastem(4)
- large_rough = prof % skin % fastem(5)
- chan = channels(i)
- freq_ghz = coef % frequency_ghz(chan)
-
- !Simple Debye + Fresnel model gives reflectivities
- fen = freq_ghz / freqr
- fen_sq = fen * fen
- den1 = 1.0_JPRB + fen_sq
- perm_Real = (perm_static+perm_infinite*fen_sq) / den1
- perm_imag = fen*(perm_static-perm_infinite) / den1
- permittivity = Cmplx(perm_Real,perm_imag,jprb)
- perm1 = sqrt(permittivity - geom%sinzen_sq)
- perm2 = permittivity * geom%coszen
- rhth = (geom%coszen - perm1) / (geom%coszen + perm1)
- rvth = (perm2 - perm1)/(perm2 + perm1)
- fresnel_v_Real = Dble(rvth)
- fresnel_v_imag = Aimag(rvth)
- fresnel_v = fresnel_v_Real * fresnel_v_Real + &
- & fresnel_v_imag * fresnel_v_imag
- fresnel_h_Real = Dble(rhth)
- fresnel_h_imag = Aimag(rhth)
- fresnel_h = fresnel_h_Real * fresnel_h_Real + &
- & fresnel_h_imag * fresnel_h_imag
-
- !Small scale roughness correction
- delta = 4.0_JPRB * pi * coef % ff_cwn(chan) * 0.1_JPRB * small_rough
- delta2 = delta * delta
- small_rough_cor = Exp(-delta2*geom%coszen_sq)
-
- !Large scale roughness correction
- qdepol = 0.35_JPRB - 0.35_JPRB*Exp(-0.60_JPRB*freq_ghz*large_rough*large_rough)
-
- emissfactor_v = 1.0_JPRB - fresnel_v * small_rough_cor
- emissfactor_h = 1.0_JPRB - fresnel_h * small_rough_cor
- emissfactor = emissfactor_h - emissfactor_v
- emissstokes(i,1) = emissfactor_v + qdepol * emissfactor
- emissstokes(i,2) = emissfactor_h - qdepol * emissfactor
- emissstokes(i,3) = 0.0_JPRB
- emissstokes(i,4) = 0.0_JPRB
-
- reflectstokes(i,:) = 1.0_JPRB - emissstokes(i,:)
- ! End of if sea else land if else endif loop
- End If
- ! Now return only required polarisations - either the calculated vector (V, H, or full Stokes)
- If (pol_id <= 3 .or. pol_id >= 6) then
- Do ich=1,polarisations(i,3)
- emissivity(ichannel+ich-1)=emissstokes(i,ich)
- reflectivity(ichannel+ich-1)=reflectstokes(i,ich)
- End Do
- End If
- ! Or V-pol only
- If (pol_id == 4) then
- emissivity(ichannel)=emissstokes(i,1)
- reflectivity(ichannel)=reflectstokes(i,1)
- End If
- ! Or H-pol only
- If (pol_id == 5) then
- emissivity(ichannel)=emissstokes(i,2)
- reflectivity(ichannel)=reflectstokes(i,2)
- End If
- ! End loop over channels
- End Do
-End Subroutine rttov_calcemis_mw
diff --git a/src/LIB/RTTOV/src/rttov_calcemis_mw.interface b/src/LIB/RTTOV/src/rttov_calcemis_mw.interface
deleted file mode 100644
index 82dbee401fc3625407270aaf510c2167c596ee19..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_calcemis_mw.interface
+++ /dev/null
@@ -1,50 +0,0 @@
-Interface
-!
-Subroutine rttov_calcemis_mw ( &
- profiles, & ! in
- geometry, & ! in
- coef, & ! in
- nfrequencies, & ! in
- nchannels, & ! in
- nprofiles, & ! in
- channels, & ! in
- polarisations, & ! in
- lprofiles, & ! in
- transmission, & ! in
- calcemis, & ! in
- emissivity, & ! inout
- reflectivity, & ! out
- errorstatus ) ! inout
- Use rttov_const, Only : &
- pi ,&
- surftype_sea ,&
- errorstatus_fatal
-
- Use rttov_types, Only : &
- rttov_coef ,&
- profile_Type ,&
- transmission_Type ,&
- geometry_Type
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
- Integer(Kind=jpim), Intent(in) :: nprofiles
- Type(profile_Type), Intent(in) ,Target :: profiles(nprofiles)
- Type(geometry_Type), Intent(in) ,Target :: geometry(nprofiles)
- Type(rttov_coef), Intent(in) :: coef
- Integer(Kind=jpim), Intent(in) :: nfrequencies
- Integer(Kind=jpim), Intent(in) :: nchannels
- Integer(Kind=jpim), Intent(in) :: channels(nfrequencies)
- Integer(Kind=jpim), Intent(in) :: polarisations(nchannels,3)
- Integer(Kind=jpim), Intent(in) :: lprofiles(nfrequencies)
- Type(transmission_Type), Intent(in) :: transmission
- Logical, Intent(in) :: calcemis(nchannels)
- Real(Kind=jprb), Intent(inout) :: emissivity(nchannels)
- Real(Kind=jprb), Intent(out) :: reflectivity(nchannels)
- Integer(Kind=jpim), Intent(inout) :: errorstatus(nprofiles)
-
-
-
-End Subroutine rttov_calcemis_mw
-End Interface
diff --git a/src/LIB/RTTOV/src/rttov_calcemis_mw_ad.F90 b/src/LIB/RTTOV/src/rttov_calcemis_mw_ad.F90
deleted file mode 100644
index f4c46e2af265123222fc8e50c7dcca702a42b659..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_calcemis_mw_ad.F90
+++ /dev/null
@@ -1,974 +0,0 @@
-!
-Subroutine rttov_calcemis_mw_ad ( &
- & profiles, &! in
- & profiles_ad, &! inout
- & geometry, &! in
- & coef, &! in
- & nfrequencies, &! in
- & nchannels, &! in
- & nprofiles, &! in
- & channels, &! in
- & polarisations, &! in
- & lprofiles, &! in
- & transmission, &! in
- & transmission_ad, &! inout
- & calcemis, &! in
- & emissivity_ad, &! inout
- & reflectivity_ad ) ! inout
- ! Description:
- ! Adjoint of rttov_calcemis_mw
- ! To compute MW surface emissivities for all channels and all
- ! profiles if desired
- !
- ! Copyright:
- ! This software was developed within the context of
- ! the EUMETSAT Satellite Application Facility on
- ! Numerical Weather Prediction (NWP SAF), under the
- ! Cooperation Agreement dated 25 November 1998, between
- ! EUMETSAT and the Met Office, UK, by one or more partners
- ! within the NWP SAF. The partners in the NWP SAF are
- ! the Met Office, ECMWF, KNMI and MeteoFrance.
- !
- ! Copyright 2002, EUMETSAT, All Rights Reserved.
- !
- ! Method:
- ! FASTEM-1 English and Hewison 1998.
- ! FASTEM-2 Deblonde and English 2001.
- ! FASTEM-3 English 2003.
- ! http://www.metoffice.com/research/interproj/nwpsaf/rtm/evalfastems.pdf
- ! Current Code Owner: SAF NWP
- !
- ! History:
- ! Version Date Comment
- ! ------- ---- -------
- ! 1.0 01/12/2002 New F90 code with structures (P Brunel A Smith)
- ! 1.1 02/01/2003 Comments added (R Saunders)
- ! 1.2 26/09/2003 Polarimetric code and Fastem-3 (S. English)
- ! 1.3 18/08/2004 Fixed bug in adjoint (S English)
- ! 1.4 29/03/2005 Add end of header comment (J. Cameron)
- ! 1.5 14/10/2005 Reintroduce -r 122:123 changes, see -r 133:134).
- ! Fixing bug in azimuth angles > 270 (J Cameron)
- !
- ! Code Description:
- ! Language: Fortran 90.
- ! Software Standards: "European Standards for Writing and
- ! Documenting Exchangeable Fortran 90 Code".
- !
- ! Declarations:
- ! Modules used:
- !
- ! Imported Parameters:
- Use rttov_const, Only : &
- & pi ,&
- & surftype_sea
-
- ! Imported Type Definitions:
- Use rttov_types, Only : &
- & rttov_coef ,&
- & profile_Type ,&
- & transmission_Type ,&
- & geometry_Type
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
- !subroutine arguments:
- Integer(Kind=jpim), Intent(in) :: nprofiles
- Integer(Kind=jpim), Intent(in) :: nfrequencies
- Integer(Kind=jpim), Intent(in) :: nchannels
- Type(profile_Type), Intent(in) ,Target :: profiles(nprofiles)
- Type(geometry_Type), Intent(in) ,Target :: geometry(nprofiles)
- Type(rttov_coef), Intent(in) :: coef
- Integer(Kind=jpim), Intent(in) :: channels(nfrequencies)
- Integer(Kind=jpim), Intent(in) :: polarisations(nchannels,3)
- Integer(Kind=jpim), Intent(in) :: lprofiles(nfrequencies)
- Type(transmission_Type), Intent(in) :: transmission
- Logical, Intent(in) :: calcemis(nchannels)
-
- Type(profile_Type), Intent(inout) ,Target :: profiles_ad(nprofiles)
- Type(transmission_Type), Intent(inout) :: transmission_ad
- Real(Kind=jprb), Intent(inout) :: emissivity_ad(nchannels)
- Real(Kind=jprb), Intent(inout) :: reflectivity_ad(nchannels)
-
- !local constants:
- Real(Kind=jprb), Parameter :: quadcof(4,2) = Reshape( &
- & (/ 0.0_JPRB, 1.0_JPRB, 1.0_JPRB, 2.0_JPRB, &
- & 1.0_JPRB, -1.0_JPRB, 1.0_JPRB, -1.0_JPRB /), (/4,2/) )
- Real(Kind=jprb), Parameter :: freqfixed(4) = Reshape( &
- & (/ 7.0_JPRB, 10.0_JPRB, 19.0_JPRB, 37.0_JPRB /), (/4/) )
-
- !local variables:
- Real(Kind=jprb) :: tcelsius
- Real(Kind=jprb) :: tcelsius_sq
- Real(Kind=jprb) :: tcelsius_cu
- Real(Kind=jprb) :: f1,f2
- Real(Kind=jprb) :: del1,del2
- Real(Kind=jprb) :: einf
- Real(Kind=jprb) :: fen,fen_sq
- Real(Kind=jprb) :: den1,den2
- Real(Kind=jprb) :: perm_free
- Real(Kind=jprb) :: sigma
- Real(Kind=jprb) :: perm_real1,perm_real2
- Real(Kind=jprb) :: perm_imag1,perm_imag2,perm_imag3
- Real(Kind=jprb) :: perm_Real,perm_imag
- Real(Kind=jprb) :: perm_static,perm_infinite
- Real(Kind=jprb) :: freq_ghz,freq_ghz_sq
- Real(Kind=jprb) :: fresnel_v_Real,fresnel_v_imag
- Real(Kind=jprb) :: fresnel_h_Real,fresnel_h_imag
- Real(Kind=jprb) :: fresnel(4)
- Real(Kind=jprb) :: small_rough_cor,foam_cor(4)
- Real(Kind=jprb) :: large_rough_cor(4)
- Real(Kind=jprb) :: small_rough,large_rough
- Real(Kind=jprb) :: emiss_save(4)
- Real(Kind=jprb) :: variance,varm
- Real(Kind=jprb) :: wind10
- Real(Kind=jprb) :: wind10_sq,windsec
- Real(Kind=jprb) :: wind10_direction, windangle, windratio ! Note wind azimuth is in radians
- Real(Kind=jprb) :: emissstokes(nfrequencies,4)
- Real(Kind=jprb) :: emissstokes_ad(nfrequencies,4)
- Real(Kind=jprb) :: reflectstokes_ad(nfrequencies,4)
- Real(Kind=jprb) :: u19,phi,dfreq
- Real(Kind=jprb) :: tbfixed(4,4,3)! Surface brightness temperature azimuthal variation terms for 37, 19, 10, 7 GHz
- Real(Kind=jprb) :: efixed(4,4,3) ! Emissivity azimuthal variation terms for 7, 10, 19, 37 GHz
- Real(Kind=jprb) :: einterpolated(4,3)! Emissivity azimuthal variation terms for interpolated to required frequency
- Real(Kind=jprb) :: a1e,a2e,a3e ! coefficients used in azimuthal emissivity model
- Real(Kind=jprb) :: zrough_v,zrough_h
- Real(Kind=jprb) :: zreflmod_v,zreflmod_h
- Real(Kind=jprb) :: delta,delta2
- Real(Kind=jprb) :: qdepol,emissfactor
- Real(Kind=jprb) :: emissfactor_v,emissfactor_h
- Real(Kind=jprb) :: zc(12),zx(9)
- Real(Kind=jprb) :: opdpsfc,freqr
- Real(Kind=jprb), Pointer :: c(:)
- Complex(Kind=jprb) :: perm1,perm2
- Complex(Kind=jprb) :: rhth,rvth
- Complex(Kind=jprb) :: permittivity
- Integer(Kind=jpim) :: i,j,chan,istokes,ifreq,m
- Integer(Kind=jpim) :: iquadrant ! Determines which quadrant (NE, SE, SW, NW) the wind is blowing to
- Integer(Kind=jpim) :: pol_id ! polarisation indice
- Integer(Kind=jpim) :: i_freq,j_stokes,ich,ichannel ! indices used in azimuthal emissivity model
- Integer(Kind=jpim) :: jcof,jcofm1
- Type(profile_Type), Pointer :: prof
- Type(profile_Type), Pointer :: prof_ad
- Type(geometry_Type), Pointer :: geom
-
-
- Real(Kind=jprb) :: tcelsius_ad
- Real(Kind=jprb) :: tcelsius_sq_ad
- Real(Kind=jprb) :: tcelsius_cu_ad
- Real(Kind=jprb) :: f1_ad, f2_ad
- Real(Kind=jprb) :: del1_ad, del2_ad
- Real(Kind=jprb) :: einf_ad
- Real(Kind=jprb) :: fen_ad, fen_sq_ad
- Real(Kind=jprb) :: den1_ad, den2_ad
- Real(Kind=jprb) :: sigma_ad
- Real(Kind=jprb) :: perm_real1_ad, perm_real2_ad
- Real(Kind=jprb) :: perm_imag1_ad, perm_imag2_ad, perm_imag3_ad
- Real(Kind=jprb) :: perm_Real_ad, perm_imag_ad
- Real(Kind=jprb) :: perm_static_ad, perm_infinite_ad
- Real(Kind=jprb) :: fresnel_v_Real_ad, fresnel_v_imag_ad
- Real(Kind=jprb) :: fresnel_h_Real_ad, fresnel_h_imag_ad
- Real(Kind=jprb) :: fresnel_v_ad, fresnel_h_ad
- Real(Kind=jprb) :: small_rough_cor_ad, foam_cor_ad
- Real(Kind=jprb) :: large_rough_cor_ad(2)
- Real(Kind=jprb) :: small_rough_ad, large_rough_ad
- Real(Kind=jprb) :: variance_ad, varm_ad
- Real(Kind=jprb) :: wind10_ad
- Real(Kind=jprb) :: wind10_sq_ad, windsec_ad
- Real(Kind=jprb) :: wind10_direction_ad, windangle_ad, windratio_ad ! Note wind azimuth is in radians
- Real(Kind=jprb) :: azimuthal_emiss_ad, azimuthal_emiss,u19_ad,phi_ad
- Real(Kind=jprb) :: tbfixed_ad(4,4,3) ! Surface brightness temperature azimuthal variation terms for 37, 19, 10, 7 GHz
- Real(Kind=jprb) :: efixed_ad(4,4,3) ! Emissivity azimuthal variation terms for 7, 10, 19, 37 GHz
- Real(Kind=jprb) :: einterpolated_ad(4,3) ! Emissivity azimuthal variation terms for interpolated to required frequency
- Real(Kind=jprb) :: a1e_ad,a2e_ad,a3e_ad ! coefficients used in azimuthal emissivity model
- Real(Kind=jprb) :: opdpsfc_ad, freqr_ad
- Real(Kind=jprb) :: zrough_v_ad, zrough_h_ad
- Real(Kind=jprb) :: zreflmod_v_ad, zreflmod_h_ad
- Real(Kind=jprb) :: delta_ad, delta2_ad
- Real(Kind=jprb) :: qdepol_ad, emissfactor_ad
- Real(Kind=jprb) :: emissfactor_v_ad, emissfactor_h_ad
- Real(Kind=jprb) :: zx_ad(9)
- Complex(Kind=jprb) :: perm1_ad, perm2_ad
- Complex(Kind=jprb) :: rhth_ad, rvth_ad
- Complex(Kind=jprb) :: permittivity_ad
- Integer(Kind=jpim) :: wanted_fastem_ver ! user fastem version request
-
- Real(Kind=jprb) :: test_variance
-
- !- End of header --------------------------------------------------------
-
- ! If the coefficent file contains FASTEM 2 it contains also FASTEM 1 but
- ! the version choosen is given by coef % fastem_ver value
- wanted_fastem_ver = coef % fastem_ver
-
- !If a TL value of emissivity is passed to the routine
- !Loop over channels
-
- phi_ad=0.0_JPRB
- efixed_ad(:,:,:)=0.0_JPRB
-
- Do i = 1, nfrequencies
- ichannel=polarisations(i,1)
- If ( .Not. calcemis(ichannel) ) Cycle
- chan = channels(i)
- prof => profiles( lprofiles(i) )
- prof_ad => profiles_ad( lprofiles(i) )
- geom => geometry( lprofiles(i) )
-
- !-------------------------------
- !0. Point to fastem coefficients
- !-------------------------------
-
- c => coef % fastem_coef
-
- pol_id = coef % fastem_polar(chan) + 1
- reflectstokes_ad(i,:) = 0.0_JPRB
- emissstokes_ad(i,:) = 0.0_JPRB
-
- If (pol_id <= 3 .or. pol_id >= 6) then
- Do Ich=1, polarisations(i,3)
- reflectstokes_ad(i,ich) = reflectivity_ad(ichannel+ich-1)
- emissstokes_ad(i,ich) = emissivity_ad(ichannel+ich-1)
- End Do
- End If
-
- If (pol_id == 4) then
- reflectstokes_ad(i,1) = reflectivity_ad(ichannel)
- emissstokes_ad(i,1) = emissivity_ad(ichannel)
- End If
-
- If (pol_id == 5) then
- reflectstokes_ad(i,2) = reflectivity_ad(ichannel)
- emissstokes_ad(i,2) = emissivity_ad(ichannel)
- End If
-
- wind10_ad = 0._JPRB
- wind10_direction_ad = 0.0_JPRB
-
- !---------------
- !1. Sea surfaces
- !---------------
-
- If ( prof % skin % surftype == surftype_sea ) Then
-
-
- !-------------------------------------------
- !1.1 Calculate channel independent variables
- !-------------------------------------------
- wind10_sq = prof % s2m % u * prof % s2m % u +&
- & prof % s2m % v * prof % s2m % v
- wind10 = Sqrt( wind10_sq )
- windsec = wind10 * geom%seczen
- if (prof % s2m % u >= 0.0_JPRB .AND. prof % s2m % v >= 0.0_JPRB) iquadrant=1
- if (prof % s2m % u >= 0.0_JPRB .AND. prof % s2m % v < 0.0_JPRB) iquadrant=2
- if (prof % s2m % u < 0.0_JPRB .AND. prof % s2m % v >= 0.0_JPRB) iquadrant=4
- if (prof % s2m % u < 0.0_JPRB .AND. prof % s2m % v < 0.0_JPRB) iquadrant=3
-
- if (abs(prof % s2m % v) >= 0.0001_JPRB) then
- windratio=prof % s2m % u/prof % s2m % v
- else
- windratio=0.0
- if (abs(prof % s2m % u) > 0.0001_JPRB) then
- windratio=999999.0*prof % s2m % u
- endif
- endif
-
- windangle=atan(windratio)
- wind10_direction = quadcof(iquadrant,1)*pi+windangle*quadcof(iquadrant,2)
- !Set values for temperature polynomials (convert from kelvin to celsius)
- tcelsius = prof % skin % t - 273.15_JPRB
- tcelsius_sq = tcelsius * tcelsius !quadratic
- tcelsius_cu = tcelsius_sq * tcelsius !cubic
-
- !Define two relaxation frequencies, f1 and f2
- f1 = c(1) + c(2) * tcelsius + c(3) * tcelsius_sq
- f2 = c(4) + c(5) * tcelsius + c(6) * tcelsius_sq + c(7) * tcelsius_cu
-
- !Static permittivity estatic = del1+del2+einf
- del1 = c(8) + c(9) * tcelsius + c(10) * tcelsius_sq + c(11) * tcelsius_cu
- del2 = c(12) + c(13) * tcelsius + c(14) * tcelsius_sq + c(15) * tcelsius_cu
- einf = c(18) + c(19) * tcelsius
-
- freq_ghz = coef % frequency_ghz(chan)
- freq_ghz_sq = freq_ghz * freq_ghz
-
- !-----------------------------------------------------
- !1.2 calculate permittivity using double-debye formula
- !-----------------------------------------------------
-
- fen = 2.0_JPRB * c(20) * freq_ghz * 0.001_JPRB
- fen_sq = fen*fen
- den1 = 1.0_JPRB + fen_sq * f1 * f1
- den2 = 1.0_JPRB + fen_sq * f2 * f2
- perm_real1 = del1 / den1
- perm_real2 = del2 / den2
- perm_imag1 = del1 * fen * f1 / den1
- perm_imag2 = del2 * fen * f2 / den2
- perm_free = 8.854E-03_JPRB
- sigma = 2.906_JPRB + 0.09437_JPRB * tcelsius
- perm_imag3 = sigma / (2.0_JPRB * c(20) * perm_free * freq_ghz)
- perm_Real = perm_real1 + perm_real2 + einf
- perm_imag = perm_imag1 + perm_imag2 + perm_imag3
- permittivity = Cmplx(perm_Real,perm_imag,jprb)
-
- !-------------------------------------------------------------
- !1.3 calculate complex reflection coefficients and corrections
- !-------------------------------------------------------------
-
-
- !1.3.1) Fresnel reflection coefficients
- !------
-
- perm1 = sqrt(permittivity - geom%sinzen_sq)
- perm2 = permittivity * geom%coszen
- rhth = (geom%coszen-perm1) / (geom%coszen+perm1)
- rvth = (perm2-perm1) / (perm2+perm1)
- ! fresnel_v_real = dble(rvth)
- fresnel_v_Real = Real(rvth)
- fresnel_v_imag = Aimag(rvth)
- fresnel(1) = fresnel_v_Real * fresnel_v_Real + &
- & fresnel_v_imag * fresnel_v_imag
- ! fresnel_h_real = dble(rhth)
- fresnel_h_Real = Real(rhth)
- fresnel_h_imag = Aimag(rhth)
- fresnel(2) = fresnel_h_Real * fresnel_h_Real + &
- & fresnel_h_imag * fresnel_h_imag
- fresnel(3) = 0.0_JPRB
- fresnel(4) = 0.0_JPRB
-
- !1.3.2) Small scale correction to reflection coefficients
- !------
-
- If (freq_ghz >= 15.0) Then
- small_rough_cor = Exp( c(21) * wind10 * geom % coszen_sq / (freq_ghz_sq) )
- Else
- small_rough_cor = 1.0
- End If
-
- !1.3.3) Large scale geometric correction
- !------
-
- !Point to correct coefficients for this version. There are 36 altogether.
- !Those for FASTEM-2 are stored in section 24:59 of the array, those for
- !FASTEM1 in section 60:95.
- If ( wanted_fastem_ver == 2 ) Then
- c => coef%fastem_coef(24:59)
- Else
- c => coef%fastem_coef(60:95)
- End If
- Do j = 1, 12
- zc(j) = c(j*3-2) + c(j*3-1)*freq_ghz + c(j*3)*freq_ghz_sq
- End Do
- !Point back to all coefficients again
- c => coef%fastem_coef
-
- large_rough_cor(1) = &
- & (zc(1) + &
- & zc(2) * geom%seczen + &
- & zc(3) * geom%seczen_sq + &
- & zc(4) * wind10 + &
- & zc(5) * wind10_sq + &
- & zc(6) * windsec) / 100._JPRB
- large_rough_cor(2) = &
- & (zc(7) + &
- & zc(8) * geom%seczen + &
- & zc(9) * geom%seczen_sq + &
- & zc(10) * wind10 + &
- & zc(11) * wind10_sq + &
- & zc(12) * windsec) / 100._JPRB
- large_rough_cor(3) = 0.0_JPRB
- large_rough_cor(4) = 0.0_JPRB
-
- ! Introduce emiss_v_save and emiss_h_save arrays to be able
- ! to simplify further AD code
- emiss_save(:) = 1.0 - fresnel(:) * small_rough_cor + large_rough_cor(:)
-
- !Apply foam correction
- foam_cor(1) = c(22) * ( wind10 ** c(23) )
- foam_cor(2) = c(22) * ( wind10 ** c(23) )
- !Currently ignore foam effects on 3rd and 4th elements.
- foam_cor(3) = 0.0_JPRB
- foam_cor(4) = 0.0_JPRB
-
- emissstokes(i,:) = emiss_save(:) - foam_cor(:)*emiss_save(:) + foam_cor(:)
- emissstokes(i,3) = 0.0
- emissstokes(i,4) = 0.0
-
- If ((wanted_fastem_ver == 2 .or. (wanted_fastem_ver == 3 .And. geom%seczen <= 2.0_JPRB)) .And. &
- & transmission % tau_surf(ichannel) < 0.9999_JPRB .And. &
- & transmission % tau_surf(ichannel) > 0.00001_JPRB ) Then
-
- !Convert windspeed to slope variance using the Cox and Munk model
- variance = 0.00512_JPRB * wind10 + 0.0030_JPRB
- varm = variance * c(138)
- variance = varm * ( c(139) * freq_ghz + c(140) )
-
- test_variance = variance
- If ( variance > varm ) Then
- variance = varm
- Endif
- If ( variance < 0.0_JPRB ) Then
- variance = 0.0_JPRB
- Endif
-
- !Compute surface to space optical depth
- opdpsfc = -log(transmission % tau_surf(ichannel)) / geom%seczen
-
- !Define nine predictors for the effective angle calculation
- zx(1) = 1.0_JPRB
- zx(2) = variance
- zx(4) = 1.0_JPRB / geom%coszen
- zx(3) = zx(2) * zx(4)
- zx(5) = zx(3) * zx(3)
- zx(6) = zx(4) * zx(4)
- zx(7) = zx(2) * zx(2)
- zx(8) = log(opdpsfc)
- zx(9) = zx(8) * zx(8)
-
- zrough_v = 1.0_JPRB
- zrough_h = 1.0_JPRB
-
- Do jcof = 1,7
- jcofm1 = jcof-1
- !Switched h to v Deblonde SSMIS june 7, 2001
- zrough_h = zrough_h + &
- & zx(jcof) * ( c(96+jcofm1*3) &
- & + zx(8) * c(97+jcofm1*3) &
- & + zx(9) * c(98+jcofm1*3) )
- zrough_v = zrough_v + &
- & zx(jcof) * ( c(117+jcofm1*3) &
- & + zx(8) * c(118+jcofm1*3) &
- & + zx(9) * c(119+jcofm1*3) )
- End Do
- zreflmod_v = (1.0_JPRB-transmission % tau_surf(ichannel)**zrough_v) / (1.0_JPRB-transmission % tau_surf(ichannel))
- zreflmod_h = (1.0_JPRB-transmission % tau_surf(ichannel)**zrough_h) / (1.0_JPRB-transmission % tau_surf(ichannel))
-
- End If
-
- !.......end of forward part....................................
- !
- ! * Now run adjoint code of fastem
- !
- ! Only apply non-specular correction for Fastem-3 if theta < 60 degrees
- If ((wanted_fastem_ver == 2 .or. (wanted_fastem_ver == 3 .And. geom%seczen <= 2.0_JPRB)) .And. &
- & transmission % tau_surf(ichannel) < 0.9999_JPRB .And. transmission % tau_surf(ichannel) > 0.00001_JPRB ) Then
-
- If ( wanted_fastem_ver == 3) then
- ! Add azimuthal component from Fuzhong Weng (NOAA/NESDIS) based on work by Dr. Gene Poe (NRL)
- ! Angle between wind direction and satellite azimuthal view angle
- ! Assume 19m wind = 10m wind for now (fix later).
- phi = pi - wind10_direction + prof % azangle*pi/180.0_JPRB
- u19=wind10
- Do ich = 0,15
- a1e = c(141+ich*12) + u19*(c(142+ich*12)+ u19*(c(143+ich*12)+u19*c(144+ich*12)))
- a2e = c(145+ich*12) + u19*(c(146+ich*12)+ u19*(c(147+ich*12)+u19*c(148+ich*12)))
- a3e = c(149+ich*12) + u19*(c(150+ich*12)+ u19*(c(151+ich*12)+u19*c(152+ich*12)))
-
- i_freq = int(ich/4) + 1 ! 37, 19, 10, 7 GHz
- j_stokes = mod(ich,4) + 1
- tbfixed(j_stokes,i_freq,1) = a1e
- tbfixed(j_stokes,i_freq,2) = a2e
- tbfixed(j_stokes,i_freq,3) = a3e
- End Do
-
- Do M=1,3
- Do istokes=1,4
- efixed(1,istokes,M)= tbfixed(istokes,4,M) ! 7 GHz
- efixed(2,istokes,M)= tbfixed(istokes,3,M) ! 10 GHz
- efixed(3,istokes,M)= tbfixed(istokes,2,M) ! 19 GHz
- efixed(4,istokes,M)= tbfixed(istokes,1,M) ! 37 GHz
- End Do
-
- ! Interpolate results to required frequency based on 7, 10, 19, 37 GHz
- If (freq_ghz.le.freqfixed(1)) Then
- einterpolated(:,M)=efixed(1,:,M)
- Else If(freq_ghz.ge.freqfixed(4)) then
- einterpolated(:,M)=efixed(4,:,M)
- Else
- If(freq_ghz.lt.freqfixed(2)) ifreq=2
- If(freq_ghz.lt.freqfixed(3).and.freq_ghz.ge.freqfixed(2)) ifreq=3
- If(freq_ghz.ge.freqfixed(3)) ifreq=4
- dfreq=(freq_ghz-freqfixed(ifreq-1))/(freqfixed(ifreq)-freqfixed(ifreq-1))
- einterpolated(:,M)=efixed(ifreq-1,:,M)+dfreq*(efixed(ifreq,:,M)-efixed(ifreq-1,:,M))
- EndIf
- EndDo
-
- Do istokes = 1,4
- azimuthal_emiss=0.0_JPRB
- Do M=1,3
- If(istokes.le.2) Then
- azimuthal_emiss=azimuthal_emiss+einterpolated(istokes,M)*cos(m*phi)*(1.0_JPRB-geom%coszen)&
- &/(1.0_JPRB - 0.6018_JPRB)
- Else
- azimuthal_emiss=azimuthal_emiss+einterpolated(istokes,M)*sin(m*phi)*(1.0_JPRB-geom%coszen)&
- &/(1.0_JPRB - 0.6018_JPRB)
- End If
- End Do
- emissstokes(i,istokes)=emissstokes(i,istokes)+azimuthal_emiss
-
- End Do
- EndIf
-
- zreflmod_v_ad = reflectstokes_ad(i,1) * (1.0_JPRB-emissstokes(i,1))
- zreflmod_h_ad = reflectstokes_ad(i,2) * (1.0_JPRB-emissstokes(i,2))
- zreflmod_v_ad = zreflmod_v_ad - 0.5_JPRB * reflectstokes_ad(i,3) * emissstokes(i,3) &
- & - 0.5_JPRB * reflectstokes_ad(i,4) * emissstokes(i,4)
- zreflmod_h_ad = zreflmod_h_ad - 0.5_JPRB * reflectstokes_ad(i,3) * emissstokes(i,3) &
- & - 0.5_JPRB * reflectstokes_ad(i,4) * emissstokes(i,4)
-
- emissstokes_ad(i,4) = emissstokes_ad(i,4) - 0.5_JPRB * (zreflmod_v + zreflmod_h) * reflectstokes_ad(i,4)
- emissstokes_ad(i,3) = emissstokes_ad(i,3) - 0.5_JPRB * (zreflmod_v + zreflmod_h) * reflectstokes_ad(i,3)
- emissstokes_ad(i,2) = emissstokes_ad(i,2) - reflectstokes_ad(i,2) * zreflmod_h
- emissstokes_ad(i,1) = emissstokes_ad(i,1) - reflectstokes_ad(i,1) * zreflmod_v
-
- zrough_v_ad = -zreflmod_v_ad * &
- & ( transmission % tau_surf(ichannel)**zrough_v * Log(transmission % tau_surf(ichannel)) ) / &
- & (1.0_JPRB-transmission % tau_surf(ichannel))
-
- transmission_ad % tau_surf(ichannel) = transmission_ad % tau_surf(ichannel) + zreflmod_v_ad *&
- & (-zrough_v * transmission % tau_surf(ichannel)**(zrough_v-1.0_JPRB) * &
- & (1.0_JPRB-transmission % tau_surf(ichannel)) + &
- & ( 1.0_JPRB-transmission % tau_surf(ichannel)**zrough_v) ) &
- & / (1.0_JPRB-transmission % tau_surf(ichannel))**2
-
- zrough_h_ad = - zreflmod_h_ad * &
- & ( transmission % tau_surf(ichannel)**zrough_h * Log(transmission % tau_surf(ichannel)) ) / &
- & (1.0_JPRB-transmission % tau_surf(ichannel))
-
- transmission_ad % tau_surf(ichannel) = transmission_ad % tau_surf(ichannel) + zreflmod_h_ad *&
- & (-zrough_h * transmission %tau_surf(ichannel)**(zrough_h-1.0_JPRB) * &
- & (1.0_JPRB-transmission % tau_surf(ichannel)) + &
- & ( 1.0_JPRB-transmission % tau_surf(ichannel)**zrough_h) ) &
- & / (1.0_JPRB-transmission % tau_surf(ichannel))**2
-
- zx_ad(:) = 0._JPRB
- Do jcof = 1,7
- jcofm1 = jcof-1
- !Switched h to v Deblonde SSMIS june 7, 2001
-
- zx_ad(9) = zx_ad(9) + zrough_v_ad * zx(jcof) * c(119+jcofm1*3)
- zx_ad(8) = zx_ad(8) + zrough_v_ad * zx(jcof) * c(118+jcofm1*3)
- zx_ad(jcof) = zrough_v_ad *&
- & ( c(117+jcofm1*3) &
- & + zx(8) * c(118+jcofm1*3) &
- & + zx(9) * c(119+jcofm1*3) )
-
- zx_ad(9) = zx_ad(9) + zrough_h_ad * zx(jcof) * c(98+jcofm1*3)
- zx_ad(8) = zx_ad(8) + zrough_h_ad * zx(jcof) * c(97+jcofm1*3)
- zx_ad(jcof) = zx_ad(jcof) + zrough_h_ad *&
- & ( c(96+jcofm1*3) &
- & + zx(8) * c(97+jcofm1*3) &
- & + zx(9) * c(98+jcofm1*3) )
-
- End Do
- zrough_v_ad = 0._JPRB
- zrough_h_ad = 0._JPRB
-
- !Define nine predictors for the effective angle calculation
- zx_ad(8) = zx_ad(8) + zx_ad(9) * 2 * zx(8)
-
- opdpsfc_ad = zx_ad(8) / opdpsfc
-
- zx_ad(2) = zx_ad(2) + zx_ad(7) * 2 * zx(2)
-
- zx_ad(4) = zx_ad(4) + zx_ad(6) * 2 * zx(4)
-
- zx_ad(3) = zx_ad(3) + zx_ad(5) * 2 * zx(3)
-
- zx_ad(2) = zx_ad(2) + zx_ad(3) * zx(4)
-
- zx_ad(4) = 0._JPRB
-
- variance_ad = zx_ad(2)
-
- zx_ad(1) = 0._JPRB
-
- !Compute surface to space optical depth
- transmission_ad % tau_surf(ichannel) = transmission_ad % tau_surf(ichannel) - opdpsfc_ad /&
- & ( transmission % tau_surf(ichannel) * geom%seczen )
-
- If ( test_variance < varm ) Then
- varm_ad = variance_ad * ( c(139) * freq_ghz + c(140) )
- Else
- varm_ad = variance_ad
- Endif
-
- variance_ad = varm_ad * c(138)
- wind10_ad = wind10_ad + variance_ad * 0.00512_JPRB
- Else
- emissstokes_ad(i,:) = emissstokes_ad(i,:) - reflectstokes_ad(i,:)
- End If
-
- If ( wanted_fastem_ver == 3) then
- azimuthal_emiss_ad = 0.0_JPRB
- phi_ad = 0.0_JPRB
- Do istokes=1,4
- azimuthal_emiss_ad=emissstokes_ad(i,istokes)
- Do M=1,3
- If(istokes.le.2) Then
- einterpolated_ad(istokes,M)=azimuthal_emiss_ad*cos(m*phi)*(1.0_JPRB-geom%coszen)/&
- &(1.0_JPRB - 0.6018_JPRB)
- phi_ad= phi_ad - azimuthal_emiss_ad*einterpolated(istokes,M)*m*sin(m*phi)*(1.0_JPRB-geom%coszen)/&
- &(1.0_JPRB - 0.6018_JPRB)
- Else
- einterpolated_ad(istokes,M)=azimuthal_emiss_ad*sin(m*phi)*(1.0_JPRB-geom%coszen)/(1.0_JPRB - 0.6018_JPRB)
- phi_ad= phi_ad + azimuthal_emiss_ad*einterpolated(istokes,M)*m*cos(m*phi)*(1.0_JPRB-geom%coszen)/&
- &(1.0_JPRB - 0.6018_JPRB)
- End If
- Enddo
- End Do
-
- efixed_ad(:,:,:) = 0.0_JPRB
- Do M=1,3
- If (freq_ghz.le.freqfixed(1)) Then
- efixed_ad(1,:,M)=efixed_ad(1,:,M)+einterpolated_ad(:,M)
- Else If(freq_ghz.ge.freqfixed(4)) then
- efixed_ad(4,:,M)=efixed_ad(4,:,M)+einterpolated_ad(:,M)
- Else
- If(freq_ghz.lt.freqfixed(2)) ifreq=2
- If(freq_ghz.lt.freqfixed(3).and.freq_ghz.ge.freqfixed(2)) ifreq=3
- If(freq_ghz.ge.freqfixed(3)) ifreq=4
- dfreq=(freq_ghz-freqfixed(ifreq-1))/(freqfixed(ifreq)-freqfixed(ifreq-1))
- efixed_ad(ifreq,:,M)=efixed_ad(ifreq,:,M)+einterpolated_ad(:,M)*dfreq
- efixed_ad(ifreq-1,:,M)=efixed_ad(ifreq-1,:,M)+einterpolated_ad(:,M)*(1.0-dfreq)
- End If
-
- Do istokes=1,4
- tbfixed_ad(istokes,4,M)= efixed_ad(1,istokes,M) ! 7 GHz
- tbfixed_ad(istokes,3,M)= efixed_ad(2,istokes,M) ! 10 GHz
- tbfixed_ad(istokes,2,M)= efixed_ad(3,istokes,M) ! 19 GHz
- tbfixed_ad(istokes,1,M)= efixed_ad(4,istokes,M) ! 37 GHz
- End Do
- End Do
-
- u19_ad = 0.0_JPRB
- Do ich = 0,15_JPRB
- i_freq = int(ich/4) + 1 ! 37, 19, 10, 7 GHz
- j_stokes = mod(ich,4) + 1
- a3e_ad = tbfixed_ad(j_stokes,i_freq,3)
- a2e_ad = tbfixed_ad(j_stokes,i_freq,2)
- a1e_ad = tbfixed_ad(j_stokes,i_freq,1)
- u19_ad = u19_ad + a3e_ad*(c(150+ich*12)+u19*(2.0*c(151+ich*12)+3.0*u19*c(152+ich*12)))
- u19_ad = u19_ad + a2e_ad*(c(146+ich*12)+u19*(2.0*c(147+ich*12)+3.0*u19*c(148+ich*12)))
- u19_ad = u19_ad + a1e_ad*(c(142+ich*12)+u19*(2.0*c(143+ich*12)+3.0*u19*c(144+ich*12)))
- End Do
- wind10_ad = wind10_ad + u19_ad
- wind10_direction_ad = -1.0_JPRB * phi_ad
- End If
-
- ! Be careful do TL first because the next 2 lines of the direct model
- ! have variables in input/output of the statement
-
- foam_cor_ad = 0.0_JPRB
- Do Ich=1,4
- foam_cor_ad = foam_cor_ad + emissstokes_ad(i,ich) * (1.0_JPRB - emiss_save(ich))
- emissstokes_ad(i,Ich) = emissstokes_ad(i,ich) * (1.0_JPRB - foam_cor(ich))
- End Do
-
- !Apply foam correction
- wind10_ad = wind10_ad + foam_cor_ad *&
- & c(22) * c(23) * ( wind10 ** (c(23)-1.0_JPRB) )
-
- !1.3.3) Large scale geometric correction
- !------
- fresnel_v_ad = -emissstokes_ad(i,1) * small_rough_cor
- small_rough_cor_ad = -emissstokes_ad(i,1) * fresnel(1)
- large_rough_cor_ad(1) = emissstokes_ad(i,1)
-
- fresnel_h_ad = -emissstokes_ad(i,2) * small_rough_cor
-
- small_rough_cor_ad = small_rough_cor_ad - emissstokes_ad(i,2) * fresnel(2)
- large_rough_cor_ad(2) = emissstokes_ad(i,2)
-
- windsec_ad = large_rough_cor_ad(2) * zc(12) / 100._JPRB
- wind10_sq_ad = large_rough_cor_ad(2) * zc(11) / 100._JPRB
- wind10_ad = wind10_ad + large_rough_cor_ad(2) * zc(10) / 100._JPRB
-
-
- windsec_ad = windsec_ad + large_rough_cor_ad(1) * zc(6) / 100._JPRB
- wind10_sq_ad = wind10_sq_ad + large_rough_cor_ad(1) * zc(5) / 100._JPRB
- wind10_ad = wind10_ad + large_rough_cor_ad(1) * zc(4) / 100._JPRB
-
-
- !1.3.2) Small scale correction to reflection coefficients
- !------
-
- If (freq_ghz >= 15.0) Then
- wind10_ad = wind10_ad + small_rough_cor_ad *&
- & small_rough_cor * c(21) * geom % coszen_sq / (freq_ghz_sq)
- End If
-
- !1.3.1) Fresnel reflection coefficients
- !------
-
- fresnel_h_real_ad = fresnel_h_ad * 2 * fresnel_h_real
- fresnel_h_imag_ad = fresnel_h_ad * 2 * fresnel_h_imag
-
- rhth_ad = CMPLX(fresnel_h_real_ad, -fresnel_h_imag_ad,jprb)
-
- fresnel_v_real_ad = fresnel_v_ad * 2 * fresnel_v_real
- fresnel_v_imag_ad = fresnel_v_ad * 2 * fresnel_v_imag
-
- rvth_ad = CMPLX(fresnel_v_real_ad, -fresnel_v_imag_ad,jprb)
-
- perm1_ad = - rvth_ad * 2 * perm2 / (perm2+perm1)**2
- perm2_ad = rvth_ad * 2 * perm1 / (perm2+perm1)**2
-
- perm1_ad = perm1_ad - rhth_ad * 2 * geom%coszen / (geom%coszen+perm1)**2
-
- permittivity_ad = perm2_ad * geom%coszen
-
- permittivity_ad = permittivity_ad + perm1_ad * 0.5_JPRB / perm1
-
- !-----------------------------------------------------
- !1.2 calculate permittivity using double-debye formula
- !-----------------------------------------------------
-
- perm_Real_ad = Real( permittivity_ad )
- perm_imag_ad = -Aimag( permittivity_ad )
-
- perm_imag1_ad = perm_imag_ad
- perm_imag2_ad = perm_imag_ad
- perm_imag3_ad = perm_imag_ad
-
- einf_ad = perm_real_ad
- perm_real1_ad = perm_real_ad
- perm_real2_ad = perm_real_ad
-
- sigma_ad = perm_imag3_ad / (2.0_JPRB * c(20) * perm_free * freq_ghz)
- tcelsius_ad = 0.09437_JPRB * sigma_ad
-
- del2_ad = perm_imag2_ad * fen * den2 * f2 / (den2 * den2)
- den2_ad = -perm_imag2_ad * fen * del2 * f2 / (den2 * den2)
- f2_ad = perm_imag2_ad * fen * den2 * del2/ (den2 * den2)
-
- del1_ad = perm_imag1_ad * fen * den1 * f1 / (den1 * den1)
- den1_ad = -perm_imag1_ad * fen * del1 * f1 / (den1 * den1)
- f1_ad = perm_imag1_ad * fen * den1 * del1/ (den1 * den1)
-
-
- del2_ad = del2_ad + perm_real2_ad * den2 / (den2 * den2)
- den2_ad = den2_ad - perm_real2_ad * del2 / (den2 * den2)
-
- del1_ad = del1_ad + perm_real1_ad * den1 / (den1 * den1)
- den1_ad = den1_ad - perm_real1_ad * del1 / (den1 * den1)
-
-
- f2_ad = f2_ad + den2_ad * 2 * fen_sq * f2
- f1_ad = f1_ad + den1_ad * 2 * fen_sq * f1
-
- !Static permittivity estatic = del1+del2+einf
- tcelsius_ad = tcelsius_ad + c(19) * einf_ad
- tcelsius_ad = tcelsius_ad + del2_ad * c(13)
- tcelsius_sq_ad = del2_ad * c(14)
- tcelsius_cu_ad = del2_ad * c(15)
-
- tcelsius_ad = tcelsius_ad + del1_ad * c(9)
- tcelsius_sq_ad = tcelsius_sq_ad + del1_ad * c(10)
- tcelsius_cu_ad = tcelsius_cu_ad + del1_ad * c(11)
-
-
- !Define two relaxation frequencies, f1 and f2
- tcelsius_ad = tcelsius_ad + f2_ad * c(5)
- tcelsius_sq_ad = tcelsius_sq_ad + f2_ad * c(6)
- tcelsius_cu_ad = tcelsius_cu_ad + f2_ad * c(7)
-
- tcelsius_ad = tcelsius_ad + f1_ad * c(2)
- tcelsius_sq_ad = tcelsius_sq_ad + f1_ad * c(3)
-
-
- !Set values for temperature polynomials (convert from kelvin to celsius)
- tcelsius_ad = tcelsius_ad + tcelsius_cu_ad * 3 * tcelsius_sq
-
- tcelsius_ad = tcelsius_ad + tcelsius_sq_ad * 2 * tcelsius
- prof_ad % skin % t = prof_ad % skin % t + tcelsius_ad
-
- wind10_ad = wind10_ad + windsec_ad * geom%seczen
- windangle_ad = wind10_direction_ad *quadcof(iquadrant,2)
- windratio_ad = 0.0_JPRB
- if (abs(prof % s2m % v) >= 0.0001_JPRB) windratio_ad = windangle_ad/(1.0_JPRB+windratio*windratio)
-
-! prof_ad % s2m % u=0.0_JPRB
-! prof_ad % s2m % v=0.0_JPRB
-
- If (abs(prof % s2m % v) >= 0.0001_JPRB) then
- prof_ad % s2m % u = prof_ad % s2m % u + windratio_ad*prof % s2m % v /&
- & (prof % s2m % v *prof % s2m % v)
- prof_ad % s2m % v = prof_ad % s2m % v - windratio_ad*prof % s2m % u /&
- & (prof % s2m % v *prof % s2m % v)
- Else
- If (abs(prof % s2m % u) > 0.0001_JPRB) then
- prof_ad % s2m % u=999999.0*windratio_ad
- Endif
- Endif
- wind10_ad = wind10_ad + wind10_sq_ad * 2 * wind10
-
- If( wind10 > 0._JPRB ) Then
- wind10_sq_ad = 0.5_JPRB*wind10_ad/wind10
- Else
- wind10_sq_ad = 0.0_JPRB
- Endif
-
- prof_ad % s2m % u = prof_ad % s2m % u +&
- & 2 * wind10_sq_ad * prof % s2m % u
- prof_ad % s2m % v = prof_ad % s2m % v +&
- & 2 * wind10_sq_ad * prof % s2m % v
- prof_ad % skin % fastem(:) = 0._JPRB
-
- Else
- !--------------------
- !2. Land/ice surfaces
- !--------------------
-
- !Coherent surface scattering model coefficients (input with the profile)
- perm_static = prof % skin % fastem(1)
- perm_infinite = prof % skin % fastem(2)
- freqr = prof % skin % fastem(3)
- small_rough = prof % skin % fastem(4)
- large_rough = prof % skin % fastem(5)
- chan = channels(i)
- freq_ghz = coef % frequency_ghz(chan)
-
- !Simple Debye + Fresnel model gives reflectivities
- fen = freq_ghz / freqr
- fen_sq = fen * fen
- den1 = 1.0_JPRB + fen_sq
- perm_Real = (perm_static+perm_infinite*fen_sq) / den1
- perm_imag = fen*(perm_static-perm_infinite) / den1
- permittivity = Cmplx(perm_Real,perm_imag,jprb)
- perm1 = sqrt(permittivity - geom%sinzen_sq)
- perm2 = permittivity * geom%coszen
- rhth = (geom%coszen - perm1) / (geom%coszen + perm1)
- rvth = (perm2 - perm1)/(perm2 + perm1)
- ! fresnel_v_real = dble(rvth)
- fresnel_v_Real = Real(rvth)
- fresnel_v_imag = Aimag(rvth)
- fresnel(1) = fresnel_v_Real * fresnel_v_Real + &
- & fresnel_v_imag * fresnel_v_imag
- ! fresnel_h_real = dble(rhth)
- fresnel_h_Real = Real(rhth)
- fresnel_h_imag = Aimag(rhth)
- fresnel(2) = fresnel_h_Real * fresnel_h_Real + &
- & fresnel_h_imag * fresnel_h_imag
-
- !Small scale roughness correction
- delta = 4.0_JPRB * pi * coef % ff_cwn(chan) * 0.1_JPRB * small_rough
- delta2 = delta * delta
- small_rough_cor = Exp(-delta2*geom%coszen_sq)
-
- !Large scale roughness correction
- qdepol = 0.35_JPRB - 0.35_JPRB*Exp(-0.60_JPRB*freq_ghz*large_rough*large_rough)
- emissfactor_v = 1.0_JPRB - fresnel(1) * small_rough_cor
- emissfactor_h = 1.0_JPRB - fresnel(2) * small_rough_cor
- emissfactor = emissfactor_h - emissfactor_v
- emissstokes(i,1) = emissfactor_v + qdepol * emissfactor
- emissstokes(i,2) = emissfactor_h - qdepol * emissfactor
- !reflect_v(i) = 1.0_JPRB - emiss_v(i)
- !reflect_h(i) = 1.0_JPRB - emiss_h(i)
-
- !.......end of forward part....................................
- !
- ! * Now run adjoint code of fastem
- !
- emissstokes_ad(i,2) = emissstokes_ad(i,2) - reflectstokes_ad(i,2)
- emissstokes_ad(i,1) = emissstokes_ad(i,1) - reflectstokes_ad(i,1)
-
- emissfactor_h_ad = emissstokes_ad(i,2)
- qdepol_ad = -emissstokes_ad(i,2) * emissfactor
- emissfactor_ad = -emissstokes_ad(i,2) * qdepol
-
- emissfactor_v_ad = emissstokes_ad(i,1)
- qdepol_ad = qdepol_ad +emissstokes_ad(i,1) * emissfactor
- emissfactor_ad = emissfactor_ad +emissstokes_ad(i,1) * qdepol
-
- emissfactor_v_ad = emissfactor_v_ad - emissfactor_ad
- emissfactor_h_ad = emissfactor_h_ad + emissfactor_ad
-
- fresnel_h_ad = -emissfactor_h_ad * small_rough_cor
- small_rough_cor_ad = -emissfactor_h_ad * fresnel(2)
-
- fresnel_v_ad = -emissfactor_v_ad * small_rough_cor
- small_rough_cor_ad = small_rough_cor_ad -emissfactor_v_ad * fresnel(1)
-
- !Large scale roughness correction
- large_rough_ad = qdepol_ad * 0.35_JPRB * 0.60_JPRB*freq_ghz*2*large_rough *&
- & Exp(-0.60_JPRB*freq_ghz*large_rough*large_rough)
-
- !Small scale roughness correction
- delta2_ad = -small_rough_cor_ad * geom%coszen_sq * small_rough_cor
- delta_ad = delta2_ad* 2 * delta
- small_rough_ad = 4.0_JPRB * pi * coef % ff_cwn(chan) * 0.1_JPRB * delta_ad
-
- !1.3.1) Fresnel reflection coefficients
- !Simple Debye + Fresnel model gives reflectivities
- !------
- fresnel_h_real_ad = fresnel_h_ad * 2 * fresnel_h_real
- fresnel_h_imag_ad = fresnel_h_ad * 2 * fresnel_h_imag
-
- rhth_ad = CMPLX(fresnel_h_real_ad, -fresnel_h_imag_ad,jprb)
-
- fresnel_v_real_ad = fresnel_v_ad * 2 * fresnel_v_real
- fresnel_v_imag_ad = fresnel_v_ad * 2 * fresnel_v_imag
-
- rvth_ad = CMPLX(fresnel_v_real_ad, -fresnel_v_imag_ad,jprb)
-
- perm1_ad = - rvth_ad * 2 * perm2 / (perm2+perm1)**2
- perm2_ad = rvth_ad * 2 * perm1 / (perm2+perm1)**2
-
- perm1_ad = perm1_ad - rhth_ad * 2 * geom%coszen / (geom%coszen+perm1)**2
-
- permittivity_ad = perm2_ad * geom%coszen
-
- permittivity_ad = permittivity_ad + perm1_ad * 0.5_JPRB / perm1
-
- perm_Real_ad = Real( permittivity_ad )
- perm_imag_ad = -Aimag( permittivity_ad )
-
- fen_ad = perm_imag_ad *&
- & (perm_static - perm_infinite)/ den1
- perm_static_ad = perm_imag_ad *&
- & fen / den1
- perm_infinite_ad = -perm_imag_ad *&
- & fen / den1
- den1_ad = -perm_imag_ad *&
- & fen * (perm_static - perm_infinite)/ (den1*den1)
-
- perm_static_ad = perm_static_ad + perm_real_ad / den1
- perm_infinite_ad = perm_infinite_ad + perm_real_ad *&
- & fen_sq / den1
- fen_sq_ad = perm_real_ad *&
- & perm_infinite / den1
- den1_ad = den1_ad - perm_real_ad *&
- & (perm_static + perm_infinite * fen_sq) / (den1*den1)
-
-
- fen_sq_ad = fen_sq_ad + den1_ad
-
- fen_ad = fen_ad + fen_sq_ad * 2* fen
-
- freqr_ad = -fen_ad * freq_ghz / freqr**2
-
- prof_ad % skin % fastem(1) = prof_ad % skin % fastem(1) +&
- & perm_static_ad
-
- prof_ad % skin % fastem(2) = prof_ad % skin % fastem(2) +&
- & perm_infinite_ad
-
- prof_ad % skin % fastem(3) = prof_ad % skin % fastem(3) +&
- & freqr_ad
-
- prof_ad % skin % fastem(4) = prof_ad % skin % fastem(4) +&
- & small_rough_ad
-
- prof_ad % skin % fastem(5) = prof_ad % skin % fastem(5) +&
- & large_rough_ad
-
- End If
-
- End Do
-
-
- emissivity_ad(:) = emissivity_ad(:) - reflectivity_ad(:)
-
-
-End Subroutine rttov_calcemis_mw_ad
diff --git a/src/LIB/RTTOV/src/rttov_calcemis_mw_ad.interface b/src/LIB/RTTOV/src/rttov_calcemis_mw_ad.interface
deleted file mode 100644
index fedf65f7c641f33b2030d5bf0abb19d3e1eaf4a1..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_calcemis_mw_ad.interface
+++ /dev/null
@@ -1,52 +0,0 @@
-Interface
-!
-Subroutine rttov_calcemis_mw_ad ( &
- profiles, & ! in
- profiles_ad, & ! inout
- geometry, & ! in
- coef, & ! in
- nfrequencies, & ! in
- nchannels, & ! in
- nprofiles, & ! in
- polarisations, & ! in
- channels, & ! in
- lprofiles, & ! in
- transmission, & ! in
- transmission_ad, & ! inout
- calcemis, & ! in
- emissivity_ad, & ! inout
- reflectivity_ad ) ! inout
- Use rttov_const, Only : &
- pi ,&
- surftype_sea
-
- Use rttov_types, Only : &
- rttov_coef ,&
- profile_Type ,&
- transmission_Type ,&
- geometry_Type
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
- Integer(Kind=jpim), Intent(in) :: nprofiles
- Type(profile_Type), Intent(in) ,Target :: profiles(nprofiles)
- Type(geometry_Type), Intent(in) ,Target :: geometry(nprofiles)
- Type(rttov_coef), Intent(in) :: coef
- Integer(Kind=jpim), Intent(in) :: nfrequencies
- Integer(Kind=jpim), Intent(in) :: nchannels
- Integer(Kind=jpim), Intent(in) :: channels(nfrequencies)
- Integer(Kind=jpim), Intent(in) :: polarisations(nchannels,3)
- Integer(Kind=jpim), Intent(in) :: lprofiles(nfrequencies)
- Type(transmission_Type), Intent(in) :: transmission
- Logical, Intent(in) :: calcemis(nchannels)
-
- Type(profile_Type), Intent(inout) ,Target :: profiles_ad(nprofiles)
- Type(transmission_Type), Intent(inout) :: transmission_ad
- Real(Kind=jprb), Intent(inout) :: emissivity_ad(nchannels)
- Real(Kind=jprb), Intent(inout) :: reflectivity_ad(nchannels)
-
-
-
-End Subroutine rttov_calcemis_mw_ad
-End Interface
diff --git a/src/LIB/RTTOV/src/rttov_calcemis_mw_k.F90 b/src/LIB/RTTOV/src/rttov_calcemis_mw_k.F90
deleted file mode 100644
index b0b2a902e33b0f46cb9d3c13374072c8ec9c13ca..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_calcemis_mw_k.F90
+++ /dev/null
@@ -1,1156 +0,0 @@
-!
-Subroutine rttov_calcemis_mw_k ( &
- & profiles, &! in
- & profiles_k, &! inout
- & geometry, &! in
- & coef, &! in
- & nfrequencies, &! in
- & nchannels, &! in
- & nprofiles, &! in
- & channels, &! in
- & polarisations, &! in
- & lprofiles, &! in
- & transmission, &! in
- & transmission_k, &! inout
- & calcemis, &! in
- & emissivity_k, &! inout
- & reflectivity_k ) ! inout
- ! Description:
- ! K matrix of rttov_calcemis_mw
- ! To compute MW surface emissivities for all channels and all
- ! profiles if desired
- !
- ! Copyright:
- ! This software was developed within the context of
- ! the EUMETSAT Satellite Application Facility on
- ! Numerical Weather Prediction (NWP SAF), under the
- ! Cooperation Agreement dated 25 November 1998, between
- ! EUMETSAT and the Met Office, UK, by one or more partners
- ! within the NWP SAF. The partners in the NWP SAF are
- ! the Met Office, ECMWF, KNMI and MeteoFrance.
- !
- ! Copyright 2002, EUMETSAT, All Rights Reserved.
- !
- ! Method:
- ! FASTEM-1 English and Hewison 1998.
- ! FASTEM-2 Deblonde and English 2001.
- ! FASTEM-3 English 2003
- ! http://www.metoffice.com/research/interproj/nwpsaf/rtm/evalfastems.pdf
- ! Current Code Owner: SAF NWP
- !
- ! History:
- ! Version Date Comment
- ! ------- ---- -------
- ! 1.0 01/12/2002 New F90 code with structures (P Brunel A Smith)
- ! 1.1 02/01/2003 Comments added (R Saunders)
- ! 1.2 26/09/2003 Polarimetric code and Fastem-3 (S. English)!
- ! 1.3 18/08/2004 Corrected bug in K code (S English)
- ! 1.4 29/03/2005 Add end of header comment (J. Cameron)
- ! 1.5 14/10/2005 Reintroduce -r 122:123 changes, see -r 133:134
- ! Fixing bug in azimuith angles > 270. (J Cameron)
- ! 1.6 01/09/2006 Fix bug in if loop to generate K of u and v over sea
- ! added abs() (A Doherty)
- ! Code Description:
- ! Language: Fortran 90.
- ! Software Standards: "European Standards for Writing and
- ! Documenting Exchangeable Fortran 90 Code".
- !
- ! Declarations:
- ! Modules used:
- !
- ! Imported Parameters:
- Use rttov_const, Only : &
- & pi ,&
- & surftype_sea
-
- ! Imported Type Definitions:
- Use rttov_types, Only : &
- & rttov_coef ,&
- & profile_Type ,&
- & transmission_Type ,&
- & geometry_Type
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
- !subroutine arguments:
- Integer(Kind=jpim), Intent(in) :: nfrequencies
- Integer(Kind=jpim), Intent(in) :: nprofiles
- Integer(Kind=jpim), Intent(in) :: nchannels
- Type(profile_Type), Intent(in) ,Target :: profiles(nprofiles)
- Type(geometry_Type), Intent(in) ,Target :: geometry(nprofiles)
- Type(rttov_coef), Intent(in) :: coef
- Integer(Kind=jpim), Intent(in) :: channels(nfrequencies)
- Integer(Kind=jpim), Intent(in) :: polarisations(nchannels,3)
- Integer(Kind=jpim), Intent(in) :: lprofiles(nfrequencies)
- Type(transmission_Type), Intent(in) :: transmission
- Logical, Intent(in) :: calcemis(nchannels)
-
- Type(profile_Type), Intent(inout) ,Target :: profiles_k(nchannels)
- Type(transmission_Type), Intent(inout) :: transmission_k
- Real(Kind=jprb), Intent(inout) :: emissivity_k(nchannels)
- Real(Kind=jprb), Intent(inout) :: reflectivity_k(nchannels)
-
- !local constants:
- Real(Kind=jprb), Parameter :: quadcof(4,2) = Reshape( &
- & (/ 0.0_JPRB, 1.0_JPRB, 1.0_JPRB, 2.0_JPRB, &
- & 1.0_JPRB, -1.0_JPRB, 1.0_JPRB, -1.0_JPRB /), (/4,2/) )
- Real(Kind=jprb), Parameter :: freqfixed(4) = Reshape( &
- & (/ 7.0_JPRB, 10.0_JPRB, 19.0_JPRB, 37.0_JPRB /), (/4/) )
-
- !local variables:
- Real(Kind=jprb) :: tcelsius
- Real(Kind=jprb) :: tcelsius_sq
- Real(Kind=jprb) :: tcelsius_cu
- Real(Kind=jprb) :: f1,f2
- Real(Kind=jprb) :: del1,del2
- Real(Kind=jprb) :: einf
- Real(Kind=jprb) :: fen,fen_sq
- Real(Kind=jprb) :: den1,den2
- Real(Kind=jprb) :: perm_free
- Real(Kind=jprb) :: sigma
- Real(Kind=jprb) :: perm_real1,perm_real2
- Real(Kind=jprb) :: perm_imag1,perm_imag2,perm_imag3
- Real(Kind=jprb) :: perm_Real,perm_imag
- Real(Kind=jprb) :: perm_static,perm_infinite
- Real(Kind=jprb) :: freq_ghz,freq_ghz_sq
- Real(Kind=jprb) :: fresnel_v_Real,fresnel_v_imag
- Real(Kind=jprb) :: fresnel_h_Real,fresnel_h_imag
- Real(Kind=jprb) :: fresnel(4)
- Real(Kind=jprb) :: small_rough_cor,foam_cor(4)
- Real(Kind=jprb) :: large_rough_cor(4)
- Real(Kind=jprb) :: small_rough,large_rough
- Real(Kind=jprb) :: emiss_save(4)
- Real(Kind=jprb) :: variance,varm
- Real(Kind=jprb) :: wind10
- Real(Kind=jprb) :: wind10_sq,windsec
- Real(Kind=jprb) :: wind10_direction, windangle, windratio ! Note wind azimuth is in radians
- Real(Kind=jprb) :: emissstokes(nfrequencies,4)
- Real(Kind=jprb) :: emissstokes_k(nfrequencies,4)
- Real(Kind=jprb) :: reflectstokes_k(nfrequencies,4)
- Real(Kind=jprb) :: u19,phi,dfreq
- Real(Kind=jprb) :: tbfixed(4,4,3) ! Surface brightness temperature azimuthal variation terms for 37, 19, 10, 7 GHz
- Real(Kind=jprb) :: efixed(4,4,3) ! Emissivity azimuthal variation terms for 7, 10, 19, 37 GHz
- Real(Kind=jprb) :: einterpolated(4,3) ! Emissivity azimuthal variation terms for interpolated to required frequency
- Real(Kind=jprb) :: a1e,a2e,a3e !,ac,a2c,a3c ! coefficients used in azimuthal emissivity model
- Real(Kind=jprb) :: opdpsfc,freqr
- Real(Kind=jprb) :: zrough_v,zrough_h
- Real(Kind=jprb) :: zreflmod_v,zreflmod_h
- Real(Kind=jprb) :: delta,delta2
- Real(Kind=jprb) :: qdepol,emissfactor
- Real(Kind=jprb) :: emissfactor_v,emissfactor_h
- Real(Kind=jprb) :: zc(12),zx(9)
- Real(Kind=jprb), Pointer :: c(:)
- Complex(Kind=jprb) :: perm1,perm2
- Complex(Kind=jprb) :: rhth,rvth
- Complex(Kind=jprb) :: permittivity
- Integer(Kind=jpim) :: i,j,chan,istokes,ifreq,m
- Integer(Kind=jpim) :: iquadrant ! Determines which quadrant (NE, SE, SW, NW) the wind is blowing to
- Integer(Kind=jpim) :: pol_id ! polarisation indice
- Integer(Kind=jpim) :: i_freq,j_stokes,ich,ichannel ! indices used in azimuthal emissivity model
- Integer(Kind=jpim) :: jcof,jcofm1
- Type(profile_Type), Pointer :: prof
- Type(profile_Type), Pointer :: prof_k
- Type(geometry_Type), Pointer :: geom
-
- Real(Kind=jprb) :: tcelsius_k(4)
- Real(Kind=jprb) :: tcelsius_sq_k(4)
- Real(Kind=jprb) :: tcelsius_cu_k(4)
- Real(Kind=jprb) :: f1_k(4), f2_k(4)
- Real(Kind=jprb) :: del1_k(4), del2_k(4)
- Real(Kind=jprb) :: einf_k(4)
- Real(Kind=jprb) :: fen_k(4), fen_sq_k(4)
- Real(Kind=jprb) :: den1_k(4), den2_k(4)
- Real(Kind=jprb) :: sigma_k(4)
- Real(Kind=jprb) :: perm_real1_k(4), perm_real2_k(4)
- Real(Kind=jprb) :: perm_imag1_k(4), perm_imag2_k(4), perm_imag3_k(4)
- Real(Kind=jprb) :: perm_Real_k(4), perm_imag_k(4)
- Real(Kind=jprb) :: perm_static_k(4), perm_infinite_k(4)
- Real(Kind=jprb) :: fresnel_v_Real_k, fresnel_v_imag_k
- Real(Kind=jprb) :: fresnel_h_Real_k, fresnel_h_imag_k
- Real(Kind=jprb) :: fresnel_v_k, fresnel_h_k
- Real(Kind=jprb) :: small_rough_cor_k(4), foam_cor_k(4)
- Real(Kind=jprb) :: large_rough_cor_k(4)
- Real(Kind=jprb) :: small_rough_k(4), large_rough_k(4)
- Real(Kind=jprb) :: variance_k(4), varm_k(4)
- Real(Kind=jprb) :: wind10_k(4)
- Real(Kind=jprb) :: wind10_sq_k(4), windsec_k(4)
- Real(Kind=jprb) :: wind10_direction_k(4), windangle_k(4), windratio_k(4) ! Note wind azimuth is in radians
- Real(Kind=jprb) :: azimuthal_emiss_k,azimuthal_emiss,u19_k(4),phi_k(4)
- Real(Kind=jprb) :: tbfixed_k(4,4,3) ! Surface brightness temperature azimuthal variation terms for 37, 19, 10, 7 GHz
- Real(Kind=jprb) :: efixed_k(4,4,3) ! Emissivity azimuthal variation terms for 7, 10, 19, 37 GHz
- Real(Kind=jprb) :: einterpolated_k(4,3) ! Emissivity azimuthal variation terms for interpolated to required frequency
- Real(Kind=jprb) :: a1e_k,a2e_k,a3e_k ! coefficients used in azimuthal emissivity model
- Real(Kind=jprb) :: opdpsfc_k(4), freqr_k(4)
- Real(Kind=jprb) :: zrough_v_k, zrough_h_k, zrough_3v_k, zrough_4v_k, zrough_3h_k, zrough_4h_k
- Real(Kind=jprb) :: zreflmod_v_k, zreflmod_h_k, zreflmod_3_k, zreflmod_4_k
- Real(Kind=jprb) :: delta_k(4), delta2_k(4)
- Real(Kind=jprb) :: qdepol_k(4), emissfactor_k
- Real(Kind=jprb) :: emissfactor_v_k, emissfactor_h_k
- Real(Kind=jprb) :: zx_k(9,4)
- Complex(Kind=jprb) :: perm1_k(4), perm2_k(4)
- Complex(Kind=jprb) :: rhth_k, rvth_k
- Complex(Kind=jprb) :: permittivity_k(4)
- Integer(Kind=jpim) :: wanted_fastem_ver ! user fastem version request
- Integer(Kind=jpim) :: ipol, npol
-
- Real(Kind=jprb) :: test_variance
-
- !- End of header --------------------------------------------------------
-
- ! If the coefficent file contains FASTEM 2 it contains also FASTEM 1 but
- ! the version choosen is given by coef % fastem_ver value
- wanted_fastem_ver = coef % fastem_ver
-
- !If a TL value of emissivity is passed to the routine
- !Loop over channels
-
- phi_k(:)=0.0_JPRB
- efixed_k(:,:,:)=0.0_JPRB
-
- Do i = 1, nfrequencies
- ichannel=polarisations(i,1)
- ipol = polarisations(i,1)
- npol = polarisations(i,3)
- If ( .Not. calcemis(ichannel) ) Cycle
-
- chan = channels(i)
- prof => profiles( lprofiles(i) )
- prof_k => profiles_k( (i) )
- geom => geometry( lprofiles(i) )
-
- !-------------------------------
- !0. Point to fastem coefficients
- !-------------------------------
-
- c => coef % fastem_coef
-
- pol_id = coef % fastem_polar(chan) + 1
- Do Ich=1, 4
- reflectstokes_k(i,ich) = 0.0_JPRB
- emissstokes_k(i,ich) = 0.0_JPRB
- End Do
-
- If (pol_id <= 3 .or. pol_id >= 6) then
- Do Ich=1, polarisations(i,3)
- reflectstokes_k(i,ich) = reflectivity_k(ichannel+ich-1)
- emissstokes_k(i,ich) = emissivity_k(ichannel+ich-1)
- End Do
- End If
-
- If (pol_id == 4) then
- reflectstokes_k(i,1) = reflectivity_k(ichannel)
- emissstokes_k(i,1) = emissivity_k(ichannel)
- End If
-
- If (pol_id == 5) then
- reflectstokes_k(i,2) = reflectivity_k(ichannel)
- emissstokes_k(i,2) = emissivity_k(ichannel)
- End If
-
- wind10_k(:) = 0.0_JPRB
- wind10_direction_k(:) = 0.0_JPRB
-
- !---------------
- !1. Sea surfaces
- !---------------
-
- If ( prof % skin % surftype == surftype_sea ) Then
-
- !-------------------------------------------
- !1.1 Calculate channel independent variables
- !-------------------------------------------
- wind10_sq = prof % s2m % u * prof % s2m % u +&
- & prof % s2m % v * prof % s2m % v
- wind10 = Sqrt( wind10_sq )
- windsec = wind10 * geom%seczen
- if (prof % s2m % u >= 0.0_JPRB .AND. prof % s2m % v >= 0.0_JPRB) iquadrant=1
- if (prof % s2m % u >= 0.0_JPRB .AND. prof % s2m % v < 0.0_JPRB) iquadrant=2
- if (prof % s2m % u < 0.0_JPRB .AND. prof % s2m % v >= 0.0_JPRB) iquadrant=4
- if (prof % s2m % u < 0.0_JPRB .AND. prof % s2m % v < 0.0_JPRB) iquadrant=3
-
- If (abs(prof % s2m % v) >= 0.0001_JPRB) then
- windratio=prof % s2m % u/prof % s2m % v
- Else
- windratio=0.0_JPRB
- If (abs(prof % s2m % u) > 0.0001_JPRB) then
- windratio=999999.0_JPRB*prof % s2m % u
- Endif
- Endif
-
- windangle=atan(windratio)
- wind10_direction = quadcof(iquadrant,1)*pi+windangle*quadcof(iquadrant,2)
-
- !Set values for temperature polynomials (convert from kelvin to celsius)
- tcelsius = prof % skin % t - 273.15_JPRB
- tcelsius_sq = tcelsius * tcelsius !quadratic
- tcelsius_cu = tcelsius_sq * tcelsius !cubic
-
- !Define two relaxation frequencies, f1 and f2
- f1 = c(1) + c(2) * tcelsius + c(3) * tcelsius_sq
- f2 = c(4) + c(5) * tcelsius + c(6) * tcelsius_sq + c(7) * tcelsius_cu
-
- !Static permittivity estatic = del1+del2+einf
- del1 = c(8) + c(9) * tcelsius + c(10) * tcelsius_sq + c(11) * tcelsius_cu
- del2 = c(12) + c(13) * tcelsius + c(14) * tcelsius_sq + c(15) * tcelsius_cu
- einf = c(18) + c(19) * tcelsius
-
- freq_ghz = coef % frequency_ghz(chan)
- freq_ghz_sq = freq_ghz * freq_ghz
-
- !-----------------------------------------------------
- !1.2 calculate permittivity using double-debye formula
- !-----------------------------------------------------
-
- fen = 2.0_JPRB * c(20) * freq_ghz * 0.001_JPRB
- fen_sq = fen*fen
- den1 = 1.0_JPRB + fen_sq * f1 * f1
- den2 = 1.0_JPRB + fen_sq * f2 * f2
- perm_real1 = del1 / den1
- perm_real2 = del2 / den2
- perm_imag1 = del1 * fen * f1 / den1
- perm_imag2 = del2 * fen * f2 / den2
- perm_free = 8.854E-03_JPRB
- sigma = 2.906_JPRB + 0.09437_JPRB * tcelsius
- perm_imag3 = sigma / (2.0_JPRB * c(20) * perm_free * freq_ghz)
- perm_Real = perm_real1 + perm_real2 + einf
- perm_imag = perm_imag1 + perm_imag2 + perm_imag3
- permittivity = Cmplx(perm_Real,perm_imag,jprb)
-
- !-------------------------------------------------------------
- !1.3 calculate complex reflection coefficients and corrections
- !-------------------------------------------------------------
-
-
- !1.3.1) Fresnel reflection coefficients
- !------
-
- perm1 = sqrt(permittivity - geom%sinzen_sq)
- perm2 = permittivity * geom%coszen
- rhth = (geom%coszen-perm1) / (geom%coszen+perm1)
- rvth = (perm2-perm1) / (perm2+perm1)
- ! fresnel_v_real = dble(rvth)
- fresnel_v_Real = Real(rvth)
- fresnel_v_imag = Aimag(rvth)
- fresnel(1) = fresnel_v_Real * fresnel_v_Real + &
- & fresnel_v_imag * fresnel_v_imag
- ! fresnel_h_real = dble(rhth)
- fresnel_h_Real = Real(rhth)
- fresnel_h_imag = Aimag(rhth)
- fresnel(2) = fresnel_h_Real * fresnel_h_Real + &
- & fresnel_h_imag * fresnel_h_imag
- fresnel(3) = 0.0_JPRB
- fresnel(4) = 0.0_JPRB
-
- !1.3.2) Small scale correction to reflection coefficients
- !------
-
- If (freq_ghz >= 15.0) Then
- small_rough_cor = Exp( c(21) * wind10 * geom % coszen_sq / (freq_ghz_sq) )
- Else
- small_rough_cor = 1.0
- End If
-
-
- !1.3.3) Large scale geometric correction
- !------
-
- !Point to correct coefficients for this version. There are 36 altogether.
- !Those for FASTEM-2 are stored in section 24:59 of the array, those for
- !FASTEM1 in section 60:95.
- If ( wanted_fastem_ver == 2 ) Then
- c => coef%fastem_coef(24:59)
- Else
- c => coef%fastem_coef(60:95)
- End If
- Do j = 1, 12
- zc(j) = c(j*3-2) + c(j*3-1)*freq_ghz + c(j*3)*freq_ghz_sq
- End Do
- !Point back to all coefficients again
- c => coef%fastem_coef
-
- large_rough_cor(1) = &
- & (zc(1) + &
- & zc(2) * geom%seczen + &
- & zc(3) * geom%seczen_sq + &
- & zc(4) * wind10 + &
- & zc(5) * wind10_sq + &
- & zc(6) * windsec) / 100._JPRB
- large_rough_cor(2) = &
- & (zc(7) + &
- & zc(8) * geom%seczen + &
- & zc(9) * geom%seczen_sq + &
- & zc(10) * wind10 + &
- & zc(11) * wind10_sq + &
- & zc(12) * windsec) / 100._JPRB
- large_rough_cor(3) = 0.0_JPRB
- large_rough_cor(4) = 0.0_JPRB
-
- ! Introduce emiss_v_save and emiss_h_save arrays to be able
- ! to simplify further AD code
- Do Ich=1,4
- emiss_save(Ich) = 1.0_JPRB - fresnel(Ich) * small_rough_cor + large_rough_cor(Ich)
- End Do
-
- !Apply foam correction
- foam_cor(1) = c(22) * ( wind10 ** c(23) )
- foam_cor(2) = c(22) * ( wind10 ** c(23) )
- !Currently ignore foam effects on 3rd and 4th elements.
- foam_cor(3) = 0.0_JPRB
- foam_cor(4) = 0.0_JPRB
-
- Do Ich=1,4
- emissstokes(i,Ich) = emiss_save(Ich) - foam_cor(Ich)*emiss_save(Ich) + foam_cor(Ich)
- End Do
- emissstokes(i,3) = 0.0
- emissstokes(i,4) = 0.0
-
- ! Only apply non-specular correction for Fastem-3 if theta < 60 degrees
- If ((wanted_fastem_ver == 2 .or. (wanted_fastem_ver == 3 .And. geom%seczen <= 2.0_JPRB)) .And. &
- & transmission % tau_surf(ichannel) < 0.9999_JPRB .And. transmission % tau_surf(ichannel) > 0.00001_JPRB ) Then
-
- !Convert windspeed to slope variance using the Cox and Munk model
- variance = 0.00512_JPRB * wind10 + 0.0030_JPRB
- varm = variance * c(138)
- variance = varm * ( c(139) * freq_ghz + c(140) )
-
- test_variance = variance
- If ( variance > varm ) Then
- variance = varm
- Endif
- If ( variance < 0.0_JPRB ) Then
- variance = 0.0_JPRB
- Endif
-
- !Compute surface to space optical depth
- opdpsfc = -log(transmission % tau_surf(ichannel)) / geom%seczen
-
- !Define nine predictors for the effective angle calculation
- zx(1) = 1.0_JPRB
- zx(2) = variance
- zx(4) = 1.0_JPRB / geom%coszen
- zx(3) = zx(2) * zx(4)
- zx(5) = zx(3) * zx(3)
- zx(6) = zx(4) * zx(4)
- zx(7) = zx(2) * zx(2)
- zx(8) = log(opdpsfc)
- zx(9) = zx(8) * zx(8)
-
- zrough_v = 1.0_JPRB
- zrough_h = 1.0_JPRB
-
- Do jcof = 1,7
- jcofm1 = jcof-1
- !Switched h to v Deblonde SSMIS june 7, 2001
- zrough_h = zrough_h + &
- & zx(jcof) * ( c(96+jcofm1*3) &
- & + zx(8) * c(97+jcofm1*3) &
- & + zx(9) * c(98+jcofm1*3) )
- zrough_v = zrough_v + &
- & zx(jcof) * ( c(117+jcofm1*3) &
- & + zx(8) * c(118+jcofm1*3) &
- & + zx(9) * c(119+jcofm1*3) )
- End Do
-
- zreflmod_v = (1.0_JPRB-transmission % tau_surf(ichannel)**zrough_v) /&
- & (1.0_JPRB-transmission % tau_surf(ichannel))
- zreflmod_h = (1.0_JPRB-transmission % tau_surf(ichannel)**zrough_h) /&
- & (1.0_JPRB-transmission % tau_surf(ichannel))
-
- !reflect_v(i) = zreflmod_v * (1.0-emiss_v(i))
- !reflect_h(i) = zreflmod_h * (1.0-emiss_h(i))
-
- !Else
- !reflect_v(i) = 1.0 - emiss_v(i)
- !reflect_h(i) = 1.0 - emiss_h(i)
-
- End If
-
- !.......end of forward part....................................
- !
- ! * Now run K code of fastem
- !
- ! Only apply non-specular correction for Fastem-3 if theta < 60 degrees
- If ((wanted_fastem_ver == 2 .or. (wanted_fastem_ver == 3 .And. geom%seczen <= 2.0_JPRB)) .And. &
- & transmission % tau_surf(ichannel) < 0.9999_JPRB .And. transmission % tau_surf(ichannel) > 0.00001_JPRB ) Then
-
- If ( wanted_fastem_ver == 3) then
- ! Add azimuthal component from Fuzhong Weng (NOAA/NESDIS) based on work by Dr. Gene Poe (NRL)
- ! Angle between wind direction and satellite azimuthal view angle
- ! Assume 19m wind = 10m wind for now (fix later).
- phi = pi - wind10_direction + prof % azangle*pi/180.0_JPRB
- u19=wind10
- Do ich = 0,15
- a1e = c(141+ich*12) + u19*(c(142+ich*12)+ u19*(c(143+ich*12)+u19*c(144+ich*12)))
- a2e = c(145+ich*12) + u19*(c(146+ich*12)+ u19*(c(147+ich*12)+u19*c(148+ich*12)))
- a3e = c(149+ich*12) + u19*(c(150+ich*12)+ u19*(c(151+ich*12)+u19*c(152+ich*12)))
-
- i_freq = int(ich/4) + 1 ! 37, 19, 10, 7 GHz
- j_stokes = mod(ich,4) + 1
- tbfixed(j_stokes,i_freq,1) = a1e
- tbfixed(j_stokes,i_freq,2) = a2e
- tbfixed(j_stokes,i_freq,3) = a3e
- End Do
-
- Do M=1,3
- Do ifreq=1,4
- efixed(1,ifreq,M)= tbfixed(ifreq,4,M) ! 7 GHz
- efixed(2,ifreq,M)= tbfixed(ifreq,3,M) ! 10 GHz
- efixed(3,ifreq,M)= tbfixed(ifreq,2,M) ! 19 GHz
- efixed(4,ifreq,M)= tbfixed(ifreq,1,M) ! 37 GHz
- End Do
-
- ! Interpolate results to required frequency based on 7, 10, 19, 37 GHz
-
- If (freq_ghz.le.freqfixed(1)) Then
- einterpolated(:,M)=efixed(1,:,M)
- Else If(freq_ghz.ge.freqfixed(4)) then
- einterpolated(:,M)=efixed(4,:,M)
- Else
- If(freq_ghz.lt.freqfixed(2)) ifreq=2
- If(freq_ghz.lt.freqfixed(3).and.freq_ghz.ge.freqfixed(2)) ifreq=3
- If(freq_ghz.ge.freqfixed(3)) ifreq=4
- dfreq=(freq_ghz-freqfixed(ifreq-1))/(freqfixed(ifreq)-freqfixed(ifreq-1))
- einterpolated(:,M)=efixed(ifreq-1,:,M)+dfreq*(efixed(ifreq,:,M)-efixed(ifreq-1,:,M))
- EndIf
- EndDo
- Do istokes = 1,4
- azimuthal_emiss=0.0_JPRB
- Do M=1,3
- If(istokes.le.2) Then
- azimuthal_emiss=azimuthal_emiss+einterpolated(istokes,M)*cos(m*phi)*(1.0_JPRB-geom%coszen)&
- &/(1.0_JPRB - 0.6018_JPRB)
- Else
- azimuthal_emiss=azimuthal_emiss+einterpolated(istokes,M)*sin(m*phi)*(1.0_JPRB-geom%coszen)&
- &/(1.0_JPRB - 0.6018_JPRB)
- End If
- End Do
- emissstokes(i,istokes)=emissstokes(i,istokes)+azimuthal_emiss
-
- End Do
- EndIf
- zreflmod_v_k = reflectstokes_k(i,1) * (1.0_JPRB-emissstokes(i,1))
- zreflmod_h_k = reflectstokes_k(i,2) * (1.0_JPRB-emissstokes(i,2))
- zreflmod_3_k = - 1.0_JPRB * reflectstokes_k(i,3) * emissstokes(i,3)
- zreflmod_4_k = - 1.0_JPRB * reflectstokes_k(i,4) * emissstokes(i,4)
-
- emissstokes_k(i,4) = emissstokes_k(i,4) - 0.5_JPRB * (zreflmod_v + zreflmod_h) * reflectstokes_k(i,4)
- emissstokes_k(i,3) = emissstokes_k(i,3) - 0.5_JPRB * (zreflmod_v + zreflmod_h) * reflectstokes_k(i,3)
- emissstokes_k(i,2) = emissstokes_k(i,2) - reflectstokes_k(i,2) * zreflmod_h
- emissstokes_k(i,1) = emissstokes_k(i,1) - reflectstokes_k(i,1) * zreflmod_v
- zrough_v_k = -zreflmod_v_k * &
- & ( transmission % tau_surf(ichannel)**zrough_v * Log(transmission % tau_surf(ichannel)) ) / &
- & (1.0_JPRB-transmission % tau_surf(ichannel))
-
- zrough_h_k = - zreflmod_h_k * &
- & ( transmission % tau_surf(ichannel)**zrough_h * Log(transmission % tau_surf(ichannel)) ) / &
- & (1.0_JPRB-transmission % tau_surf(ichannel))
-
- If (npol >= 2) Then
-
- transmission_k % tau_surf(ipol) = transmission_k % tau_surf(ipol) + zreflmod_v_k *&
- & (-zrough_v * transmission % tau_surf(ipol)**(zrough_v-1.0_JPRB) * &
- & (1.0_JPRB-transmission % tau_surf(ipol)) + &
- & ( 1.0_JPRB-transmission % tau_surf(ipol)**zrough_v) ) &
- & / (1.0_JPRB-transmission % tau_surf(ipol))**2
-
- transmission_k % tau_surf(ipol+1) = transmission_k % tau_surf(ipol+1) + zreflmod_h_k *&
- & (-zrough_h * transmission % tau_surf(ipol)**(zrough_h-1.0_JPRB) * &
- & (1.0_JPRB-transmission % tau_surf(ipol)) + &
- & ( 1.0_JPRB-transmission % tau_surf(ipol)**zrough_h) ) &
- & / (1.0_JPRB-transmission % tau_surf(ipol))**2
-
- EndiF
-
- If (npol >= 3) Then
-
- zrough_3v_k = - zreflmod_3_k * &
- & (0.5* (transmission % tau_surf(ichannel+2)**zrough_v) &
- * Log(transmission % tau_surf(ichannel+2)) ) / (1.0_JPRB-transmission % tau_surf(ichannel+2))
-
- zrough_4v_k = -zreflmod_4_k * &
- & (0.5*(transmission % tau_surf(ichannel+3)**zrough_v) &
- * Log(transmission % tau_surf(ichannel+3)) ) / (1.0_JPRB-transmission % tau_surf(ichannel+3))
-
- zrough_3h_k = - zreflmod_3_k * &
- & (0.5* (transmission % tau_surf(ichannel+2)**zrough_h) &
- * Log(transmission % tau_surf(ichannel+2)) ) / (1.0_JPRB-transmission % tau_surf(ichannel+2))
-
- zrough_4h_k = -zreflmod_4_k * &
- & (0.5*( transmission % tau_surf(ichannel+3)**zrough_h) &
- * Log(transmission % tau_surf(ichannel+3)) ) / (1.0_JPRB-transmission % tau_surf(ichannel+3))
-
-
- transmission_k % tau_surf(ipol+2) = transmission_k % tau_surf(ipol+2) + 0.5_JPRB * zreflmod_3_k *&
- & (-zrough_h * transmission % tau_surf(ipol)**(zrough_h-1.0_JPRB) * &
- & (1.0_JPRB-transmission % tau_surf(ipol)) + &
- & ( 1.0_JPRB-transmission % tau_surf(ipol)**zrough_h) ) &
- & / (1.0_JPRB-transmission % tau_surf(ipol))**2
-
- transmission_k % tau_surf(ipol+2) = transmission_k % tau_surf(ipol+2) + 0.5_JPRB * zreflmod_3_k *&
- & (-zrough_v * transmission % tau_surf(ipol)**(zrough_v-1.0_JPRB) * &
- & (1.0_JPRB-transmission % tau_surf(ipol)) + &
- & ( 1.0_JPRB-transmission % tau_surf(ipol)**zrough_v) ) &
- & / (1.0_JPRB-transmission % tau_surf(ipol))**2
- transmission_k % tau_surf(ipol+3) = transmission_k % tau_surf(ipol+3) + 0.5_JPRB * zreflmod_4_k *&
- & (-zrough_h * transmission % tau_surf(ipol)**(zrough_h-1.0_JPRB) * &
- & (1.0_JPRB-transmission % tau_surf(ipol)) + &
- & ( 1.0_JPRB-transmission % tau_surf(ipol)**zrough_h) ) &
- & / (1.0_JPRB-transmission % tau_surf(ipol))**2
-
- transmission_k % tau_surf(ipol+3) = transmission_k % tau_surf(ipol+3) + 0.5_JPRB * zreflmod_4_k *&
- & (-zrough_v * transmission % tau_surf(ipol)**(zrough_v-1.0_JPRB) * &
- & (1.0_JPRB-transmission % tau_surf(ipol)) + &
- & ( 1.0_JPRB-transmission % tau_surf(ipol)**zrough_v) ) &
- & / (1.0_JPRB-transmission % tau_surf(ipol))**2
- End If
- If (npol == 1 .and. pol_id == 5) Then
- transmission_k % tau_surf(ipol) = transmission_k % tau_surf(ipol) + zreflmod_h_k *&
- & (-zrough_h * transmission % tau_surf(ichannel)**(zrough_h-1.0_JPRB) * &
- & (1.0_JPRB-transmission % tau_surf(ichannel)) + &
- & ( 1.0_JPRB-transmission % tau_surf(ichannel)**zrough_h) ) &
- & / (1.0_JPRB-transmission % tau_surf(ichannel))**2
- End If
-
- If (npol == 1 .and. pol_id == 4) Then
- transmission_k % tau_surf(ipol) = transmission_k % tau_surf(ipol) + zreflmod_v_k *&
- & (-zrough_v * transmission % tau_surf(ichannel)**(zrough_v-1.0_JPRB) * &
- & (1.0_JPRB-transmission % tau_surf(ichannel)) + &
- & ( 1.0_JPRB-transmission % tau_surf(ichannel)**zrough_v) ) &
- & / (1.0_JPRB-transmission % tau_surf(ichannel))**2
- End If
- zx_k(:,:) = 0.0_JPRB
- Do jcof = 1,7
- jcofm1 = jcof-1
- !Switched h to v Deblonde SSMIS june 7, 2001
-
- zx_k(9,1) = zx_k(9,1) + zrough_v_k * zx(jcof) * c(119+jcofm1*3)
- zx_k(8,1) = zx_k(8,1) + zrough_v_k * zx(jcof) * c(118+jcofm1*3)
- zx_k(jcof,1) = zrough_v_k *&
- & ( c(117+jcofm1*3) &
- & + zx(8) * c(118+jcofm1*3) &
- & + zx(9) * c(119+jcofm1*3) )
-
- zx_k(9,2) = zx_k(9,2) + zrough_h_k * zx(jcof) * c(98+jcofm1*3)
- zx_k(8,2) = zx_k(8,2) + zrough_h_k * zx(jcof) * c(97+jcofm1*3)
- zx_k(jcof,2) = zrough_h_k *&
- & ( c(96+jcofm1*3) &
- & + zx(8) * c(97+jcofm1*3) &
- + zx(9) * c(98+jcofm1*3) )
-
- If (npol >= 3) Then
- zx_k(9,3) = zx_k(9,3) + zrough_3v_k * zx(jcof) * c(119+jcofm1*3)
- zx_k(8,3) = zx_k(8,3) + zrough_3v_k * zx(jcof) * c(118+jcofm1*3)
- zx_k(jcof,3) = zrough_3v_k *&
- & ( c(117+jcofm1*3) &
- & + zx(8) * c(118+jcofm1*3) &
- & + zx(9) * c(119+jcofm1*3) )
-
- zx_k(9,3) = zx_k(9,3) + zrough_3h_k * zx(jcof) * c(98+jcofm1*3)
- zx_k(8,3) = zx_k(8,3) + zrough_3h_k * zx(jcof) * c(97+jcofm1*3)
- zx_k(jcof,3) = zx_k(jcof,3) + zrough_3h_k *&
- & ( c(96+jcofm1*3) &
- & + zx(8) * c(97+jcofm1*3) &
- + zx(9) * c(98+jcofm1*3) )
-
- zx_k(9,4) = zx_k(9,4) + zrough_4v_k * zx(jcof) * c(119+jcofm1*3)
- zx_k(8,4) = zx_k(8,4) + zrough_4v_k * zx(jcof) * c(118+jcofm1*3)
- zx_k(jcof,4) = zrough_4v_k *&
- & ( c(117+jcofm1*3) &
- & + zx(8) * c(118+jcofm1*3) &
- & + zx(9) * c(119+jcofm1*3) )
-
- zx_k(9,4) = zx_k(9,4) + zrough_4h_k * zx(jcof) * c(98+jcofm1*3)
- zx_k(8,4) = zx_k(8,4) + zrough_4h_k * zx(jcof) * c(97+jcofm1*3)
- zx_k(jcof,4) = zx_k(jcof,4) + zrough_4h_k *&
- & ( c(96+jcofm1*3) &
- & + zx(8) * c(97+jcofm1*3) &
- + zx(9) * c(98+jcofm1*3) )
- EndIf
- End Do
-
- zrough_v_k = 0.0_JPRB
- zrough_h_k = 0.0_JPRB
-
- !Define nine predictors for the effective angle calculation
-
- zx_k(8,:) = zx_k(8,:) + zx_k(9,:) * 2 * zx(8)
-
- opdpsfc_k(:) = zx_k(8,:) / opdpsfc
- zx_k(2,:) = zx_k(2,:) + zx_k(7,:) * 2 * zx(2)
-
- zx_k(4,:) = zx_k(4,:) + zx_k(6,:) * 2 * zx(4)
-
- zx_k(3,:) = zx_k(3,:) + zx_k(5,:) * 2 * zx(3)
-
- zx_k(2,:) = zx_k(2,:) + zx_k(3,:) * zx(4)
-
- zx_k(4,:) = 0.0_JPRB
-
- variance_k(:) = zx_k(2,:)
-
- zx_k(1,:) = 0.0_JPRB
-
- !Compute surface to space optical depth
- If (npol >= 2) Then
- transmission_k % tau_surf(ipol) = transmission_k % tau_surf(ipol) - opdpsfc_k(1) /&
- & ( transmission % tau_surf(ichannel) * geom%seczen )
- transmission_k % tau_surf(ipol+1) = transmission_k % tau_surf(ipol+1) - opdpsfc_k(2) /&
- & ( transmission % tau_surf(ichannel) * geom%seczen )
- End If
- If (npol >= 3) Then
- transmission_k % tau_surf(ipol+2) = transmission_k % tau_surf(ipol+2) - opdpsfc_k(3) /&
- & ( transmission % tau_surf(ichannel) * geom%seczen )
- transmission_k % tau_surf(ipol+3) = transmission_k % tau_surf(ipol+3) - opdpsfc_k(4) /&
- & ( transmission % tau_surf(ichannel) * geom%seczen )
- End If
- If (npol == 1 .and. pol_id == 5) Then
- transmission_k % tau_surf(ipol) = transmission_k % tau_surf(ipol) - opdpsfc_k(2) /&
- & ( transmission % tau_surf(ichannel) * geom%seczen )
- End If
- If (npol == 1 .and. pol_id == 4) Then
- transmission_k % tau_surf(ipol) = transmission_k % tau_surf(ipol) - opdpsfc_k(1) /&
- & ( transmission % tau_surf(ichannel) * geom%seczen )
- End If
-
- If ( test_variance < varm ) Then
- varm_k(:) = variance_k(:) * ( c(139) * freq_ghz + c(140) )
- Else
- varm_k(:) = variance_k(:)
- Endif
-
- variance_k(:) = varm_k(:) * c(138)
- wind10_k(:) = wind10_k(:) + variance_k(:) * 0.00512_JPRB
-
- Else
- emissstokes_k(i,:) = emissstokes_k(i,:) - reflectstokes_k(i,:)
-
- End If
-
- If ( wanted_fastem_ver == 3) then
- einterpolated_k(:,:) = 0.0_JPRB
- phi_k(:)=0.0_JPRB
- Do istokes=1,4
- azimuthal_emiss_k=emissstokes_k(i,istokes)
- Do M=1,3
- If(istokes.le.2) Then
- einterpolated_k(istokes,M)= azimuthal_emiss_k*cos(m*phi)*(1.0_JPRB-geom%coszen)/(1.0_JPRB - 0.6018_JPRB)
- phi_k(istokes)=phi_k(istokes) - azimuthal_emiss_k*einterpolated(istokes,M)*m*sin(m*phi)*&
- (1.0_JPRB-geom%coszen)/(1.0_JPRB - 0.6018_JPRB)
- Else
- einterpolated_k(istokes,M)= azimuthal_emiss_k*sin(m*phi)*(1.0_JPRB-geom%coszen)/(1.0_JPRB - 0.6018_JPRB)
- phi_k(istokes)=phi_k(istokes) + azimuthal_emiss_k*einterpolated(istokes,M)*m*cos(m*phi)*&
- (1.0_JPRB-geom%coszen)/(1.0_JPRB - 0.6018_JPRB)
- End If
- Enddo
- End Do
-
- efixed_k(:,:,:) = 0.0_JPRB
- Do M=1,3
- If (freq_ghz.le.freqfixed(1)) Then
- efixed_k(1,:,M)=einterpolated_k(:,M)
- Else If(freq_ghz.ge.freqfixed(4)) then
- efixed_k(4,:,M)=einterpolated_k(:,M)
- Else
- If(freq_ghz.lt.freqfixed(2)) ifreq=2
- If(freq_ghz.lt.freqfixed(3).and.freq_ghz.ge.freqfixed(2)) ifreq=3
- If(freq_ghz.ge.freqfixed(3)) ifreq=4
- dfreq=(freq_ghz-freqfixed(ifreq-1))/(freqfixed(ifreq)-freqfixed(ifreq-1))
- Do istokes=1,4
- efixed_k(ifreq,istokes,M)=einterpolated_k(istokes,M)*dfreq
- efixed_k(ifreq-1,istokes,M)=einterpolated_k(istokes,M)*(1.0_JPRB-dfreq)
- End Do
- End If
-
- Do istokes=1,4
- tbfixed_k(istokes,4,M)= efixed_k(1,istokes,M) ! 7 GHz
- tbfixed_k(istokes,3,M)= efixed_k(2,istokes,M) ! 10 GHz
- tbfixed_k(istokes,2,M)= efixed_k(3,istokes,M) ! 19 GHz
- tbfixed_k(istokes,1,M)= efixed_k(4,istokes,M) ! 37 GHz
- End Do
- End Do
-
- u19_k(:)=0.0_JPRB
- Do ich = 0,15
- i_freq = int(ich/4) + 1 ! 37, 19, 10, 7 GHz
- j_stokes = mod(ich,4) + 1
- a3e_k = tbfixed_k(j_stokes,i_freq,3)
- a2e_k = tbfixed_k(j_stokes,i_freq,2)
- a1e_k = tbfixed_k(j_stokes,i_freq,1)
-
- u19_k(j_stokes) = u19_k(j_stokes) + a3e_k*(c(150+ich*12)+ u19*(2.0*c(151+ich*12)+3.0*u19*c(152+ich*12)))
- u19_k(j_stokes) = u19_k(j_stokes) + a2e_k*(c(146+ich*12)+ u19*(2.0*c(147+ich*12)+3.0*u19*c(148+ich*12)))
- u19_k(j_stokes) = u19_k(j_stokes) + a1e_k*(c(142+ich*12)+ u19*(2.0*c(143+ich*12)+3.0*u19*c(144+ich*12)))
- End Do
-
- wind10_k(:) = wind10_k(:) + u19_k(:)
- wind10_direction_k(:) = -1.0_JPRB * phi_k(:)
- End If
-
- foam_cor_k(:) = emissstokes_k(i,:) * (1. - emiss_save(:))
- emissstokes_k(i,:) = emissstokes_k(i,:) * (1. - foam_cor(:))
-
- !Apply foam correction
- wind10_k(:) = wind10_k(:) + foam_cor_k(:) *&
- & c(22) * c(23) * ( wind10 ** (c(23)-1.0_JPRB) )
-
- !1.3.3) Large scale geometric correction
- !------
-
- small_rough_cor_k(:) = 0.0_JPRB
- large_rough_cor_k(:) = 0.0_JPRB
- windsec_k(:) = 0.0_JPRB
- wind10_sq_k(:) = 0.0_JPRB
-
- fresnel_v_k = -emissstokes_k(i,1) * small_rough_cor
- small_rough_cor_k(1) = -emissstokes_k(i,1) * fresnel(1)
- large_rough_cor_k(1) = emissstokes_k(i,1)
-
- fresnel_h_k = -emissstokes_k(i,2) * small_rough_cor
- small_rough_cor_k(2) = -emissstokes_k(i,2) * fresnel(2)
- large_rough_cor_k(2) = emissstokes_k(i,2)
-
- windsec_k(1) = large_rough_cor_k(1) * zc(6) / 100._JPRB
- wind10_sq_k(1) = large_rough_cor_k(1) * zc(5) / 100._JPRB
- wind10_k(1) = wind10_k(1) + large_rough_cor_k(1) * zc(4) / 100._JPRB
-
- windsec_k(2) = large_rough_cor_k(2) * zc(12) / 100._JPRB
- wind10_sq_k(2) = large_rough_cor_k(2) * zc(11) / 100._JPRB
- wind10_k(2) = wind10_k(2) + large_rough_cor_k(2) * zc(10) / 100._JPRB
-
- !1.3.2) Small scale correction to reflection coefficients
- !------
-
- If (freq_ghz >= 15.0) Then
- wind10_k(:) = wind10_k(:) + small_rough_cor_k(:) *&
- & small_rough_cor * c(21) * geom % coszen_sq / (freq_ghz_sq)
- End If
-
- !1.3.1) Fresnel reflection coefficients
- !------
- fresnel_h_real_k = fresnel_h_k * 2 * fresnel_h_real
- fresnel_h_imag_k = fresnel_h_k * 2 * fresnel_h_imag
-
- rhth_k = CMPLX(fresnel_h_real_k, -fresnel_h_imag_k,jprb)
-
- fresnel_v_real_k = fresnel_v_k * 2 * fresnel_v_real
- fresnel_v_imag_k = fresnel_v_k * 2 * fresnel_v_imag
-
- rvth_k = CMPLX(fresnel_v_real_k, -fresnel_v_imag_k,jprb)
-
- perm1_k(:) = 0.0_JPRB
- perm2_k(:) = 0.0_JPRB
-
- perm1_k(1) = - rvth_k * 2 * perm2 / (perm2+perm1)**2
- perm2_k(1) = rvth_k * 2 * perm1 / (perm2+perm1)**2
-
- perm1_k(2) = - rhth_k * 2 * geom%coszen / (geom%coszen+perm1)**2
-
- permittivity_k(:) = perm2_k(:) * geom%coszen
-
- permittivity_k(:) = permittivity_k(:) + perm1_k(:) * 0.5_JPRB / perm1
-
- !-----------------------------------------------------
- !1.2 calculate permittivity using double-debye formula
- !-----------------------------------------------------
-
- perm_Real_k(:) = Real( permittivity_k(:) )
- perm_imag_k(:) = -Aimag( permittivity_k(:) )
-
- perm_imag1_k(:) = perm_imag_k(:)
- perm_imag2_k(:) = perm_imag_k(:)
- perm_imag3_k(:) = perm_imag_k(:)
-
- einf_k(:) = perm_real_k(:)
- perm_real1_k(:) = perm_real_k(:)
- perm_real2_k(:) = perm_real_k(:)
- sigma_k(:) = perm_imag3_k(:) / (2.0_JPRB * c(20) * perm_free * freq_ghz)
- tcelsius_k(:) = 0.09437_JPRB * sigma_k(:)
-
- del2_k(:) = perm_imag2_k(:) * fen * den2 * f2 / (den2 * den2)
- den2_k(:) = -perm_imag2_k(:) * fen * del2 * f2 / (den2 * den2)
- f2_k(:) = perm_imag2_k(:) * fen * den2 * del2/ (den2 * den2)
-
- del1_k(:) = perm_imag1_k(:) * fen * den1 * f1 / (den1 * den1)
- den1_k(:) = -perm_imag1_k(:) * fen * del1 * f1 / (den1 * den1)
- f1_k(:) = perm_imag1_k(:) * fen * den1 * del1/ (den1 * den1)
-
- del2_k(:) = del2_k(:) + perm_real2_k * den2 / (den2 * den2)
- den2_k(:) = den2_k(:) - perm_real2_k * del2 / (den2 * den2)
-
- del1_k(:) = del1_k(:) + perm_real1_k * den1 / (den1 * den1)
- den1_k(:) = den1_k(:) - perm_real1_k * del1 / (den1 * den1)
-
- f2_k(:) = f2_k(:) + den2_k(:) * 2 * fen_sq * f2
- f1_k(:) = f1_k(:) + den1_k(:) * 2 * fen_sq * f1
-
- !Static permittivity estatic = del1+del2+einf
- tcelsius_k(:) = tcelsius_k(:) + c(19) * einf_k(:)
-
- tcelsius_k(:) = tcelsius_k(:) + del2_k(:) * c(13)
- tcelsius_sq_k(:) = del2_k(:) * c(14)
- tcelsius_cu_k(:) = del2_k(:) * c(15)
-
- tcelsius_k(:) = tcelsius_k(:) + del1_k(:) * c(9)
- tcelsius_sq_k(:) = tcelsius_sq_k(:) + del1_k(:) * c(10)
- tcelsius_cu_k(:) = tcelsius_cu_k(:) + del1_k(:) * c(11)
-
- !Define two relaxation frequencies, f1 and f2
- tcelsius_k(:) = tcelsius_k(:) + f2_k(:) * c(5)
- tcelsius_sq_k(:) = tcelsius_sq_k(:) + f2_k(:) * c(6)
- tcelsius_cu_k(:) = tcelsius_cu_k(:) + f2_k(:) * c(7)
-
- tcelsius_k(:) = tcelsius_k(:) + f1_k(:) * c(2)
- tcelsius_sq_k(:) = tcelsius_sq_k(:) + f1_k(:) * c(3)
-
- !Set values for temperature polynomials (convert from kelvin to celsius)
- tcelsius_k(:) = tcelsius_k(:) + tcelsius_cu_k(:) * 3 * tcelsius_sq
-
-
-
- tcelsius_k(:) = tcelsius_k(:) + tcelsius_sq_k(:) * 2 * tcelsius
-
- wind10_k(:) = wind10_k(:) + windsec_k(:) * geom%seczen
- windangle_k(:) = wind10_direction_k(:)*quadcof(iquadrant,2)
- windratio_k(:) = 0.0_JPRB
- if (abs(prof % s2m % v) >= 0.0001_JPRB) windratio_k(:) = windangle_k(:)/&
- & (1.0_JPRB+windratio*windratio)
-
- If (abs(prof % s2m % v) >= 0.0001_JPRB) then
- If (npol >= 2) Then
- Do Istokes = 1, npol
- prof_k => profiles_k( (ipol+istokes-1) )
- prof_k % s2m % u = prof_k % s2m % u + windratio_k(istokes)*prof % s2m % v /&
- & (prof % s2m % v *prof % s2m % v)
- prof_k % s2m % v = prof_k % s2m % v - windratio_k(istokes)*prof % s2m % u /&
- & (prof % s2m % v *prof % s2m % v)
- End Do
- End If
- If (npol == 1) Then
- prof_k => profiles_k( (ipol) )
- prof_k % s2m % u = prof_k % s2m % u + windratio_k(pol_id-3)*prof % s2m % v /&
- & (prof % s2m % v *prof % s2m % v)
- prof_k % s2m % v = prof_k % s2m % v - windratio_k(pol_id-3)*prof % s2m % u /&
- & (prof % s2m % v *prof % s2m % v)
- End If
- Else
- If (abs(prof % s2m % u) > 0.0001_JPRB) then
- If (npol >= 2) Then
- Do Istokes = 1, npol
- prof_k => profiles_k( (ipol+istokes-1) )
- prof_k % s2m % u=prof_k % s2m % u + 999999.0*windratio_k(istokes)
- End Do
- End If
- If (npol == 1) Then
- prof_k => profiles_k( (ipol) )
- prof_k % s2m % u=prof_k % s2m % u + 999999.0*windratio_k(pol_id-3)
- Endif
- Endif
- Endif
-
- wind10_k(:) = wind10_k(:) + wind10_sq_k(:) * 2 * wind10
-
- If( wind10 > 0. ) Then
- wind10_sq_k(:) = 0.5_JPRB*wind10_k(:)/wind10
- Else
- wind10_sq_k = 0.0_JPRB
-
- Endif
-
- If (npol >= 2) Then
- Do Istokes = 1, npol
- prof_k => profiles_k( (ipol+istokes-1) )
- prof_k % s2m % u = prof_k % s2m % u + 2 * wind10_sq_k(istokes) * prof % s2m % u
- prof_k % s2m % v = prof_k % s2m % v + 2 * wind10_sq_k(istokes) * prof % s2m % v
- prof_k % skin % t = prof_k % skin % t + tcelsius_k(istokes)
- End Do
- End If
- If (npol == 1) Then
- prof_k => profiles_k( (ipol) )
- prof_k % s2m % u = prof_k % s2m % u + 2 * wind10_sq_k(pol_id-3) * prof % s2m % u
- prof_k % s2m % v = prof_k % s2m % v + 2 * wind10_sq_k(pol_id-3) * prof % s2m % v
- prof_k % skin % t = prof_k % skin % t + tcelsius_k(pol_id-3)
- End If
- prof_k % skin % fastem(:) = 0.0_JPRB
-
-
- Else
- !--------------------
- !2. Land/ice surfaces
- !--------------------
-
- !Coherent surface scattering model coefficients (input with the profile)
- perm_static = prof % skin % fastem(1)
- perm_infinite = prof % skin % fastem(2)
- freqr = prof % skin % fastem(3)
- small_rough = prof % skin % fastem(4)
- large_rough = prof % skin % fastem(5)
- chan = channels(i)
- freq_ghz = coef % frequency_ghz(chan)
-
- !Simple Debye + Fresnel model gives reflectivities
- fen = freq_ghz / freqr
- fen_sq = fen * fen
- den1 = 1.0_JPRB + fen_sq
- perm_Real = (perm_static+perm_infinite*fen_sq) / den1
- perm_imag = fen*(perm_static-perm_infinite) / den1
- permittivity = Cmplx(perm_Real,perm_imag,jprb)
- perm1 = sqrt(permittivity - geom%sinzen_sq)
- perm2 = permittivity * geom%coszen
- rhth = (geom%coszen - perm1) / (geom%coszen + perm1)
- rvth = (perm2 - perm1)/(perm2 + perm1)
- ! fresnel_v_real = dble(rvth)
- fresnel_v_Real = Real(rvth)
- fresnel_v_imag = Aimag(rvth)
- fresnel(1) = fresnel_v_Real * fresnel_v_Real + &
- & fresnel_v_imag * fresnel_v_imag
- ! fresnel_h_real = dble(rhth)
- fresnel_h_Real = Real(rhth)
- fresnel_h_imag = Aimag(rhth)
- fresnel(2) = fresnel_h_Real * fresnel_h_Real + &
- & fresnel_h_imag * fresnel_h_imag
-
- !Small scale roughness correction
- delta = 4.0_JPRB * pi * coef % ff_cwn(chan) * 0.1_JPRB * small_rough
- delta2 = delta * delta
- small_rough_cor = Exp(-delta2*geom%coszen_sq)
-
- !Large scale roughness correction
- qdepol = 0.35_JPRB - 0.35_JPRB*Exp(-0.60_JPRB*freq_ghz*large_rough*large_rough)
-
- emissfactor_v = 1.0_JPRB - fresnel(1) * small_rough_cor
- emissfactor_h = 1.0_JPRB - fresnel(2) * small_rough_cor
- emissfactor = emissfactor_h - emissfactor_v
- emissstokes(i,1) = emissfactor_v + qdepol * emissfactor
- emissstokes(i,2) = emissfactor_h - qdepol * emissfactor
-
-
- !.......end of forward part....................................
- !
- ! * Now run K code of fastem
- !
-
- emissstokes_k(i,2) = emissstokes_k(i,2) - reflectstokes_k(i,2)
- emissstokes_k(i,1) = emissstokes_k(i,1) - reflectstokes_k(i,1)
-
- emissfactor_h_k = emissstokes_k(i,2)
- qdepol_k(2) = -emissstokes_k(i,2) * emissfactor
- emissfactor_k = -emissstokes_k(i,2) * qdepol
-
- emissfactor_v_k = emissstokes_k(i,1)
- qdepol_k(1) = emissstokes_k(i,1) * emissfactor
- emissfactor_k = emissfactor_k +emissstokes_k(i,1) * qdepol
- qdepol_k(3) = 0.0_JPRB
- qdepol_k(4) = 0.0_JPRB
-
- emissfactor_v_k = emissfactor_v_k - emissfactor_k
- emissfactor_h_k = emissfactor_h_k + emissfactor_k
-
- fresnel_h_k = -emissfactor_h_k * small_rough_cor
- small_rough_cor_k(2) = -emissfactor_h_k * fresnel(2)
-
- fresnel_v_k = -emissfactor_v_k * small_rough_cor
- small_rough_cor_k(1) = -emissfactor_v_k * fresnel(1)
- small_rough_cor_k(4) = 0.0_JPRB
- small_rough_cor_k(3) = 0.0_JPRB
-
- !Large scale roughness correction
- large_rough_k(:) = qdepol_k(:) * 0.35_JPRB * 0.60_JPRB*freq_ghz*2*large_rough *&
- & Exp(-0.60_JPRB*freq_ghz*large_rough*large_rough)
-
- !Small scale roughness correction
- delta2_k(:) = -small_rough_cor_k(:) * geom%coszen_sq * small_rough_cor
- delta_k(:) = delta2_k(:)* 2 * delta
- small_rough_k(:) = 4.0_JPRB * pi * coef % ff_cwn(chan) * 0.1_JPRB * delta_k(:)
-
- !1.3.1) Fresnel reflection coefficients
- !Simple Debye + Fresnel model gives reflectivities
- !------
- fresnel_h_real_k = fresnel_h_k * 2 * fresnel_h_real
- fresnel_h_imag_k = fresnel_h_k * 2 * fresnel_h_imag
-
- rhth_k = CMPLX(fresnel_h_real_k, -fresnel_h_imag_k, jprb)
-
- fresnel_v_real_k = fresnel_v_k * 2 * fresnel_v_real
- fresnel_v_imag_k = fresnel_v_k * 2 * fresnel_v_imag
-
- rvth_k = CMPLX(fresnel_v_real_k, -fresnel_v_imag_k, jprb)
-
- perm1_k(1) = - rvth_k * 2 * perm2 / (perm2+perm1)**2
- perm2_k(1) = rvth_k * 2 * perm1 / (perm2+perm1)**2
-
- perm1_k(2) = - rhth_k * 2 * geom%coszen / (geom%coszen+perm1)**2
- perm2_k(2) = 0.0_JPRB
- perm1_k(3) = 0.0_JPRB
- perm1_k(4) = 0.0_JPRB
- perm2_k(3) = 0.0_JPRB
- perm2_k(4) = 0.0_JPRB
-
- permittivity_k(:) = perm2_k(:) * geom%coszen
-
- permittivity_k(:) = permittivity_k(:) + perm1_k(:) * 0.5_JPRB / perm1
-
- perm_Real_k(:) = Real( permittivity_k(:) )
- perm_imag_k(:) = -Aimag( permittivity_k(:) )
-
- fen_k(:) = perm_imag_k(:) *&
- & (perm_static - perm_infinite)/ den1
- perm_static_k(:) = perm_imag_k(:) *&
- & fen / den1
- perm_infinite_k(:) = -perm_imag_k(:) *&
- & fen / den1
- den1_k(:) = -perm_imag_k(:) *&
- & fen * (perm_static - perm_infinite)/ (den1*den1)
-
- perm_static_k(:) = perm_static_k(:) + perm_real_k(:) / den1
- perm_infinite_k(:) = perm_infinite_k(:) + perm_real_k(:) *&
- & fen_sq / den1
- fen_sq_k(:) = perm_real_k(:) *&
- & perm_infinite / den1
- den1_k(:) = den1_k(:) - perm_real_k(:) *&
- & (perm_static + perm_infinite * fen_sq) / (den1*den1)
-
-
- fen_sq_k(:) = fen_sq_k(:) + den1_k(:)
-
- fen_k(:) = fen_k(:) + fen_sq_k(:) * 2* fen
-
- freqr_k(:) = -fen_k(:) * freq_ghz / freqr**2
-
- If (npol >= 2) Then
- Do Istokes = 1, npol
- prof_k => profiles_k( (ipol+istokes-1) )
- prof_k % skin % fastem(1) = prof_k % skin % fastem(1) +&
- & perm_static_k(Istokes)
- prof_k % skin % fastem(2) = prof_k % skin % fastem(2) +&
- & perm_infinite_k(Istokes)
- prof_k % skin % fastem(3) = prof_k % skin % fastem(3) +&
- & freqr_k(Istokes)
- prof_k % skin % fastem(4) = prof_k % skin % fastem(4) +&
- & small_rough_k(Istokes)
- prof_k % skin % fastem(5) = prof_k % skin % fastem(5) +&
- & large_rough_k (Istokes)
- End Do
-
- End If
- If (npol == 1) Then
- prof_k => profiles_k( (ipol) )
- prof_k % skin % fastem(1) = prof_k % skin % fastem(1) +&
- & perm_static_k(1) + perm_static_k(2)
- prof_k % skin % fastem(2) = prof_k % skin % fastem(2) +&
- & perm_infinite_k(1) + perm_infinite_k(2)
- prof_k % skin % fastem(3) = prof_k % skin % fastem(3) +&
- & freqr_k(1) + freqr_k(2)
- prof_k % skin % fastem(4) = prof_k % skin % fastem(4) +&
- & small_rough_k(1) + small_rough_k(2)
- prof_k % skin % fastem(5) = prof_k % skin % fastem(5) +&
- & large_rough_k (1) + large_rough_k (2)
- End If
-
- End If
-
- End Do
-
- emissivity_k(:) = emissivity_k(:) - reflectivity_k(:)
-
-End Subroutine rttov_calcemis_mw_k
diff --git a/src/LIB/RTTOV/src/rttov_calcemis_mw_k.interface b/src/LIB/RTTOV/src/rttov_calcemis_mw_k.interface
deleted file mode 100644
index 4f210a15ecf99f1d24fb2ca745be18ef59689161..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_calcemis_mw_k.interface
+++ /dev/null
@@ -1,52 +0,0 @@
-Interface
-!
-Subroutine rttov_calcemis_mw_k ( &
- profiles, & ! in
- profiles_k, & ! inout
- geometry, & ! in
- coef, & ! in
- nfrequencies, & ! in
- nchannels, & ! in
- nprofiles, & ! in
- channels, & ! in
- polarisations, & ! in
- lprofiles, & ! in
- transmission, & ! in
- transmission_k, & ! inout
- calcemis, & ! in
- emissivity_k, & ! inout
- reflectivity_k ) ! inout
- Use rttov_const, Only : &
- pi ,&
- surftype_sea
-
- Use rttov_types, Only : &
- rttov_coef ,&
- profile_Type ,&
- transmission_Type ,&
- geometry_Type
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
- Integer(Kind=jpim), Intent(in) :: nprofiles
- Type(profile_Type), Intent(in) ,Target :: profiles(nprofiles)
- Type(geometry_Type), Intent(in) ,Target :: geometry(nprofiles)
- Type(rttov_coef), Intent(in) :: coef
- Integer(Kind=jpim), Intent(in) :: nfrequencies
- Integer(Kind=jpim), Intent(in) :: nchannels
- Integer(Kind=jpim), Intent(in) :: channels(nfrequencies)
- Integer(Kind=jpim), Intent(in) :: polarisations(nchannels,3)
- Integer(Kind=jpim), Intent(in) :: lprofiles(nfrequencies)
-
- Type(transmission_Type), Intent(in):: transmission
- Logical, Intent(in) :: calcemis(nchannels)
-
- Type(profile_Type), Intent(inout) ,Target :: profiles_k(nchannels)
- Type(transmission_Type), Intent(inout) :: transmission_k
- Real(Kind=jprb), Intent(inout) :: emissivity_k(nchannels)
- Real(Kind=jprb), Intent(inout) :: reflectivity_k(nchannels)
-
-
-End Subroutine rttov_calcemis_mw_k
-End Interface
diff --git a/src/LIB/RTTOV/src/rttov_calcemis_mw_tl.F90 b/src/LIB/RTTOV/src/rttov_calcemis_mw_tl.F90
deleted file mode 100644
index 96ece5e472d31077ba55120e222186845547def1..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_calcemis_mw_tl.F90
+++ /dev/null
@@ -1,791 +0,0 @@
-!
-Subroutine rttov_calcemis_mw_tl ( &
- & profiles, &! in
- & profiles_tl, &! in
- & geometry, &! in
- & coef, &! in
- & nfrequencies, &! in
- & nchannels, &! in
- & nprofiles, &! in
- & channels, &! in
- & polarisations, &! in
- & lprofiles, &! in
- & transmission, &! in
- & transmission_tl, &! in
- & calcemis, &! in
- & emissivity_tl, &! inout
- & reflectivity_tl ) ! out
- ! Description:
- ! Tangent Linear of rttov_calcemis_mw
- ! To compute MW surface emissivities for all channels and all
- ! profiles if desired
- !
- ! Copyright:
- ! This software was developed within the context of
- ! the EUMETSAT Satellite Application Facility on
- ! Numerical Weather Prediction (NWP SAF), under the
- ! Cooperation Agreement dated 25 November 1998, between
- ! EUMETSAT and the Met Office, UK, by one or more partners
- ! within the NWP SAF. The partners in the NWP SAF are
- ! the Met Office, ECMWF, KNMI and MeteoFrance.
- !
- ! Copyright 2002, EUMETSAT, All Rights Reserved.
- !
- ! Method:
- ! FASTEM-1 English and Hewison 1998.
- ! FASTEM-2 Deblonde and English 2001.
- ! FASTEM-3 English 2003.
- ! http://www.metoffice.com/research/interproj/nwpsaf/rtm/evalfastems.pdf
- ! Current Code Owner: SAF NWP
- !
- ! History:
- ! Version Date Comment
- ! ------- ---- -------
- ! 1.0 01/12/2002 New F90 code with structures (P Brunel A Smith)
- ! 1.1 02/01/2003 Comments added (R Saunders)
- ! 1.2 26/09/2003 Polarimetric code and Fastem-3 (S English)
- ! 1.3 18/08/2004 Added some _JPRB to constants (S English)
- ! 1.4 29/03/2005 Add end of header comment (J. Cameron)
- ! 1.5 14/10/2005 Reintroduce -r 121:122 changes, see -r 133:134
- ! Fixing bug in azimuth angles > 270 (J Cameron)
- !
- ! Code Description:
- ! Language: Fortran 90.
- ! Software Standards: "European Standards for Writing and
- ! Documenting Exchangeable Fortran 90 Code".
- !
- ! Declarations:
- ! Modules used:
- !
- ! Imported Parameters:
- Use rttov_const, Only : &
- & pi ,&
- & surftype_sea
-
- ! Imported Type Definitions:
- Use rttov_types, Only : &
- & rttov_coef ,&
- & profile_Type ,&
- & transmission_Type ,&
- & geometry_Type
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
- !subroutine arguments:
- Integer(Kind=jpim), Intent(in) :: nprofiles
- Integer(Kind=jpim), Intent(in) :: nfrequencies
- Type(profile_Type), Intent(in) ,Target :: profiles(nprofiles)
- Type(geometry_Type), Intent(in) ,Target :: geometry(nprofiles)
- Type(rttov_coef), Intent(in) :: coef
- Integer(Kind=jpim), Intent(in) :: nchannels
- Integer(Kind=jpim), Intent(in) :: channels(nfrequencies)
- Integer(Kind=jpim), Intent(in) :: polarisations(nchannels,3)
- Integer(Kind=jpim), Intent(in) :: lprofiles(nfrequencies)
-
- Type(transmission_Type), Intent(in):: transmission
- Logical, Intent(in) :: calcemis(nchannels)
-
- Type(profile_Type), Intent(in) ,Target :: profiles_tl(nprofiles)
- Type(transmission_Type), Intent(in) :: transmission_tl
- Real(Kind=jprb), Intent(inout) :: emissivity_tl(nchannels)
- Real(Kind=jprb), Intent(out) :: reflectivity_tl(nchannels)
-
-
-
- !local constants:
- Real(Kind=jprb), Parameter :: quadcof(4,2) = Reshape( &
- & (/ 0.0_JPRB, 1.0_JPRB, 1.0_JPRB, 2.0_JPRB, &
- & 1.0_JPRB, -1.0_JPRB, 1.0_JPRB, -1.0_JPRB /), (/4,2/) )
- Real(Kind=jprb), Parameter :: freqfixed(4) = Reshape( &
- & (/ 7.0_JPRB, 10.0_JPRB, 19.0_JPRB, 37.0_JPRB /), (/4/) )
-
- !local variables:
- Real(Kind=jprb) :: tcelsius
- Real(Kind=jprb) :: tcelsius_sq
- Real(Kind=jprb) :: tcelsius_cu
- Real(Kind=jprb) :: f1,f2
- Real(Kind=jprb) :: del1,del2
- Real(Kind=jprb) :: einf
- Real(Kind=jprb) :: fen,fen_sq
- Real(Kind=jprb) :: den1,den2
- Real(Kind=jprb) :: perm_free
- Real(Kind=jprb) :: sigma
- Real(Kind=jprb) :: perm_real1,perm_real2
- Real(Kind=jprb) :: perm_imag1,perm_imag2,perm_imag3
- Real(Kind=jprb) :: perm_Real,perm_imag
- Real(Kind=jprb) :: perm_static,perm_infinite
- Real(Kind=jprb) :: freq_ghz,freq_ghz_sq
- Real(Kind=jprb) :: fresnel_v_Real,fresnel_v_imag
- Real(Kind=jprb) :: fresnel_h_Real,fresnel_h_imag
- Real(Kind=jprb) :: fresnel_v,fresnel_h
- Real(Kind=jprb) :: small_rough_cor,foam_cor
- Real(Kind=jprb) :: large_rough_cor(2)
- Real(Kind=jprb) :: small_rough,large_rough
- Real(Kind=jprb) :: variance,varm
- Real(Kind=jprb) :: wind10
- Real(Kind=jprb) :: wind10_sq,windsec
- Real(Kind=jprb) :: wind10_direction, windangle, windratio ! Note wind azimuth is in radians
- Real(Kind=jprb) :: opdpsfc,freqr
- Real(Kind=jprb) :: zrough_v,zrough_h
- Real(Kind=jprb) :: zreflmod_v,zreflmod_h
- Real(Kind=jprb) :: delta,delta2
- Real(Kind=jprb) :: qdepol,emissfactor
- Real(Kind=jprb) :: emissfactor_v,emissfactor_h
- Real(Kind=jprb) :: emissstokes(nfrequencies,4)
- Real(Kind=jprb) :: emissstokes_tl(nfrequencies,4)
- Real(Kind=jprb) :: reflectstokes_tl(nfrequencies,4)
- Real(Kind=jprb) :: zc(12),zx(9)
- Real(Kind=jprb) :: azimuthal_emiss,u19,phi,dfreq
- Real(Kind=jprb) :: tbfixed(4,4,3) ! Surface brightness temperature azimuthal variation terms for 37, 19, 10, 7 GHz
- Real(Kind=jprb) :: efixed(4,4,3) ! Emissivity azimuthal variation terms for 7, 10, 19, 37 GHz
- Real(Kind=jprb) :: einterpolated(4,3) ! Emissivity azimuthal variation terms for interpolated to required frequency
- Real(Kind=jprb) :: a1e,a2e,a3e ! coefficients used in azimuthal emissivity model
- Real(Kind=jprb), Pointer :: c(:)
- Complex(Kind=jprb) :: perm1,perm2
- Complex(Kind=jprb) :: rhth,rvth
- Complex(Kind=jprb) :: permittivity
- Integer(Kind=jpim) :: i,j,chan,istokes,ifreq,m
- Integer(Kind=jpim) :: iquadrant ! Determines which quadrant (NE, SE, SW, NW) the wind is blowing to
- Integer(Kind=jpim) :: pol_id ! polarisation indice
- Integer(Kind=jpim) :: i_freq,j_stokes,ich,ichannel ! indices used in azimuthal emissivity model
- Integer(Kind=jpim) :: jcof,jcofm1
- Type(profile_Type), Pointer :: prof
- Type(profile_Type), Pointer :: prof_tl
- Type(geometry_Type), Pointer :: geom
-
-
- Real(Kind=jprb) :: tcelsius_tl
- Real(Kind=jprb) :: tcelsius_sq_tl
- Real(Kind=jprb) :: tcelsius_cu_tl
- Real(Kind=jprb) :: f1_tl, f2_tl
- Real(Kind=jprb) :: del1_tl, del2_tl
- Real(Kind=jprb) :: einf_tl
- Real(Kind=jprb) :: fen_tl, fen_sq_tl
- Real(Kind=jprb) :: den1_tl, den2_tl
- Real(Kind=jprb) :: sigma_tl
- Real(Kind=jprb) :: perm_real1_tl, perm_real2_tl
- Real(Kind=jprb) :: perm_imag1_tl, perm_imag2_tl, perm_imag3_tl
- Real(Kind=jprb) :: perm_Real_tl, perm_imag_tl
- Real(Kind=jprb) :: perm_static_tl, perm_infinite_tl
- Real(Kind=jprb) :: fresnel_v_Real_tl, fresnel_v_imag_tl
- Real(Kind=jprb) :: fresnel_h_Real_tl, fresnel_h_imag_tl
- Real(Kind=jprb) :: fresnel_v_tl, fresnel_h_tl
- Real(Kind=jprb) :: small_rough_cor_tl, foam_cor_tl
- Real(Kind=jprb) :: large_rough_cor_tl(2)
- Real(Kind=jprb) :: small_rough_tl, large_rough_tl
- Real(Kind=jprb) :: variance_tl, varm_tl
- Real(Kind=jprb) :: wind10_tl
- Real(Kind=jprb) :: wind10_sq_tl, windsec_tl
- Real(Kind=jprb) :: wind10_direction_tl, windangle_tl, windratio_tl ! Note wind azimuth is in radians
- Real(Kind=jprb) :: opdpsfc_tl, freqr_tl
- Real(Kind=jprb) :: zrough_v_tl, zrough_h_tl
- Real(Kind=jprb) :: zreflmod_v_tl, zreflmod_h_tl
- Real(Kind=jprb) :: delta_tl, delta2_tl
- Real(Kind=jprb) :: qdepol_tl, emissfactor_tl
- Real(Kind=jprb) :: emissfactor_v_tl, emissfactor_h_tl
- Real(Kind=jprb) :: zx_tl(9)
- Real(Kind=jprb) :: azimuthal_emiss_tl,u19_tl,phi_tl
- Real(Kind=jprb) :: tbfixed_tl(4,4,3) ! Surface brightness temperature azimuthal variation terms for 37, 19, 10, 7 GHz
- Real(Kind=jprb) :: efixed_tl(4,4,3) ! Emissivity azimuthal variation terms for 7, 10, 19, 37 GHz
- Real(Kind=jprb) :: einterpolated_tl(4,3) ! Emissivity azimuthal variation terms for interpolated to required frequency
- Real(Kind=jprb) :: a1e_tl,a2e_tl,a3e_tl,atot ! coefficients used in azimuthal emissivity model
- Complex(Kind=jprb) :: perm1_tl, perm2_tl
- Complex(Kind=jprb) :: rhth_tl, rvth_tl
- Complex(Kind=jprb) :: permittivity_tl
- Integer(Kind=jpim) :: wanted_fastem_ver,iii ! user fastem version request
-
-!- End of header --------------------------------------------------------
-
- ! If the coefficent file contains FASTEM 2 it contains also FASTEM 1 but
- ! the version choosen is given by coef % fastem_ver value
- wanted_fastem_ver = coef % fastem_ver
-
- !If a TL value of emissivity is passed to the routine
- ! this means that there is no need to compute it
- Where(emissivity_tl(:) /= 0.0_JPRB)
- reflectivity_tl(:) = - emissivity_tl(:)
- End Where
-
- !Loop over channels
- Do i = 1, nfrequencies
- ichannel=polarisations(i,1)
- If ( .Not. (calcemis(ichannel) .And. emissivity_tl(ichannel) == 0.0_JPRB) ) Cycle
- chan = channels(i)
- prof => profiles( lprofiles(i) )
- prof_tl => profiles_tl( lprofiles(i) )
- geom => geometry( lprofiles(i) )
- pol_id = coef % fastem_polar(chan) + 1
-
- !-------------------------------
- !0. Point to fastem coefficients
- !-------------------------------
-
- c => coef % fastem_coef
-
- !---------------
- !1. Sea surfaces
- !---------------
-
- If ( prof % skin % surftype == surftype_sea ) Then
- !-------------------------------------------
- !1.1 Calculate channel independent variables
- !-------------------------------------------
- ! no TL on wind direction, but TL on wind speed
- wind10_sq = prof % s2m % u * prof % s2m % u +&
- & prof % s2m % v * prof % s2m % v
- wind10 = Sqrt( wind10_sq )
- windsec = wind10 * geom%seczen
- wind10_sq_tl = 2.0_JPRB * prof % s2m %u * prof_tl % s2m % u + 2.0_JPRB * prof % s2m %v * prof_tl % s2m % v
-
- If( wind10 > 0._JPRB ) Then
- wind10_tl = 0.5_JPRB * wind10_sq_tl/wind10
- Else
- wind10_tl = 0.0_JPRB
- Endif
-
- windsec_tl = wind10_tl * geom%seczen
-
- !Set values for temperature polynomials (convert from kelvin to celsius)
- tcelsius = prof % skin % t - 273.15_JPRB
- tcelsius_sq = tcelsius * tcelsius !quadratic
- tcelsius_cu = tcelsius_sq * tcelsius !cubic
-
- tcelsius_tl = prof_tl % skin % t
- tcelsius_sq_tl = 2 * tcelsius * tcelsius_tl
- tcelsius_cu_tl = 3 * tcelsius_sq * tcelsius_tl
-
- !Define two relaxation frequencies, f1 and f2
- f1 = c(1) + c(2) * tcelsius + c(3) * tcelsius_sq
- f2 = c(4) + c(5) * tcelsius + c(6) * tcelsius_sq + c(7) * tcelsius_cu
- f1_tl = c(2) * tcelsius_tl + c(3) * tcelsius_sq_tl
- f2_tl = c(5) * tcelsius_tl + c(6) * tcelsius_sq_tl + c(7) * tcelsius_cu_tl
-
-
- !Static permittivity estatic = del1+del2+einf
- del1 = c(8) + c(9) * tcelsius + c(10) * tcelsius_sq + c(11) * tcelsius_cu
- del2 = c(12) + c(13) * tcelsius + c(14) * tcelsius_sq + c(15) * tcelsius_cu
- einf = c(18) + c(19) * tcelsius
- del1_tl = c(9) * tcelsius_tl + c(10) * tcelsius_sq_tl + c(11) * tcelsius_cu_tl
- del2_tl = c(13) * tcelsius_tl + c(14) * tcelsius_sq_tl + c(15) * tcelsius_cu_tl
- einf_tl = c(19) * tcelsius_tl
-
-
- freq_ghz = coef % frequency_ghz(chan)
- freq_ghz_sq = freq_ghz * freq_ghz
-
- !-----------------------------------------------------
- !1.2 calculate permittivity using double-debye formula
- !-----------------------------------------------------
-
- fen = 2.0_JPRB * c(20) * freq_ghz * 0.001_JPRB
- fen_sq = fen*fen
- den1 = 1.0_JPRB + fen_sq * f1 * f1
- den2 = 1.0_JPRB + fen_sq * f2 * f2
- perm_real1 = del1 / den1
- perm_real2 = del2 / den2
- perm_imag1 = del1 * fen * f1 / den1
- perm_imag2 = del2 * fen * f2 / den2
- perm_free = 8.854E-03_JPRB
- sigma = 2.906_JPRB + 0.09437_JPRB * tcelsius
- perm_imag3 = sigma / (2.0_JPRB * c(20) * perm_free * freq_ghz)
- perm_Real = perm_real1 + perm_real2 + einf
- perm_imag = perm_imag1 + perm_imag2 + perm_imag3
- permittivity = Cmplx(perm_Real,perm_imag,jprb)
-
- den1_tl = 2 * fen_sq * f1 * f1_tl
- den2_tl = 2 * fen_sq * f2 * f2_tl
- perm_real1_tl = (den1 * del1_tl - del1 * den1_tl) / (den1 * den1)
- perm_real2_tl = (den2 * del2_tl - del2 * den2_tl) / (den2 * den2)
- perm_imag1_tl = fen * ( den1 * ( del1_tl * f1 + del1 * f1_tl)&
- & - (del1 * f1 * den1_tl) ) / (den1 * den1)
- perm_imag2_tl = fen * ( den2 * ( del2_tl * f2 + del2 * f2_tl)&
- & - (del2 * f2 * den2_tl) ) / (den2 * den2)
- sigma_tl = 0.09437_JPRB * tcelsius_tl
- perm_imag3_tl = sigma_tl / (2.0_JPRB * c(20) * perm_free * freq_ghz)
- perm_Real_tl = perm_real1_tl + perm_real2_tl + einf_tl
- perm_imag_tl = perm_imag1_tl + perm_imag2_tl + perm_imag3_tl
- permittivity_tl = Cmplx(perm_Real_tl,perm_imag_tl,jprb)
-
- !-------------------------------------------------------------
- !1.3 calculate complex reflection coefficients and corrections
- !-------------------------------------------------------------
-
-
- !1.3.1) Fresnel reflection coefficients
- !------
-
- perm1 = sqrt(permittivity - geom%sinzen_sq)
- perm2 = permittivity * geom%coszen
- rhth = (geom%coszen-perm1) / (geom%coszen+perm1)
- rvth = (perm2-perm1) / (perm2+perm1)
- ! fresnel_v_real = dble(rvth)
- fresnel_v_Real = Real(rvth)
- fresnel_v_imag = Aimag(rvth)
- fresnel_v = fresnel_v_Real * fresnel_v_Real + &
- & fresnel_v_imag * fresnel_v_imag
- ! fresnel_h_real = dble(rhth)
- fresnel_h_Real = Real(rhth)
- fresnel_h_imag = Aimag(rhth)
- fresnel_h = fresnel_h_Real * fresnel_h_Real + &
- & fresnel_h_imag * fresnel_h_imag
-
-
- perm1_tl = 0.5_JPRB * permittivity_tl / perm1
- perm2_tl = permittivity_tl * geom%coszen
- rhth_tl = - 2 * geom%coszen * perm1_tl / (geom%coszen+perm1)**2
- rvth_tl = 2 * (perm1 * perm2_tl - perm1_tl * perm2) / (perm2+perm1)**2
- ! fresnel_v_real_tl = dble(rvth_tl)
- fresnel_v_Real_tl = Real(rvth_tl)
- fresnel_v_imag_tl = Aimag(rvth_tl)
- fresnel_v_tl = 2 * fresnel_v_Real * fresnel_v_Real_tl + &
- & 2 * fresnel_v_imag * fresnel_v_imag_tl
- ! fresnel_h_real_tl = dble(rhth_tl)
- fresnel_h_Real_tl = Real(rhth_tl)
- fresnel_h_imag_tl = Aimag(rhth_tl)
- fresnel_h_tl = 2 * fresnel_h_Real * fresnel_h_Real_tl + &
- & 2 * fresnel_h_imag * fresnel_h_imag_tl
-
- !1.3.2) Small scale correction to reflection coefficients
- !------
-
- If (freq_ghz >= 15.0) Then
- small_rough_cor = Exp( c(21) * wind10 * geom % coszen_sq / (freq_ghz_sq) )
- small_rough_cor_tl = small_rough_cor * c(21) * wind10_tl * geom % coszen_sq / (freq_ghz_sq)
- Else
- small_rough_cor = 1.0
- small_rough_cor_tl = 0.0
- End If
-
- !1.3.3) Large scale geometric correction
- !------
-
- !Point to correct coefficients for this version. There are 36 altogether.
- !Those for FASTEM-2 are stored in section 24:59 of the array, those for
- !FASTEM1 in section 60:95.
- If ( wanted_fastem_ver == 2 ) Then
- c => coef%fastem_coef(24:59)
- Else
- c => coef%fastem_coef(60:95)
- End If
- Do j = 1, 12
- zc(j) = c(j*3-2) + c(j*3-1)*freq_ghz + c(j*3)*freq_ghz_sq
- End Do
- !Point back to all coefficients again
- c => coef%fastem_coef
-
- large_rough_cor(1) = &
- & (zc(1) + &
- & zc(2) * geom%seczen + &
- & zc(3) * geom%seczen_sq + &
- & zc(4) * wind10 + &
- & zc(5) * wind10_sq + &
- & zc(6) * windsec) / 100._JPRB
- large_rough_cor(2) = &
- & (zc(7) + &
- & zc(8) * geom%seczen + &
- & zc(9) * geom%seczen_sq + &
- & zc(10) * wind10 + &
- & zc(11) * wind10_sq + &
- & zc(12) * windsec) / 100._JPRB
- ! large_rough_cor(:) = large_rough_cor(:) * 0.01
-
- large_rough_cor_tl(1) = &
- & (zc(4) * wind10_tl + &
- & zc(5) * wind10_sq_tl + &
- & zc(6) * windsec_tl ) /100._JPRB
- large_rough_cor_tl(2) = &
- & (zc(10) * wind10_tl + &
- & zc(11) * wind10_sq_tl + &
- & zc(12) * windsec_tl) /100._JPRB
-
- ! For Fastem-3 do not compute rough surface effects if theta > 60 degrees
- If ( wanted_fastem_ver <= 2.0_JPRB .or. (wanted_fastem_ver == 3 .And. geom%seczen <= 2.0_JPRB)) then
- emissstokes(i,1) = 1.0_JPRB - fresnel_v * small_rough_cor + large_rough_cor(1)
- emissstokes(i,2) = 1.0_JPRB - fresnel_h * small_rough_cor + large_rough_cor(2)
- emissstokes_tl(i,1) = - fresnel_v_tl * small_rough_cor &
- & - fresnel_v * small_rough_cor_tl &
- & + large_rough_cor_tl(1)
- emissstokes_tl(i,2) = - fresnel_h_tl * small_rough_cor &
- & - fresnel_h * small_rough_cor_tl &
- & + large_rough_cor_tl(2)
- Else
- emissstokes(i,1) = 1.0_JPRB - fresnel_v
- emissstokes(i,2) = 1.0_JPRB - fresnel_h
- emissstokes_tl(i,1) = - fresnel_v_tl
- emissstokes_tl(i,2) = - fresnel_h_tl
- End If
-
- emissstokes(i,3) = 0.0_JPRB
- emissstokes(i,4) = 0.0_JPRB
- emissstokes_tl(i,3) = 0.0_JPRB
- emissstokes_tl(i,4) = 0.0_JPRB
-
- !Apply foam correction
- foam_cor = c(22) * ( wind10 ** c(23) )
- foam_cor_tl = c(22) * c(23) * wind10_tl * ( wind10 ** (c(23)-1.0_JPRB) )
-
-
- ! Be careful do TL first because the next 2 lines of the direct model
- ! have variables in input/output of the statement
-
- emissstokes_tl(i,1) = emissstokes_tl(i,1)-foam_cor_tl*emissstokes(i,1)-foam_cor*emissstokes_tl(i,1)+foam_cor_tl
- emissstokes_tl(i,2) = emissstokes_tl(i,2)-foam_cor_tl*emissstokes(i,2)-foam_cor*emissstokes_tl(i,2)+foam_cor_tl
- emissstokes(i,1) = emissstokes(i,1) - foam_cor*emissstokes(i,1) + foam_cor
- emissstokes(i,2) = emissstokes(i,2) - foam_cor*emissstokes(i,2) + foam_cor
-
- If ( wanted_fastem_ver == 3) then
- ! Add azimuthal component from Fuzhong Weng (NOAA/NESDIS) based on work by Dr. Gene Poe (NRL)
- ! Assume 19m wind = 10m wind for now (fix later)
- u19=wind10
- if (prof % s2m % u >= 0.0_JPRB .AND. prof % s2m % v >= 0.0_JPRB) iquadrant=1
- if (prof % s2m % u >= 0.0_JPRB .AND. prof % s2m % v < 0.0_JPRB) iquadrant=2
- if (prof % s2m % u < 0.0_JPRB .AND. prof % s2m % v >= 0.0_JPRB) iquadrant=4
- if (prof % s2m % u < 0.0_JPRB .AND. prof % s2m % v < 0.0_JPRB) iquadrant=3
-
- if (abs(prof % s2m % v) >= 0.0001_JPRB) then
- windratio=prof % s2m % u/prof % s2m % v
- else
- windratio=0.0_JPRB
- if (abs(prof % s2m % u) > 0.0001_JPRB) then
- windratio=999999.0_JPRB*prof % s2m % u
- endif
- endif
-
- windangle=atan(windratio)
- wind10_direction = quadcof(iquadrant,1)*pi+windangle*quadcof(iquadrant,2)
- windratio_tl = 0.0_JPRB
-
- If (abs(prof % s2m % v) >= 0.0001_JPRB) then
- windratio_tl=(prof%s2m%v * prof_tl%s2m%u - prof_tl%s2m%v * prof%s2m%u)/&
- & (prof % s2m % v *prof % s2m % v)
- Else
- windratio_tl=0.0_JPRB
- if (abs(prof % s2m % u) > 0.0001_JPRB) then
- windratio_tl=999999.0_JPRB*prof_tl % s2m % u
- endif
- Endif
-
- windangle_tl = windratio_tl/(1.0_JPRB+windratio*windratio)
- wind10_direction_tl = windangle_tl*quadcof(iquadrant,2)
- ! Angle between wind direction and satellite azimuthal view angle
- phi = pi - wind10_direction + prof % azangle*pi/180.0_JPRB
- phi_tl = -1.0_JPRB * wind10_direction_tl
- u19_tl = wind10_tl
- tbfixed(:,:,:)=0.0_JPRB
- tbfixed_tl(:,:,:)=0.0_JPRB
- Do ich = 0,15
- a1e = c(141+ich*12) + u19*(c(142+ich*12)+ u19*(c(143+ich*12)+u19*c(144+ich*12)))
- a2e = c(145+ich*12) + u19*(c(146+ich*12)+ u19*(c(147+ich*12)+u19*c(148+ich*12)))
- a3e = c(149+ich*12) + u19*(c(150+ich*12)+ u19*(c(151+ich*12)+u19*c(152+ich*12)))
- a1e_tl = u19_tl*(c(142+ich*12)+u19*(2.0*c(143+ich*12)+3.0*u19*c(144+ich*12)))
- a2e_tl = u19_tl*(c(146+ich*12)+u19*(2.0*c(147+ich*12)+3.0*u19*c(148+ich*12)))
- a3e_tl = u19_tl*(c(150+ich*12)+u19*(2.0*c(151+ich*12)+3.0*u19*c(152+ich*12)))
- i_freq = int(ich/4) + 1 ! 37, 19, 10, 7 GHz
- j_stokes = mod(ich,4) + 1
- tbfixed(j_stokes,i_freq,1) = a1e
- tbfixed(j_stokes,i_freq,2) = a2e
- tbfixed(j_stokes,i_freq,3) = a3e
- tbfixed_tl(j_stokes,i_freq,1) = a1e_tl
- tbfixed_tl(j_stokes,i_freq,2) = a2e_tl
- tbfixed_tl(j_stokes,i_freq,3) = a3e_tl
- End Do
- efixed_tl(:,:,:)=0.0_JPRB
- einterpolated_tl(:,:)=0.0_JPRB
-
- Do M=1,3
- Do istokes=1,4
- efixed(1,istokes,M)= tbfixed(istokes,4,M) ! 7 GHz
- efixed(2,istokes,M)= tbfixed(istokes,3,M) ! 10 GHz
- efixed(3,istokes,M)= tbfixed(istokes,2,M) ! 19 GHz
- efixed(4,istokes,M)= tbfixed(istokes,1,M) ! 37 GHz
- efixed_tl(1,istokes,M)= tbfixed_tl(istokes,4,M) ! 7 GHz
- efixed_tl(2,istokes,M)= tbfixed_tl(istokes,3,M) ! 10 GHz
- efixed_tl(3,istokes,M)= tbfixed_tl(istokes,2,M) ! 19 GHz
- efixed_tl(4,istokes,M)= tbfixed_tl(istokes,1,M) ! 37 GHz
- End Do
-
- ! Interpolate results to required frequency based on 7, 10, 19, 37 GHz
- If (freq_ghz.le.freqfixed(1)) Then
- einterpolated(:,M)=efixed(1,:,M)
- einterpolated_tl(:,M)=efixed_tl(1,:,M)
- Else If(freq_ghz.ge.freqfixed(4)) then
- einterpolated(:,M)=efixed(4,:,M)
- einterpolated_tl(:,M)=efixed_tl(4,:,M)
- Else
- If(freq_ghz.lt.freqfixed(2)) ifreq=2
- If(freq_ghz.lt.freqfixed(3).and.freq_ghz.ge.freqfixed(2)) ifreq=3
- If(freq_ghz.ge.freqfixed(3)) ifreq=4
- dfreq=(freq_ghz-freqfixed(ifreq-1))/(freqfixed(ifreq)-freqfixed(ifreq-1))
- einterpolated(:,M)=efixed(ifreq-1,:,M)+dfreq*(efixed(ifreq,:,M)-efixed(ifreq-1,:,M))
- einterpolated_tl(:,M)=efixed_tl(ifreq-1,:,M)+dfreq*(efixed_tl(ifreq,:,M)-efixed_tl(ifreq-1,:,M))
- End If
- End Do
-
- Do istokes = 1,4
- azimuthal_emiss=0.0_JPRB
- azimuthal_emiss_tl=0.0_JPRB
- Do M=1,3
- If(istokes.le.2) Then
- azimuthal_emiss=azimuthal_emiss+einterpolated(istokes,M)*cos(m*phi)*&
- &(1.0_JPRB-geom%coszen)/(1.0_JPRB - 0.6018_JPRB)
- azimuthal_emiss_tl=azimuthal_emiss_tl+(einterpolated_tl(istokes,M)*cos(m*phi) -&
- & einterpolated(istokes,M)*m*sin(m*phi)*phi_tl)*(1.0_JPRB-geom%coszen)/(1.0_JPRB - 0.6018_JPRB)
- Else
- azimuthal_emiss=azimuthal_emiss+einterpolated(istokes,M)*sin(m*phi)*(1.0_JPRB-geom%coszen)/&
- &(1.0_JPRB - 0.6018_JPRB)
- azimuthal_emiss_tl=azimuthal_emiss_tl+(einterpolated_tl(istokes,M)*sin(m*phi) +&
- & einterpolated(istokes,M)*m*cos(m*phi)*phi_tl)*(1.0_JPRB-geom%coszen)/(1.0_JPRB - 0.6018_JPRB)
- End If
- End Do
- emissstokes(i,istokes)=emissstokes(i,istokes)+azimuthal_emiss
- emissstokes_tl(i,istokes)=emissstokes_tl(i,istokes)+azimuthal_emiss_tl
- End Do
- End If
-
-! Only apply non-specular correction for Fastem-3 if theta < 60 degrees
- If ((wanted_fastem_ver == 2 .or. (wanted_fastem_ver == 3 .And. geom%seczen <= 2.0_JPRB)) .And. &
- & transmission % tau_surf(ichannel) < 0.9999_JPRB .And. transmission % tau_surf(ichannel) > 0.00001_JPRB ) Then
-
- !Convert windspeed to slope variance using the Cox and Munk model
- variance = 0.00512_JPRB * wind10 + 0.0030_JPRB
- varm = variance * c(138)
- variance = varm * ( c(139) * freq_ghz + c(140) )
-
- variance_tl = 0.00512_JPRB * wind10_tl
- varm_tl = variance_tl * c(138)
- variance_tl = varm_tl * ( c(139) * freq_ghz + c(140) )
-
- If ( variance > varm ) Then
- variance = varm
- variance_tl = varm_tl
- Endif
- If ( variance < 0.0_JPRB ) Then
- variance = 0.0_JPRB
- variance_tl = 0.0_JPRB
- Endif
-
- !Compute surface to space optical depth
- opdpsfc = -log(transmission % tau_surf(ichannel)) / geom%seczen
- opdpsfc_tl = -transmission_tl % tau_surf(ichannel) / ( transmission % tau_surf(ichannel) * geom%seczen )
-
- !Define nine predictors for the effective angle calculation
- zx(1) = 1.0_JPRB
- zx(2) = variance
- zx(4) = 1.0_JPRB / geom%coszen
- zx(3) = zx(2) * zx(4)
- zx(5) = zx(3) * zx(3)
- zx(6) = zx(4) * zx(4)
- zx(7) = zx(2) * zx(2)
- zx(8) = log(opdpsfc)
- zx(9) = zx(8) * zx(8)
-
- zx_tl(1) = 0._JPRB
- zx_tl(2) = variance_tl
- zx_tl(4) = 0._JPRB
- zx_tl(3) = zx_tl(2) * zx(4)
- zx_tl(5) = 2 * zx_tl(3) * zx(3)
- zx_tl(6) = 2 * zx_tl(4) * zx(4)
- zx_tl(7) = 2 * zx_tl(2) * zx(2)
- zx_tl(8) = opdpsfc_tl / opdpsfc
- zx_tl(9) = 2 * zx_tl(8) * zx(8)
-
- zrough_v = 1.0_JPRB
- zrough_h = 1.0_JPRB
-
- zrough_v_tl = 0._JPRB
- zrough_h_tl = 0._JPRB
-
- Do jcof = 1,7
- jcofm1 = jcof-1
- !Switched h to v Deblonde SSMIS june 7, 2001
- zrough_h = zrough_h + &
- & zx(jcof) * ( c(96+jcofm1*3) &
- & + zx(8) * c(97+jcofm1*3) &
- & + zx(9) * c(98+jcofm1*3) )
- zrough_v = zrough_v + &
- & zx(jcof) * ( c(117+jcofm1*3) &
- & + zx(8) * c(118+jcofm1*3) &
- & + zx(9) * c(119+jcofm1*3) )
-
- zrough_h_tl = zrough_h_tl + &
- & zx(jcof) * ( &
- & zx_tl(8) * c(97+jcofm1*3) &
- & + zx_tl(9) * c(98+jcofm1*3) ) &
- & + zx_tl(jcof) * ( c(96+jcofm1*3) &
- & + zx(8) * c(97+jcofm1*3) &
- & + zx(9) * c(98+jcofm1*3) )
- zrough_v_tl = zrough_v_tl + &
- & zx(jcof) * ( &
- & zx_tl(8) * c(118+jcofm1*3) &
- & + zx_tl(9) * c(119+jcofm1*3) ) &
- & + zx_tl(jcof) * ( c(117+jcofm1*3) &
- & + zx(8) * c(118+jcofm1*3) &
- & + zx(9) * c(119+jcofm1*3) )
- End Do
-
- zreflmod_v = (1.0_JPRB-transmission % tau_surf(ichannel)**zrough_v)/(1.0_JPRB-transmission % tau_surf(ichannel))
- zreflmod_h = (1.0_JPRB-transmission % tau_surf(ichannel)**zrough_h)/(1.0_JPRB-transmission % tau_surf(ichannel))
-
- zreflmod_v_tl = transmission_tl % tau_surf(ichannel) *&
- & (-zrough_v * transmission % tau_surf(ichannel)**(zrough_v-1.0_JPRB) * &
- & (1.0_JPRB-transmission % tau_surf(ichannel))+&
- & ( 1.0_JPRB-transmission % tau_surf(ichannel)**zrough_v)) &
- & / (1.0_JPRB-transmission % tau_surf(ichannel))**2
-
- zreflmod_v_tl = zreflmod_v_tl - &
- & ( transmission % tau_surf(ichannel)**zrough_v * Log(transmission % tau_surf(ichannel)) * zrough_v_tl ) / &
- & (1.0_JPRB-transmission % tau_surf(ichannel))
-
- zreflmod_h_tl = transmission_tl % tau_surf(ichannel) *&
- & (-zrough_h * transmission % tau_surf(ichannel)**(zrough_h-1.0) * (1.0-transmission % tau_surf(ichannel)) + &
- & ( 1.0-transmission % tau_surf(ichannel)**zrough_h) ) &
- & / (1.0-transmission % tau_surf(ichannel))**2
- zreflmod_h_tl = zreflmod_h_tl - &
- & ( transmission % tau_surf(ichannel)**zrough_h * Log(transmission % tau_surf(ichannel)) * zrough_h_tl ) / &
- & (1.0-transmission % tau_surf(ichannel))
-
- reflectstokes_tl(i,1) = zreflmod_v_tl * (1.0-emissstokes(i,1)) - zreflmod_v * emissstokes_tl(i,1)
- reflectstokes_tl(i,2) = zreflmod_h_tl * (1.0-emissstokes(i,2)) - zreflmod_h * emissstokes_tl(i,2)
-! zreflmod_v_tl = 0.0
-! zreflmod_h_tl = 0.0
- reflectstokes_tl(i,3) = -0.5_JPRB * ((zreflmod_v_tl + zreflmod_h_tl) * emissstokes(i,3) + &
- & (zreflmod_v + zreflmod_h) * emissstokes_tl(i,3))
- reflectstokes_tl(i,4) = -0.5_JPRB * ((zreflmod_v_tl + zreflmod_h_tl) * emissstokes(i,4) + &
- & (zreflmod_v + zreflmod_h) * emissstokes_tl(i,4))
-! reflectstokes_tl(i,3) = -emissstokes_tl(i,3)
-! reflectstokes_tl(i,4) = -emissstokes_tl(i,4)
- Else
- reflectstokes_tl(i,:) = - emissstokes_tl(i,:)
- End If
-
- !--------------------
- !2. Land/ice surfaces
- !--------------------
-
- Else
-
- !Coherent surface scattering model coefficients (input with the profile)
- perm_static = prof % skin % fastem(1)
- perm_infinite = prof % skin % fastem(2)
- freqr = prof % skin % fastem(3)
- small_rough = prof % skin % fastem(4)
- large_rough = prof % skin % fastem(5)
- chan = channels(i)
- freq_ghz = coef % frequency_ghz(chan)
-
- perm_static_tl = prof_tl % skin % fastem(1)
- perm_infinite_tl = prof_tl % skin % fastem(2)
- freqr_tl = prof_tl % skin % fastem(3)
- small_rough_tl = prof_tl % skin % fastem(4)
- large_rough_tl = prof_tl % skin % fastem(5)
-
- !Simple Debye + Fresnel model gives reflectivities
- fen = freq_ghz / freqr
- fen_sq = fen * fen
- den1 = 1.0_JPRB + fen_sq
- perm_Real = (perm_static+perm_infinite*fen_sq) / den1
- perm_imag = fen*(perm_static-perm_infinite) / den1
- permittivity = Cmplx(perm_Real,perm_imag,jprb)
- perm1 = sqrt(permittivity - geom%sinzen_sq)
- perm2 = permittivity * geom%coszen
- rhth = (geom%coszen - perm1) / (geom%coszen + perm1)
- rvth = (perm2 - perm1)/(perm2 + perm1)
- ! fresnel_v_real = dble(rvth)
- fresnel_v_Real = Real(rvth)
- fresnel_v_imag = Aimag(rvth)
- fresnel_v = fresnel_v_Real * fresnel_v_Real + &
- & fresnel_v_imag * fresnel_v_imag
- ! fresnel_h_real = dble(rhth)
- fresnel_h_Real = Real(rhth)
- fresnel_h_imag = Aimag(rhth)
- fresnel_h = fresnel_h_Real * fresnel_h_Real + &
- & fresnel_h_imag * fresnel_h_imag
-
- fen_tl = -freq_ghz * freqr_tl / freqr**2
- fen_sq_tl = 2 * fen_tl * fen
- den1_tl = fen_sq_tl
- perm_Real_tl = &
- & ( den1 * (perm_static_tl + perm_infinite_tl*fen_sq + perm_infinite*fen_sq_tl) -&
- & den1_tl * (perm_static + perm_infinite * fen_sq)) / (den1*den1)
-
- perm_imag_tl = ( den1 * ( fen_tl * (perm_static - perm_infinite) + &
- & fen * (perm_static_tl - perm_infinite_tl)) - &
- & den1_tl * fen * (perm_static - perm_infinite) ) / &
- & (den1*den1)
- permittivity_tl = Cmplx(perm_Real_tl, perm_imag_tl,jprb)
- perm1_tl = 0.5_JPRB * permittivity_tl / perm1
- perm2_tl = permittivity_tl * geom%coszen
- rhth_tl = - 2 * geom%coszen * perm1_tl / (geom%coszen+perm1)**2
- rvth_tl = 2 * (perm1 * perm2_tl - perm1_tl * perm2) / (perm2+perm1)**2
- ! fresnel_v_real_tl = dble(rvth_tl)
- fresnel_v_Real_tl = Real(rvth_tl)
- fresnel_v_imag_tl = Aimag(rvth_tl)
- fresnel_v_tl = 2 * fresnel_v_Real * fresnel_v_Real_tl + &
- & 2 * fresnel_v_imag * fresnel_v_imag_tl
- ! fresnel_h_real_tl = dble(rhth_tl)
- fresnel_h_Real_tl = Real(rhth_tl)
- fresnel_h_imag_tl = Aimag(rhth_tl)
- fresnel_h_tl = 2 * fresnel_h_Real * fresnel_h_Real_tl + &
- & 2 * fresnel_h_imag * fresnel_h_imag_tl
-
-
- !Small scale roughness correction
- delta = 4.0_JPRB * pi * coef % ff_cwn(chan) * 0.1_JPRB * small_rough
- delta2 = delta * delta
- small_rough_cor = Exp(-delta2*geom%coszen_sq)
-
- delta_tl = 4.0_JPRB * pi * coef % ff_cwn(chan) * 0.1_JPRB * small_rough_tl
- delta2_tl = 2 * delta * delta_tl
- small_rough_cor_tl = -delta2_tl*geom%coszen_sq * small_rough_cor
-
- !Large scale roughness correction
- qdepol = 0.35_JPRB - 0.35_JPRB*Exp(-0.60_JPRB*freq_ghz*large_rough*large_rough)
-
- qdepol_tl = -0.35_JPRB * (-0.60_JPRB*freq_ghz*2*large_rough_tl*large_rough) *&
- & Exp(-0.60_JPRB*freq_ghz*large_rough*large_rough)
-
- emissfactor_v = 1.0_JPRB - fresnel_v * small_rough_cor
- emissfactor_h = 1.0_JPRB - fresnel_h * small_rough_cor
- emissfactor = emissfactor_h - emissfactor_v
-
- emissstokes(i,1) = emissfactor_v + qdepol * emissfactor
- emissstokes(i,2) = emissfactor_h - qdepol * emissfactor
- emissstokes(i,3) = 0.0_JPRB
- emissstokes(i,4) = 0.0_JPRB
-
- !reflect_v(i) = 1.0_JPRB - emiss_v(i)
- !reflect_h(i) = 1.0_JPRB - emiss_h(i)
-
- emissfactor_v_tl = - fresnel_v_tl * small_rough_cor - fresnel_v * small_rough_cor_tl
- emissfactor_h_tl = - fresnel_h_tl * small_rough_cor - fresnel_h * small_rough_cor_tl
- emissfactor_tl = emissfactor_h_tl - emissfactor_v_tl
- emissstokes_tl(i,1) = emissfactor_v_tl + qdepol_tl * emissfactor + qdepol * emissfactor_tl
- emissstokes_tl(i,2) = emissfactor_h_tl - qdepol_tl * emissfactor - qdepol * emissfactor_tl
- emissstokes_tl(i,3) = 0.0_JPRB
- emissstokes_tl(i,4) = 0.0_JPRB
-
- reflectstokes_tl(i,:) = - emissstokes_tl(i,:)
- End If
-
- ! Now return only required polarisations - either the calculated vector (V, H, or full Stokes)
- If (pol_id <= 3 .or. pol_id >= 6) then
- Do ich=1,polarisations(i,3)
- emissivity_tl(ichannel+ich-1)=emissstokes_tl(i,ich)
- reflectivity_tl(ichannel+ich-1)=reflectstokes_tl(i,ich)
- End Do
- End If
- ! Or V-pol only
- If (pol_id == 4) then
- emissivity_tl(ichannel)=emissstokes_tl(i,1)
- reflectivity_tl(ichannel)=reflectstokes_tl(i,1)
- End If
- ! Or H-pol only
- If (pol_id == 5) then
- emissivity_tl(ichannel)=emissstokes_tl(i,2)
- reflectivity_tl(ichannel)=reflectstokes_tl(i,2)
- End If
-
- End Do
-
-End Subroutine rttov_calcemis_mw_tl
diff --git a/src/LIB/RTTOV/src/rttov_calcemis_mw_tl.interface b/src/LIB/RTTOV/src/rttov_calcemis_mw_tl.interface
deleted file mode 100644
index 50b2711effb4c996594542038924aa92256025c8..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_calcemis_mw_tl.interface
+++ /dev/null
@@ -1,52 +0,0 @@
-Interface
-!
-Subroutine rttov_calcemis_mw_tl ( &
- profiles, & ! in
- profiles_tl, & ! in
- geometry, & ! in
- coef, & ! in
- nfrequencies, & ! in
- nchannels, & ! in
- nprofiles, & ! in
- channels, & ! in
- polarisations, & ! in
- lprofiles, & ! in
- transmission, & ! in
- transmission_tl, & ! in
- calcemis, & ! in
- emissivity_tl, & ! inout
- reflectivity_tl ) ! out
- Use rttov_const, Only : &
- pi ,&
- surftype_sea
-
- Use rttov_types, Only : &
- rttov_coef ,&
- profile_Type ,&
- transmission_Type ,&
- geometry_Type
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
- Integer(Kind=jpim), Intent(in) :: nprofiles
- Type(profile_Type), Intent(in) ,Target :: profiles(nprofiles)
- Type(geometry_Type), Intent(in) ,Target :: geometry(nprofiles)
- Type(rttov_coef), Intent(in) :: coef
- Integer(Kind=jpim), Intent(in) :: nfrequencies
- Integer(Kind=jpim), Intent(in) :: nchannels
- Integer(Kind=jpim), Intent(in) :: channels(nfrequencies)
- Integer(Kind=jpim), Intent(in) :: polarisations(nchannels,3)
- Integer(Kind=jpim), Intent(in) :: lprofiles(nfrequencies)
- Type(transmission_Type), Intent(in):: transmission
- Logical, Intent(in) :: calcemis(nchannels)
-
- Type(profile_Type), Intent(in) ,Target :: profiles_tl(nprofiles)
- Type(transmission_Type), Intent(in) :: transmission_tl
- Real(Kind=jprb), Intent(inout) :: emissivity_tl(nchannels)
- Real(Kind=jprb), Intent(out) :: reflectivity_tl(nchannels)
-
-
-
-End Subroutine rttov_calcemis_mw_tl
-End Interface
diff --git a/src/LIB/RTTOV/src/rttov_calcpolarisation.F90 b/src/LIB/RTTOV/src/rttov_calcpolarisation.F90
deleted file mode 100644
index 0091a4412ef67eb210cbbd86c2fa7ae3ed0594ae..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_calcpolarisation.F90
+++ /dev/null
@@ -1,133 +0,0 @@
-Subroutine rttov_calcpolarisation( &
- & nfrequencies, & ! in
- & nchannels, & ! in
- & nprofiles, & ! in
- & geometry, & ! in
- & channels, & ! in
- & polarisations,& ! in
- & lprofiles, & ! in
- & coeffs, & ! in
- & rad ) ! inout
- ! Description:
- ! To convert an array of brightness temperatures with 1, 2 or 4 polarisations
- ! polarisation requested by the user.
- ! There are seven options:
- ! 0. Return average of V and H polarisation.
- ! 1. Return AMSU-style mix polarisation (nominal V at nadir)
- ! 2. Return AMSU-style mix polarisation (nominal H at nadir)
- ! 3. Return Vertical polarisation
- ! 4. Return Horizontal polarisation
- ! 5. Return vertical and horizontal polarisation
- ! 6. Return full Stokes vector
- !
- ! For IR channels this variable is not required, and one unpolarised brightness
- ! temperature is computed.
- !
- ! Note options 0-4 return one polarisation per channel. Option 5 returns
- ! 2 polarisations per channel and option 6 four polarisations per channel.
- ! Note also that for options 1-3 two polarisations must be computed in RTTOV,
- ! even though only one is returned. For this reason rad%bt is replaced by
- ! rad%out, where rad%out has length of number of output channels, whereas
- ! rad%bt has length of all brightness temperatures computed in RTTOV.
- !
- ! Copyright:
- ! This software was developed within the context of
- ! the EUMETSAT Satellite Application Facility on
- ! Numerical Weather Prediction (NWP SAF), under the
- ! Cooperation Agreement dated 25 November 1998, between
- ! EUMETSAT and the Met Office, UK, by one or more partners
- ! within the NWP SAF. The partners in the NWP SAF are
- ! the Met Office, ECMWF, KNMI and MeteoFrance.
- !
- ! Copyright 2003, EUMETSAT, All Rights Reserved.
- !
- ! Method: Uses band correction coefficients for each channel
- ! read in from RT coefficient file.
- !
- ! Current Code Owner: SAF NWP
- !
- ! History:
- ! Version Date Comment
- ! ------- ---- -------
- ! 1.0 10/07/2003 New code required for polarimetric RTTOV (Steve English)
- !
- ! Code Description:
- ! Language: Fortran 90.
- ! Software Standards: "European Standards for Writing and
- ! Documenting Exchangeable Fortran 90 Code".
- !
- ! Declarations:
- ! Modules used:
- ! Imported Type Definitions:
-
- Use rttov_const, only : &
- & npolar_return, &
- & pol_v, &
- & pol_h
-
- Use rttov_types, Only : &
- & rttov_coef ,&
- & radiance_Type ,&
- & geometry_Type
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
- !subroutine arguments:
- Integer(Kind=jpim), Intent(in) :: nfrequencies
- Integer(Kind=jpim), Intent(in) :: nchannels
- Integer(Kind=jpim), Intent(in) :: nprofiles
- Type(geometry_Type), Intent(in) ,Target :: geometry(nprofiles)
- Integer(Kind=jpim), Intent(in) :: channels(nfrequencies)
- Integer(Kind=jpim), Intent(in) :: polarisations(nchannels,3)
- Integer(Kind=jpim), Intent(in) :: lprofiles(nfrequencies)
- Type(rttov_coef), Intent(in) :: coeffs ! Coefficients
- Type(radiance_Type), Intent(inout) :: rad ! input radiances and output BT
-
- ! radiances are expressed in mw/cm-1/ster/sq.m
- ! and temperatures in Kelvin
-
- !local variables:
- Real(Kind=jprb) :: emissfactor_h,emissfactor_v
- Integer(Kind=jpim) :: chan,i,j,ich,ich2,pol_id
- Type(geometry_Type), Pointer :: geom
-
- !- End of header ------------------------------------------------------
-
- ich2=1
- Do i=1,nfrequencies
- chan = channels(i)
- pol_id = 0
- pol_id = coeffs % fastem_polar(chan) + 1
- ich = polarisations(i,1)
- If (pol_id >= 4) then
- ! Return all calculated polarisations (or just computed TB for IR channels)
- Do j=1,polarisations(i,3)
- rad%out(ich2+j-1) = rad%bt(ich+j-1)
- rad%out_clear(ich2+j-1) = rad%bt_clear(ich+j-1)
- rad%total_out(ich2+j-1) = rad%total(ich+j-1)
- rad%clear_out(ich2+j-1) = rad%clear(ich+j-1)
- End Do
- Else If (pol_id == 1) then
- ! Return average of V and H polarisation
- rad%out(ich2) = 0.5_JPRB*(rad%bt(ich)+rad%bt(ich+1))
- rad%out_clear(ich2) = 0.5_JPRB*(rad%bt_clear(ich)+ rad%bt_clear(ich+1))
- rad%total_out(ich2) = 0.5_JPRB*(rad%total(ich)+rad%total(ich+1))
- rad%clear_out(ich2) = 0.5_JPRB*(rad%clear(ich)+ rad%clear(ich+1))
- Else
- geom => geometry( lprofiles(i) )
- emissfactor_v = pol_v(1,pol_id) + &
- & pol_v(2,pol_id)*geom%sinview_sq + &
- & pol_v(3,pol_id)*geom%cosview_sq
- emissfactor_h = pol_h(1,pol_id) + &
- & pol_h(2,pol_id)*geom%sinview_sq + &
- & pol_h(3,pol_id)*geom%cosview_sq
- rad%out(ich2) = rad%bt(ich)*emissfactor_v + rad%bt(ich+1)*emissfactor_h
- rad%out_clear(ich2) = rad%bt_clear(ich)*emissfactor_v + rad%bt_clear(ich+1)*emissfactor_h
- rad%total_out(ich2) = rad%total(ich)*emissfactor_v + rad%total(ich+1)*emissfactor_h
- rad%clear_out(ich2) = rad%clear(ich)*emissfactor_v + rad%clear(ich+1)*emissfactor_h
- End If
- ich2 = ich2 + npolar_return(pol_id)
- End Do
-
-End Subroutine rttov_calcpolarisation
diff --git a/src/LIB/RTTOV/src/rttov_calcpolarisation.interface b/src/LIB/RTTOV/src/rttov_calcpolarisation.interface
deleted file mode 100644
index 19d9a8bcab3e8ca865c0a357faa6f3111dda9839..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_calcpolarisation.interface
+++ /dev/null
@@ -1,91 +0,0 @@
-Interface
-!
-Subroutine rttov_calcpolarisation( &
- nfrequencies, & ! in
- nchannels, & ! in
- nprofiles, & ! in
- geometry, & ! in
- channels, & ! in
- polarisations, & ! in
- lprofiles, & ! in
- coeffs, & ! in
- rad ) ! inout
- ! Description:
- ! To convert an array of brightness temperatures with 1, 2 or 4 polarisations
- ! polarisation requested by the user.
- ! There are seven options:
- ! 0. Return average of V and H polarisation.
- ! 1. Return AMSU-style mix polarisation (nominal V at nadir)
- ! 2. Return AMSU-style mix polarisation (nominal H at nadir)
- ! 3. Return Vertical polarisation
- ! 4. Return Horizontal polarisation
- ! 5. Return vertical and horizontal polarisation
- ! 6. Return full Stokes vector
- !
- ! For IR channels this variable is not required, and one unpolarised brightness
- ! temperature is computed.
- !
- ! Note options 0-4 return one polarisation per channel. Option 5 returns
- ! 2 polarisations per channel and option 6 four polarisations per channel.
- ! Note also that for options 1-3 two polarisations must be computed in RTTOV,
- ! even though only one is returned. For this reason rad%bt is replaced by
- ! rad%out, where rad%out has length of number of output channels, whereas
- ! rad%bt has length of all brightness temperatures computed in RTTOV.
- !
- ! Copyright:
- ! This software was developed within the context of
- ! the EUMETSAT Satellite Application Facility on
- ! Numerical Weather Prediction (NWP SAF), under the
- ! Cooperation Agreement dated 25 November 1998, between
- ! EUMETSAT and the Met Office, UK, by one or more partners
- ! within the NWP SAF. The partners in the NWP SAF are
- ! the Met Office, ECMWF, KNMI and MeteoFrance.
- !
- ! Copyright 2003, EUMETSAT, All Rights Reserved.
- !
- ! Method: Uses band correction coefficients for each channel
- ! read in from RT coefficient file.
- !
- ! Current Code Owner: SAF NWP
- !
- ! History:
- ! Version Date Comment
- ! ------- ---- -------
- ! 1.0 10/07/2003 New code required for polarimetric RTTOV (Steve English)
- !
- ! Code Description:
- ! Language: Fortran 90.
- ! Software Standards: "European Standards for Writing and
- ! Documenting Exchangeable Fortran 90 Code".
- !
- ! Declarations:
- ! Modules used:
- ! Imported Type Definitions:
-
- Use rttov_const, only : &
- npolar_return, &
- npolar_compute, &
- pol_v, &
- pol_h
-
- Use rttov_types, Only : &
- rttov_coef ,&
- radiance_Type ,&
- geometry_Type
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
- !subroutine arguments:
- Integer(Kind=jpim), Intent(in) :: nfrequencies
- Integer(Kind=jpim), Intent(in) :: nchannels
- Integer(Kind=jpim), Intent(in) :: nprofiles
- Type(geometry_Type), Intent(in) ,Target :: geometry(nprofiles)
- Integer(Kind=jpim), Intent(in) :: channels(nfrequencies)
- Integer(Kind=jpim), Intent(in) :: polarisations(nchannels,3)
- Integer(Kind=jpim), Intent(in) :: lprofiles(nfrequencies)
- Type(rttov_coef), Intent(in) :: coeffs ! Coefficients
- Type(radiance_Type), Intent(inout) :: rad ! input radiances and output BT
-
-End Subroutine rttov_calcpolarisation
-End Interface
diff --git a/src/LIB/RTTOV/src/rttov_calcpolarisation_ad.F90 b/src/LIB/RTTOV/src/rttov_calcpolarisation_ad.F90
deleted file mode 100644
index 308c5542b769299773a2a5c427863515711cf7cc..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_calcpolarisation_ad.F90
+++ /dev/null
@@ -1,147 +0,0 @@
-!
-Subroutine rttov_calcpolarisation_ad( &
- & nfrequencies, & ! in
- & nchannels, & ! in
- & nbtout, & ! in
- & profiles, & ! in
- & nprofiles, & ! in
- & geometry, & ! in
- & channels, & ! in
- & polarisations, & ! in
- & lprofiles, & ! in
- & coeffs, & ! in
- & rad_ad ) ! inout
- ! Description:
- ! To convert an array of brightness temperatures with 1, 2 or 4 polarisations
- ! polarisation requested by the user.
- ! There are seven options:
- ! 0. Return average of V and H polarisation.
- ! 1. Return AMSU-style mix polarisation (nominal V at nadir)
- ! 2. Return AMSU-style mix polarisation (nominal H at nadir)
- ! 3. Return Vertical polarisation
- ! 4. Return Horizontal polarisation
- ! 5. Return vertical and horizontal polarisation
- ! 6. Return full Stokes vector
- !
- ! For IR channels this variable is not required, and one unpolarised brightness
- ! temperature is computed.
- !
- ! Note options 0-4 return one polarisation per channel. Option 5 returns
- ! 2 polarisations per channel and option 6 four polarisations per channel.
- ! Note also that for options 1-3 two polarisations must be computed in RTTOV,
- ! even though only one is returned. For this reason rad%bt is replaced by
- ! rad%out, where rad%out has length of number of output channels, whereas
- ! rad%bt has length of all brightness temperatures computed in RTTOV.
- !
- ! Copyright:
- ! This software was developed within the context of
- ! the EUMETSAT Satellite Application Facility on
- ! Numerical Weather Prediction (NWP SAF), under the
- ! Cooperation Agreement dated 25 November 1998, between
- ! EUMETSAT and the Met Office, UK, by one or more partners
- ! within the NWP SAF. The partners in the NWP SAF are
- ! the Met Office, ECMWF, KNMI and MeteoFrance.
- !
- ! Copyright 2003, EUMETSAT, All Rights Reserved.
- !
- ! Method: Uses band correction coefficients for each channel
- ! read in from RT coefficient file.
- !
- ! Current Code Owner: SAF NWP
- !
- ! History:
- ! Version Date Comment
- ! ------- ---- -------
- ! 1.0 10/07/2003 New code required for polarimetric RTTOV (Steve English)
- !
- ! Code Description:
- ! Language: Fortran 90.
- ! Software Standards: "European Standards for Writing and
- ! Documenting Exchangeable Fortran 90 Code".
- !
- ! Declarations:
- ! Modules used:
- ! Imported Type Definitions:
-
- Use rttov_const, only : &
- & npolar_return, &
- & pol_v, &
- & pol_h
-
- Use rttov_types, Only : &
- & rttov_coef ,&
- & radiance_Type ,&
- & profile_Type ,&
- & geometry_Type
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
- !subroutine arguments:
- Integer(Kind=jpim), Intent(in) :: nfrequencies
- Integer(Kind=jpim), Intent(in) :: nchannels
- Integer(Kind=jpim), Intent(in) :: nbtout
- Integer(Kind=jpim), Intent(in) :: nprofiles
- Type(profile_Type), Intent(in) ,Target :: profiles(nprofiles)
- Type(geometry_Type), Intent(in) ,Target :: geometry(nprofiles)
- Integer(Kind=jpim), Intent(in) :: channels(nfrequencies)
- Integer(Kind=jpim), Intent(in) :: polarisations(nchannels,3)
- Integer(Kind=jpim), Intent(in) :: lprofiles(nfrequencies)
- Type(rttov_coef), Intent(in) :: coeffs ! Coefficients
- Type(radiance_Type), Intent(inout) :: rad_ad ! input radiances and output BT
-
- ! radiances are expressed in mw/cm-1/ster/sq.m
- ! and temperatures in Kelvin
-
- !local variables:
- Real(Kind=jprb) :: emissfactor_h,emissfactor_v
- Integer(Kind=jpim) :: chan,i,j,ich,ich2,pol_id
- Type(geometry_Type), Pointer :: geom
-
- !- End of header ------------------------------------------------------
-
- ich2=1
- Do i=1,nfrequencies
- chan = channels(i)
- pol_id = 0
- pol_id = coeffs % fastem_polar(chan) + 1
- ich = polarisations(i,1)
- If (pol_id >= 4) then
- ! Return all calculated polarisations (or just computed TB for IR channels)
- Do j=1,polarisations(i,3)
- rad_ad%bt(ich+j-1) = rad_ad%bt(ich+j-1) + rad_ad%out(ich2+j-1)
- rad_ad%bt_clear(ich+j-1) = rad_ad%bt_clear(ich+j-1) + rad_ad%out_clear(ich2+j-1)
- rad_ad%total(ich+j-1) = rad_ad%total(ich+j-1) + rad_ad%total_out(ich2+j-1)
- rad_ad%clear(ich+j-1) = rad_ad%clear(ich+j-1) + rad_ad%clear_out(ich2+j-1)
- End Do
- Else If (pol_id == 1) then
- ! Return average of V and H polarisation
- rad_ad%bt(ich) = 0.5_JPRB*rad_ad%out(ich2)
- rad_ad%bt(ich+1) = 0.5_JPRB*rad_ad%out(ich2)
- rad_ad%bt_clear(ich) = 0.5_JPRB*rad_ad%out_clear(ich2)
- rad_ad%bt_clear(ich+1) = 0.5_JPRB*rad_ad%out_clear(ich2)
- rad_ad%total(ich) = 0.5_JPRB*rad_ad%total_out(ich2)
- rad_ad%total(ich+1) = 0.5_JPRB*rad_ad%total_out(ich2)
- rad_ad%clear(ich) = 0.5_JPRB*rad_ad%clear_out(ich2)
- rad_ad%clear(ich+1) = 0.5_JPRB*rad_ad%clear_out(ich2)
- Else
- geom => geometry( lprofiles(i) )
- emissfactor_v = pol_v(1,pol_id) + &
- & pol_v(2,pol_id)*geom%sinview_sq + &
- & pol_v(3,pol_id)*geom%cosview_sq
- emissfactor_h = pol_h(1,pol_id) + &
- & pol_h(2,pol_id)*geom%sinview_sq + &
- & pol_h(3,pol_id)*geom%cosview_sq
- rad_ad%bt(ich) = rad_ad%bt(ich) + rad_ad%out(ich2)*emissfactor_v
- rad_ad%bt(ich+1) = rad_ad%bt(ich+1) + rad_ad%out(ich2)*emissfactor_h
- rad_ad%bt_clear(ich) = rad_ad%bt_clear(ich) + rad_ad%out_clear(ich2)*emissfactor_v
- rad_ad%bt_clear(ich+1) = rad_ad%bt_clear(ich+1) + rad_ad%out_clear(ich2)*emissfactor_h
- rad_ad%total(ich) = rad_ad%total(ich) + rad_ad%total_out(ich2)*emissfactor_v
- rad_ad%total(ich+1) = rad_ad%total(ich+1) + rad_ad%total_out(ich2)*emissfactor_h
- rad_ad%clear(ich) = rad_ad%clear(ich) + rad_ad%clear_out(ich2)*emissfactor_v
- rad_ad%clear(ich+1) = rad_ad%clear(ich+1) + rad_ad%clear_out(ich2)*emissfactor_h
- End If
- ich2 = ich2 + npolar_return(pol_id)
- End Do
-
-End Subroutine rttov_calcpolarisation_ad
diff --git a/src/LIB/RTTOV/src/rttov_calcpolarisation_ad.interface b/src/LIB/RTTOV/src/rttov_calcpolarisation_ad.interface
deleted file mode 100644
index 1101068a6c33e750adaa41712c907862b17cf445..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_calcpolarisation_ad.interface
+++ /dev/null
@@ -1,96 +0,0 @@
-Interface
-!
-Subroutine rttov_calcpolarisation_ad( &
- nfrequencies, & ! in
- nchannels, & ! in
- nbtout, & ! in
- profiles, & ! in
- nprofiles, & ! in
- geometry, & ! in
- channels, & ! in
- polarisations, & ! in
- lprofiles, & ! in
- coeffs, & ! in
- rad_ad ) ! inout
- ! Description:
- ! To convert an array of brightness temperatures with 1, 2 or 4 polarisations
- ! polarisation requested by the user.
- ! There are seven options:
- ! 0. Return average of V and H polarisation.
- ! 1. Return AMSU-style mix polarisation (nominal V at nadir)
- ! 2. Return AMSU-style mix polarisation (nominal H at nadir)
- ! 3. Return Vertical polarisation
- ! 4. Return Horizontal polarisation
- ! 5. Return vertical and horizontal polarisation
- ! 6. Return full Stokes vector
- !
- ! For IR channels this variable is not required, and one unpolarised brightness
- ! temperature is computed.
- !
- ! Note options 0-4 return one polarisation per channel. Option 5 returns
- ! 2 polarisations per channel and option 6 four polarisations per channel.
- ! Note also that for options 1-3 two polarisations must be computed in RTTOV,
- ! even though only one is returned. For this reason rad%bt is replaced by
- ! rad%out, where rad%out has length of number of output channels, whereas
- ! rad%bt has length of all brightness temperatures computed in RTTOV.
- !
- ! Copyright:
- ! This software was developed within the context of
- ! the EUMETSAT Satellite Application Facility on
- ! Numerical Weather Prediction (NWP SAF), under the
- ! Cooperation Agreement dated 25 November 1998, between
- ! EUMETSAT and the Met Office, UK, by one or more partners
- ! within the NWP SAF. The partners in the NWP SAF are
- ! the Met Office, ECMWF, KNMI and MeteoFrance.
- !
- ! Copyright 2003, EUMETSAT, All Rights Reserved.
- !
- ! Method: Uses band correction coefficients for each channel
- ! read in from RT coefficient file.
- !
- ! Current Code Owner: SAF NWP
- !
- ! History:
- ! Version Date Comment
- ! ------- ---- -------
- ! 1.0 10/07/2003 New code required for polarimetric RTTOV (Steve English)
- !
- ! Code Description:
- ! Language: Fortran 90.
- ! Software Standards: "European Standards for Writing and
- ! Documenting Exchangeable Fortran 90 Code".
- !
- ! Declarations:
- ! Modules used:
- ! Imported Type Definitions:
-
- Use rttov_const, only : &
- npolar_return, &
- npolar_compute, &
- pol_v, &
- pol_h
-
- Use rttov_types, Only : &
- rttov_coef ,&
- radiance_Type ,&
- profile_Type ,&
- geometry_Type
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
- !subroutine arguments:
- Integer(Kind=jpim), Intent(in) :: nfrequencies
- Integer(Kind=jpim), Intent(in) :: nchannels
- Integer(Kind=jpim), Intent(in) :: nbtout
- Integer(Kind=jpim), Intent(in) :: nprofiles
- Type(profile_Type), Intent(in) ,Target :: profiles(nprofiles)
- Type(geometry_Type), Intent(in) ,Target :: geometry(nprofiles)
- Integer(Kind=jpim), Intent(in) :: channels(nfrequencies)
- Integer(Kind=jpim), Intent(in) :: polarisations(nchannels,3)
- Integer(Kind=jpim), Intent(in) :: lprofiles(nfrequencies)
- Type(rttov_coef), Intent(in) :: coeffs ! Coefficients
- Type(radiance_Type), Intent(inout) :: rad_ad ! input radiances and output BT
-
-End Subroutine rttov_calcpolarisation_ad
-End Interface
diff --git a/src/LIB/RTTOV/src/rttov_calcpolarisation_tl.F90 b/src/LIB/RTTOV/src/rttov_calcpolarisation_tl.F90
deleted file mode 100644
index 13806e92e3660bbf8d9f63fc87ab68effe8e81a5..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_calcpolarisation_tl.F90
+++ /dev/null
@@ -1,134 +0,0 @@
-!
-Subroutine rttov_calcpolarisation_tl( &
- & nfrequencies, & ! in
- & nchannels, & ! in
- & nprofiles, & ! in
- & geometry, & ! in
- & channels, & ! in
- & polarisations, & ! in
- & lprofiles, & ! in
- & coeffs, & ! in
- & rad_tl ) ! inout
- ! Description:
- ! To convert an array of brightness temperatures with 1, 2 or 4 polarisations
- ! polarisation requested by the user.
- ! There are seven options:
- ! 0. Return average of V and H polarisation.
- ! 1. Return AMSU-style mix polarisation (nominal V at nadir)
- ! 2. Return AMSU-style mix polarisation (nominal H at nadir)
- ! 3. Return Vertical polarisation
- ! 4. Return Horizontal polarisation
- ! 5. Return vertical and horizontal polarisation
- ! 6. Return full Stokes vector
- !
- ! For IR channels this variable is not required, and one unpolarised brightness
- ! temperature is computed.
- !
- ! Note options 0-4 return one polarisation per channel. Option 5 returns
- ! 2 polarisations per channel and option 6 four polarisations per channel.
- ! Note also that for options 1-3 two polarisations must be computed in RTTOV,
- ! even though only one is returned. For this reason rad%bt is replaced by
- ! rad%out, where rad%out has length of number of output channels, whereas
- ! rad%bt has length of all brightness temperatures computed in RTTOV.
- !
- ! Copyright:
- ! This software was developed within the context of
- ! the EUMETSAT Satellite Application Facility on
- ! Numerical Weather Prediction (NWP SAF), under the
- ! Cooperation Agreement dated 25 November 1998, between
- ! EUMETSAT and the Met Office, UK, by one or more partners
- ! within the NWP SAF. The partners in the NWP SAF are
- ! the Met Office, ECMWF, KNMI and MeteoFrance.
- !
- ! Copyright 2003, EUMETSAT, All Rights Reserved.
- !
- ! Method: Uses band correction coefficients for each channel
- ! read in from RT coefficient file.
- !
- ! Current Code Owner: SAF NWP
- !
- ! History:
- ! Version Date Comment
- ! ------- ---- -------
- ! 1.0 10/07/2003 New code required for polarimetric RTTOV (Steve English)
- !
- ! Code Description:
- ! Language: Fortran 90.
- ! Software Standards: "European Standards for Writing and
- ! Documenting Exchangeable Fortran 90 Code".
- !
- ! Declarations:
- ! Modules used:
- ! Imported Type Definitions:
-
- Use rttov_const, only : &
- & npolar_return, &
- & pol_v , &
- & pol_h
-
- Use rttov_types, Only : &
- & rttov_coef ,&
- & radiance_Type ,&
- & geometry_Type
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
- !subroutine arguments:
- Integer(Kind=jpim), Intent(in) :: nfrequencies
- Integer(Kind=jpim), Intent(in) :: nchannels
- Integer(Kind=jpim), Intent(in) :: nprofiles
- Type(geometry_Type), Intent(in) ,Target :: geometry(nprofiles)
- Integer(Kind=jpim), Intent(in) :: channels(nfrequencies)
- Integer(Kind=jpim), Intent(in) :: polarisations(nchannels,3)
- Integer(Kind=jpim), Intent(in) :: lprofiles(nfrequencies)
- Type(rttov_coef), Intent(in) :: coeffs ! Coefficients
- Type(radiance_Type), Intent(inout) :: rad_tl ! input radiances and output BT
-
- ! radiances are expressed in mw/cm-1/ster/sq.m
- ! and temperatures in Kelvin
-
- !local variables:
- Real(Kind=jprb) :: emissfactor_h,emissfactor_v
- Integer(Kind=jpim) :: chan,i,j,ich,ich2,pol_id
- Type(geometry_Type), Pointer :: geom
-
- !- End of header ------------------------------------------------------
-
- ich2=1
- Do i=1,nfrequencies
- chan = channels(i)
- pol_id = 0
- pol_id = coeffs % fastem_polar(chan) + 1
- ich = polarisations(i,1)
- If (pol_id >= 4) then
- ! Return all calculated polarisations (or just computed TB for IR channels)
- Do j=1,polarisations(i,3)
- rad_tl%out(ich2+j-1) = rad_tl%bt(ich+j-1)
- rad_tl%out_clear(ich2+j-1) = rad_tl%bt_clear(ich+j-1)
- rad_tl%total_out(ich2+j-1) = rad_tl%total(ich+j-1)
- rad_tl%clear_out(ich2+j-1) = rad_tl%clear(ich+j-1)
- End Do
- Else If (pol_id == 1) then
- ! Return average of V and H polarisation
- rad_tl%out(ich2) = 0.5_JPRB*(rad_tl%bt(ich)+rad_tl%bt(ich+1))
- rad_tl%out_clear(ich2) = 0.5_JPRB*(rad_tl%bt_clear(ich)+ rad_tl%bt_clear(ich+1))
- rad_tl%total_out(ich2) = 0.5_JPRB*(rad_tl%total(ich)+rad_tl%total(ich+1))
- rad_tl%clear_out(ich2) = 0.5_JPRB*(rad_tl%clear(ich)+ rad_tl%clear(ich+1))
- Else
- geom => geometry( lprofiles(i) )
- emissfactor_v = pol_v(1,pol_id) + &
- & pol_v(2,pol_id)*geom%sinview_sq + &
- & pol_v(3,pol_id)*geom%cosview_sq
- emissfactor_h = pol_h(1,pol_id) + &
- & pol_h(2,pol_id)*geom%sinview_sq + &
- & pol_h(3,pol_id)*geom%cosview_sq
- rad_tl%out(ich2) = rad_tl%bt(ich)*emissfactor_v + rad_tl%bt(ich+1)*emissfactor_h
- rad_tl%out_clear(ich2) = rad_tl%bt_clear(ich)*emissfactor_v + rad_tl%bt_clear(ich+1)*emissfactor_h
- rad_tl%total_out(ich2) = rad_tl%total(ich)*emissfactor_v + rad_tl%total(ich+1)*emissfactor_h
- rad_tl%clear_out(ich2) = rad_tl%clear(ich)*emissfactor_v + rad_tl%clear(ich+1)*emissfactor_h
- End If
- ich2 = ich2 + npolar_return(pol_id)
- End Do
-
-End Subroutine rttov_calcpolarisation_tl
diff --git a/src/LIB/RTTOV/src/rttov_calcpolarisation_tl.interface b/src/LIB/RTTOV/src/rttov_calcpolarisation_tl.interface
deleted file mode 100644
index f82652f68588a1392187bea7d9e40696cbdff1f4..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_calcpolarisation_tl.interface
+++ /dev/null
@@ -1,91 +0,0 @@
-Interface
-!
-Subroutine rttov_calcpolarisation_tl( &
- nfrequencies, & ! in
- nchannels, & ! in
- nprofiles, & ! in
- geometry, & ! in
- channels, & ! in
- polarisations, & ! in
- lprofiles, & ! in
- coeffs, & ! in
- rad_tl ) ! inout
- ! Description:
- ! To convert an array of brightness temperatures with 1, 2 or 4 polarisations
- ! polarisation requested by the user.
- ! There are seven options:
- ! 0. Return average of V and H polarisation.
- ! 1. Return AMSU-style mix polarisation (nominal V at nadir)
- ! 2. Return AMSU-style mix polarisation (nominal H at nadir)
- ! 3. Return Vertical polarisation
- ! 4. Return Horizontal polarisation
- ! 5. Return vertical and horizontal polarisation
- ! 6. Return full Stokes vector
- !
- ! For IR channels this variable is not required, and one unpolarised brightness
- ! temperature is computed.
- !
- ! Note options 0-4 return one polarisation per channel. Option 5 returns
- ! 2 polarisations per channel and option 6 four polarisations per channel.
- ! Note also that for options 1-3 two polarisations must be computed in RTTOV,
- ! even though only one is returned. For this reason rad%bt is replaced by
- ! rad%out, where rad%out has length of number of output channels, whereas
- ! rad%bt has length of all brightness temperatures computed in RTTOV.
- !
- ! Copyright:
- ! This software was developed within the context of
- ! the EUMETSAT Satellite Application Facility on
- ! Numerical Weather Prediction (NWP SAF), under the
- ! Cooperation Agreement dated 25 November 1998, between
- ! EUMETSAT and the Met Office, UK, by one or more partners
- ! within the NWP SAF. The partners in the NWP SAF are
- ! the Met Office, ECMWF, KNMI and MeteoFrance.
- !
- ! Copyright 2003, EUMETSAT, All Rights Reserved.
- !
- ! Method: Uses band correction coefficients for each channel
- ! read in from RT coefficient file.
- !
- ! Current Code Owner: SAF NWP
- !
- ! History:
- ! Version Date Comment
- ! ------- ---- -------
- ! 1.0 10/07/2003 New code required for polarimetric RTTOV (Steve English)
- !
- ! Code Description:
- ! Language: Fortran 90.
- ! Software Standards: "European Standards for Writing and
- ! Documenting Exchangeable Fortran 90 Code".
- !
- ! Declarations:
- ! Modules used:
- ! Imported Type Definitions:
-
- Use rttov_const, only : &
- npolar_return, &
- npolar_compute, &
- pol_v , &
- pol_h
-
- Use rttov_types, Only : &
- rttov_coef ,&
- radiance_Type ,&
- geometry_Type
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
- !subroutine arguments:
- Integer(Kind=jpim), Intent(in) :: nfrequencies
- Integer(Kind=jpim), Intent(in) :: nchannels
- Integer(Kind=jpim), Intent(in) :: nprofiles
- Type(geometry_Type), Intent(in) ,Target :: geometry(nprofiles)
- Integer(Kind=jpim), Intent(in) :: channels(nfrequencies)
- Integer(Kind=jpim), Intent(in) :: polarisations(nchannels,3)
- Integer(Kind=jpim), Intent(in) :: lprofiles(nfrequencies)
- Type(rttov_coef), Intent(in) :: coeffs ! Coefficients
- Type(radiance_Type), Intent(inout) :: rad_tl ! input radiances and output BT
-
-End Subroutine rttov_calcpolarisation_tl
-End Interface
diff --git a/src/LIB/RTTOV/src/rttov_calcrad.F90 b/src/LIB/RTTOV/src/rttov_calcrad.F90
deleted file mode 100644
index f0691a43fabe7f07f52a730422b924ce1952f941..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_calcrad.F90
+++ /dev/null
@@ -1,159 +0,0 @@
-!
-Subroutine rttov_calcrad( &
- & addcosmic, &! in
- & nchannels, &! in
- & nfrequencies, &! in
- & nprofiles, &! in
- & channels, &! in
- & polarisations, &! in
- & lprofiles, &! in
- & profiles, &! in
- & coeffs, &! in
- & rad_cosmic, &! out
- & rad_skin, &! out
- & rad_surfair, &! out
- & rad_layer ) ! out
- ! Description:
- ! To convert an array of atmospheric temperatures
- ! to planck radiances in many channels
- !
- ! Copyright:
- ! This software was developed within the context of
- ! the EUMETSAT Satellite Application Facility on
- ! Numerical Weather Prediction (NWP SAF), under the
- ! Cooperation Agreement dated 25 November 1998, between
- ! EUMETSAT and the Met Office, UK, by one or more partners
- ! within the NWP SAF. The partners in the NWP SAF are
- ! the Met Office, ECMWF, KNMI and MeteoFrance.
- !
- ! Copyright 2002, EUMETSAT, All Rights Reserved.
- !
- ! Method: Uses band correction factors to convert T to radiance
- ! which have been precomputed for each channel and are read from
- ! the RT coefficient file.
- !
- ! Current Code Owner: SAF NWP
- !
- ! History:
- ! Version Date Comment
- ! ------- ---- -------
- ! 1.0 01/12/2002 New F90 code with structures (P Brunel A Smith)
- ! based on PLNCX of previous RTTOV versions
- ! 1.1 02/01/2003 Comments added (R Saunders)
- ! 1.2 26/09/2003 Multiple polarisations (S English)
- ! 1.3 11/02/2005 Code vectorisation improved (D Dent)
- !
- ! Code Description:
- ! Language: Fortran 90.
- ! Software Standards: "European Standards for Writing and
- ! Documenting Exchangeable Fortran 90 Code".
- !
- ! Declarations:
- ! Modules used:
-
- ! Imported Parameters:
- Use rttov_const, Only: &
- & tcosmic
-
- ! Imported Type Definitions:
- Use rttov_types, Only : &
- & rttov_coef ,&
- & profile_Type
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
- !subroutine arguments:
- Integer(Kind=jpim), Intent(in) :: nprofiles ! number of profiles
- Type(profile_Type), Intent(in) ,Target :: profiles(nprofiles)! profiles
- Type(rttov_coef), Intent(in) :: coeffs ! coefficients (Planck)
- Integer(Kind=jpim), Intent(in) :: nfrequencies ! Number of processed radiances
- Integer(Kind=jpim), Intent(in) :: nchannels ! Number of processed radiances
- Integer(Kind=jpim), Intent(in) :: channels(nfrequencies) ! Array of channel indices.
- Integer(Kind=jpim), Intent(in) :: polarisations(nchannels,3) ! Array of channel indices.
- Integer(Kind=jpim), Intent(in) :: lprofiles(nfrequencies) ! Array of profile indices.
- Logical, Intent(in) :: addcosmic ! switch for adding cosmic background
-
- Real(Kind=jprb), Intent(out) :: rad_cosmic(nchannels) ! cosmic background radiance
- Real(Kind=jprb), Intent(out) :: rad_skin(nchannels) ! surface skin radiance
- Real(Kind=jprb), Intent(out) :: rad_surfair(nchannels) ! 2m air radiance
- Real(Kind=jprb), Intent(out) :: rad_layer( coeffs%nlevels , nchannels ) ! layer radiances
- ! radiances are expressed in mw/cm-1/ster/sq.m
- ! and temperatures in Kelvin
- !local variables:
- Real(Kind=jprb) :: t_effective ! effective temperature
- Real(Kind=jprb) :: t_effective_1(nfrequencies) ! effective temperature
- Real(Kind=jprb) :: t_effective_2(nfrequencies) ! effective temperature
- Real(Kind=jprb) :: t_effective_3(coeffs%nlevels,nfrequencies) ! effective temperature
- Real(Kind=jprb) :: rad_skin_freq, rad_surfair_freq
- Real(Kind=jprb) :: rad_skin_f(nfrequencies), rad_surfair_f(nfrequencies)
- Real(Kind=jprb) :: rad_layer_f(coeffs%nlevels,nfrequencies)
- Real(Kind=jprb) :: rad_layer_freq(coeffs%nlevels),rad_cosmic_freq
- Integer(Kind=jpim) :: chan,i,lev,jpol,npol,ipol ! loop indices
- Type(profile_Type), Pointer :: prof ! pointer on profile structures
-
- !- End of header ------------------------------------------------------
-
- If ( addcosmic ) Then
-!cdir nodep
- Do i = 1, nfrequencies
- chan = channels(i)
- t_effective = coeffs%ff_bco(chan) + coeffs%ff_bcs(chan) * tcosmic
- rad_cosmic_freq = coeffs%planck1(chan) / &
- & ( Exp( coeffs%planck2(chan)/t_effective ) - 1.0_JPRB )
- ipol = polarisations(i,1)
- npol = polarisations(i,3)
- Do jpol=ipol, ipol+npol-1
- rad_cosmic(jpol) = rad_cosmic_freq
- End Do
- End Do
- Else
- rad_cosmic(:) = 0.0_JPRB
- End If
-
- Do i = 1, nfrequencies
-
- chan = channels(i)
- ! point to corresponding profile (temp. for pressure levels, 2m, skin)
- prof => profiles( lprofiles(i) )
- t_effective_1(i) = coeffs%ff_bco(chan) + coeffs%ff_bcs(chan) * prof % skin % t
- t_effective_2(i) = coeffs%ff_bco(chan) + coeffs%ff_bcs(chan) * prof % s2m % t
- Do lev = 1, coeffs%nlevels
- t_effective_3(lev,i) = coeffs%ff_bco(chan) + coeffs%ff_bcs(chan) * prof % t(lev)
- End Do
- End Do
-
-!cdir nodep
- Do i = 1, nfrequencies
-
- chan = channels(i)
-
- rad_skin_f(i) = coeffs%planck1(chan) / &
- & ( Exp( coeffs%planck2(chan)/t_effective_1(i) ) - 1.0_JPRB )
-
- rad_surfair_f(i) = coeffs%planck1(chan) / &
- & ( Exp( coeffs%planck2(chan)/t_effective_2(i) ) - 1.0_JPRB )
-
- End Do
- Do i = 1, nfrequencies
- chan = channels(i)
- Do lev = 1, coeffs%nlevels
- rad_layer_f(lev,i) = coeffs%planck1(chan) / &
- & ( Exp( coeffs%planck2(chan)/t_effective_3(lev,i) ) - 1.0_JPRB )
- End Do
- End Do
- !
- Do i = 1, nfrequencies
-
- ipol = polarisations(i,1)
- npol = polarisations(i,3)
- Do jpol=ipol, ipol+npol-1
- rad_skin(jpol) = rad_skin_f(i)
- rad_surfair(jpol) = rad_surfair_f(i)
- Do lev = 1, coeffs%nlevels
- rad_layer(lev,jpol)=rad_layer_f(lev,i)
- End Do
- End Do
- End Do
-
-End Subroutine rttov_calcrad
diff --git a/src/LIB/RTTOV/src/rttov_calcrad.interface b/src/LIB/RTTOV/src/rttov_calcrad.interface
deleted file mode 100644
index 28772bd9145d0c68d2de370b030bc5bdd0412cfe..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_calcrad.interface
+++ /dev/null
@@ -1,43 +0,0 @@
-Interface
-!
-Subroutine rttov_calcrad( &
- addcosmic, & ! in
- nchannels, & ! in
- nfrequencies, & ! in
- nprofiles, & ! in
- channels, & ! in
- polarisations, & ! in
- lprofiles, & ! in
- profiles, & ! in
- coeffs, & ! in
- rad_cosmic, & ! out
- rad_skin, & ! out
- rad_surfair, & ! out
- rad_layer ) ! out
-
- Use rttov_const, Only: &
- tcosmic
-
- Use rttov_types, Only : &
- rttov_coef ,&
- profile_Type
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
- Integer(Kind=jpim), Intent(in) :: nprofiles ! number of profiles
- Integer(Kind=jpim), Intent(in) :: nfrequencies
- Integer(Kind=jpim), Intent(in) :: nchannels
- Integer(Kind=jpim), Intent(in) :: channels(nfrequencies)
- Integer(Kind=jpim), Intent(in) :: polarisations(nchannels,3)
- Integer(Kind=jpim), Intent(in) :: lprofiles(nfrequencies)
- Type(rttov_coef), Intent(in) :: coeffs ! coefficients (Planck)
- Type(profile_Type), Intent(in) ,Target :: profiles(nprofiles)! profiles
- Logical, Intent(in) :: addcosmic ! switch for adding cosmic background
-
- Real(Kind=jprb), Intent(out) :: rad_cosmic(nchannels) ! cosmic background radiance
- Real(Kind=jprb), Intent(out) :: rad_skin(nchannels) ! surface skin radiance
- Real(Kind=jprb), Intent(out) :: rad_surfair(nchannels) ! 2m air radiance
- Real(Kind=jprb), Intent(out) :: rad_layer( coeffs%nlevels , nchannels ) ! layer radiances
-
-End Subroutine rttov_calcrad
-End Interface
diff --git a/src/LIB/RTTOV/src/rttov_calcrad_ad.F90 b/src/LIB/RTTOV/src/rttov_calcrad_ad.F90
deleted file mode 100644
index 8620e960fc09f8328dd4d1a522dd52bf03039feb..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_calcrad_ad.F90
+++ /dev/null
@@ -1,164 +0,0 @@
-Subroutine rttov_calcrad_ad( &
- & nfrequencies, &! in
- & nchannels, &! in
- & nprofiles, &! in
- & channels, &! in
- & polarisations, &! in
- & lprofiles, &! in
- & profiles, &! in
- & profiles_ad, &! inout
- & coeffs, &! in
- & rad_skin, &! in
- & rad_surfair, &! in
- & rad_layer, &! in
- & rad_skin_ad, &! in
- & rad_surfair_ad, &! in
- & rad_layer_ad ) ! in
- !
- ! Description:
- ! AD code to convert an array of atmospheric temperatures
- ! to planck radiances in many channels
- ! No AD on Rad Cosmic, ad = 0.
- !
- ! derivative of Planck function with respect to temperature is
- !
- ! C2 * Nu
- ! C1 * C2 * Nu**4 * Exp( ------- )
- ! T
- ! B'(T,Nu) = ------------------------------------- dT
- ! ( C2 * Nu )**2
- ! T**2 *( Exp( ------- ) - 1 )
- ! ( T )
- !
- !
- ! which can be reduced to the following, with
- ! C1 = C1 * Nu**3
- ! C2 = C2 * Nu
- !
- ! C2 * B(T,Nu) * (C1 + B(T,Nu))
- ! B'(T,Nu) = ----------------------------- dT
- ! C1 * T**2
- !
- !
- ! Copyright:
- ! This software was developed within the context of
- ! the EUMETSAT Satellite Application Facility on
- ! Numerical Weather Prediction (NWP SAF), under the
- ! Cooperation Agreement dated 25 November 1998, between
- ! EUMETSAT and the Met Office, UK, by one or more partners
- ! within the NWP SAF. The partners in the NWP SAF are
- ! the Met Office, ECMWF, KNMI and MeteoFrance.
- !
- ! Copyright 2002, EUMETSAT, All Rights Reserved.
- !
- ! Method: Uses band correction factors to convert T to radiance
- ! which have been precomputed for each channel and are read from
- ! the RT coefficient file.
- !
- ! Current Code Owner: SAF NWP
- !
- ! History:
- ! Version Date Comment
- ! ------- ---- -------
- ! 1.0 01/12/2002 New F90 code with structures (P Brunel A Smith)
- ! based on PLNCX of previous RTTOV versions
- ! 1.1 02/01/2003 Comments added (R Saunders)
- ! 1.2 26/09/2003 Multiple polarisations (S English)
- ! 1.3 29/03/2005 Add end of header comment (J. Cameron)
- !
- ! Code Description:
- ! Language: Fortran 90.
- ! Software Standards: "European Standards for Writing and
- ! Documenting Exchangeable Fortran 90 Code".
- !
- ! Declarations:
- ! Modules used:
- Use rttov_types, only : &
- & rttov_coef ,&
- & profile_type
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
- !subroutine arguments:
- Integer(Kind=jpim), Intent(in) :: nprofiles
- Type(profile_Type), Intent(in) ,Target :: profiles(nprofiles)
- Type(profile_Type), Intent(inout) ,Target :: profiles_ad(nprofiles)
- Type(rttov_coef), Intent(in) :: coeffs
- Integer(Kind=jpim), Intent(in) :: nfrequencies ! Number of processed radiances
- Integer(Kind=jpim), Intent(in) :: nchannels
- Integer(Kind=jpim), Intent(in) :: channels(nfrequencies)
- Integer(Kind=jpim), Intent(in) :: polarisations(nchannels,3) ! Array of channel indices.
- Integer(Kind=jpim), Intent(in) :: lprofiles(nfrequencies)
- Real(Kind=jprb), Intent(in) :: rad_skin(nchannels)
- Real(Kind=jprb), Intent(in) :: rad_surfair(nchannels)
- Real(Kind=jprb), Intent(in) :: rad_layer( coeffs%nlevels , nchannels )
-
- Real(Kind=jprb), Intent(in) :: rad_skin_ad(nchannels)
- Real(Kind=jprb), Intent(in) :: rad_surfair_ad(nchannels)
- Real(Kind=jprb), Intent(in) :: rad_layer_ad( coeffs%nlevels , nchannels )
-
- !local variables:
- Real(Kind=jprb) :: t_effective
- Real(Kind=jprb) :: t_effective_ad
-
- Real(Kind=jprb) :: rad_skin_freq_ad, rad_surfair_freq_ad, rad_layer_freq_ad(coeffs%nlevels)
- Integer(Kind=jpim) :: chan,i,lev,jpol,kpol,npol,ipol ! loop indices
-
- Type(profile_Type), Pointer :: prof
- Type(profile_Type), Pointer :: prof_ad
-
- !- End of header --------------------------------------------------------
-
- Do i = 1, nfrequencies
-
- chan = channels(i)
- ! point to corresponding profile and geometry structures
- prof => profiles( lprofiles(i) )
- prof_ad => profiles_ad( lprofiles(i) )
- ipol = polarisations(i,1)
- npol = polarisations(i,3)
- rad_skin_freq_ad = 0.0_JPRB
- rad_surfair_freq_ad = 0.0_JPRB
- Do lev=1,coeffs%nlevels
- rad_layer_freq_ad(lev) = 0.0_JPRB
- End Do
-
- Do jpol=ipol, ipol+npol-1
- rad_skin_freq_ad = rad_skin_freq_ad + rad_skin_ad(jpol)
- rad_surfair_freq_ad = rad_surfair_freq_ad + rad_surfair_ad(jpol)
- Do lev = 1, coeffs%nlevels
- rad_layer_freq_ad(lev) = rad_layer_freq_ad(lev) + rad_layer_ad(lev,jpol)
- End Do
- End Do
-
- t_effective = coeffs%ff_bco(chan) + coeffs%ff_bcs(chan) * prof % skin % t
- t_effective_ad = ( coeffs%planck2(chan) * rad_skin(ipol) * &
- & ( coeffs%planck1(chan) + rad_skin(ipol) ) / &
- & ( coeffs%planck1(chan) * t_effective**2 )) * &
- & rad_skin_freq_ad
-
- prof_ad % skin % t = prof_ad % skin % t + coeffs%ff_bcs(chan) * t_effective_ad
-
-
- t_effective = coeffs%ff_bco(chan) + coeffs%ff_bcs(chan) * prof % s2m % t
- t_effective_ad = ( coeffs%planck2(chan) * rad_surfair(ipol) * &
- & ( coeffs%planck1(chan) + rad_surfair(ipol) ) / &
- & ( coeffs%planck1(chan) * t_effective**2 )) * &
- & rad_surfair_freq_ad
-
- prof_ad % s2m % t = prof_ad % s2m % t + coeffs%ff_bcs(chan) * t_effective_ad
-
- Do lev = 1, coeffs%nlevels
- t_effective = coeffs%ff_bco(chan) + coeffs%ff_bcs(chan) * prof % t(lev)
- t_effective_ad = ( coeffs%planck2(chan) * rad_layer(lev,ipol) * &
- & ( coeffs%planck1(chan) + rad_layer(lev,ipol) ) / &
- & ( coeffs%planck1(chan) * t_effective**2 )) * &
- & rad_layer_freq_ad(lev)
-
- prof_ad % t(lev) = prof_ad % t(lev) + coeffs%ff_bcs(chan) * t_effective_ad
- End Do
-
- End Do
-
-End Subroutine rttov_calcrad_ad
diff --git a/src/LIB/RTTOV/src/rttov_calcrad_ad.interface b/src/LIB/RTTOV/src/rttov_calcrad_ad.interface
deleted file mode 100644
index 008f3c52ca5cc12cf3a834428b345710c1a86399..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_calcrad_ad.interface
+++ /dev/null
@@ -1,47 +0,0 @@
-Interface
-Subroutine rttov_calcrad_ad( &
- nfrequencies, & ! in
- nchannels, & ! in
- nprofiles, & ! in
- channels, & ! in
- polarisations, & ! in
- lprofiles, & ! in
- profiles, & ! in
- profiles_ad, & ! inout
- coeffs, & ! in
- rad_skin, & ! in
- rad_surfair, & ! in
- rad_layer, & ! in
- rad_skin_ad, & ! in
- rad_surfair_ad, & ! in
- rad_layer_ad ) ! in
-
- Use rttov_types, only : &
- rttov_coef ,&
- profile_type
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
- Integer(Kind=jpim), Intent(in) :: nprofiles
- Type(profile_Type), Intent(in) ,Target :: profiles(nprofiles)
- Type(profile_Type), Intent(inout) ,Target :: profiles_ad(nprofiles)
- Type(rttov_coef), Intent(in) :: coeffs
-
- Integer(Kind=jpim), Intent(in) :: nfrequencies ! Number of processed radiances
- Integer(Kind=jpim), Intent(in) :: nchannels
- Integer(Kind=jpim), Intent(in) :: channels(nfrequencies)
- Integer(Kind=jpim), Intent(in) :: polarisations(nchannels,3) ! Array of channel indices.
- Integer(Kind=jpim), Intent(in) :: lprofiles(nfrequencies)
- Real(Kind=jprb), Intent(in) :: rad_skin(nchannels)
- Real(Kind=jprb), Intent(in) :: rad_surfair(nchannels)
- Real(Kind=jprb), Intent(in) :: rad_layer( coeffs%nlevels , nchannels )
-
- Real(Kind=jprb), Intent(in) :: rad_skin_ad(nchannels)
- Real(Kind=jprb), Intent(in) :: rad_surfair_ad(nchannels)
- Real(Kind=jprb), Intent(in) :: rad_layer_ad( coeffs%nlevels , nchannels )
-
-
-
-End Subroutine rttov_calcrad_ad
-End Interface
diff --git a/src/LIB/RTTOV/src/rttov_calcrad_k.F90 b/src/LIB/RTTOV/src/rttov_calcrad_k.F90
deleted file mode 100644
index 7c7471b4de21ef2d8dd53cb4d6c2c320ba323ae5..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_calcrad_k.F90
+++ /dev/null
@@ -1,160 +0,0 @@
-Subroutine rttov_calcrad_k( &
- & nfrequencies, &! in
- & nchannels, &! in
- & nprofiles, &! in
- & channels, &! in
- & polarisations, &! in
- & lprofiles, &! in
- & profiles, &! in
- & profiles_k, &! inout
- & coeffs, &! in
- & rad_skin, &! in
- & rad_surfair, &! in
- & rad_layer, &! in
- & rad_skin_k, &! in
- & rad_surfair_k, &! in
- & rad_layer_k ) ! in
-
- ! Description:
- ! K code to convert an array of atmospheric temperatures
- ! to planck radiances in many channels
- ! No K on Rad Cosmic, k = 0.
- !
- ! derivative of Planck function with respect to temperature is
- !
- ! C2 * Nu
- ! C1 * C2 * Nu**4 * Exp( ------- )
- ! T
- ! B'(T,Nu) = ------------------------------------- dT
- ! ( C2 * Nu )**2
- ! T**2 *( Exp( ------- ) - 1 )
- ! ( T )
- !
- !
- ! which can be reduced to the following, with
- ! C1 = C1 * Nu**3
- ! C2 = C2 * Nu
- !
- ! C2 * B(T,Nu) * (C1 + B(T,Nu))
- ! B'(T,Nu) = ----------------------------- dT
- ! C1 * T**2
- !
- !
- ! Copyright:
- ! This software was developed within the context of
- ! the EUMETSAT Satellite Application Facility on
- ! Numerical Weather Prediction (NWP SAF), under the
- ! Cooperation Agreement dated 25 November 1998, between
- ! EUMETSAT and the Met Office, UK, by one or more partners
- ! within the NWP SAF. The partners in the NWP SAF are
- ! the Met Office, ECMWF, KNMI and MeteoFrance.
- !
- ! Copyright 2002, EUMETSAT, All Rights Reserved.
- !
- ! Method: Uses band correction factors to convert T to radiance
- ! which have been precomputed for each channel and are read from
- ! the RT coefficient file.
- !
- ! Current Code Owner: SAF NWP
- !
- ! History:
- ! Version Date Comment
- ! ------- ---- -------
- ! 1.0 01/12/2002 New F90 code with structures (P Brunel A Smith)
- ! based on PLNCX of previous RTTOV versions
- ! 1.1 02/01/2003 Comments added (R Saunders)
- ! 1.2 26/09/2003 Multiple polarisations (S English)
- ! 1.3 29/03/2005 Add end of header comment (J. Cameron)
- !
- ! Code Description:
- ! Language: Fortran 90.
- ! Software Standards: "European Standards for Writing and
- ! Documenting Exchangeable Fortran 90 Code".
- !
- ! Declarations:
- ! Modules used:
- !
- Use rttov_types, only : &
- & rttov_coef ,&
- & profile_type
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
- !subroutine arguments:
- Integer(Kind=jpim), Intent(in) :: nprofiles
- Integer(Kind=jpim), Intent(in) :: nchannels
- Integer(Kind=jpim), Intent(in) :: nfrequencies ! Number of processed radiances
- Type(profile_Type), Intent(in) ,Target :: profiles(nprofiles)
- Type(profile_Type), Intent(inout) ,Target :: profiles_k(nchannels)
- Type(rttov_coef), Intent(in) :: coeffs
- Integer(Kind=jpim), Intent(in) :: channels(nfrequencies)
- Integer(Kind=jpim), Intent(in) :: polarisations(nchannels,3) ! Array of channel indices.
- Integer(Kind=jpim), Intent(in) :: lprofiles(nfrequencies)
- Real(Kind=jprb), Intent(in) :: rad_skin(nchannels)
- Real(Kind=jprb), Intent(in) :: rad_surfair(nchannels)
- Real(Kind=jprb), Intent(in) :: rad_layer( coeffs%nlevels , nchannels )
-
- Real(Kind=jprb), Intent(in) :: rad_skin_k(nchannels)
- Real(Kind=jprb), Intent(in) :: rad_surfair_k(nchannels)
- Real(Kind=jprb), Intent(in) :: rad_layer_k( coeffs%nlevels , nchannels )
-
- !local variables:
- Real(Kind=jprb) :: t_effective
- Real(Kind=jprb) :: t_effective_k
- Real(Kind=jprb) :: rad_skin_freq_k, rad_surfair_freq_k, rad_layer_freq_k(coeffs%nlevels)
- Integer(Kind=jpim) :: chan,i,lev,jpol,kpol,npol,ipol ! loop indices
- Type(profile_Type), Pointer :: prof
- Type(profile_Type), Pointer :: prof_k
-
-!- End of header --------------------------------------------------------
-
- Do i = 1, nfrequencies
-
- chan = channels(i)
- ipol = polarisations(i,1)
- npol = polarisations(i,3)
-
- Do jpol=ipol, ipol+npol-1
- rad_skin_freq_k = rad_skin_k(jpol)
- rad_surfair_freq_k = rad_surfair_k(jpol)
- Do lev = 1, coeffs%nlevels
- rad_layer_freq_k(lev) = rad_layer_k(lev,jpol)
- End Do
- ! point to corresponding profile and geometry structures
- prof => profiles( lprofiles(i) )
- prof_k => profiles_k( jpol )
-
- t_effective = coeffs%ff_bco(chan) + coeffs%ff_bcs(chan) * prof % skin % t
- t_effective_k = ( coeffs%planck2(chan) * rad_skin(ipol) * &
- & ( coeffs%planck1(chan) + rad_skin(ipol) ) / &
- & ( coeffs%planck1(chan) * t_effective**2 )) * &
- & rad_skin_freq_k
-
- prof_k % skin % t = prof_k % skin % t + coeffs%ff_bcs(chan) * t_effective_k
-
-
- t_effective = coeffs%ff_bco(chan) + coeffs%ff_bcs(chan) * prof % s2m % t
- t_effective_k = ( coeffs%planck2(chan) * rad_surfair(ipol) * &
- & ( coeffs%planck1(chan) + rad_surfair(ipol) ) / &
- & ( coeffs%planck1(chan) * t_effective**2 )) * &
- & rad_surfair_freq_k
-
- prof_k % s2m % t = prof_k % s2m % t + coeffs%ff_bcs(chan) * t_effective_k
-
-
- Do lev = 1, coeffs%nlevels
- t_effective = coeffs%ff_bco(chan) + coeffs%ff_bcs(chan) * prof % t(lev)
- t_effective_k = ( coeffs%planck2(chan) * rad_layer(lev,ipol) * &
- & ( coeffs%planck1(chan) + rad_layer(lev,ipol) ) / &
- & ( coeffs%planck1(chan) * t_effective**2 )) * &
- & rad_layer_freq_k(lev)
-
- prof_k % t(lev) = prof_k % t(lev) + coeffs%ff_bcs(chan) * t_effective_k
- End Do
-
- End Do
-
- End Do
-
-End Subroutine rttov_calcrad_k
diff --git a/src/LIB/RTTOV/src/rttov_calcrad_k.interface b/src/LIB/RTTOV/src/rttov_calcrad_k.interface
deleted file mode 100644
index fc3ca0f7bb2dec85c08998e8a798902831109b2f..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_calcrad_k.interface
+++ /dev/null
@@ -1,45 +0,0 @@
-Interface
-Subroutine rttov_calcrad_k( &
- nfrequencies, & ! in
- nchannels, & ! in
- nprofiles, & ! in
- channels, & ! in
- polarisations, & ! in
- lprofiles, & ! in
- profiles, & ! in
- profiles_k, & ! inout
- coeffs, & ! in
- rad_skin, & ! in
- rad_surfair, & ! in
- rad_layer, & ! in
- rad_skin_k, & ! in
- rad_surfair_k, & ! in
- rad_layer_k ) ! in
-
- Use rttov_types, only : &
- rttov_coef ,&
- profile_type
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
- Integer(Kind=jpim), Intent(in) :: nfrequencies ! Number of processed radiances
- Integer(Kind=jpim), Intent(in) :: nprofiles
- Integer(Kind=jpim), Intent(in) :: nchannels
- Type(profile_Type), Intent(in) ,Target :: profiles(nprofiles)
- Type(profile_Type), Intent(inout) ,Target :: profiles_k(nchannels)
- Type(rttov_coef), Intent(in) :: coeffs
- Integer(Kind=jpim), Intent(in) :: channels(nfrequencies)
- Integer(Kind=jpim), Intent(in) :: polarisations(nchannels,3) ! Array of channel indices.
- Integer(Kind=jpim), Intent(in) :: lprofiles(nfrequencies)
- Real(Kind=jprb), Intent(in) :: rad_skin(nchannels)
- Real(Kind=jprb), Intent(in) :: rad_surfair(nchannels)
- Real(Kind=jprb), Intent(in) :: rad_layer( coeffs%nlevels , nchannels )
-
- Real(Kind=jprb), Intent(in) :: rad_skin_k(nchannels)
- Real(Kind=jprb), Intent(in) :: rad_surfair_k(nchannels)
- Real(Kind=jprb), Intent(in) :: rad_layer_k( coeffs%nlevels , nchannels )
-
-
-
-End Subroutine rttov_calcrad_k
-End Interface
diff --git a/src/LIB/RTTOV/src/rttov_calcrad_tl.F90 b/src/LIB/RTTOV/src/rttov_calcrad_tl.F90
deleted file mode 100644
index 26213dfff63884f87470cbce2c7fb90a92cc6b00..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_calcrad_tl.F90
+++ /dev/null
@@ -1,154 +0,0 @@
-Subroutine rttov_calcrad_tl( &
- & nfrequencies, &! in
- & nchannels, &! in
- & nprofiles, &! in
- & channels, &! in
- & polarisations, &! in
- & lprofiles, &! in
- & profiles, &! in
- & profiles_tl, &! in
- & coeffs, &! in
- & rad_skin, &! in
- & rad_surfair, &! in
- & rad_layer, &! in
- & rad_skin_tl, &! out
- & rad_surfair_tl, &! out
- & rad_layer_tl ) ! out
- !
- ! Description:
- ! TL code to convert an array of atmospheric temperatures
- ! to planck radiances in many channels
- ! No TL on Rad Cosmic, tl = 0.
- !
- ! derivative of Planck function with respect to temperature is
- !
- ! C2 * Nu
- ! C1 * C2 * Nu**4 * Exp( ------- )
- ! T
- ! B'(T,Nu) = ------------------------------------- dT
- ! ( C2 * Nu )**2
- ! T**2 *( Exp( ------- ) - 1 )
- ! ( T )
- !
- !
- ! which can be reduced to the following, with
- ! C1 = C1 * Nu**3
- ! C2 = C2 * Nu
- !
- ! C2 * B(T,Nu) * (C1 + B(T,Nu))
- ! B'(T,Nu) = ----------------------------- dT
- ! C1 * T**2
- !
- !
- ! Copyright:
- ! This software was developed within the context of
- ! the EUMETSAT Satellite Application Facility on
- ! Numerical Weather Prediction (NWP SAF), under the
- ! Cooperation Agreement dated 25 November 1998, between
- ! EUMETSAT and the Met Office, UK, by one or more partners
- ! within the NWP SAF. The partners in the NWP SAF are
- ! the Met Office, ECMWF, KNMI and MeteoFrance.
- !
- ! Copyright 2002, EUMETSAT, All Rights Reserved.
- !
- ! Method: Uses band correction factors to convert T to radiance
- ! which have been precomputed for each channel and are read from
- ! the RT coefficient file.
- !
- ! Current Code Owner: SAF NWP
- !
- ! History:
- ! Version Date Comment
- ! ------- ---- -------
- ! 1.0 01/12/2002 New F90 code with structures (P Brunel A Smith)
- ! based on PLNCX of previous RTTOV versions
- ! 1.1 02/01/2003 Comments added (R Saunders)
- ! 1.2 26/09/2003 Multiple polarisations (S English)
- ! 1.3 29/03/2005 Add end of header comment (J. Cameron)
- !
- ! Code Description:
- ! Language: Fortran 90.
- ! Software Standards: "European Standards for Writing and
- ! Documenting Exchangeable Fortran 90 Code".
- !
- ! Declarations:
- ! Modules used:
-
- !
- Use rttov_types, only : &
- & rttov_coef ,&
- & profile_type
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
- !subroutine arguments:
- Integer(Kind=jpim), Intent(in) :: nprofiles
- Type(profile_Type), Intent(in) ,Target :: profiles(nprofiles)
- Type(profile_Type), Intent(in) ,Target :: profiles_tl(nprofiles)
- Type(rttov_coef), Intent(in) :: coeffs
- Integer(Kind=jpim), Intent(in) :: nfrequencies ! Number of processed radiances
- Integer(Kind=jpim), Intent(in) :: nchannels
- Integer(Kind=jpim), Intent(in) :: channels(nfrequencies)
- Integer(Kind=jpim), Intent(in) :: polarisations(nchannels,3) ! Array of channel indices.
- Integer(Kind=jpim), Intent(in) :: lprofiles(nfrequencies)
- Real(Kind=jprb), Intent(in) :: rad_skin(nchannels)
- Real(Kind=jprb), Intent(in) :: rad_surfair(nchannels)
- Real(Kind=jprb), Intent(in) :: rad_layer( coeffs%nlevels , nchannels )
- Real(Kind=jprb), Intent(out) :: rad_skin_tl(nchannels)
- Real(Kind=jprb), Intent(out) :: rad_surfair_tl(nchannels)
- Real(Kind=jprb), Intent(out) :: rad_layer_tl( coeffs%nlevels , nchannels )
-
-
-
- !local variables:
- Real(Kind=jprb) :: t_effective
- Real(Kind=jprb) :: t_effective_tl
- Real(Kind=jprb) :: rad_skin_freq_tl, rad_surfair_freq_tl, rad_layer_freq_tl(coeffs%nlevels)
- Integer(Kind=jpim) :: chan,i,lev,jpol,kpol,npol,ipol ! loop indices
- Type(profile_Type), Pointer :: prof
- Type(profile_Type), Pointer :: prof_tl
-
- !- End of header --------------------------------------------------------
-
- Do i = 1, nfrequencies
- chan = channels(i)
- ipol=polarisations(i,1)
- npol = polarisations(i,3)
- ! point to corresponding profile and geometry structures
- prof => profiles( lprofiles(i) )
- prof_tl => profiles_tl( lprofiles(i) )
-
- t_effective = coeffs%ff_bco(chan) + coeffs%ff_bcs(chan) * prof % skin % t
- t_effective_tl = coeffs%ff_bcs(chan) * prof_tl % skin % t
- rad_skin_freq_tl =( coeffs%planck2(chan) * rad_skin(ipol) * &
- & ( coeffs%planck1(chan) + rad_skin(ipol) ) / &
- & ( coeffs%planck1(chan) * t_effective**2 )) * &
- & t_effective_tl
-
- t_effective = coeffs%ff_bco(chan) + coeffs%ff_bcs(chan) * prof % s2m % t
- t_effective_tl = coeffs%ff_bcs(chan) * prof_tl % s2m % t
- rad_surfair_freq_tl =( coeffs%planck2(chan) * rad_surfair(ipol) * &
- & ( coeffs%planck1(chan) + rad_surfair(ipol) ) / &
- & ( coeffs%planck1(chan) * t_effective**2 )) * &
- & t_effective_tl
-
- Do lev = 1, coeffs%nlevels
- t_effective = coeffs%ff_bco(chan) + coeffs%ff_bcs(chan) * prof % t(lev)
- t_effective_tl = coeffs%ff_bcs(chan) * prof_tl % t(lev)
- rad_layer_freq_tl(lev) =( coeffs%planck2(chan) * rad_layer(lev,ipol) * &
- & ( coeffs%planck1(chan) + rad_layer(lev,ipol) ) / &
- & ( coeffs%planck1(chan) * t_effective**2 ) ) * &
- & t_effective_tl
- End Do
- !
- Do jpol=ipol, ipol+npol-1
- rad_skin_tl(jpol) = rad_skin_freq_tl
- rad_surfair_tl(jpol) = rad_surfair_freq_tl
- Do lev = 1, coeffs%nlevels
- rad_layer_tl(lev,jpol)=rad_layer_freq_tl(lev)
- End Do
- End Do
- End Do
-
-End Subroutine rttov_calcrad_tl
diff --git a/src/LIB/RTTOV/src/rttov_calcrad_tl.interface b/src/LIB/RTTOV/src/rttov_calcrad_tl.interface
deleted file mode 100644
index ee4e0750c58c37938cf8998de1305fa54497f83f..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_calcrad_tl.interface
+++ /dev/null
@@ -1,46 +0,0 @@
-Interface
-Subroutine rttov_calcrad_tl( &
- nfrequencies, & ! in
- nchannels, & ! in
- nprofiles, & ! in
- channels, & ! in
- polarisations, & ! in
- lprofiles, & ! in
- profiles, & ! in
- profiles_tl, & ! in
- coeffs, & ! in
- rad_skin, & ! in
- rad_surfair, & ! in
- rad_layer, & ! in
- rad_skin_tl, & ! out
- rad_surfair_tl, & ! out
- rad_layer_tl ) ! out
-
- Use rttov_types, only : &
- rttov_coef ,&
- profile_type
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
- Integer(Kind=jpim), Intent(in) :: nprofiles
- Type(profile_Type), Intent(in) ,Target :: profiles(nprofiles)
- Type(profile_Type), Intent(in) ,Target :: profiles_tl(nprofiles)
- Type(rttov_coef), Intent(in) :: coeffs
- Integer(Kind=jpim), Intent(in) :: nfrequencies ! Number of processed radiances
- Integer(Kind=jpim), Intent(in) :: nchannels
- Integer(Kind=jpim), Intent(in) :: channels(nfrequencies)
- Integer(Kind=jpim), Intent(in) :: polarisations(nchannels,3) ! Array of channel indices.
- Integer(Kind=jpim), Intent(in) :: lprofiles(nfrequencies)
- Real(Kind=jprb), Intent(in) :: rad_skin(nchannels)
- Real(Kind=jprb), Intent(in) :: rad_surfair(nchannels)
- Real(Kind=jprb), Intent(in) :: rad_layer( coeffs%nlevels , nchannels )
-
- Real(Kind=jprb), Intent(out) :: rad_skin_tl(nchannels)
- Real(Kind=jprb), Intent(out) :: rad_surfair_tl(nchannels)
- Real(Kind=jprb), Intent(out) :: rad_layer_tl( coeffs%nlevels , nchannels )
-
-
-
-End Subroutine rttov_calcrad_tl
-End Interface
diff --git a/src/LIB/RTTOV/src/rttov_checkinput.F90 b/src/LIB/RTTOV/src/rttov_checkinput.F90
deleted file mode 100644
index e5359f7df70ddf6693fec8d03a392707cc2f20d3..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_checkinput.F90
+++ /dev/null
@@ -1,301 +0,0 @@
-!
-Subroutine rttov_checkinput( &
- & prof, &! in
- & coef, &! in
- & errorstatus ) ! out
- ! Description:
- ! Check input profile/angles
- ! (i) Are physically realistic
- ! (ii) Profile values are within the basis set used to
- ! generate the coefficients
- ! Unphysical values return a fatal error status
- ! Profile values outside the basis set return a warning status
- !
- ! Copyright:
- ! This software was developed within the context of
- ! the EUMETSAT Satellite Application Facility on
- ! Numerical Weather Prediction (NWP SAF), under the
- ! Cooperation Agreement dated 25 November 1998, between
- ! EUMETSAT and the Met Office, UK, by one or more partners
- ! within the NWP SAF. The partners in the NWP SAF are
- ! the Met Office, ECMWF, KNMI and MeteoFrance.
- !
- ! Copyright 2002, EUMETSAT, All Rights Reserved.
- !
- ! Method: Check input profiles with fixed limits specified
- ! in constants and coeff file.
- !
- ! Current Code Owner: SAF NWP
- !
- ! History:
- ! Version Date Comment
- ! ------- ---- -------
- ! 1.0 01/12/2002 New F90 code with structures (P Brunel A Smith)
- ! 1.1 02/01/2003 More comments added (R Saunders)
- ! 1.2 29/01/2003 More tests and add CO2 (P Brunel)
- ! 1.3 27/06/2005 Uncommented water vapor and ozone profile checks (R Saunders)
- !
- ! Code Description:
- ! Language: Fortran 90.
- ! Software Standards: "European Standards for Writing and
- ! Documenting Exchangeable Fortran 90 Code".
- !
- ! Declarations:
- ! Modules used:
-
- ! Imported Parameters:
- Use rttov_const, Only : &
- & errorstatus_success ,&
- & errorstatus_warning ,&
- & errorstatus_fatal ,&
- & nsurftype ,&
- & gas_id_watervapour ,&
- & gas_id_ozone ,&
- & gas_id_co2 ,&
- & tmax ,&
- & tmin ,&
- & qmax ,&
- & qmin ,&
- & o3max ,&
- & o3min ,&
- & co2max ,&
- & co2min ,&
- & clwmax ,&
- & clwmin ,&
- & pmax ,&
- & pmin ,&
- & wmax ,&
- & zenmax ,&
- & ctpmax ,&
- & ctpmin
-
- ! Imported Type Definitions:
- Use rttov_types, Only : &
- & rttov_coef ,&
- & profile_Type
-
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
-#include "rttov_errorreport.interface"
-
- ! subroutine arguments
- ! scalar arguments with intent(in):
- Type(profile_Type), Intent (in) :: prof ! input profiles
- Type( rttov_coef ), Intent (in) :: coef ! coefficients
-
- ! scalar arguments with intent(out):
- Integer(Kind=jpim), Intent (out) :: errorstatus ! return code
-
-
-
- !local variables:
- Real(Kind=jprb) :: wind
- Real(Kind=jprb) :: dp( coef % nlevels )
- Character (len=80) :: errMessage
- Character (len=16) :: NameOfRoutine = 'rttov_checkinput'
- Integer(Kind=jpim) :: firstlevel,ilev
- Integer(Kind=jpim) :: ig ! gas number
- !- End of header --------------------------------------------------------
-
- !-------------
- !0. Initialize
- !-------------
-
- errorstatus = errorstatus_success
-
- !determine first pressure level above the surface (note levels are top down)
- Do firstlevel = coef % nlevels, 1, -1
- If ( coef % ref_prfl_p(firstlevel) <= prof % s2m % p ) Exit
- End Do
-
- ! Compare Profile Levels and Model Levels
- If ( prof % nlevels /= coef % nlevels ) Then
- errorstatus = errorstatus_fatal
- Write( errMessage, '( "invalid profile number of levels" )' )
- Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine)
- End If
-
- dp(:) = abs ( coef % ref_prfl_p(:) - prof % p(:) ) / coef % ref_prfl_p(:)
- If ( Any( dp > 0.01_JPRB ) ) Then
- errorstatus = errorstatus_fatal
- Write( errMessage, '( "invalid profile pressure levels" )' )
- Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine)
- End If
-
- !------------------------------
- !1. Check for unphysical values
- !------------------------------
- ! zenith angle
- If ( prof % zenangle > zenmax .Or. &
- & prof % zenangle < 0._JPRB ) Then
- errorstatus = errorstatus_fatal
- Write( errMessage, '( "invalid zenith angle" )' )
- Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine)
- End If
-
- ! Cloud Top Pressure
- If ( prof % ctp > ctpmax .Or. &
- & prof % ctp < ctpmin ) Then
- errorstatus = errorstatus_fatal
- Write( errMessage, '( "invalid cloud top pressure" )' )
- Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine)
- End If
-
- ! Cloud Fraction
- If ( prof % cfraction > 100._JPRB .Or. &
- & prof % cfraction < 0._JPRB ) Then
- errorstatus = errorstatus_fatal
- Write( errMessage, '( "invalid cloud fraction" )' )
- Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine)
- End If
-
- !1.1 surface variables
- !---------------------
-
- ! Pressure
- If ( prof % s2m % p > pmax .Or. &
- & prof % s2m % p < pmin ) Then
- errorstatus = errorstatus_fatal
- Write( errMessage, '( "invalid surface pressure" )' )
- Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine)
- End If
-
- ! 2m air temperature
- If ( prof % s2m % t > tmax .Or. &
- & prof % s2m % t < tmin ) Then
- errorstatus = errorstatus_fatal
- Write( errMessage, '( "invalid 2m air temperature" )' )
- Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine)
- End If
-
- ! 2m water vapour
- If ( prof % s2m % q > qmax .Or. &
- & prof % s2m % q < qmin ) Then
- errorstatus = errorstatus_fatal
- Write( errMessage, '( "invalid 2m water vapour" )' )
- Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine)
- End If
-
- ! surface wind speed
- wind = sqrt(&
- & prof % s2m % u * prof % s2m % u + &
- & prof % s2m % v * prof % s2m % v )
- If ( wind > wmax .Or. &
- & wind < 0._JPRB ) Then
- errorstatus = errorstatus_fatal
- Write( errMessage, '( "invalid 2m wind speed" )' )
- Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine)
- End If
-
- ! surface skin temperature
- If ( prof % skin % t > tmax .Or. &
- & prof % skin % t < tmin ) Then
- errorstatus = errorstatus_fatal
- Write( errMessage, '( "invalid skin surface temperature" )' )
- Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine)
- End If
-
- ! surface type
- If ( prof % skin % surftype < 0 .Or. prof % skin % surftype > nsurftype ) Then
- errorstatus = errorstatus_fatal
- Write( errMessage, '( "some invalid surface type" )' )
- Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine)
- End If
-
- !1.2 atmospheric variables
- !-------------------------
-
- ! temperature
- If ( Any( prof % t(1:firstlevel) > tmax ) .Or. &
- & Any( prof % t(1:firstlevel) < tmin ) ) Then
- errorstatus = errorstatus_fatal
- Write( errMessage, '( "some invalid atmospheric temperature" )' )
- Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine)
- End If
-
- ! water vapour
- If ( Any( prof % q(1:firstlevel) > qmax ) .Or. &
- Any( prof % q(1:firstlevel) < qmin ) ) Then
- errorstatus = errorstatus_fatal
- Write( errMessage, '( "some invalid atmospheric water vapour" )' )
- Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine)
- End If
-
- ! ozone
- If ( prof % ozone_Data .And. coef % nozone > 0) Then
- If ( Any( prof % o3(1:firstlevel) > o3max ) .Or. &
- Any( prof % o3(1:firstlevel) < o3min ) ) Then
- errorstatus = errorstatus_fatal
- Write( errMessage, '( "some invalid atmospheric ozone" )' )
- Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine)
- End If
- Endif
-
- ! CO2
- If ( prof % co2_Data .And. coef % nco2 > 0) Then
- If ( Any( prof % co2(1:firstlevel) > co2max ) .Or. &
- & Any( prof % co2(1:firstlevel) < co2min ) ) Then
- errorstatus = errorstatus_fatal
- Write( errMessage, '( "some invalid atmospheric CO2" )' )
- Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine)
- End If
- Endif
-
- ! cloud liquid water
- If ( prof % clw_Data ) Then
- If ( Any( prof % clw(1:firstlevel) > clwmax ) .Or. &
- & Any( prof % clw(1:firstlevel) < clwmin ) ) Then
- errorstatus = errorstatus_fatal
- Write( errMessage, '( "some invalid cloud liquid water" )' )
- Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine)
- End If
- Endif
-
- !-----------------------------
- !2. Check against basis values
- !-----------------------------
-
-
- If ( errorstatus /= errorstatus_fatal ) Then
-
- If ( Any( prof % t(1:firstlevel) > coef % lim_prfl_tmax(1:firstlevel) ) .Or. &
- & Any( prof % t(1:firstlevel) < coef % lim_prfl_tmin(1:firstlevel) ) ) Then
- errorstatus = errorstatus_warning
- Write( errMessage, '( "some atmospheric temperature outside coef. limits" )' )
- Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine)
- End If
-
- ig = coef % fmv_gas_pos( gas_id_watervapour )
- If ( Any( prof % q(1:firstlevel) > coef % lim_prfl_gmax(1:firstlevel, ig) ) .Or. &
- Any( prof % q(1:firstlevel) < coef % lim_prfl_gmin(1:firstlevel, ig) ) ) Then
- errorstatus = errorstatus_warning
- Write( errMessage, '( "some atmospheric water vapour outside coef. limits" )' )
- Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine)
- End If
-
- If ( prof % ozone_Data .And. coef % nozone > 0) Then
- ig = coef % fmv_gas_pos( gas_id_ozone )
- If ( Any( prof % o3(1:firstlevel) > coef % lim_prfl_gmax(1:firstlevel, ig) ) .Or. &
- Any( prof % o3(1:firstlevel) < coef % lim_prfl_gmin(1:firstlevel, ig) ) ) Then
- errorstatus = errorstatus_warning
- Write( errMessage, '( "some atmospheric ozone outside coef. limits" )' )
- Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine)
- End If
- End If
-
- If ( prof % co2_Data .And. coef % nco2 > 0) Then
- ig = coef % fmv_gas_pos( gas_id_co2 )
- If ( Any( prof % co2(1:firstlevel) > coef % lim_prfl_gmax(1:firstlevel, ig) ) .Or. &
- & Any( prof % co2(1:firstlevel) < coef % lim_prfl_gmin(1:firstlevel, ig) ) ) Then
- errorstatus = errorstatus_warning
- Write( errMessage, '( "some atmospheric CO2 outside coef. limits" )' )
- Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine)
- End If
- End If
-
- End If
-
-
-End Subroutine rttov_checkinput
diff --git a/src/LIB/RTTOV/src/rttov_checkinput.interface b/src/LIB/RTTOV/src/rttov_checkinput.interface
deleted file mode 100644
index b5f6369e75f49e08572bede9ed17bbf4a8bfbbfe..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_checkinput.interface
+++ /dev/null
@@ -1,50 +0,0 @@
-Interface
-!
-Subroutine rttov_checkinput( &
- prof, & ! in
- coef, & ! in
- errorstatus ) ! out
-
- Use rttov_const, Only : &
- errorstatus_success ,&
- errorstatus_warning ,&
- errorstatus_fatal ,&
- nsurftype ,&
- gas_id_watervapour ,&
- gas_id_ozone ,&
- gas_id_co2 ,&
- tmax ,&
- tmin ,&
- qmax ,&
- qmin ,&
- o3max ,&
- o3min ,&
- co2max ,&
- co2min ,&
- clwmax ,&
- clwmin ,&
- pmax ,&
- pmin ,&
- wmax ,&
- zenmax ,&
- ctpmax ,&
- ctpmin
-
- Use rttov_types, Only : &
- rttov_coef ,&
- profile_Type
-
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
- Type(profile_Type), Intent (in) :: prof ! input profiles
- Type( rttov_coef ), Intent (in) :: coef ! coefficients
-
- Integer(Kind=jpim), Intent (out) :: errorstatus ! return code
-
-
-
-
-End Subroutine rttov_checkinput
-End Interface
diff --git a/src/LIB/RTTOV/src/rttov_cld.F90 b/src/LIB/RTTOV/src/rttov_cld.F90
deleted file mode 100644
index 0b343d7392f5a3b60117d7482e68ff0cb90228f6..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_cld.F90
+++ /dev/null
@@ -1,344 +0,0 @@
-!
-Subroutine rttov_cld( &
- & errorstatus, &! out
- & nfrequencies, &! in
- & nchannels, &! in
- & nbtout, &! in
- & nprofiles, &! in
- & channels, &! in
- & polarisations, &! in
- & lprofiles, &! in
- & profiles, &! inout (to invalid clw absorption)
- & cld_profiles, &! in
- & coef, &! in
- & calcemis, &! in
- & emissivity, &! inout
- & cld_radiance ) ! inout
- ! Description:
- ! to compute multi-channel radiances and brightness
- ! temperatures for many profiles per call in a cloudy sky.
- !
- ! Copyright:
- ! This software was developed within the context of
- ! the EUMETSAT Satellite Application Facility on
- ! Numerical Weather Prediction (NWP SAF), under the
- ! Cooperation Agreement dated 25 November 1998, between
- ! EUMETSAT and the Met Office, UK, by one or more partners
- ! within the NWP SAF. The partners in the NWP SAF are
- ! the Met Office, ECMWF, KNMI and MeteoFrance.
- !
- ! Copyright 2002, EUMETSAT, All Rights Reserved.
- !
- ! Method:
- ! See Chevallier, F., P. Bauer, G. A. Kelly, C. Jakob,
- ! and T. McNally, 2001 Model clouds over oceans as seen
- ! from space: comparison with HIRS/2 and MSU radiances.
- ! J. Climate 14 4216-4229.
- !
- ! Current Code Owner: SAF NWP
- !
- ! History:
- ! Version Date Comment
- ! ------- ---- -------
- ! 1.0 03/2001 Initial version (F. Chevallier)
- ! 1.1 19/7/2001 Version for testing RTTOV-7 (R. Saunders)
- ! 2.0 01/12/2002 New F90 code with structures (P Brunel A Smith)
- ! 2.1 02/01/2002 Comments added (R Saunders)
- ! 2.2 08/01/04 Added polarisation (S English)
- ! 2.3 06/10/04 Add errorstatus to rttov_emiscld call (J Cameron)
- !
- ! Code Description:
- ! Language: Fortran 90.
- ! Software Standards: "European Standards for Writing and
- ! Documenting Exchangeable Fortran 90 Code".
- !
- ! Declarations:
- ! Modules used:
- ! Imported Parameters:
- Use rttov_const, Only : &
- & sensor_id_mw ,&
- & errorstatus_success ,&
- & errorstatus_fatal ,&
- & overlap_scheme
-
- ! Imported Type Definitions:
- Use rttov_types, Only : &
- & rttov_coef ,&
- & geometry_Type ,&
- & profile_Type ,&
- & profile_cloud_Type ,&
- & transmission_Type ,&
- & radiance_Type ,&
- & radiance_cloud_Type
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
-#include "rttov_errorreport.interface"
-#include "rttov_direct.interface"
-#include "rttov_intex.interface"
-#include "rttov_emiscld.interface"
-#include "rttov_aitosu.interface"
-#include "rttov_calcbt.interface"
-#include "rttov_setgeometry.interface"
-#include "rttov_calcpolarisation.interface"
-
- !subroutine arguments:
- Integer(Kind=jpim), Intent(in) :: nbtout ! Number of output radiances
- Integer(Kind=jpim), Intent(in) :: nfrequencies ! Number of output radiances
- Integer(Kind=jpim), Intent(in) :: nchannels ! Number of output radiances
- ! (= channels used * profiles)
- Integer(Kind=jpim), Intent(in) :: nprofiles ! Number of profiles
- Integer(Kind=jpim), Intent(in) :: channels(nfrequencies) ! Channel indices
- Integer(Kind=jpim), Intent(in) :: polarisations(nchannels,3) ! Channel indices
- Integer(Kind=jpim), Intent(in) :: lprofiles(nfrequencies) ! Profiles indices
- Type(profile_Type), Intent(inout) :: profiles(nprofiles) ! Profiles on RTTOV levels
- Type(profile_cloud_Type), Intent(in) :: cld_profiles(nprofiles) ! Cloud profiles on NWP levels
- Type(rttov_coef), Intent(in) :: coef ! Coefficients
- Logical, Intent(in) :: calcemis(nchannels) ! switch for emmissivity calc.
- Real(Kind=jprb), Intent(inout) :: emissivity(nchannels) ! surface emmissivity
- Type(radiance_cloud_Type), Intent(inout) :: cld_radiance ! radiances (mw/cm-1/ster/sq.m)
- Integer(Kind=jpim), Intent(out) :: errorstatus(nprofiles) ! return flag
-
- !local variables:
- Logical :: addcloud
- Integer(Kind=jpim) :: nwp_levels ! number of levels for NWP profiles
- Integer(Kind=jpim) :: nrt_levels ! number of levels for RTTOV_direct integration
- Integer(Kind=jpim) :: jl ! loop indice
- Integer(Kind=jpim) :: jk ! loop indice
- Integer(Kind=jpim) :: ipf ! loop indice
- Integer(Kind=jpim) :: alloc_status(10)
- Integer(Kind=jpim) :: freq
- Type(geometry_Type) :: angles(nprofiles) ! geometry angles
-
- Character (len=80) :: errMessage
- Character (len=10) :: NameOfRoutine = 'rttov_cld '
-
- Type(radiance_Type) :: radiance
- Type(transmission_Type) :: transmission
-
- !- End of header --------------------------------------------------------
- errorstatus(:) = errorstatus_success
- alloc_status(:) = 0
-
- ! allocate radiance results arrays with number of channels
- radiance % clear => cld_radiance % clear
-
- radiance % clear_out => cld_radiance % clear_out
- radiance % cloudy => cld_radiance % cloudy
- radiance % total => cld_radiance % total
- radiance % total_out => cld_radiance % total_out
- radiance % bt => cld_radiance % bt
- radiance % bt_clear => cld_radiance % bt_clear
- radiance % out => cld_radiance % out
- radiance % out_clear => cld_radiance % out_clear
- radiance % upclear => cld_radiance % upclear
- radiance % dnclear => cld_radiance % dnclear
- radiance % reflclear => cld_radiance % reflclear
- Allocate( radiance % overcast(coef % nlevels, nchannels) ,stat=alloc_status(1))
- Allocate( radiance % downcld (coef % nlevels, nchannels) ,stat=alloc_status(2))
-
- ! allocate transmission structure
- Allocate( transmission % tau_surf ( nchannels ) ,stat= alloc_status(3))
- Allocate( transmission % tau_layer ( coef % nlevels, nchannels ) ,stat= alloc_status(4))
- Allocate( transmission % od_singlelayer( coef % nlevels, nchannels ) ,stat= alloc_status(5))
-
- If( Any(alloc_status /= 0) ) Then
- errorstatus(:) = errorstatus_fatal
- Write( errMessage, '( "mem allocation error")' )
- Call Rttov_ErrorReport (errorstatus_fatal, errMessage, NameOfRoutine)
- Return
- End If
-
-
- !* 1. Gas absorption
-
- addcloud = .True.
-
- ! No calculation of CLW absorption inside "classical" RTTOV
- If ( Any(.Not.profiles(:)%clw_Data) ) Then
- ! warning message
- profiles(:)%clw_Data = .False.
- End If
-
- Call rttov_direct( &
- & errorstatus, &! out
- & nfrequencies, &! in
- & nchannels, &! in
- & nbtout, &! in
- & nprofiles, &! in
- & channels, &! in
- & polarisations, &! in
- & lprofiles, &! in
- & profiles, &! in
- & coef, &! in
- & addcloud, &! in
- & calcemis, &! in
- & emissivity, &! inout
- & transmission, &! inout
- & radiance ) ! inout
-
- If ( any( errorstatus(:) == errorstatus_fatal ) ) Then
- Write( errMessage, '( "error in rttov_direct")' )
- Call Rttov_ErrorReport (errorstatus_fatal, errMessage, NameOfRoutine)
- Return
- End If
-
-
- ! In order to make minimum changes inside the Cloud code
- ! we will pass some structure elements as arguments to the
- ! routines
- ! For example: number of levels cld_profiles(1)%nlevels
-
-
- ! Be carefull that inside routines local arrays have a different
- ! shape as structures (see rttov_types)
- ! For RTTOV8 all arrays with channels and levels dimensions have the
- ! following shape (nlevels, nchannels). This is the reverse
-
-
- ! for local arrays of cloud routines.
-
-
- !* 2. Interpolate cloud contribution to model levels
- ! compute arrays overcast, downcld of type cld_radiancedata
- nwp_levels = cld_profiles(1) % nlevels
- nrt_levels = profiles(1) % nlevels
-
- Do jl = 1, nchannels
- freq = polarisations(jl,2)
- ipf = lprofiles(freq)
- Call rttov_intex( &
- & nrt_levels, &! in
- & nwp_levels, &! in
- & profiles(ipf) % p, &! in
- & cld_profiles(ipf) % p, &! in
- & radiance % overcast(1:nrt_levels,jl), &! in
- & cld_radiance % overcast(1:nwp_levels,jl) ) ! inout
-
- Call rttov_intex( &
- & nrt_levels, &! in
- & nwp_levels, &! in
- & profiles(ipf) % p, &! in
- & cld_profiles(ipf) % p, &! in
- & radiance % downcld(1:nrt_levels,jl), &! in
- & cld_radiance % downcld(1:nwp_levels,jl) ) ! inout
- End Do
-
- !* 3. Calculate cloud emissivity
- Call rttov_emiscld( &
- & errorstatus, &! out
- & nfrequencies, &! in
- & nchannels, &! in
- & nprofiles, &! in
- & nwp_levels, &! in
- & channels, &! in
- & polarisations, &! in
- & lprofiles, &! in
- & profiles, &! in (surftype and zenangle)
- & coef, &! in (frequencies mw/ir/hi)
- & cld_profiles, &! in
- & cld_radiance) ! inout (cldemis part only)
- If ( any( errorstatus(:) == errorstatus_fatal ) ) Then
- Write( errMessage, '( "error in rttov_emiscld")' )
- Call Rttov_ErrorReport (errorstatus_fatal, errMessage, NameOfRoutine)
- Return
- End If
-
- !* 4. Compute the weights of the cloud layers
- ! ---------------------------------------
- Call rttov_aitosu( &
- & nfrequencies, &! in
- & nchannels, &! in
- & nprofiles, &! in
- & nwp_levels, &! in
- & polarisations, &! in
- & lprofiles, &! in
- & overlap_scheme, &! in
- & cld_profiles, &! in (cloud cover)
- & cld_radiance ) ! inout (cldemis input and
- ! cs_wtao, cs_wsurf, wtao, wsurf in output)
-
- !* 5. Integrate *rt* equation.
- ! --------- ---- --------
- ! clear-sky contribution
- ! without the surface reflection
- cld_radiance % total (:) = cld_radiance % cs_wtoa(:) * cld_radiance % upclear (:)
- ! with the surface-reflected clear-sky downward radiance
- cld_radiance % total (:) = cld_radiance % total (:) +&
- & cld_radiance % cs_wsurf(:) * cld_radiance % cs_wtoa(:) *&
- & cld_radiance % reflclear (:)
- !
- ! cloud contribution
- Do jk = 1, nwp_levels
- ! cloud upward emission
- cld_radiance % total (:) = cld_radiance % total (:) +&
- & cld_radiance % wtoa(jk,:) * cld_radiance % overcast(jk,:)
-
- ! cloud downward emission, reflected at the surface
- cld_radiance % total (:) = cld_radiance % total (:) +&
- & cld_radiance % wsurf(jk,:) * cld_radiance % cs_wtoa(:) *&
- & cld_radiance % downcld(jk,:)
- End Do
-
- ! Remember that radiance struture is mainly pointing on cld_radiance
- ! so we can use radiance struture for conversion of radiance to brightness temperatue.
- Call rttov_calcbt( &
- & nfrequencies, &! in
- & nchannels, &! in
- & channels, &! in
- & polarisations, &! in
- & coef, &! in
- & radiance ) ! inout
-
- If (coef % id_sensor == sensor_id_mw) Then
- Do ipf = 1, nprofiles
- Call rttov_setgeometry( &
- & profiles(ipf), &! in
- & coef, &! in
- & angles(ipf) ) ! out
- End Do
- !
- Call rttov_calcpolarisation( &
- & nfrequencies, &! in
- & nchannels, &! in
- & nprofiles, &! in
- & angles, &! in
- & channels, &! in
- & polarisations, &! in
- & lprofiles, &! in
- & coef, &! in
- & radiance ) ! inout
- Else
- radiance%out = radiance%bt
- radiance%out_clear = radiance%bt_clear
- radiance%total_out = radiance%total
- radiance%clear_out = radiance%clear
- End If
-
- ! deallocate radiance structure for overcast and dowcld arrays
- Deallocate( radiance % overcast ,stat= alloc_status(1))
- Deallocate( radiance % downcld ,stat= alloc_status(2))
- ! deallocate transmission structure
- Deallocate( transmission % tau_surf ,stat= alloc_status(3))
- Deallocate( transmission % tau_layer ,stat= alloc_status(4))
- Deallocate( transmission % od_singlelayer,stat= alloc_status(5))
-
- If( Any(alloc_status /= 0) ) Then
- errorstatus(:) = errorstatus_fatal
- Write( errMessage, '( "mem deallocation error")' )
- Call Rttov_ErrorReport (errorstatus_fatal, errMessage, NameOfRoutine)
- Return
- End If
-!!$ nullify ( radiance % clear )
-!!$ nullify ( radiance % cloudy )
-!!$ nullify ( radiance % total )
-!!$ nullify ( radiance % bt )
-!!$ nullify ( radiance % bt_clear )
-!!$ nullify ( radiance % upclear )
-!!$ nullify ( radiance % dnclear )
-!!$ nullify ( radiance % reflclear )
-
- !
-
-End Subroutine rttov_cld
diff --git a/src/LIB/RTTOV/src/rttov_cld.interface b/src/LIB/RTTOV/src/rttov_cld.interface
deleted file mode 100644
index dfe9d6d7331b16581b778ba5f87208586f5e8e40..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_cld.interface
+++ /dev/null
@@ -1,52 +0,0 @@
-Interface
-!
-Subroutine rttov_cld( &
- errorstatus, & ! out
- nfrequencies, & ! in
- nchannels, & ! in
- nbtout, & ! in
- nprofiles, & ! in
- channels, & ! in
- polarisations, & ! in
- lprofiles, & ! in
- profiles, & ! inout (to invalid clw absorption)
- cld_profiles, & ! in
- coef, & ! in
- calcemis, & ! in
- emissivity, & ! inout
- cld_radiance ) ! inout
- Use rttov_const, Only : &
- errorstatus_success ,&
- errorstatus_fatal ,&
- overlap_scheme
-
- Use rttov_types, Only : &
- rttov_coef ,&
- geometry_Type ,&
- profile_Type ,&
- profile_cloud_Type ,&
- transmission_Type ,&
- radiance_Type ,&
- radiance_cloud_Type
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
- Integer(Kind=jpim), Intent(in) :: nbtout ! Number of output radiances
- Integer(Kind=jpim), Intent(in) :: nfrequencies ! Number of output radiances
- Integer(Kind=jpim), Intent(in) :: nchannels
- Integer(Kind=jpim), Intent(in) :: nprofiles
- Integer(Kind=jpim), Intent(in) :: channels(nfrequencies)
- Integer(Kind=jpim), Intent(in) :: polarisations(nchannels,3) ! Channel indices
- Integer(Kind=jpim), Intent(in) :: lprofiles(nfrequencies)
- Type(profile_Type), Intent(inout) :: profiles(nprofiles) ! Profiles on RTTOV levels
- Type(profile_cloud_Type), Intent(in) :: cld_profiles(nprofiles) ! Cloud profiles on NWP levels
- Type(rttov_coef), Intent(in) :: coef ! Coefficients
- Logical, Intent(in) :: calcemis(nchannels) ! switch for emmissivity calc.
- Real(Kind=jprb), Intent(inout) :: emissivity(nchannels) ! surface emmissivity
- Type(radiance_cloud_Type), Intent(inout) :: cld_radiance ! radiances (mw/cm-1/ster/sq.m)
- Integer(Kind=jpim), Intent(out) :: errorstatus(nprofiles) ! return flag
-
-
-End Subroutine rttov_cld
-End Interface
diff --git a/src/LIB/RTTOV/src/rttov_cld_ad.F90 b/src/LIB/RTTOV/src/rttov_cld_ad.F90
deleted file mode 100644
index b9778cef3be9dde196512eb7718ae3820204aa4f..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_cld_ad.F90
+++ /dev/null
@@ -1,648 +0,0 @@
-Subroutine Rttov_cld_ad ( &
- & errorstatus, &! out
- & nfrequencies, &! in
- & nchannels, &! in
- & nbtout, &! in
- & nprofiles, &! in
- & channels, &! in
- & polarisations, &! in
- & lprofiles, &! in
- & profiles, &! in
- & cld_profiles, &! in
- & coef, &! in
- & switchrad, &! in
- & calcemis, &! in
- & emissivity, &! inout
- & profiles_ad, &! inout
- & cld_profiles_ad, &! inout
- & emissivity_ad, &! inout
- & cld_radiance, &! inout
- & cld_radiance_ad ) ! inout
- !
- ! Description:
- ! to compute multi-channel radiances and brightness
- ! temperatures for many profiles per call in a cloudy sky.
- ! Note that cld_radiance_ad can be used for all its structure elements
- ! In normal case the element total or bt is the only one initialised but
- ! for some particular cases like for rttov_cld_ad some other elements
- ! have been already init.
- ! According to the argument switchrad the main input total or bt is used
- ! switchrad == true bt is the input, brightness temperature
- ! switchrad == false total is the input, radiance
- !
- ! The AD outputs cld_profiles_ad, profiles_ad and emissivity_ad should be
- ! allocated and initialised before calling the subroutine
- !
- !
- ! Copyright:
- ! This software was developed within the context of
- ! the EUMETSAT Satellite Application Facility on
- ! Numerical Weather Prediction (NWP SAF), under the
- ! Cooperation Agreement dated 25 November 1998, between
- ! EUMETSAT and the Met Office, UK, by one or more partners
- ! within the NWP SAF. The partners in the NWP SAF are
- ! the Met Office, ECMWF, KNMI and MeteoFrance.
- !
- ! Copyright 2002, EUMETSAT, All Rights Reserved.
- !
- ! Method:
- ! See Chevallier, F., P. Bauer, G. A. Kelly, C. Jakob,
- ! and T. McNally, 2001 Model clouds over oceans as seen
- ! from space: comparison with HIRS/2 and MSU radiances.
- ! J. Climate 14 4216-4229.
- !
- ! Current Code Owner: SAF NWP
- !
- ! History:
- ! Version Date Comment
- ! ------- ---- -------
- ! 1.0 03/2001 Initial version (F. Chevallier)
- ! 1.1 19/7/2001 Version for testing RTTOV-7 (R. Saunders)
- ! 2.0 01/12/2002 New F90 code with structures (P Brunel A Smith)
- ! 2.1 02/01/2002 Comments added (R Saunders)
- ! 2.2 08/01/04 Added polarisation (S English)
- ! 2.3 06/10/04 Add errorstatus to rttov_emiscld_ad call (J Cameron)
- ! 2.4 29/03/2005 Add end of header comment (J. Cameron)
- !
- ! Code Description:
- ! Language: Fortran 90.
- ! Software Standards: "European Standards for Writing and
- ! Documenting Exchangeable Fortran 90 Code".
- !
- ! Declarations:
- ! Modules used:
- ! Imported Parameters:
-
- Use rttov_const, Only : &
- & sensor_id_mw ,&
- & errorstatus_success ,&
- & errorstatus_fatal ,&
- & overlap_scheme
-
- Use rttov_types, Only : &
- & rttov_coef ,&
- & geometry_Type ,&
- & profile_Type ,&
- & profile_cloud_Type ,&
- & transmission_Type ,&
- & radiance_Type ,&
- & radiance_cloud_Type
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-#include "rttov_errorreport.interface"
-#include "rttov_direct.interface"
-#include "rttov_ad.interface"
-#include "rttov_intex.interface"
-#include "rttov_intex_ad.interface"
-#include "rttov_emiscld.interface"
-#include "rttov_emiscld_ad.interface"
-#include "rttov_aitosu.interface"
-#include "rttov_aitosu_ad.interface"
-#include "rttov_calcbt.interface"
-#include "rttov_calcbt_ad.interface"
-#include "rttov_setgeometry.interface"
-#include "rttov_calcpolarisation.interface"
-#include "rttov_calcpolarisation_ad.interface"
-
- !subroutine arguments:
- Integer(Kind=jpim), Intent(in) :: nfrequencies
- Integer(Kind=jpim), Intent(in) :: nchannels
- Integer(Kind=jpim), Intent(in) :: nbtout
- Integer(Kind=jpim), Intent(in) :: nprofiles
- Integer(Kind=jpim), Intent(in) :: channels(nfrequencies)
- Integer(Kind=jpim), Intent(in) :: polarisations(nchannels,3)
- Integer(Kind=jpim), Intent(in) :: lprofiles(nfrequencies)
- Logical, Intent(in) :: switchrad ! true if input is BT
- Type(profile_Type), Intent(inout) :: profiles(nprofiles)
- Type(profile_cloud_Type), Intent(in) :: cld_profiles(nprofiles)
- Type(rttov_coef), Intent(in) :: coef
- Logical, Intent(in) :: calcemis(nchannels)
- Real(Kind=jprb), Intent(inout) :: emissivity(nchannels)
- Type(radiance_cloud_type), Intent(inout) :: cld_radiance! in because of meme allocation
-
-
- Type(profile_Type), Intent(inout) :: profiles_ad(nprofiles)
- Type(profile_cloud_Type), Intent(inout) :: cld_profiles_ad(nprofiles)
- Real(Kind=jprb), Intent(inout) :: emissivity_ad(nchannels)
- Type(radiance_cloud_type), Intent(inout) :: cld_radiance_ad
- Integer(Kind=jpim), Intent(out) :: errorstatus(nprofiles)
-
- !local variables:
- Logical :: addcloud
- Integer(Kind=jpim) :: nwp_levels ! number of levels for NWP profiles
- Integer(Kind=jpim) :: nrt_levels ! number of levels for RTTOV_direct integration
- Integer(Kind=jpim) :: jl ! loop indice
- Integer(Kind=jpim) :: jk ! loop indice
- Integer(Kind=jpim) :: ipf ! loop indice
- Integer(Kind=jpim) :: alloc_status(20)
- Integer(Kind=jpim) :: freq
- Type(geometry_Type) :: angles(nprofiles) ! geometry angles
- Character (len=80) :: errMessage
- Character (len=12) :: NameOfRoutine = 'rttov_cld_ad'
-
- Real(Kind=jprb) :: null_press(coef%nlevels)
- Real(Kind=jprb) :: total_ref(nchannels), bt_ref(nchannels)
- !Real(Kind=jprb) :: tau_surf(nchannels)
- !Real(Kind=jprb) :: tau_layer(coef%nlevels,nchannels)
- Type(radiance_Type) :: radiance
- Type(radiance_Type) :: radiance_ad
- Type(transmission_Type) :: transmission
- Type(transmission_Type) :: transmission_ad
-
- !- End of header --------------------------------------------------------
-
- errorstatus(:) = errorstatus_success
- alloc_status(:) = 0
-
- ! allocate radiance results arrays with number of channels
- radiance % clear => cld_radiance % clear
- radiance % clear_out => cld_radiance % clear_out
- radiance % cloudy => cld_radiance % cloudy
- radiance % total => cld_radiance % total
- radiance % total_out => cld_radiance % total_out
- radiance % bt => cld_radiance % bt
- radiance % bt_clear => cld_radiance % bt_clear
- radiance % out => cld_radiance % out
- radiance % out_clear => cld_radiance % out_clear
- radiance % upclear => cld_radiance % upclear
- radiance % dnclear => cld_radiance % dnclear
- radiance % reflclear => cld_radiance % reflclear
- allocate( radiance % overcast ( coef % nlevels, nchannels ) ,stat= alloc_status(1))
- allocate( radiance % downcld ( coef % nlevels, nchannels ) ,stat= alloc_status(2))
-
- ! allocate transmission arrays
- Allocate( transmission % tau_surf ( nchannels ) ,stat= alloc_status(3))
- Allocate( transmission % tau_layer ( coef % nlevels, nchannels ) ,stat= alloc_status(4))
- Allocate( transmission % od_singlelayer( coef % nlevels, nchannels ) ,stat= alloc_status(5))
-
- If( any(alloc_status /= 0) ) then
- errorstatus(:) = errorstatus_fatal
- Write( errMessage, '( "mem allocation error")' )
- Call Rttov_ErrorReport (errorstatus_fatal, errMessage, NameOfRoutine)
- Return
- End If
-
- ! Repeat Direct Code
- !* 1. Gas absorption
-
- addcloud = .true.
-
- ! No calculation of CLW absorption inside "classical" RTTOV
- if ( any(.not.profiles(:)%clw_data) ) then
- ! warning message
- profiles(:)%clw_data = .false.
- End If
-
- ! inside "classical" RTTOV profile should be considered clear
- if ( any(profiles(:)%cfraction > 0._JPRB) ) then
- ! warning message
- profiles(:)%cfraction = 0._JPRB
- End If
- Call rttov_direct( &
- & errorstatus, &! out
- & nfrequencies, &! in
- & nchannels, &! in
- & nbtout, &! in
- & nprofiles, &! in
- & channels, &! in
- & polarisations, &! in
- & lprofiles, &! in
- & profiles, &! in
- & coef, &! in
- & addcloud, &! in
- & calcemis, &! in
- & emissivity, &! inout
- & transmission, &! inout
- & radiance ) ! inout
- If ( any( errorstatus(:) == errorstatus_fatal ) ) Then
- Write( errMessage, '( "error in rttov_direct")' )
- Call Rttov_ErrorReport (errorstatus_fatal, errMessage, NameOfRoutine)
- Return
- End If
-
- ! In order to make minimum changes inside the Cloud code
- ! we will pass some structure elements as arguments to the
- ! routines
- ! For example: number of levels cld_profiles(1)%nlevels
-
-
- ! Be carefull that inside routines local arrays have a different
- ! shape as structures (see rttov_types)
- ! For RTTOV8 all arrays with channels and levels dimensions have the
- ! following shape (nlevels, nchannels). This is the reverse
-
-
- ! for local arrays of cloud routines.
-
-
- !* 2. Interpolate cloud contribution to model levels
- ! compute arrays overcast, downcld of type cld_radiancedata
- nwp_levels = cld_profiles(1) % nlevels
- nrt_levels = profiles(1) % nlevels
-
- DO jl = 1, nchannels
- freq = polarisations(jl,2)
- ipf = lprofiles(freq)
- call rttov_intex( &
- & nrt_levels, &! in
- & nwp_levels, &! in
- & profiles(ipf) % p, &! in
- & cld_profiles(ipf) % p, &! in
- & radiance % overcast(1:nrt_levels,jl), &! in
- & cld_radiance % overcast(1:nwp_levels,jl) ) ! inout
-
- call rttov_intex( &
- & nrt_levels, &! in
- & nwp_levels, &! in
- & profiles(ipf) % p, &! in
- & cld_profiles(ipf) % p, &! in
- & radiance % downcld(1:nrt_levels,jl), &! in
- & cld_radiance % downcld(1:nwp_levels,jl) ) ! inout
- End Do
-
- !* 3. Calculate cloud emissivity
- call rttov_emiscld( &
- & errorstatus, &! out
- & nfrequencies, &! in
- & nchannels, &! in
- & nprofiles, &! in
- & nwp_levels, &! in
- & channels, &! in
- & polarisations, &! in
- & lprofiles, &! in
- & profiles, &! in (surftype and zenangle)
- & coef, &! in (frequencies mw/ir/hi)
- & cld_profiles, &! in
- & cld_radiance) ! inout (cldemis part only)
- If ( any( errorstatus(:) == errorstatus_fatal ) ) Then
- Write( errMessage, '( "error in rttov_emiscld")' )
- Call Rttov_ErrorReport (errorstatus_fatal, errMessage, NameOfRoutine)
- Return
- End If
-
- !* 4. Compute the weights of the cloud layers
- ! ---------------------------------------
- call rttov_aitosu( &
- & nfrequencies, &! in
- & nchannels, &! in
- & nprofiles, &! in
- & nwp_levels, &! in
- & polarisations, &! in
- & lprofiles, &! in
- & overlap_scheme, &! in
- & cld_profiles, &! in (cloud cover)
- & cld_radiance ) ! inout (cldemis input and
- ! cs_wtao, cs_wsurf, wtao, wsurf in output)
-
- !* 5. Integrate *rt* equation.
- ! --------- ---- --------
- ! clear-sky contribution
- ! without the surface reflection
- cld_radiance % total (:) = cld_radiance % cs_wtoa(:) *&
- & cld_radiance % upclear (:)
- ! with the surface-reflected clear-sky downward radiance
- cld_radiance % total (:) = cld_radiance % total (:) +&
- & cld_radiance % cs_wsurf(:) *&
- & cld_radiance % cs_wtoa(:) *&
- & cld_radiance % reflclear (:)
-
- !
- ! cloud contribution
- DO jk = 1, nwp_levels
- ! cloud upward emission
- cld_radiance % total (:) = cld_radiance % total (:) +&
- & cld_radiance % wtoa(jk,:) *&
- & cld_radiance % overcast(jk,:)
-
- ! cloud downward emission, reflected at the surface
- cld_radiance % total (:) = cld_radiance % total (:) +&
- & cld_radiance % wsurf(jk,:) *&
- & cld_radiance % cs_wtoa(:) *&
- & cld_radiance % downcld(jk,:)
- END DO
-
- ! Remember that radiance struture is mainly pointing on cld_radiance
- ! so we can use radiance struture for conversion of radiance to brightness temperatue.
- Call rttov_calcbt( &
- & nfrequencies, &! in
- & nchannels, &! in
- & channels, &! in
- & polarisations, &! in
- & coef, &! in
- & radiance ) ! inout
-
- ! Save cloudy radiance/brightness temperature since they are overwritten in rttov_ad
- total_ref(:) = cld_radiance % total (:)
- bt_ref (:) = cld_radiance % bt (:)
-
- !-----------------------------------------------------------
- ! AD code
- !-----------------------------------------------------------
-
- ! Initialise AD variables
- ! allocate radiance AD results arrays with number of channels
- radiance_ad % clear => cld_radiance_ad % clear
- radiance_ad % clear_out => cld_radiance_ad % clear_out
- radiance_ad % cloudy => cld_radiance_ad % cloudy
- radiance_ad % total => cld_radiance_ad % total
- radiance_ad % total_out => cld_radiance_ad % total_out
- radiance_ad % bt => cld_radiance_ad % bt
- radiance_ad % out => cld_radiance_ad % out
- radiance_ad % out_clear => cld_radiance_ad % out_clear
- radiance_ad % bt_clear => cld_radiance_ad % bt_clear
- radiance_ad % upclear => cld_radiance_ad % upclear
- radiance_ad % reflclear => cld_radiance_ad % reflclear
- allocate( radiance_ad % overcast ( coef % nlevels, nchannels ) ,stat= alloc_status(1))
- allocate( radiance_ad % downcld ( coef % nlevels, nchannels ) ,stat= alloc_status(2))
- allocate( transmission_ad % tau_surf ( nchannels ) ,stat= alloc_status(3))
- allocate( transmission_ad % tau_layer ( coef % nlevels, nchannels ) ,stat= alloc_status(4))
- allocate( transmission_ad % od_singlelayer( coef % nlevels, nchannels ) ,stat= alloc_status(5))
-
- If( any(alloc_status /= 0) ) then
- errorstatus(:) = errorstatus_fatal
- Write( errMessage, '( "mem allocation error")' )
- Call Rttov_ErrorReport (errorstatus_fatal, errMessage, NameOfRoutine)
- Return
- End If
- radiance_ad % overcast (:,:) = 0._JPRB
- radiance_ad % downcld (:,:) = 0._JPRB
- transmission_ad % tau_surf (:) = 0._JPRB
- transmission_ad % tau_layer (:,:) = 0._JPRB
- transmission_ad % od_singlelayer (:,:) = 0._JPRB
-
- If (coef % id_sensor == sensor_id_mw) Then
- Do ipf = 1, nprofiles
- Call rttov_setgeometry( &
- & profiles(ipf), &! in
- & coef, &! in
- & angles(ipf) ) ! out
- End Do
- !
- Call rttov_calcpolarisation( &
- & nfrequencies, &! in
- & nchannels, &! in
- & nprofiles, &! in
- & angles, &! in
- & channels, &! in
- & polarisations, &! in
- & lprofiles, &! in
- & coef, &! in
- & radiance ) ! inout
- Call rttov_calcpolarisation_ad( &
- & nfrequencies, &! in
- & nchannels, &! in
- & nbtout, &! in
- & profiles, &! in
- & nprofiles, &! in
- & angles, &! in
- & channels, &! in
- & polarisations, &! in
- & lprofiles, &! in
- & coef, &! in
- & radiance_ad ) ! inout
- Else
- radiance%out = radiance%bt
- radiance%out_clear = radiance%bt_clear
- radiance%total_out = radiance%total
- radiance%clear_out = radiance%clear
- radiance_ad%bt = radiance_ad%out
- radiance_ad%bt_clear = radiance_ad%out_clear
- radiance_ad%total = radiance_ad%total_out
- radiance_ad%clear = radiance_ad%clear_out
- End If
-
-! if input AD unit is temperature, convert it in radiance
- if ( switchrad ) then
- Call rttov_calcbt_ad( &
- & nfrequencies, &! in
- & nchannels, &! in
- & channels, &! in
- & polarisations, &! in
- & coef, &! in
- & radiance, &! in
- & radiance_ad ) ! inout output is only radiance_ad%total
- endif
-
- !* 5. Integrate *rt* equation.
- ! --------- ---- --------
- ! cloud contribution
- DO jk = 1, nwp_levels
- ! cloud downward emission, reflected at the surface
- cld_radiance_ad%downcld(jk,:) = cld_radiance_ad%downcld(jk,:) +&
- & cld_radiance_ad % total (:) *&
- & cld_radiance %wsurf(jk,:) *&
- & cld_radiance %cs_wtoa(:)
-
- cld_radiance_ad%cs_wtoa(:) = cld_radiance_ad%cs_wtoa(:) +&
- & cld_radiance_ad % total (:) *&
- & cld_radiance %wsurf(jk,:) *&
- & cld_radiance %downcld(jk,:)
-
- cld_radiance_ad%wsurf(jk,:) = cld_radiance_ad%wsurf(jk,:) +&
- & cld_radiance_ad % total (:) *&
- & cld_radiance %cs_wtoa(:) *&
- & cld_radiance %downcld(jk,:)
-
- ! cloud upward emission
- cld_radiance_ad % wtoa(jk,:) = cld_radiance_ad % wtoa(jk,:) +&
- & cld_radiance_ad % total (:) *&
- & cld_radiance % overcast(jk,:)
-
- cld_radiance_ad % overcast(jk,:) = cld_radiance_ad % overcast(jk,:) +&
- & cld_radiance_ad % total (:) *&
- & cld_radiance % wtoa(jk,:)
-
- END DO
-
- ! with the surface-reflected clear-sky downward radiance
- cld_radiance_ad%cs_wsurf(:) = cld_radiance_ad%cs_wsurf(:) +&
- & cld_radiance_ad % total (:) *&
- & cld_radiance %cs_wtoa(:) *&
- & cld_radiance %reflclear(:)
-
- cld_radiance_ad%cs_wtoa(:) = cld_radiance_ad%cs_wtoa(:) +&
- & cld_radiance_ad % total (:) *&
- & cld_radiance %cs_wsurf(:) *&
- & cld_radiance %reflclear(:)
-
- cld_radiance_ad%reflclear(:) = cld_radiance_ad%reflclear(:) +&
- & cld_radiance_ad % total (:) *&
- & cld_radiance %cs_wsurf(:) *&
- & cld_radiance %cs_wtoa(:)
-
-
- ! clear-sky contribution
- ! without the surface reflection
- cld_radiance_ad % cs_wtoa(:) = cld_radiance_ad % cs_wtoa(:) +&
- & cld_radiance_ad % total (:) *&
- & cld_radiance % upclear (:)
-
- cld_radiance_ad % upclear (:) = cld_radiance_ad % upclear (:) +&
- & cld_radiance_ad % total (:) *&
- & cld_radiance % cs_wtoa(:)
-
- cld_radiance_ad % total (:) = 0._JPRB
-
- !* 4. Compute the weights of the cloud layers
- ! ---------------------------------------
- call rttov_aitosu_ad( &
- & nfrequencies, &! in
- & nchannels, &! in
- & nprofiles, &! in
- & nwp_levels, &! in
- & polarisations, &! in
- & lprofiles, &! in
- & overlap_scheme, &! in
- & cld_profiles, &! in (cloud cover)
- & cld_profiles_ad, &! inout (cloud cover updated)
- & cld_radiance , &! inout (cldemis in input and
- ! cs_wtao, cs_wsurf, wtao, wsurf in output are zeroed)
- & cld_radiance_ad ) ! inout (cldemis updated and
- ! cs_wtao, cs_wsurf, wtao, wsurf in output are zeroed)
-
-
- !* 3. Calculate cloud emissivity
- call rttov_emiscld_ad( &
- & errorstatus, &! out
- & nfrequencies, &! in
- & nchannels, &! in
- & nprofiles, &! in
- & nwp_levels, &! in
- & channels, &! in
- & polarisations, &! in
- & lprofiles, &! in
- & profiles, &! in (surftype and zenangle)
- & coef, &! in (frequencies mw/ir/hi)
- & cld_profiles, &! in
- & cld_profiles_ad, &! inout
- & cld_radiance, &! inout (cldemis part only)
- & cld_radiance_ad) ! inout (cldemis part only)
- If ( any( errorstatus(:) == errorstatus_fatal ) ) Then
- Write( errMessage, '( "error in rttov_emiscld")' )
- Call Rttov_ErrorReport (errorstatus_fatal, errMessage, NameOfRoutine)
- Return
- End If
-
- !* 2. Interpolate cloud contribution to model levels
- ! compute arrays overcast, downcld of type cld_radiancedata
- DO jl = 1, nchannels
- freq = polarisations(jl,2)
- ipf = lprofiles(freq)
- null_press(:) = 0._JPRB
- call rttov_intex_ad( &
- & nrt_levels, &! in
- & nwp_levels, &! in
- & null_press, &! inout
- & cld_profiles_ad(ipf) % p, &! inout
- & radiance_ad % downcld(1:nrt_levels,jl), &! inout
- & cld_radiance_ad % downcld(1:nwp_levels,jl), &! inout
- & profiles(ipf) % p, &! in
- & cld_profiles(ipf) % p, &! in
- & radiance % downcld(1:nrt_levels,jl), &! in
- & cld_radiance % downcld(1:nwp_levels,jl) ) ! out
-
- null_press(:) = 0._JPRB
- call rttov_intex_ad( &
- & nrt_levels, &! in
- & nwp_levels, &! in
- & null_press, &! inout
- & cld_profiles_ad(ipf) % p, &! inout
- & radiance_ad % overcast(1:nrt_levels,jl), &! inout
- & cld_radiance_ad % overcast(1:nwp_levels,jl), &! inout
- & profiles(ipf) % p, &! in
- & cld_profiles(ipf) % p, &! in
- & radiance % overcast(1:nrt_levels,jl), &! in
- & cld_radiance % overcast(1:nwp_levels,jl) ) ! out
-
- End Do
-
-
- ! Input of CLD_AD code are Bt increments for "total" (cloudy) and
- ! "clear" arrays
- ! Cloudy part has been considered above, now just consider the gas absorption
- ! and run rttov_ad in clear conditions
- ! Overcast arrays have been interpolated to rttov levels and are part on the
- ! input of rttov_ad. They are represented by structure elements
- ! upclear, reflclear, overcast and downcld
- if( switchrad ) then
- radiance_ad%out(:) = radiance_ad%out_clear(:)
- radiance_ad%total(:) = 0._JPRB
- radiance_ad%cloudy(:)= 0._JPRB
- radiance_ad%clear(:) = 0._JPRB
- radiance_ad%out_clear(:) = 0._JPRB
- radiance_ad%bt_clear(:) = 0._JPRB
- radiance_ad%bt(:) = 0._JPRB
- Else
- radiance_ad%total_out(:) = radiance_ad%clear_out(:)
- radiance_ad%out(:) = 0._JPRB
- radiance_ad%cloudy(:)= 0._JPRB
- radiance_ad%clear(:) = 0._JPRB
- radiance_ad%out_clear(:) = 0._JPRB
- radiance_ad%bt_clear(:) = 0._JPRB
- radiance_ad%bt(:) = 0._JPRB
- End If
- !* 1. Gas absorption
-
- addcloud = .true.
-
- ! No calculation of CLW absorption inside "classical" RTTOV
- if ( any(.not.profiles(:)%clw_data) ) then
- ! warning message
- profiles(:)%clw_data = .false.
- End If
-
- Call rttov_ad( &
- & errorstatus, &! out
- & nfrequencies, &! in
- & nchannels, &! in
- & nbtout, &! in
- & nprofiles, &! in
- & channels, &! in
- & polarisations, &! in
- & lprofiles, &! in
- & profiles, &! in
- & coef, &! in
- & addcloud, &! in
- & switchrad, &! in
- & calcemis, &! in
- & emissivity, &! inout
- & profiles_ad, &! inout
- & emissivity_ad, &! inout
- & transmission, &! inout
- & transmission_ad, &! inout
- & radiance, &! inout
- & radiance_ad ) ! inout
-
- If ( any( errorstatus(:) == errorstatus_fatal ) ) Then
- Write( errMessage, '( "error in rttov_ad")' )
- Call Rttov_ErrorReport (errorstatus_fatal, errMessage, NameOfRoutine)
- Return
- End If
-
- ! Get correct values of cloudy radiance/brightness temperature
- cld_radiance % total (:) = total_ref(:)
- cld_radiance % bt (:) = bt_ref (:)
-
-
- ! deallocate radiance structure for overcast and dowcld arrays
- deallocate( radiance % overcast ,stat= alloc_status(1))
- deallocate( radiance % downcld ,stat= alloc_status(2))
- deallocate( radiance_ad % overcast ,stat= alloc_status(3))
- deallocate( radiance_ad % downcld ,stat= alloc_status(4))
- deallocate( transmission % tau_surf ,stat= alloc_status(5))
- deallocate( transmission % tau_layer ,stat= alloc_status(6))
- deallocate( transmission % od_singlelayer,stat= alloc_status(7))
- deallocate( transmission_ad % tau_surf ,stat= alloc_status(8))
- deallocate( transmission_ad % tau_layer ,stat= alloc_status(9))
- deallocate( transmission_ad % od_singlelayer,stat= alloc_status(10))
-
- If( any(alloc_status /= 0) ) then
- errorstatus(:) = errorstatus_fatal
- Write( errMessage, '( "mem deallocation error")' )
- Call Rttov_ErrorReport (errorstatus_fatal, errMessage, NameOfRoutine)
- Return
- End If
-
-
-End Subroutine Rttov_cld_ad
diff --git a/src/LIB/RTTOV/src/rttov_cld_ad.interface b/src/LIB/RTTOV/src/rttov_cld_ad.interface
deleted file mode 100644
index a8410243a78ce110dd8cc39de71c9ad9e88d5fb0..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_cld_ad.interface
+++ /dev/null
@@ -1,76 +0,0 @@
-Interface
-Subroutine Rttov_cld_ad ( &
- errorstatus, & ! out
- nfrequencies, & ! in
- nchannels, & ! in
- nbtout, & ! in
- nprofiles, & ! in
- channels, & ! in
- polarisations, & ! in
- lprofiles, & ! in
- profiles, & ! in
- cld_profiles, & ! in
- coef, & ! in
- switchrad, & ! in
- calcemis, & ! in
- emissivity, & ! inout
- profiles_ad, & ! inout
- cld_profiles_ad,& ! inout
- emissivity_ad, & ! inout
- cld_radiance, & ! inout
- cld_radiance_ad ) ! inout
-
-! Note that cld_radiance_ad can be used for all its structure elements
-! In normal case the element total or bt is the only one initialised but
-! for some particular cases like for rttov_cld_ad some other elements
-! have been already init.
-! According to the argument switchrad the main input total or bt is used
-! switchrad == true bt is the input, brightness temperature
-! switchrad == false total is the input, radiance
-
-! The AD outputs cld_profiles_ad, profiles_ad and emissivity_ad should be
-! allocated and initialised before calling the subroutine
-!
-
- Use rttov_const, Only : &
- errorstatus_success ,&
- errorstatus_fatal ,&
- overlap_scheme
-
- Use rttov_types, Only : &
- rttov_coef ,&
- geometry_Type ,&
- profile_Type ,&
- profile_cloud_Type ,&
- transmission_Type ,&
- radiance_Type ,&
- radiance_cloud_Type
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
- Integer(Kind=jpim), Intent(in) :: nfrequencies
- Integer(Kind=jpim), Intent(in) :: nchannels
- Integer(Kind=jpim), Intent(in) :: nbtout
- Integer(Kind=jpim), Intent(in) :: nprofiles
- Integer(Kind=jpim), Intent(in) :: channels(nfrequencies)
- Integer(Kind=jpim), Intent(in) :: polarisations(nchannels,3)
- Integer(Kind=jpim), Intent(in) :: lprofiles(nfrequencies)
- Logical, Intent(in) :: switchrad ! true if input is BT
- Type(profile_Type), Intent(inout) :: profiles(nprofiles)
- Type(profile_cloud_Type), Intent(in) :: cld_profiles(nprofiles)
- Type(rttov_coef), Intent(in) :: coef
- Logical, Intent(in) :: calcemis(nchannels)
- Real(Kind=jprb), Intent(inout) :: emissivity(nchannels)
- Type(radiance_cloud_type), Intent(inout) :: cld_radiance! in because of meme allocation
-
-
- Type(profile_Type), Intent(inout) :: profiles_ad(nprofiles)
- Type(profile_cloud_Type), Intent(inout) :: cld_profiles_ad(nprofiles)
- Real(Kind=jprb), Intent(inout) :: emissivity_ad(nchannels)
- Type(radiance_cloud_type), Intent(inout) :: cld_radiance_ad
- Integer(Kind=jpim), Intent(out) :: errorstatus(nprofiles)
-
-
-End Subroutine Rttov_cld_ad
-End Interface
diff --git a/src/LIB/RTTOV/src/rttov_cld_k.F90 b/src/LIB/RTTOV/src/rttov_cld_k.F90
deleted file mode 100644
index dcdd6dae0bea953bfb603e76b3de01a04982138e..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_cld_k.F90
+++ /dev/null
@@ -1,428 +0,0 @@
-Subroutine Rttov_cld_k ( &
- & errorstatus, &! out
- & nfrequencies, &! in
- & nchannels, &! in
- & nbtout, &! in
- & nprofiles, &! in
- & channels, &! in
- & polarisations, &! in
- & lprofiles, &! in
- & profiles, &! in
- & cld_profiles, &! in
- & coef, &! in
- & switchrad, &! in
- & calcemis, &! in
- & emissivity, &! inout
- & profiles_k , &! inout
- & cld_profiles_k , &! inout
- & emissivity_k , &! inout
- & cld_radiance) ! inout
-
- ! Description:
- ! to compute microwave multi-channel radiances and brightness
- ! temperatures for many profiles per call in a cloudy sky.
- !
- ! According to the argument switchrad the main input total or bt is used
- ! switchrad == true bt is the input, brightness temperature
- ! switchrad == false total is the input, radiance
- ! The AD outputs cld_profiles_ad, profiles_ad and emissivity_ad should be
- ! allocated and initialised before calling the subroutine
- !
- ! Copyright:
- ! This software was developed within the context of
- ! the EUMETSAT Satellite Application Facility on
- ! Numerical Weather Prediction (NWP SAF), under the
- ! Cooperation Agreement dated 25 November 1998, between
- ! EUMETSAT and the Met Office, UK, by one or more partners
- ! within the NWP SAF. The partners in the NWP SAF are
- ! the Met Office, ECMWF, KNMI and MeteoFrance.
- !
- ! Copyright 2003, EUMETSAT, All Rights Reserved.
- !
- ! Method :
- ! ------
- ! According to the argument switchrad the main input total or bt is used
- ! switchrad == true bt is the input, brightness temperature
- ! switchrad == false total is the input, radiance
- !
- ! The K outputs cld_profiles_k , profiles_k and emissivity_k should be
- ! allocated and initialised before calling the subroutine
- !
- ! Current Code Owner: SAF NWP
- !
- ! History:
- ! Version Date Comment
- ! ------- ---- -------
- ! 1.0 09/2003 Initial version (F. Chevallier) Note not based on RTTOV-7 code
- ! 1.1 08/01/04 Added polarisation (S English)
- ! 1.2 06/10/04 Change stop to return (J Cameron)
- ! 1.3 29/03/05 Add end of header comment (J. Cameron)
- !
- ! Code Description:
- ! Language: Fortran 90.
- ! Software Standards: "European Standards for Writing and
- ! Documenting Exchangeable Fortran 90 Code".
- ! Declarations:
-
- Use rttov_const, Only : &
- & sensor_id_mw ,&
- & errorstatus_success ,&
- & errorstatus_fatal ,&
- & overlap_scheme
-
- Use rttov_types, Only : &
- & rttov_coef ,&
- & geometry_Type ,&
- & profile_Type ,&
- & profile_cloud_Type ,&
- & radiance_cloud_Type
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
-#include "rttov_cld_ad.interface"
-#include "rttov_errorreport.interface"
-
- !subroutine arguments:
- Integer(Kind=jpim), Intent(in) :: nfrequencies
- Integer(Kind=jpim), Intent(in) :: nchannels
- Integer(Kind=jpim), Intent(in) :: nbtout
- Integer(Kind=jpim), Intent(in) :: nprofiles
- Integer(Kind=jpim), Intent(in) :: channels(nfrequencies)
- Integer(Kind=jpim), Intent(in) :: polarisations(nchannels,3)
- Integer(Kind=jpim), Intent(in) :: lprofiles(nfrequencies)
- Logical, Intent(in) :: switchrad ! true if input is BT
- Type(profile_Type), Intent(inout) :: profiles(nprofiles)
- Type(profile_cloud_Type), Intent(in) :: cld_profiles(nprofiles)
- Type(rttov_coef), Intent(in) :: coef
- Logical, Intent(in) :: calcemis(nchannels)
- Real(Kind=jprb), Intent(inout) :: emissivity(nchannels)
- Type(radiance_cloud_type), Intent(inout) :: cld_radiance! in because of meme allocation
- Type(profile_Type), Intent(inout) :: profiles_k(nchannels)
- Type(profile_cloud_Type), Intent(inout) :: cld_profiles_k(nchannels)
- Real(Kind=jprb), Intent(inout) :: emissivity_k(nchannels)
- Integer(Kind=jpim), Intent(out) :: errorstatus(nprofiles)
-
- !local variables:
- Integer(Kind=jpim) :: i, j, jj, k, istart, istop, nchan, nprof ,nfreq
- Integer(Kind=jpim) :: kchan, kstart, kstop, kemis
- Integer(Kind=jpim) :: kbtout, jstart, jstop, jcount
- Integer(Kind=jpim) :: kpol(nchannels/nprofiles,3)
- Integer(Kind=jpim) :: kchannels(nfrequencies/nprofiles)
- Logical :: kcalcemis(nchannels/nprofiles)
- Real(Kind=jprb) :: kemissivity(nchannels/nprofiles)
- Integer(Kind=jpim) :: freq
- Type(geometry_Type) :: angles(nprofiles) ! geometry angles
- Type(profile_Type) :: profiles_ad(1)
- Type(profile_cloud_Type) :: cld_profiles_ad(1)
- Type(radiance_cloud_type) :: cld_rad
- Type(radiance_cloud_type) :: cld_radiance_ad
- Real(Kind=jprb) :: emissivity_ad(nchannels/nprofiles)
- Integer(Kind=jpim) :: lprof(nfrequencies/nprofiles)
- Real(Kind=jprb) :: total_ref(nchannels), bt_ref(nchannels)
- Character (len=80) :: errMessage
- Character (len=11) :: NameOfRoutine = 'rttov_cld_k'
-
- !- End of header --------------------------------------------------------
-
- errorstatus(:) = errorstatus_success
-
- nprof = 1
- nfreq = nfrequencies/nprofiles
- kbtout = nbtout/nprofiles
- kchan = nchannels/nprofiles
-
- Do j = 1, nprof
- profiles_ad(j) % nlevels = coef % nlevels
- Allocate( profiles_ad(j) % p ( coef % nlevels ) )
- Allocate( profiles_ad(j) % t ( coef % nlevels ) )
- Allocate( profiles_ad(j) % q ( coef % nlevels ) )
- Allocate( profiles_ad(j) % o3 ( coef % nlevels ) )
- Allocate( profiles_ad(j) % clw( coef % nlevels ) )
- End do
- Do j = 1, nprof
- cld_profiles_ad(j) % nlevels = cld_profiles(1) % nlevels
- Allocate( cld_profiles_ad(j) % p ( cld_profiles(1) % nlevels ) )
- Allocate( cld_profiles_ad(j) % ph ( cld_profiles(1) % nlevels+1 ) )
- Allocate( cld_profiles_ad(j) % t ( cld_profiles(1) % nlevels ) )
- Allocate( cld_profiles_ad(j) % cc ( cld_profiles(1) % nlevels ) )
- Allocate( cld_profiles_ad(j) % clw( cld_profiles(1) % nlevels ) )
- Allocate( cld_profiles_ad(j) % ciw( cld_profiles(1) % nlevels ) )
- End do
-
-
- istop = 0
- kstop = 0
- jstop = 0
- lprof(:) = 1
- kpol(:,:) = 0
- Do i = 1, nprofiles
-
- istart = istop + 1
- istop = istart + kchan - 1
- kstart = kstop + 1
- kstop = kstart + nfreq - 1
- nchan = kchan
- jstart = jstop + 1
- jstop = jstart + kbtout -1
- ! transfer arrays to single profile arrays
- kpol(1:nchan,:) = polarisations(1:nchan,:) ! Note assumes first array is same for every prof
- kchannels(1:nfreq) = channels(kstart:kstop)
- kemissivity(1:nchan) = emissivity(istart:istop)
- kcalcemis(1:nchan) = calcemis(istart:istop)
-
- ! Allocate structure with arrays dimensioned to nchan
- Allocate( cld_radiance_ad % clear ( nchan ) )
- Allocate( cld_radiance_ad % clear_out( nchan ) )
- Allocate( cld_radiance_ad % cloudy ( nchan ) )
- Allocate( cld_radiance_ad % total ( nchan ) )
- Allocate( cld_radiance_ad % total_out( nchan ) )
- Allocate( cld_radiance_ad % bt ( nchan ) )
- Allocate( cld_radiance_ad % bt_clear ( nchan ) )
- Allocate( cld_radiance_ad % out_clear( nchan ) )
- Allocate( cld_radiance_ad % out ( nchan ) )
- Allocate( cld_radiance_ad % upclear ( nchan ) )
- Allocate( cld_radiance_ad % reflclear( nchan ) )
- Allocate( cld_radiance_ad % overcast ( cld_profiles(1) % nlevels, nchan ) )
- Allocate( cld_radiance_ad % downcld ( cld_profiles(1) % nlevels, nchan ) )
- Allocate( cld_radiance_ad % cldemis ( cld_profiles(1) % nlevels, nchan ) )
- Allocate( cld_radiance_ad % wtoa ( cld_profiles(1) % nlevels, nchan ) )
- Allocate( cld_radiance_ad % wsurf ( cld_profiles(1) % nlevels, nchan ) )
- Allocate( cld_radiance_ad % cs_wtoa ( nchan ) )
- Allocate( cld_radiance_ad % cs_wsurf ( nchan ) )
- Allocate( cld_rad % clear ( nchan ) )
- Allocate( cld_rad % clear_out( nchan ) )
- Allocate( cld_rad % cloudy ( nchan ) )
- Allocate( cld_rad % total ( nchan ) )
- Allocate( cld_rad % total_out( nchan ) )
- Allocate( cld_rad % bt ( nchan ) )
- Allocate( cld_rad % bt_clear ( nchan ) )
- Allocate( cld_rad % out ( nchan ) )
- Allocate( cld_rad % out_clear( nchan ) )
- Allocate( cld_rad % upclear ( nchan ) )
- Allocate( cld_rad % dnclear ( nchan ) )
- Allocate( cld_rad % reflclear( nchan ) )
- Allocate( cld_rad % overcast ( cld_profiles(1) % nlevels, nchan ) )
- Allocate( cld_rad % downcld ( cld_profiles(1) % nlevels, nchan ) )
- Allocate( cld_rad % cldemis ( cld_profiles(1) % nlevels, nchan ) )
- Allocate( cld_rad % wtoa ( cld_profiles(1) % nlevels, nchan ) )
- Allocate( cld_rad % wsurf ( cld_profiles(1) % nlevels, nchan ) )
- Allocate( cld_rad % cs_wtoa ( nchan ) )
- Allocate( cld_rad % cs_wsurf ( nchan ) )
-
- jcount = jstart-1
- kemis = istart
- Do j = istart, istop
- jcount = jcount + 1
- !
- ! Initialise AD input
- !
- cld_radiance_ad % clear (:) = 0._JPRB
- cld_radiance_ad % clear_out(:) = 0._JPRB
- cld_radiance_ad % cloudy (:) = 0._JPRB
- cld_radiance_ad % total (:) = 0._JPRB
- cld_radiance_ad % total_out(:) = 0._JPRB
- cld_radiance_ad % bt (:) = 0._JPRB
- cld_radiance_ad % bt_clear (:) = 0._JPRB
- cld_radiance_ad % out (:) = 0._JPRB
- cld_radiance_ad % out_clear(:) = 0._JPRB
- cld_radiance_ad % upclear (:) = 0._JPRB
- cld_radiance_ad % reflclear(:) = 0._JPRB
- cld_radiance_ad % overcast (:,:) = 0._JPRB
- cld_radiance_ad % downcld (:,:) = 0._JPRB
- cld_radiance_ad % cldemis (:,:) = 0._JPRB
- cld_radiance_ad % wtoa (:,:) = 0._JPRB
- cld_radiance_ad % wsurf (:,:) = 0._JPRB
- cld_radiance_ad % cs_wtoa (:) = 0._JPRB
- cld_radiance_ad % cs_wsurf (:) = 0._JPRB
- If ( switchrad ) Then
- cld_radiance_ad % out (j - istart + 1) = 1._JPRB
- Else
- cld_radiance_ad % total_out (j - istart + 1) = 1._JPRB
- Endif
- !
- ! Initialise AD output
- !
- profiles_ad(1) % ozone_Data = .False. ! no meaning
- profiles_ad(1) % co2_Data = .False. ! no meaning
- profiles_ad(1) % clw_Data = .False. ! no meaning
- profiles_ad(1) % zenangle = -1 ! no meaning
-
- ! increments for atmospheric variables
- profiles_ad(1) % p(:) = 0._JPRB ! no AD on pressure levels
- profiles_ad(1) % t(:) = 0._JPRB ! temperarure
- profiles_ad(1) % o3(:) = 0._JPRB ! O3 ppmv
- profiles_ad(1) % clw(:) = 0._JPRB ! clw
- profiles_ad(1) % q(:) = 0._JPRB ! WV
-
- ! increments for air surface variables
- profiles_ad(1) % s2m % t = 0._JPRB! temperarure
- profiles_ad(1) % s2m % q = 0._JPRB ! WV
- profiles_ad(1) % s2m % o = 0._JPRB ! O3
- profiles_ad(1) % s2m % p = 0._JPRB! pressure
- profiles_ad(1) % s2m % u = 0._JPRB! wind components
- profiles_ad(1) % s2m % v = 0._JPRB! wind components
-
- ! increments for skin variables
- profiles_ad(1) % skin % surftype = -1 ! no meaning
- profiles_ad(1) % skin % t = 0._JPRB ! on temperarure
- profiles_ad(1) % skin % fastem = 0._JPRB
-
- ! increments for cloud variables
- profiles_ad(1) % ctp = 0._JPRB ! pressure
- profiles_ad(1) % cfraction = 0._JPRB ! cloud fraction
-
- ! Cloud profiles
- cld_profiles_ad(1) % p (:) = 0._JPRB
- cld_profiles_ad(1) % ph (:) = 0._JPRB
- cld_profiles_ad(1) % t (:) = 0._JPRB
- cld_profiles_ad(1) % cc (:) = 0._JPRB
- cld_profiles_ad(1) % clw(:) = 0._JPRB
- cld_profiles_ad(1) % ciw(:) = 0._JPRB
-
- ! surface emissivity
- emissivity_ad(:) = 0._JPRB
-
- Call Rttov_cld_ad ( &
- & errorstatus(i), &! out
- & nfreq, &! in
- & nchan, &! in
- & kbtout, &! in
- & nprof, &! in
- & kchannels, &! in
- & kpol, &! in
- & lprof, &! in
- & profiles(i), &! in
- & cld_profiles(i), &! in
- & coef, &! in
- & switchrad, &! in
- & kcalcemis, &! in
- & kemissivity, &! inout
- & profiles_ad, &! inout
- & cld_profiles_ad, &! inout
- & emissivity_ad, &! inout
- & cld_rad, &! inout
- & cld_radiance_ad ) ! inout
-
- If ( errorstatus(i) == errorstatus_fatal ) Then
- Write( errMessage, '( "error in rttov_cld_ad")' )
- Call Rttov_ErrorReport (errorstatus_fatal, errMessage, NameOfRoutine)
- Return
- End If
-
- !
- ! Save derivatives for that profile and that channel in K matrix
- !
-
- If (jcount <= jstop) Then
- ! increments for atmospheric variables
- profiles_k(jcount) % t(:) = profiles_ad(1) % t(:)
- profiles_k(jcount) % o3(:) = profiles_ad(1) % o3(:)
- profiles_k(jcount) % q(:) = profiles_ad(1) % q(:)
-
- ! increments for air surface variables
- profiles_k(jcount) % s2m % t = profiles_ad(1) % s2m % t
- profiles_k(jcount) % s2m % q = profiles_ad(1) % s2m % q
- profiles_k(jcount) % s2m % o = profiles_ad(1) % s2m % o
- profiles_k(jcount) % s2m % p = profiles_ad(1) % s2m % p
- profiles_k(jcount) % s2m % u = profiles_ad(1) % s2m % u
- profiles_k(jcount) % s2m % v = profiles_ad(1) % s2m % v
-
- ! increments for skin variables
- profiles_k(jcount) % skin % t = profiles_ad(1) % skin % t
- profiles_k(jcount) % skin % fastem = profiles_ad(1) % skin % fastem
-
- ! Cloud profiles
- cld_profiles_k(jcount) % p (:) = cld_profiles_ad(1) % p (:)
- cld_profiles_k(jcount) % ph (:) = cld_profiles_ad(1) % ph (:)
- cld_profiles_k(jcount) % t (:) = cld_profiles_ad(1) % t (:)
- cld_profiles_k(jcount) % cc (:) = cld_profiles_ad(1) % cc (:)
- cld_profiles_k(jcount) % clw(:) = cld_profiles_ad(1) % clw(:)
- cld_profiles_k(jcount) % ciw(:) = cld_profiles_ad(1) % ciw(:)
- Endif
-
- ! increments for surface emissivity
- If ( kemis <= istop )Then
- jj = kpol(j-istart+1,2)
- Do k = 1 , kpol(jj,3)
- emissivity_k(kemis) = emissivity_ad(kemis-istart+1)
- kemis = kemis + 1
- Enddo
- Endif
-
- ! Save cloudy radiance/brightness temperature
- total_ref(istart:istop) = cld_rad % total (1:nchan)
- bt_ref (istart:istop) = cld_rad % bt (1:nchan)
-
- Enddo
-
- ! Deallocate structure with arrays dimensioned to nchan
- Deallocate( cld_radiance_ad % clear )
- Deallocate( cld_radiance_ad % clear_out )
- Deallocate( cld_radiance_ad % cloudy )
- Deallocate( cld_radiance_ad % total )
- Deallocate( cld_radiance_ad % total_out )
- Deallocate( cld_radiance_ad % bt )
- Deallocate( cld_radiance_ad % bt_clear )
- Deallocate( cld_radiance_ad % out )
- Deallocate( cld_radiance_ad % out_clear )
- Deallocate( cld_radiance_ad % upclear )
- Deallocate( cld_radiance_ad % reflclear )
- Deallocate( cld_radiance_ad % overcast )
- Deallocate( cld_radiance_ad % downcld )
- Deallocate( cld_radiance_ad % cldemis )
- Deallocate( cld_radiance_ad % wtoa )
- Deallocate( cld_radiance_ad % wsurf )
- Deallocate( cld_radiance_ad % cs_wtoa )
- Deallocate( cld_radiance_ad % cs_wsurf )
- Deallocate( cld_rad % clear )
- Deallocate( cld_rad % clear_out )
- Deallocate( cld_rad % cloudy )
- Deallocate( cld_rad % total )
- Deallocate( cld_rad % total_out )
- Deallocate( cld_rad % bt )
- Deallocate( cld_rad % bt_clear )
- Deallocate( cld_rad % out )
- Deallocate( cld_rad % out_clear )
- Deallocate( cld_rad % upclear )
- Deallocate( cld_rad % dnclear )
- Deallocate( cld_rad % reflclear )
- Deallocate( cld_rad % overcast )
- Deallocate( cld_rad % downcld )
- Deallocate( cld_rad % cldemis )
- Deallocate( cld_rad % wtoa )
- Deallocate( cld_rad % wsurf )
- Deallocate( cld_rad % cs_wtoa )
- Deallocate( cld_rad % cs_wsurf )
- Enddo
-
- Do j = 1, nchan
- profiles_k(j) % p(:) = 0._JPRB
- profiles_k(j) % clw(:) = 0._JPRB
- profiles_k(j) % ctp = 0._JPRB
- profiles_k(j) % cfraction = 0._JPRB
- Enddo
-
- ! Get correct values of cloudy radiance/brightness temperature
- cld_radiance % total (:) = total_ref(:)
- cld_radiance % bt (:) = bt_ref (:)
-
-
- Do j = 1, nprof
- Deallocate( profiles_ad(j) % p )
- Deallocate( profiles_ad(j) % t )
- Deallocate( profiles_ad(j) % q )
- Deallocate( profiles_ad(j) % o3 )
- Deallocate( profiles_ad(j) % clw)
- End do
- Do j = 1, nprof
- Deallocate( cld_profiles_ad(j) % p )
- Deallocate( cld_profiles_ad(j) % ph )
- Deallocate( cld_profiles_ad(j) % t )
- Deallocate( cld_profiles_ad(j) % cc )
- Deallocate( cld_profiles_ad(j) % clw)
- Deallocate( cld_profiles_ad(j) % ciw)
- End do
-
-
-End Subroutine Rttov_cld_k
diff --git a/src/LIB/RTTOV/src/rttov_cld_k.interface b/src/LIB/RTTOV/src/rttov_cld_k.interface
deleted file mode 100644
index 04f38da1e1d3a0272f5d3103245009b1057fcb92..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_cld_k.interface
+++ /dev/null
@@ -1,61 +0,0 @@
-Interface
-Subroutine Rttov_cld_k ( &
- errorstatus, & ! out
- nfrequencies, & ! in
- nchannels, & ! in
- nbtout, & ! in
- nprofiles, & ! in
- channels, & ! in
- polarisations, & ! in
- lprofiles, & ! in
- profiles, & ! in
- cld_profiles, & ! in
- coef, & ! in
- switchrad, & ! in
- calcemis, & ! in
- emissivity, & ! inout
- profiles_k , & ! inout
- cld_profiles_k ,& ! inout
- emissivity_k , & ! inout
- cld_radiance) ! inout
-
-
- Use rttov_const, Only : &
- errorstatus_success ,&
- errorstatus_fatal ,&
- overlap_scheme
-
- Use rttov_types, Only : &
- rttov_coef ,&
- geometry_Type ,&
- profile_Type ,&
- profile_cloud_Type ,&
- radiance_cloud_Type
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
- Integer(Kind=jpim), Intent(in) :: nfrequencies
- Integer(Kind=jpim), Intent(in) :: nchannels
- Integer(Kind=jpim), Intent(in) :: nbtout
- Integer(Kind=jpim), Intent(in) :: nprofiles
- Integer(Kind=jpim), Intent(in) :: channels(nfrequencies)
- Integer(Kind=jpim), Intent(in) :: polarisations(nchannels,3)
- Integer(Kind=jpim), Intent(in) :: lprofiles(nfrequencies)
- Logical, Intent(in) :: switchrad ! true if input is BT
- Type(profile_Type), Intent(inout) :: profiles(nprofiles)
- Type(profile_cloud_Type), Intent(in) :: cld_profiles(nprofiles)
- Type(rttov_coef), Intent(in) :: coef
- Logical, Intent(in) :: calcemis(nchannels)
- Real(Kind=jprb), Intent(inout) :: emissivity(nchannels)
- Type(radiance_cloud_type), Intent(inout) :: cld_radiance! in because of meme allocation
-
-
- Type(profile_Type), Intent(inout) :: profiles_k(nchannels)
- Type(profile_cloud_Type), Intent(inout) :: cld_profiles_k(nchannels)
- Real(Kind=jprb), Intent(inout) :: emissivity_k(nchannels)
- Integer(Kind=jpim), Intent(out) :: errorstatus(nprofiles)
-
-
-End Subroutine Rttov_cld_k
-End Interface
diff --git a/src/LIB/RTTOV/src/rttov_cld_profout_k.F90 b/src/LIB/RTTOV/src/rttov_cld_profout_k.F90
deleted file mode 100644
index 440182369ed1b5277bf44bf7dc9fd490822088f5..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_cld_profout_k.F90
+++ /dev/null
@@ -1,171 +0,0 @@
-!
-Subroutine rttov_cld_profout_k( &
- nfrequencies, & ! in
- nchannels, & ! in
- nbtout, & ! in
- nprofiles, & ! in
- channels, & ! in
- lprofiles, & ! in
- polarisations, & ! in
- coef, & ! in
- geometry, & ! in
- cld_profiles_k_all, & ! in
- cld_profiles_k) ! Out
- ! Description:
- ! To convert an K-matrix brightness temperatures with 1, 2 or 4 polarisations
- ! polarisation requested by the user.
- ! There are seven options:
- ! 0. Return average of V and H polarisation.
- ! 1. Return AMSU-style mix polarisation (nominal V at nadir)
- ! 2. Return AMSU-style mix polarisation (nominal H at nadir)
- ! 3. Return Vertical polarisation
- ! 4. Return Horizontal polarisation
- ! 5. Return vertical and horizontal polarisation
- ! 6. Return full Stokes vector
- !
- ! For IR channels this variable is not required, and one unpolarised brightness
- ! temperature is computed.
- !
- ! Note options 0-4 return one polarisation per channel. Option 5 returns
- ! 2 polarisations per channel and option 6 four polarisations per channel.
- ! Note also that for options 1-3 two polarisations must be computed in RTTOV,
- ! even though only one is returned. For this reason rad%bt is replaced by
- ! rad%out, where rad%out has length of number of output channels, whereas
- ! rad%bt has length of all brightness temperatures computed in RTTOV.
- !
- ! Copyright:
- ! This software was developed within the context of
- ! the EUMETSAT Satellite Application Facility on
- ! Numerical Weather Prediction (NWP SAF), under the
- ! Cooperation Agreement dated 25 November 1998, between
- ! EUMETSAT and the Met Office, UK, by one or more partners
- ! within the NWP SAF. The partners in the NWP SAF are
- ! the Met Office, ECMWF, KNMI and MeteoFrance.
- !
- ! Copyright 2003, EUMETSAT, All Rights Reserved.
- !
- ! Method: Uses band correction coefficients for each channel
- ! read in from RT coefficient file.
- !
- ! Current Code Owner: SAF NWP
- !
- ! History:
- ! Version Date Comment
- ! ------- ---- -------
- ! 1.0 10/07/2003 New code required for polarimetric RTTOV (Steve English)
- ! 1.1 13/10/2006 Corrected bug in pol_id (R Saunders)
- ! Code Description:
- ! Language: Fortran 90.
- ! Software Standards: "European Standards for Writing and
- ! Documenting Exchangeable Fortran 90 Code".
- !
- ! Declarations:
- ! Modules used:
- ! Imported Type Definitions:
-
- Use rttov_const, only : &
- npolar_return, &
- npolar_compute, &
- pol_v , &
- pol_h
-
- Use rttov_types, Only : &
- rttov_coef, &
- profile_cloud_Type, &
- geometry_Type
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
- !subroutine arguments:
- Integer(Kind=jpim), Intent(in) :: nbtout
- Integer(Kind=jpim), Intent(in) :: nchannels
- Integer(Kind=jpim), Intent(in) :: nfrequencies
- Integer(Kind=jpim), Intent(in) :: nprofiles
- Type(geometry_Type), Intent(in) ,Target :: geometry(nprofiles)
- Integer(Kind=jpim), Intent(in) :: channels(nfrequencies)
- Integer(Kind=jpim), Intent(in) :: polarisations(nchannels,3)
- Integer(Kind=jpim), Intent(in) :: lprofiles(nfrequencies)
- Type(rttov_coef), Intent(in) :: coef ! Coefficients
- Type(profile_cloud_Type), Intent(inout) ,Target :: cld_profiles_k(nbtout)
- Type(profile_cloud_Type), Intent(inout) ,Target :: cld_profiles_k_all(nchannels)
-
- ! radiances are expressed in mw/cm-1/ster/sq.m
- ! and temperatures in Kelvin
-
- !local variables:
- Real(Kind=jprb) :: emissfactor_h,emissfactor_v
- Integer(Kind=jpim) :: chan,i,j,ich,ich2,pol_id,ii,nwp_levels
- !Type(geometry_Type), Pointer :: geom
-
- !- End of header ------------------------------------------------------
-
- nwp_levels = cld_profiles_k(1)%nlevels
-
- ich2=1
- Do i=1,nfrequencies
- chan = channels(i)
- pol_id = 0
- pol_id = coef % fastem_polar(chan) + 1
- ich = polarisations(i,1)
- If (pol_id >= 4) then
- ! Return all calculated polarisations (or just computed TB for IR channels)
- Do j=1,polarisations(i,3)
- Do ii=1,nwp_levels
- cld_profiles_k(ich2+j-1) % p(ii) = cld_profiles_k_all(ich+j-1) % p(ii)
- cld_profiles_k(ich2+j-1) % ph(ii) = cld_profiles_k_all(ich+j-1) % ph(ii)
- cld_profiles_k(ich2+j-1) % t(ii) = cld_profiles_k_all(ich+j-1) % t(ii)
- cld_profiles_k(ich2+j-1) % cc(ii) = cld_profiles_k_all(ich+j-1) % cc(ii)
- cld_profiles_k(ich2+j-1) % clw(ii) = cld_profiles_k_all(ich+j-1) % clw(ii)
- cld_profiles_k(ich2+j-1) % ciw(ii) = cld_profiles_k_all(ich+j-1) % ciw(ii)
- cld_profiles_k(ich2+j-1) % rain(ii) = cld_profiles_k_all(ich+j-1) % rain(ii)
- cld_profiles_k(ich2+j-1) % sp(ii) = cld_profiles_k_all(ich+j-1) % sp(ii)
- enddo
- cld_profiles_k(ich2+j-1) % ph(nwp_levels+1) = cld_profiles_k_all(ich+j-1) % ph(nwp_levels+1)
- End Do
- Else If (pol_id == 1) then
- ! Return average of V and H polarisation
- Do ii=1,nwp_levels
- cld_profiles_k(ich2) % p(ii) = cld_profiles_k_all(ich) % p(ii) + cld_profiles_k_all(ich+1) % p(ii)
- cld_profiles_k(ich2) % ph(ii) = cld_profiles_k_all(ich) % ph(ii) + cld_profiles_k_all(ich+1) % ph(ii)
- cld_profiles_k(ich2) % t(ii) = cld_profiles_k_all(ich) % t(ii) + cld_profiles_k_all(ich+1) % t(ii)
- cld_profiles_k(ich2) % cc(ii) = cld_profiles_k_all(ich) % cc(ii) + cld_profiles_k_all(ich+1) % cc(ii)
- cld_profiles_k(ich2) % clw(ii) = cld_profiles_k_all(ich) % clw(ii) + cld_profiles_k_all(ich+1) % clw(ii)
- cld_profiles_k(ich2) % ciw(ii) = cld_profiles_k_all(ich) % ciw(ii) + cld_profiles_k_all(ich+1) % ciw(ii)
- cld_profiles_k(ich2) % rain(ii) = cld_profiles_k_all(ich) % rain(ii) + cld_profiles_k_all(ich+1) % rain(ii)
- cld_profiles_k(ich2) % sp(ii) = cld_profiles_k_all(ich) % sp(ii) + cld_profiles_k_all(ich+1) % sp(ii)
- enddo
- cld_profiles_k(ich2) % ph(nwp_levels+1) = cld_profiles_k_all(ich) % ph(nwp_levels+1) + &
- cld_profiles_k_all(ich+1) % ph(nwp_levels+1)
- Else
- !geom => geometry( lprofiles(i) )
- emissfactor_v = pol_v(1,pol_id)+pol_v(2,pol_id)+pol_v(3,pol_id)
- emissfactor_h = pol_h(1,pol_id)+pol_h(2,pol_id)+pol_h(3,pol_id)
- Do ii=1,nwp_levels
- cld_profiles_k(ich2) % p(ii) = cld_profiles_k_all(ich) % p(ii)*emissfactor_v +&
- cld_profiles_k_all(ich+1) % p(ii)*emissfactor_h
- cld_profiles_k(ich2) % ph(ii) = cld_profiles_k_all(ich) % ph(ii)*emissfactor_v +&
- cld_profiles_k_all(ich+1) % ph(ii)*emissfactor_h
- cld_profiles_k(ich2) % t(ii) = cld_profiles_k_all(ich) % t(ii)*emissfactor_v + &
- cld_profiles_k_all(ich+1) % t(ii)*emissfactor_h
- cld_profiles_k(ich2) % cc(ii) = cld_profiles_k_all(ich) % cc(ii)*emissfactor_v + &
- cld_profiles_k_all(ich+1) % cc(ii)*emissfactor_h
- cld_profiles_k(ich2) % clw(ii) = cld_profiles_k_all(ich) % clw(ii)*emissfactor_v + &
- cld_profiles_k_all(ich+1) % clw(ii)*emissfactor_h
- cld_profiles_k(ich2) % ciw(ii) = cld_profiles_k_all(ich) % ciw(ii)*emissfactor_v + &
- cld_profiles_k_all(ich+1) % ciw(ii)*emissfactor_h
- cld_profiles_k(ich2) % rain(ii) = cld_profiles_k_all(ich) % rain(ii)*emissfactor_v + &
- cld_profiles_k_all(ich+1) % rain(ii)*emissfactor_h
- cld_profiles_k(ich2) % sp(ii) = cld_profiles_k_all(ich) % sp(ii)*emissfactor_v + &
- cld_profiles_k_all(ich+1) % sp(ii)*emissfactor_h
- enddo
- cld_profiles_k(ich2) % ph(nwp_levels+1) = cld_profiles_k_all(ich) % ph(nwp_levels+1)*emissfactor_v +&
- cld_profiles_k_all(ich+1) % ph(nwp_levels+1)*emissfactor_h
- End If
- ich2 = ich2 + npolar_return(pol_id)
- End Do
-End Subroutine rttov_cld_profout_k
-
-
-
-
diff --git a/src/LIB/RTTOV/src/rttov_cld_profout_k.interface b/src/LIB/RTTOV/src/rttov_cld_profout_k.interface
deleted file mode 100644
index d13d1b4c1b0dcf0e76affb8af4c743dd995acfd0..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_cld_profout_k.interface
+++ /dev/null
@@ -1,43 +0,0 @@
-Interface
-Subroutine rttov_cld_profout_k( &
- nfrequencies, & ! in
- nchannels, & ! in
- nbtout, & ! in
- nprofiles, & ! in
- channels, & ! in
- lprofiles, & ! in
- polarisations, & ! in
- coef, & ! in
- geometry, & ! in
- cld_profiles_k_all, & ! in
- cld_profiles_k) ! Out
-
- Use rttov_const, only : &
- npolar_return, &
- npolar_compute, &
- pol_v , &
- pol_h
-
- Use rttov_types, Only : &
- rttov_coef, &
- profile_cloud_Type, &
- geometry_Type
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
- !subroutine arguments:
- Integer(Kind=jpim), Intent(in) :: nbtout
- Integer(Kind=jpim), Intent(in) :: nchannels
- Integer(Kind=jpim), Intent(in) :: nfrequencies
- Integer(Kind=jpim), Intent(in) :: nprofiles
- Type(geometry_Type), Intent(in) ,Target :: geometry(nprofiles)
- Integer(Kind=jpim), Intent(in) :: channels(nfrequencies)
- Integer(Kind=jpim), Intent(in) :: polarisations(nchannels,3)
- Integer(Kind=jpim), Intent(in) :: lprofiles(nfrequencies)
- Type(rttov_coef), Intent(in) :: coef ! Coefficients
- Type(profile_cloud_Type), Intent(inout) ,Target :: cld_profiles_k(nbtout)
- Type(profile_cloud_Type), Intent(inout) ,Target :: cld_profiles_k_all(nchannels)
-
-End Subroutine rttov_cld_profout_k
-End Interface
diff --git a/src/LIB/RTTOV/src/rttov_cld_tl.F90 b/src/LIB/RTTOV/src/rttov_cld_tl.F90
deleted file mode 100644
index f4db30ea748fd88134aafa238f764deac9786376..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_cld_tl.F90
+++ /dev/null
@@ -1,409 +0,0 @@
-Subroutine Rttov_cld_tl ( &
- & errorstatus, &! out
- & nfrequencies, &! in
- & nchannels, &! in
- & nbtout, &! in
- & nprofiles, &! in
- & channels, &! in
- & polarisations, &! in
- & lprofiles, &! in
- & profiles, &! in
- & cld_profiles, &! in
- & coef, &! in
- & calcemis, &! in
- & emissivity, &! inout
- & profiles_tl, &! in
- & cld_profiles_tl, &! in
- & emissivity_tl, &! inout
- & cld_radiance, &! inout
- & cld_radiance_tl ) ! inout
- ! Description:
- ! to compute multi-channel radiances and brightness
- ! temperatures for many profiles per call in a cloudy sky.
- !
- ! Copyright:
- ! This software was developed within the context of
- ! the EUMETSAT Satellite Application Facility on
- ! Numerical Weather Prediction (NWP SAF), under the
- ! Cooperation Agreement dated 25 November 1998, between
- ! EUMETSAT and the Met Office, UK, by one or more partners
- ! within the NWP SAF. The partners in the NWP SAF are
- ! the Met Office, ECMWF, KNMI and MeteoFrance.
- !
- ! Copyright 2002, EUMETSAT, All Rights Reserved.
- !
- ! Method:
- ! See Chevallier, F., P. Bauer, G. A. Kelly, C. Jakob,
- ! and T. McNally, 2001 Model clouds over oceans as seen
- ! from space: comparison with HIRS/2 and MSU radiances.
- ! J. Climate 14 4216-4229.
- !
- ! Current Code Owner: SAF NWP
- !
- ! History:
- ! Version Date Comment
- ! ------- ---- -------
- ! 1.0 03/2001 Initial version (F. Chevallier)
- ! 1.1 19/7/2001 Version for testing RTTOV-7 (R. Saunders)
- ! 2.0 01/12/2002 New F90 code with structures (P Brunel A Smith)
- ! 2.1 02/01/2002 Comments added (R Saunders)
- ! 2.2 08/01/04 Added polarisation (S English)
- ! 2.3 06/10/04 Add errorstatus to rttov_emiscld_tl call (J Cameron)
- ! 2.4 29/03/2005 Add end of header comment (J. Cameron)
- !
- ! Code Description:
- ! Language: Fortran 90.
- ! Software Standards: "European Standards for Writing and
- ! Documenting Exchangeable Fortran 90 Code".
- !
- ! Declarations:
- ! Modules used:
- ! Imported Parameters:
-
- Use rttov_const, Only : &
- & sensor_id_mw ,&
- & errorstatus_success ,&
- & errorstatus_fatal ,&
- & overlap_scheme
-
- Use rttov_types, Only : &
- & rttov_coef ,&
- & geometry_Type ,&
- & profile_Type ,&
- & profile_cloud_Type ,&
- & transmission_Type ,&
- & radiance_Type ,&
- & radiance_cloud_Type
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-#include "rttov_tl.interface"
-! include "rttov_intradov_tl.interface"
-#include "rttov_intex_tl.interface"
-#include "rttov_emiscld_tl.interface"
-#include "rttov_aitosu_tl.interface"
-#include "rttov_errorreport.interface"
-#include "rttov_calcbt.interface"
-#include "rttov_calcbt_tl.interface"
-#include "rttov_setgeometry.interface"
-#include "rttov_calcpolarisation.interface"
-#include "rttov_calcpolarisation_tl.interface"
-
- !subroutine arguments:
- Integer(Kind=jpim), Intent(in) :: nfrequencies
- Integer(Kind=jpim), Intent(in) :: nchannels
- Integer(Kind=jpim), Intent(in) :: nbtout
- Integer(Kind=jpim), Intent(in) :: nprofiles
- Integer(Kind=jpim), Intent(in) :: channels(nfrequencies)
- Integer(Kind=jpim), Intent(in) :: polarisations(nchannels,3)
- Integer(Kind=jpim), Intent(in) :: lprofiles(nfrequencies)
- Type(profile_Type), Intent(inout) :: profiles(nprofiles)
- Type(profile_cloud_Type), Intent(in) :: cld_profiles(nprofiles)
- Type(rttov_coef), Intent(in) :: coef
- Logical, Intent(in) :: calcemis(nchannels)
- Real(Kind=jprb), Intent(inout) :: emissivity(nchannels)
- Type(radiance_cloud_type), Intent(inout) :: cld_radiance! in because of meme allocation
-
-
- Type(profile_Type), Intent(in) :: profiles_tl(nprofiles)
- Type(profile_cloud_Type), Intent(in) :: cld_profiles_tl(nprofiles)
- Real(Kind=jprb), Intent(inout) :: emissivity_tl(nchannels)
- Type(radiance_cloud_type), Intent(inout) :: cld_radiance_tl ! in because of meme allocation
- Integer(Kind=jpim), Intent(out) :: errorstatus(nprofiles)
-
- !local variables:
- Logical :: addcloud
- Integer(Kind=jpim) :: nwp_levels ! number of levels for NWP profiles
- Integer(Kind=jpim) :: nrt_levels ! number of levels for RTTOV_direct integration
- Integer(Kind=jpim) :: jl ! loop indice
- Integer(Kind=jpim) :: jk ! loop indice
- Integer(Kind=jpim) :: ipf ! loop indice
- Integer(Kind=jpim) :: alloc_status(20)
- Character (len=80) :: errMessage
- Character (len=12) :: NameOfRoutine = 'rttov_cld_tl'
-
- Real(Kind=jprb) :: null_press(coef%nlevels)
- Integer(Kind=jpim) :: freq
- Type(geometry_Type):: angles(nprofiles) ! geometry angles
- Type(radiance_Type) :: radiance
- Type(radiance_Type) :: radiance_tl
- Type(transmission_Type) :: transmission
- Type(transmission_Type) :: transmission_tl
-
- !- End of header --------------------------------------------------------
-
- errorstatus(:) = errorstatus_success
- alloc_status(:) = 0
-
- ! allocate radiance results arrays with number of channels
- radiance % clear => cld_radiance % clear
- radiance % clear_out => cld_radiance % clear_out
- radiance % cloudy => cld_radiance % cloudy
- radiance % total => cld_radiance % total
- radiance % total_out => cld_radiance % total_out
- radiance % bt => cld_radiance % bt
- radiance % bt_clear => cld_radiance % bt_clear
- radiance % out => cld_radiance % out
- radiance % out_clear => cld_radiance % out_clear
- radiance % upclear => cld_radiance % upclear
- radiance % dnclear => cld_radiance % dnclear
- radiance % reflclear => cld_radiance % reflclear
- allocate( radiance % overcast ( coef % nlevels, nchannels ) ,stat= alloc_status(1))
- allocate( radiance % downcld ( coef % nlevels, nchannels ) ,stat= alloc_status(2))
-
- ! allocate radiance TL results arrays with number of channels
- radiance_tl % clear => cld_radiance_tl % clear
- radiance_tl % clear_out => cld_radiance_tl % clear_out
- radiance_tl % cloudy => cld_radiance_tl % cloudy
- radiance_tl % total => cld_radiance_tl % total
- radiance_tl % total_out => cld_radiance_tl % total_out
- radiance_tl % bt => cld_radiance_tl % bt
- radiance_tl % bt_clear => cld_radiance_tl % bt_clear
- radiance_tl % out => cld_radiance_tl % out
- radiance_tl % out_clear => cld_radiance_tl % out_clear
- radiance_tl % upclear => cld_radiance_tl % upclear
- radiance_tl % reflclear => cld_radiance_tl % reflclear
- allocate( radiance_tl % overcast ( coef % nlevels, nchannels ) ,stat= alloc_status(3))
- allocate( radiance_tl % downcld ( coef % nlevels, nchannels ) ,stat= alloc_status(4))
-
- ! allocate transmission arrays
- Allocate( transmission % tau_surf ( nchannels ) ,stat= alloc_status(5))
- Allocate( transmission % tau_layer ( coef % nlevels, nchannels ) ,stat= alloc_status(6))
- Allocate( transmission % od_singlelayer( coef % nlevels, nchannels ) ,stat= alloc_status(7))
- Allocate( transmission_tl % tau_surf ( nchannels ) ,stat= alloc_status(8))
- Allocate( transmission_tl % tau_layer ( coef % nlevels, nchannels ) ,stat= alloc_status(9))
- Allocate( transmission_tl % od_singlelayer( coef % nlevels, nchannels ) ,stat= alloc_status(10))
-
- If( any(alloc_status /= 0) ) then
- errorstatus(:) = errorstatus_fatal
- Write( errMessage, '( "mem allocation error")' )
- Call Rttov_ErrorReport (errorstatus_fatal, errMessage, NameOfRoutine)
- Return
- End If
-
-
- !* 1. Gas absorption
-
- addcloud = .true.
-
- ! No calculation of CLW absorption inside "classical" RTTOV
- if ( any(.not.profiles(:)%clw_data) ) then
- ! warning message
- profiles(:)%clw_data = .false.
- End If
-
- Call rttov_tl( &
- & errorstatus, &! out
- & nfrequencies, &! in
- & nchannels, &! in
- & nbtout, &! in
- & nprofiles, &! in
- & channels, &! in
- & polarisations, &! in
- & lprofiles, &! in
- & profiles, &! in
- & coef, &! in
- & addcloud, &! in
- & calcemis, &! in
- & emissivity, &! inout
- & profiles_tl, &! in
- & emissivity_tl, &! inout
- & transmission, &! inout
- & transmission_tl, &! inout
- & radiance, &! inout
- & radiance_tl ) ! inout
-
- If ( any( errorstatus(:) == errorstatus_fatal ) ) Then
- Write( errMessage, '( "error in rttov_tl")' )
- Call Rttov_ErrorReport (errorstatus_fatal, errMessage, NameOfRoutine)
- Return
- End If
-
- !* 2. Interpolate cloud contribution to model levels
- ! compute arrays overcast, downcld of type cld_radiancedata
- nwp_levels = cld_profiles(1) % nlevels
- nrt_levels = profiles(1) % nlevels
- null_press(:) = 0._JPRB
- DO jl = 1, nchannels
- freq = polarisations(jl,2)
- ipf = lprofiles(freq)
- call rttov_intex_tl( &
- & nrt_levels, &! in
- & nwp_levels, &! in
- & null_press, &! in
- & cld_profiles_tl(ipf) % p, &! in
- & radiance_tl % overcast(1:nrt_levels,jl), &! in
- & cld_radiance_tl % overcast(1:nwp_levels,jl), &! inout
- & profiles(ipf) % p, &! in
- & cld_profiles(ipf) % p, &! in
- & radiance % overcast(1:nrt_levels,jl), &! in
- & cld_radiance % overcast(1:nwp_levels,jl) ) ! out
-
- call rttov_intex_tl( &
- & nrt_levels, &! in
- & nwp_levels, &! in
- & null_press, &! in
- & cld_profiles_tl(ipf) % p, &! in
- & radiance_tl % downcld(1:nrt_levels,jl), &! in
- & cld_radiance_tl % downcld(1:nwp_levels,jl), &! inout
- & profiles(ipf) % p, &! in
- & cld_profiles(ipf) % p, &! in
- & radiance % downcld(1:nrt_levels,jl), &! in
- & cld_radiance % downcld(1:nwp_levels,jl) ) ! out
-
- End Do
-
- !* 3. Calculate cloud emissivity
- call rttov_emiscld_tl( &
- & errorstatus, &! out
- & nfrequencies, &! in
- & nchannels, &! in
- & nprofiles, &! in
- & nwp_levels, &! in
- & channels, &! in
- & polarisations, &! in
- & lprofiles, &! in
- & profiles, &! in (surftype and zenangle)
- & coef, &! in (frequencies mw/ir/hi)
- & cld_profiles, &! in
- & cld_profiles_tl, &! in
- & cld_radiance, &! inout (cldemis part only)
- & cld_radiance_tl) ! inout (cldemis part only)
- If ( any( errorstatus(:) == errorstatus_fatal ) ) Then
- Write( errMessage, '( "error in rttov_emiscld_tl")' )
- Call Rttov_ErrorReport (errorstatus_fatal, errMessage, NameOfRoutine)
- Return
- End If
-
- !* 4. Compute the weights of the cloud layers
- ! ---------------------------------------
- call rttov_aitosu_tl( &
- & nfrequencies, &! in
- & nchannels, &! in
- & nprofiles, &! in
- & nwp_levels, &! in
- & polarisations, &! in
- & lprofiles, &! in
- & overlap_scheme, &! in
- & cld_profiles, &! in (cloud cover)
- & cld_profiles_tl, &! in (cloud cover)
- & cld_radiance , &! inout (cldemis input and
- & cld_radiance_tl ) ! inout cs_wtao, cs_wsurf, wtao, wsurf in output)
-
- !* 5. Integrate *rt* equation.
- ! --------- ---- --------
- ! clear-sky contribution
- ! without the surface reflection
- cld_radiance % total (:) = cld_radiance % cs_wtoa(:) * cld_radiance % upclear (:)
- cld_radiance_tl % total (:) = cld_radiance_tl % cs_wtoa(:) * cld_radiance % upclear (:) +&
- & cld_radiance % cs_wtoa(:) * cld_radiance_tl % upclear (:)
-
- ! with the surface-reflected clear-sky downward radiance
- cld_radiance % total (:) = cld_radiance % total (:) +&
- & cld_radiance % cs_wsurf(:) * cld_radiance % cs_wtoa(:) *&
- & cld_radiance % reflclear (:)
- cld_radiance_tl % total (:) = cld_radiance_tl % total (:) +&
- & cld_radiance_tl%cs_wsurf(:) * cld_radiance %cs_wtoa(:) * cld_radiance %reflclear(:) +&
- & cld_radiance %cs_wsurf(:) * cld_radiance_tl%cs_wtoa(:) * cld_radiance %reflclear(:) +&
- & cld_radiance %cs_wsurf(:) * cld_radiance %cs_wtoa(:) * cld_radiance_tl%reflclear(:)
-
- ! cloud contribution
- DO jk = 1, nwp_levels
- ! cloud upward emission
- cld_radiance % total (:) = cld_radiance % total (:) +&
- & cld_radiance % wtoa(jk,:) * cld_radiance % overcast(jk,:)
- cld_radiance_tl % total (:) = cld_radiance_tl % total (:) +&
- & cld_radiance_tl % wtoa(jk,:) * cld_radiance % overcast(jk,:) +&
- & cld_radiance % wtoa(jk,:) * cld_radiance_tl % overcast(jk,:)
-
- ! cloud downward emission, reflected at the surface
- cld_radiance % total (:) = cld_radiance % total (:) +&
- & cld_radiance % wsurf(jk,:) * cld_radiance % cs_wtoa(:) *&
- & cld_radiance % downcld(jk,:)
- cld_radiance_tl % total (:) = cld_radiance_tl % total (:) +&
- & cld_radiance_tl%wsurf(jk,:) * cld_radiance %cs_wtoa(:) *&
- & cld_radiance %downcld(jk,:) +&
- & cld_radiance %wsurf(jk,:) * cld_radiance_tl%cs_wtoa(:) *&
- & cld_radiance %downcld(jk,:) +&
- & cld_radiance %wsurf(jk,:) * cld_radiance %cs_wtoa(:) *&
- & cld_radiance_tl%downcld(jk,:)
- END DO
-
- ! Remember that radiance struture is mainly pointing on cld_radiance
- ! so we can use radiance struture for conversion of radiance to brightness temperatue.
- Call rttov_calcbt( &
- & nfrequencies, &! in
- & nchannels, &! in
- & channels, &! in
- & polarisations, &! in
- & coef, &! in
- & radiance ) ! inout
- Call rttov_calcbt_tl( &
- & nfrequencies, &! in
- & nchannels, &! in
- & channels, &! in
- & polarisations, &! in
- & coef, &! in
- & radiance, &! in
- & radiance_tl ) ! inout
-
- If (coef % id_sensor == sensor_id_mw) Then
- Do ipf = 1, nprofiles
- Call rttov_setgeometry( &
- & profiles(ipf), &! in
- & coef, &! in
- & angles(ipf) ) ! out
- End Do
- !
- Call rttov_calcpolarisation( &
- & nfrequencies, &! in
- & nchannels, &! in
- & nprofiles, &! in
- & angles, &! in
- & channels, &! in
- & polarisations, &! in
- & lprofiles, &! in
- & coef, &! in
- & radiance ) ! inout
- Call rttov_calcpolarisation_tl( &
- & nfrequencies, &! in
- & nchannels, &! in
- & nprofiles, &! in
- & angles, &! in
- & channels, &! in
- & polarisations, &! in
- & lprofiles, &! in
- & coef, &! in
- & radiance_tl ) ! inout
- Else
- radiance%out = radiance%bt
- radiance%out_clear = radiance%bt_clear
- radiance%total_out = radiance%total
- radiance%clear_out = radiance%clear
- radiance_tl%out = radiance_tl%bt
- radiance_tl%out_clear = radiance_tl%bt_clear
- radiance_tl%total_out = radiance_tl%total
- radiance_tl%clear_out = radiance_tl%clear
- End If
- ! deallocate radiance structure for overcast and dowcld arrays
- deallocate( radiance % overcast ,stat= alloc_status(1))
- deallocate( radiance % downcld ,stat= alloc_status(2))
- deallocate( radiance_tl % overcast ,stat= alloc_status(3))
- deallocate( radiance_tl % downcld ,stat= alloc_status(4))
- ! deallocate transmission structure
- deallocate( transmission % tau_surf ,stat= alloc_status(5))
- deallocate( transmission % tau_layer ,stat= alloc_status(6))
- deallocate( transmission % od_singlelayer,stat= alloc_status(7))
- deallocate( transmission_tl % tau_surf ,stat= alloc_status(8))
- deallocate( transmission_tl % tau_layer ,stat= alloc_status(9))
- deallocate( transmission_tl % od_singlelayer,stat= alloc_status(10))
-
- If( any(alloc_status /= 0) ) then
- errorstatus(:) = errorstatus_fatal
- Write( errMessage, '( "mem deallocation error")' )
- Call Rttov_ErrorReport (errorstatus_fatal, errMessage, NameOfRoutine)
- Return
- End If
-
-
-End Subroutine Rttov_cld_tl
diff --git a/src/LIB/RTTOV/src/rttov_cld_tl.interface b/src/LIB/RTTOV/src/rttov_cld_tl.interface
deleted file mode 100644
index 486e30363e3279bd0d17ec6de520a26967eac87d..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_cld_tl.interface
+++ /dev/null
@@ -1,63 +0,0 @@
-Interface
-Subroutine Rttov_cld_tl ( &
- errorstatus, & ! out
- nfrequencies, & ! in
- nchannels, & ! in
- nbtout, & ! in
- nprofiles, & ! in
- channels, & ! in
- polarisations, & ! in
- lprofiles, & ! in
- profiles, & ! in
- cld_profiles, & ! in
- coef, & ! in
- calcemis, & ! in
- emissivity, & ! inout
- profiles_tl, & ! in
- cld_profiles_tl,& ! in
- emissivity_tl, & ! inout
- cld_radiance, & ! inout
- cld_radiance_tl ) ! inout
-
- Use rttov_const, Only : &
- errorstatus_success ,&
- errorstatus_fatal ,&
- overlap_scheme
-
- Use rttov_types, Only : &
- rttov_coef ,&
- geometry_Type ,&
- profile_Type ,&
- profile_cloud_Type ,&
- transmission_Type ,&
- radiance_Type ,&
- radiance_cloud_Type
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-! include "rttov_intradov_tl.h"
-
- Integer(Kind=jpim), Intent(in) :: nfrequencies
- Integer(Kind=jpim), Intent(in) :: nchannels
- Integer(Kind=jpim), Intent(in) :: nbtout
- Integer(Kind=jpim), Intent(in) :: nprofiles
- Integer(Kind=jpim), Intent(in) :: channels(nfrequencies)
- Integer(Kind=jpim), Intent(in) :: polarisations(nchannels,3)
- Integer(Kind=jpim), Intent(in) :: lprofiles(nfrequencies)
- Type(profile_Type), Intent(inout) :: profiles(nprofiles)
- Type(profile_cloud_Type), Intent(in) :: cld_profiles(nprofiles)
- Type(rttov_coef), Intent(in) :: coef
- Logical, Intent(in) :: calcemis(nchannels)
- Real(Kind=jprb), Intent(inout) :: emissivity(nchannels)
- Type(radiance_cloud_type), Intent(inout) :: cld_radiance! in because of meme allocation
-
-
- Type(profile_Type), Intent(in) :: profiles_tl(nprofiles)
- Type(profile_cloud_Type), Intent(in) :: cld_profiles_tl(nprofiles)
- Real(Kind=jprb), Intent(inout) :: emissivity_tl(nchannels)
- Type(radiance_cloud_type), Intent(inout) :: cld_radiance_tl ! in because of meme allocation
- Integer(Kind=jpim), Intent(out) :: errorstatus(nprofiles)
-
-
-End Subroutine Rttov_cld_tl
-End Interface
diff --git a/src/LIB/RTTOV/src/rttov_cmpuc.F90 b/src/LIB/RTTOV/src/rttov_cmpuc.F90
deleted file mode 100644
index 049c34b08551191384bf9ee9493d81d4f595f804..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_cmpuc.F90
+++ /dev/null
@@ -1,102 +0,0 @@
-!
-Function rttov_cmpuc (String1, String2)
- ! Description:
- ! compare 2 strings after removing all spaces, and upcase characters
- !
- ! Copyright:
- !
- ! This software was developed within the context of
- ! the EUMETSAT Satellite Application Facility on
- ! Numerical Weather Prediction (NWP SAF), under the
- ! Cooperation Agreement dated 25 November 1998, between
- ! EUMETSAT and the Met Office, UK, by one or more partners
- ! within the NWP SAF. The partners in the NWP SAF are
- ! the Met Office, ECMWF, KNMI and MeteoFrance.
- !
- ! Copyright 2002, EUMETSAT, All Rights Reserved.
- !
- Use parkind1, Only : jpim ,jprb
- Implicit None
- !
- ! Method:
- ! reduce string 1 , upcase string 1
- ! same for string 2
- ! compare strings
- !
- ! Current Code Owner: P. Brunel
- !
- ! History:
- ! Version Date Comment
- !
- ! 1.0 08/03/01 F90 Original P. Brunel
- ! 1.1 01/12/02 Change name P. Brunel
- !
- ! Code Description:
- ! FORTRAN 90
- !
- ! Declarations
- !
- !
- ! Function arguments
- ! Scalar arguments with intent(in):
- Character (len=*) , Intent (in) :: string1
- Character (len=*) , Intent (in) :: string2
- Logical :: rttov_cmpuc
-
-
-
- ! Local variables
- Character (len = Len(string1)) :: wstr1 ! working string 1
- Character (len = Len(string2)) :: wstr2 ! working string 2
- Integer(Kind=jpim) :: pos ! position of space character
- Integer(Kind=jpim) :: cur_char ! ASCII indice for current character
- Integer(Kind=jpim) :: amin ! ASCII indice for 'a'
- Integer(Kind=jpim) :: amaj ! ASCII indice for 'A'
- Integer(Kind=jpim) :: zmin ! ASCII indice for 'z'
- Integer(Kind=jpim) :: i ! loop indice
- !- End of header --------------------------------------------------------
-
- amin = Ichar('a')
- zmin = Ichar('z')
- amaj = Ichar('A')
-
- ! reduce string 1
- wstr1 = string1
- ! remove all spaces
- Do
- pos = Index (wstr1(1:len_Trim(wstr1)) , ' ')
- If( pos == 0 ) Exit
- wstr1(pos:) = wstr1(pos+1:)
- End Do
-
- ! reduce string 2
- wstr2 = string2
- ! remove all spaces
- Do
- pos = Index (wstr2(1:len_Trim(wstr2)), ' ')
- If( pos == 0 ) Exit
- wstr2(pos:) = wstr2(pos+1:)
- End Do
-
- ! upcase string 1
- Do i = 1, Len(wstr1)
- cur_char = Ichar(wstr1(i:i))
- If( cur_char >= amin .And. cur_char <= zmin ) Then
- wstr1(i:i) = Char(cur_char + amaj-amin)
- Endif
- End Do
-
- ! upcase string 2
- Do i = 1, Len(wstr2)
- cur_char = Ichar(wstr2(i:i))
- If( cur_char >= amin .And. cur_char <= zmin ) Then
- wstr2(i:i) = Char(cur_char + amaj-amin)
- Endif
- End Do
-
- ! compare the 2 working strings
- rttov_cmpuc = wstr2 .Eq. wstr1
-
-
-
-End Function rttov_cmpuc
diff --git a/src/LIB/RTTOV/src/rttov_cmpuc.interface b/src/LIB/RTTOV/src/rttov_cmpuc.interface
deleted file mode 100644
index a35bd9dffd1a9cc561043ed0a1000b0293506c5e..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_cmpuc.interface
+++ /dev/null
@@ -1,13 +0,0 @@
-Interface
-!
-Function rttov_cmpuc (String1, String2)
- Use parkind1, Only : jpim ,jprb
- Implicit None
- Character (len=*) , Intent (in) :: string1
- Character (len=*) , Intent (in) :: string2
- Logical :: rttov_cmpuc
-
-
-
-End Function rttov_cmpuc
-End Interface
diff --git a/src/LIB/RTTOV/src/rttov_coeffname.F90 b/src/LIB/RTTOV/src/rttov_coeffname.F90
deleted file mode 100644
index ada93263e5a50b949d1d6a2d45ed1e6c9f984335..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_coeffname.F90
+++ /dev/null
@@ -1,140 +0,0 @@
-!
-Subroutine rttov_coeffname (errorstatus, instrument, coeffname, lbinary)
- ! Description:
- !
- ! Returns the file name of a coefficent file for the instrument given
- ! in argument.
- ! Instrument refers to an array of 3 integers defining the satellite platform,
- ! satellite number and instrument number.
- ! The optional logical argument lbinary determines the filename extension
- ! and expected data storage. If lbinary is false or not present the file
- ! is assumed as a sequential formatted, in other case it is sequential
- ! unformatted. The default option is ASCII file.
- !
- ! Copyright:
- ! This software was developed within the context of
- ! the EUMETSAT Satellite Application Facility on
- ! Numerical Weather Prediction (NWP SAF), under the
- ! Cooperation Agreement dated 25 November 1998, between
- ! EUMETSAT and the Met Office, UK, by one or more partners
- ! within the NWP SAF. The partners in the NWP SAF are
- ! the Met Office, ECMWF, KNMI and MeteoFrance.
- !
- ! Copyright 2002, EUMETSAT, All Rights Reserved.
- !
- ! Method:
- !
- ! Current Code Owner: SAF NWP
- !
- ! History:
- ! Version Date Comment
- ! ------- ---- -------
- ! 1.0 01/12/2002 New F90 code with structures (P Brunel A Smith)
- !
- ! Code Description:
- ! Language: Fortran 90.
- ! Software Standards: "European Standards for Writing and
- ! Documenting Exchangeable Fortran 90 Code".
- !
- ! Declarations:
- ! Modules used:
- ! Imported Parameters:
- Use rttov_const, Only : &
- & errorstatus_success ,&
- & errorstatus_fatal ,&
- & nplatforms ,&
- & ninst ,&
- & inst_name ,&
- & platform_name
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
-#include "rttov_errorreport.interface"
-
- ! subroutine arguments
- ! scalar arguments with intent(in):
- Integer(Kind=jpim), Intent (in) :: instrument(3) ! (platform, sat_id, inst) numbers
- Logical, Optional, Intent (in) :: lbinary ! if binary file wanted
-
- ! scalar arguments with intent(out):
- Integer(Kind=jpim), Intent (out) :: errorstatus! return code
- Character (*), Intent (out) :: coeffname ! filename of the coefficient file
-
-
-
- ! Local Scalars:
- Integer(Kind=jpim) :: platform
- Integer(Kind=jpim) :: sat_id
- Integer(Kind=jpim) :: inst
- Character (len=4) :: ext ! filename extension
- Character (len=2) :: ch_sat_id
- Character (len=80) :: errMessage
- Character (len=16) :: NameOfRoutine = 'rttov_coeffname '
- !- End of header --------------------------------------------------------
-
- coeffname = 'no_name'
- errorstatus = errorstatus_success
-
- ! Consider lbinary option to create the extension character string
- If(Present(lbinary)) Then
- If(lbinary) Then
- ext = '.bin'
- Else
- ext = '.dat'
- Endif
- Else
- ext = '.dat'
- Endif
-
- ! expand instrument triplet
- platform = instrument(1)
- sat_id = instrument(2)
- inst = instrument(3)
-
- ! Test sat_id and convert to string
- If( sat_id < 10 .And. sat_id > 0 ) Then
- ! one digit
- Write(ch_sat_id,'(i1)') sat_id
- Else If( sat_id >= 10 .And. sat_id < 99 ) Then
- ! two digits
- Write(ch_sat_id,'(i2)') sat_id
- Else
- ! ERROR and exit
- Write(errMessage,"('invalid sat_id: ', i4)") sat_id
- errorstatus = errorstatus_fatal
- Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine)
- Return
- Endif
-
- ! Test platform number
- If( platform <= 0 .Or. platform > nplatforms ) Then
- ! ERROR and exit
- Write(errMessage,"('invalid platform number: ', i4)") platform
- errorstatus = errorstatus_fatal
- Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine)
- Return
- Endif
-
- ! Test instrument number (0 is HIRS)
- If( inst < 0 .Or. inst > ninst) Then
- ! ERROR and exit
- Write(errMessage,"('invalid instrument number: ', i4)") inst
- errorstatus = errorstatus_fatal
- Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine)
- Return
- Endif
-
- ! create the file name "rtcoef_platform_satellite_inst.dat"
- coeffname = 'rtcoef_' // &
- & Trim(platform_name(platform)) // &
- & '_' // &
- & Trim(ch_sat_id) // &
- & '_' // &
- & Trim(inst_name(inst)) // &
- & ext
- ! write(0,'("RTTOV_COEFFNAME: ",A)')coeffname
-
-
-
-End Subroutine rttov_coeffname
diff --git a/src/LIB/RTTOV/src/rttov_coeffname.interface b/src/LIB/RTTOV/src/rttov_coeffname.interface
deleted file mode 100644
index 1d565c36e37d2c9d9ed472c633e4c1816581658e..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_coeffname.interface
+++ /dev/null
@@ -1,25 +0,0 @@
-Interface
-!
-Subroutine rttov_coeffname (errorstatus, instrument, coeffname, lbinary)
- Use rttov_const, Only : &
- errorstatus_success ,&
- errorstatus_fatal ,&
- nplatforms ,&
- ninst ,&
- inst_name ,&
- platform_name
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
-
- Integer(Kind=jpim), Intent (in) :: instrument(3) ! (platform, sat_id, inst) numbers
- Logical, Optional, Intent (in) :: lbinary ! if binary file wanted
-
- Integer(Kind=jpim), Intent (out) :: errorstatus! return code
- Character (*), Intent (out) :: coeffname ! filename of the coefficient file
-
-
-
-End Subroutine rttov_coeffname
-End Interface
diff --git a/src/LIB/RTTOV/src/rttov_const.F90 b/src/LIB/RTTOV/src/rttov_const.F90
deleted file mode 100644
index 834681f54d26c93a978d77ce2ec38175742ef106..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_const.F90
+++ /dev/null
@@ -1,724 +0,0 @@
-!
-Module rttov_const
- ! Description:
- ! Definition of all parameters (constants) for RTTOV
- !
- ! Copyright:
- ! This software was developed within the context of
- ! the EUMETSAT Satellite Application Facility on
- ! Numerical Weather Prediction (NWP SAF), under the
- ! Cooperation Agreement dated 25 November 1998, between
- ! EUMETSAT and the Met Office, UK, by one or more partners
- ! within the NWP SAF. The partners in the NWP SAF are
- ! the Met Office, ECMWF, KNMI and MeteoFrance.
- !
- ! Copyright 2002, EUMETSAT, All Rights Reserved.
- !
- ! History:
- ! Version Date Comment
- ! ------- ---- -------
- ! 1.0 01/12/2002 New F90 code with structures (P Brunel A Smith)
- ! 1.1 29/01/2003 New platforms and instruments (P Brunel)
- ! Hard limits for input profiles
- ! 1.2 19/02/2003 Some changes to limits and comments (R Saunders)
- ! 1.3 06/05/2003 Change version number to 7.3.1
- ! and add references for physical constants (P Brunel)
- ! 1.4 08/2003 Added variables for MW scattering (F Chevallier)
- ! 1.5 18/09/2003 Added coefficients for cloud absorption properties (P Francis)
- ! 1.6 15/10/2003 Added new sections in parameter files for scatt (F Chevallier)
- ! 1.7 23/11/2003 Added new definitions of polarisations 2.1 (S English)
- ! 1.8 25/08/2005 Made inst_name a parameter (R Saunders)
- ! 1.9 11/01/2006 Added logical flag for surface humidity use (R Saunders)
- ! 1.10 06/04/2006 Added Meghatropiques (R. Saunders)
- !
- !1.1 general
- !-----------
- ! Version number of the current code
- Use parkind1, Only : jpim ,jprb
- Implicit None
- Integer(Kind=jpim), Parameter :: version = 8
- Integer(Kind=jpim), Parameter :: release = 8
- Integer(Kind=jpim), Parameter :: minor_version = 0
-
- Integer(Kind=jpim), Parameter :: version_compatible_min = 7 ! minimum version number
- Integer(Kind=jpim), Parameter :: version_compatible_max = 8 ! maximum version number
- ! compatible for coefficients.
- ! coef files with "id_comp_lvl" outside range will be rejected
-
- Character (len=16), Parameter :: rttov_magic_string = '%RTTOV_COEFF '
- Real(Kind=jprb), Parameter :: rttov_magic_number = 1.2345E+12_JPRB
-
- Integer(Kind=jpim), Parameter :: default_err_unit = 0 ! standard error unit number
- ! standard error unit number is 7 for HPUX
- Logical , Parameter :: use_q2m = .false. ! set to true to activate use of surface humidity
-
- !1.2 physical constants
- !----------------------
- ! Molecular weights (g/mole) are calculated by adding NIST Standard Atomic Weights
- ! Molecular weight of dry air refers to US standard atmosphere 1976
- ! NIST Standard Atomic Weight are:
- ! H 1.00794 (7)
- ! C 12.0107 (8)
- ! N 14.0067 (2)
- ! O 15.9994 (3)
- Real(Kind=jprb), Parameter :: mair = 28.9644_JPRB
- Real(Kind=jprb), Parameter :: mh2o = 18.01528_JPRB
- Real(Kind=jprb), Parameter :: mo3 = 47.9982_JPRB
- Real(Kind=jprb), Parameter :: mco2 = 44.0095_JPRB
- Real(Kind=jprb), Parameter :: mch4 = 16.04246_JPRB
- Real(Kind=jprb), Parameter :: mn2o = 44.0128_JPRB
- Real(Kind=jprb), Parameter :: mco = 28.0101_JPRB
-
- ! Gravity from NIST 9.80665 ms-1 (exact)
- Real(Kind=jprb), Parameter :: gravity = 9.80665_JPRB
-
- !
- ! Kaye & Laby latest library edition is 16e 1995, and gives
- ! * standard value g = 9.80665 ms-1 exactly (p.191)
- ! * earth mean radius r= 6371.00 km (p191)
- ! [defined as [(r_equator)^2 (r_pole)]^1/3]
- Real(Kind=jprb), Parameter :: pi = 3.1415926535_JPRB
- Real(Kind=jprb), Parameter :: deg2rad = pi/180.0_JPRB
- Real(Kind=jprb), Parameter :: earthradius = 6371.00_JPRB
-
- ! The Cosmic Microwave Background Spectrum from the Full COBE FIRAS Data Set
- ! Fixsen D.J. et all
- ! Astrophysical Journal v.473, p.576 December 1996
- ! CMBR = 2.728 +- 0.004K
- Real(Kind=jprb), Parameter :: tcosmic = 2.728_JPRB
- ! Real(Kind=jprb), Parameter :: tcosmic = 0.1_JPRB !used for ECMWF tests
-
- ! Universal gas constant R = 8.314510 J/mol/K
- Real(Kind=jprb), Parameter :: rgp = 8.314510_JPRB
-
- ! mean molar mass of dry air rm = 0.0289644 kg.mol^-1
- Real(Kind=jprb), Parameter :: rm = 0.0289644_JPRB
-
- !1.3 satellite and instrument information
- !----------------------------------------
-
- !platform id codes
- Integer(Kind=jpim), Parameter :: nplatforms = 20
- Integer(Kind=jpim), Parameter :: &
- platform_id_noaa = 1, &
- platform_id_dmsp = 2, &
- platform_id_meteosat = 3, &
- platform_id_goes = 4, &
- platform_id_gms = 5, &
- platform_id_fy2 = 6, &
- platform_id_trmm = 7, &
- platform_id_ers = 8, &
- platform_id_eos = 9, &
- platform_id_metop = 10, &
- platform_id_envisat = 11, &
- platform_id_msg = 12, &
- platform_id_fy1 = 13, &
- platform_id_adeos = 14, &
- platform_id_mtsat = 15, &
- platform_id_coriolis = 16, &
- platform_id_npoess = 17, &
- platform_id_gifts = 18, &
- platform_id_xxxxx = 19, &
- platform_id_meghatr = 20
-
- !platform names
- Character (len=8), Parameter :: platform_name(nplatforms) = &
- (/ 'noaa ', 'dmsp ', 'meteosat', 'goes ', 'gms ', &
- 'fy2 ', 'trmm ', 'ers ', 'eos ', 'metop ', &
- 'envisat ', 'msg ', 'fy1 ', 'adeos ', 'mtsat ', &
- 'coriolis', 'npoess ', 'gifts ', 'xxxxxxxx', 'meghatr '/)
-
- !instrument id codes
- Integer(Kind=jpim), Parameter :: &
- inst_id_hirs = 0, &
- inst_id_msu = 1, &
- inst_id_ssu = 2, &
- inst_id_amsua = 3, &
- inst_id_amsub = 4, &
- inst_id_avhrr = 5, &
- inst_id_ssmi = 6, &
- inst_id_vtpr1 = 7, &
- inst_id_vtpr2 = 8, &
- inst_id_tmi = 9, &
- inst_id_ssmis = 10, &
- inst_id_airs = 11, &
- inst_id_hsb = 12, &
- inst_id_modis = 13, &
- inst_id_atsr = 14, &
- inst_id_mhs = 15, &
- inst_id_iasi = 16, &
- inst_id_amsr = 17, &
- inst_id_mtsatim= 18, &
- inst_id_atms = 19, &
- inst_id_mviri = 20, &
- inst_id_seviri = 21, &
- inst_id_goesim = 22, &
- inst_id_goessd = 23, &
- inst_id_gmsim = 24, &
- inst_id_vissr = 25, &
- inst_id_mvisr = 26, &
- inst_id_cris = 27, &
- inst_id_cmis = 28, &
- inst_id_viirs = 29, &
- inst_id_windsat= 30, &
- inst_id_gifts = 31, &
- inst_id_xxxx1 = 32, &
- inst_id_xxxx2 = 33, &
- inst_id_saphir = 34, &
- inst_id_madras = 35
-
- Integer(Kind=jpim), Parameter :: ninst = 36
- ! List of instruments !!!! HIRS is number 0
- Character (len=8), Dimension(0:ninst-1),parameter :: inst_name = &
- & (/ 'hirs ', 'msu ', 'ssu ', 'amsua ', 'amsub ', &
- & 'avhrr ', 'ssmi ', 'vtpr1 ', 'vtpr2 ', 'tmi ', &
- & 'ssmis ', 'airs ', 'hsb ', 'modis ', 'atsr ', &
- & 'mhs ', 'iasi ', 'amsr ', 'imager ', 'atms ', &
- & 'mviri ', 'seviri ', 'imager ', 'sounder ', 'imager ', &
- & 'vissr ', 'mvisr ', 'cris ', 'cmis ', 'viirs ', &
- & 'windsat ', 'gifts ', 'xxxxxxxx', 'xxxxxxxx', 'saphir ', &
- & 'madras ' /)
-
-
- !1.4 Coefficient file Section names
- !----------------------------------
- Integer(Kind=jpim), Parameter :: nsections = 19
- Character(len=21), Parameter :: section_types(nsections) = &
- (/ 'IDENTIFICATION ', 'LINE-BY-LINE ', &
- 'FAST_MODEL_VARIABLES ', 'FILTER_FUNCTIONS ', &
- 'FUNDAMENTAL_CONSTANTS', 'SSIREM ', &
- 'FASTEM ', 'REFERENCE_PROFILE ', &
- 'PROFILE_LIMITS ', 'FAST_COEFFICIENTS ', &
- 'COEF_SUB_FILES ', 'GAZ_UNITS ', &
- 'DIMENSIONS ', 'FREQUENCIES ', &
- 'HYDROMETEOR ', 'CONVERSIONS ', &
- 'EXTINCTION ', 'ALBEDO ', &
- 'ASYMMETRY ' /)
-
- !sensors id codes
- Integer(Kind=jpim), Parameter :: nsensors = 3
- Integer(Kind=jpim), Parameter :: &
- sensor_id_ir = 1, &
- sensor_id_mw = 2, &
- sensor_id_hi = 3
-
- !sensors names
- Character (len=2), Parameter :: sensor_name(nsensors) = &
- (/ 'ir', 'mw', 'hi' /)
-
- !gas id codes
- Integer(Kind=jpim), Parameter :: ngases_max = 8
- Integer(Kind=jpim), Parameter :: &
- & gas_id_mixed = 1, &
- & gas_id_watervapour = 2, &
- & gas_id_ozone = 3, &
- & gas_id_wvcont = 4, &
- & gas_id_co2 = 5, &
- & gas_id_n2o = 6, &
- & gas_id_co = 7, &
- & gas_id_ch4 = 8
-
- !gas names
- Character (len=12), Parameter :: gas_name(ngases_max) = &
- & (/ 'Mixed_gases ', &
- & 'Water_vapour', &
- & 'Ozone ', &
- & 'WV_Continuum', &
- & 'CO2 ', &
- & 'N2O ', &
- & 'CO ', &
- & 'CH4 ' /)
-
- !gas units
- Integer(Kind=jpim), Parameter :: ngases_unit = 2
- Integer(Kind=jpim), Parameter :: &
- & gas_unit_specconc = 1, &
- & gas_unit_ppmv = 2
- Character (len=12), Parameter :: gas_unit_name(ngases_unit) = &
- & (/ 'spec. concen', &
- & 'ppmv ' /)
-
-
- !1.5 error reporting
- !-------------------
- !error status values
- Integer(Kind=jpim), Parameter :: nerrorstatus = 3
- Integer(Kind=jpim), Parameter :: errorstatus_success = 0
- Integer(Kind=jpim), Parameter :: errorstatus_warning = 1
- Integer(Kind=jpim), Parameter :: errorstatus_fatal = 2
- Integer(Kind=jpim), Parameter :: errorstatus_info = 3
- Character(len=*), Parameter :: errorstatus_text(0:nerrorstatus) = &
- (/ 'success', &
- 'warning', &
- 'fatal ', &
- 'info ' /)
-
-
- !1.6 surface types
- !-----------------
- Integer(Kind=jpim), Parameter :: nsurftype = 2
- Integer(Kind=jpim), Parameter :: surftype_land = 0
- Integer(Kind=jpim), Parameter :: surftype_sea = 1
- Integer(Kind=jpim), Parameter :: surftype_seaice = 2
-
-
- !1.7 cloud emissivity
- !---------------------
- Integer(Kind=jpim), Parameter :: overlap_scheme = 2 ! overlap scheme
- ! 1 => Geleyn and Hollingsworth (1979)
- ! 2 => Raisanen (1998)
-
- !
- ! Water cloud coefficients
- ! from Hu and Stamnes, 1993, J. Climate, Vol. 6, pp. 728-742
- !
- Integer(Kind=jpim), Parameter :: nvalhusta = 53 ! No. of wavelengths for tabulated Hu & Stamnes (droplet) data
- !
- Real(Kind=jprb), Parameter :: zhustaom(nvalhusta) = &
- & (/ 3819.71_JPRB, 3179.65_JPRB, 2710.03_JPRB, 2564.10_JPRB, 2439.02_JPRB, &
- & 2325.58_JPRB, 2222.22_JPRB, 2127.66_JPRB, 2040.82_JPRB, 1960.78_JPRB, &
- & 1886.79_JPRB, 1851.85_JPRB, 1818.18_JPRB, 1754.39_JPRB, 1694.92_JPRB, &
- & 1666.67_JPRB, 1639.34_JPRB, 1612.90_JPRB, 1587.30_JPRB, 1538.46_JPRB, &
- & 1492.54_JPRB, 1428.57_JPRB, 1408.45_JPRB, 1369.86_JPRB, 1315.79_JPRB, &
- & 1250.00_JPRB, 1162.79_JPRB, 1111.11_JPRB, 1041.67_JPRB, 1000.00_JPRB, &
- & 952.381_JPRB, 909.091_JPRB, 869.565_JPRB, 800.000_JPRB, 740.741_JPRB, &
- & 714.286_JPRB, 689.655_JPRB, 666.667_JPRB, 645.161_JPRB, 606.061_JPRB, &
- & 588.235_JPRB, 571.429_JPRB, 555.556_JPRB, 526.316_JPRB, 500.000_JPRB, &
- & 400.000_JPRB, 312.500_JPRB, 250.000_JPRB, 200.000_JPRB, 166.667_JPRB, &
- & 125.000_JPRB, 100.000_JPRB, 66.6667_JPRB /)
- !
- Real(Kind=jprb), Parameter :: zhustaa1(nvalhusta) = &
- & (/ 4.56E+03_JPRB, 2.71E+03_JPRB, 5.29E+03_JPRB, 6.40E+03_JPRB, 5.42E+03_JPRB, &
- & 4.30E+03_JPRB, 3.32E+03_JPRB, 2.69E+03_JPRB, 2.29E+03_JPRB, 2.03E+03_JPRB, &
- & 2.52E+03_JPRB, -4.31E+04_JPRB, -1.10E+03_JPRB, -2.61E+02_JPRB, -1.84E+02_JPRB, &
- & -4.93E+02_JPRB, -3.15E+04_JPRB, 1.95E+03_JPRB, 2.41E+03_JPRB, -1.14E+03_JPRB, &
- & -1.87E+02_JPRB, -4.36E+01_JPRB, -1.76E+01_JPRB, -7.13E+00_JPRB, -1.97E+00_JPRB, &
- & -2.89E-01_JPRB, -1.29E-02_JPRB, -2.60E-04_JPRB, -7.62E-02_JPRB, -9.91E-06_JPRB, &
- & -5.91E+04_JPRB, -3.88E-05_JPRB, -1.79E+00_JPRB, -8.34E+01_JPRB, -4.90E+02_JPRB, &
- & -7.78E+02_JPRB, -7.47E+02_JPRB, -6.18E+02_JPRB, -4.56E+02_JPRB, -2.83E+02_JPRB, &
- & -1.82E+02_JPRB, -1.23E+02_JPRB, -7.98E+01_JPRB, -3.52E+01_JPRB, -9.86E+00_JPRB, &
- & -1.22E-01_JPRB, -7.27E-06_JPRB, -2.93E+04_JPRB, -3.93E+03_JPRB, -4.00E+02_JPRB, &
- & 8.63E+01_JPRB, 1.71E+00_JPRB, 3.93E-02_JPRB /)
- !
- Real(Kind=jprb), Parameter :: zhustab1(nvalhusta) = &
- & (/ -1.61E+00_JPRB, -1.27E+00_JPRB, -1.73E+00_JPRB, -1.79E+00_JPRB, -1.63E+00_JPRB, &
- & -1.42E+00_JPRB, -1.19E+00_JPRB, -9.84E-01_JPRB, -7.86E-01_JPRB, -5.46E-01_JPRB, &
- & -2.26E-01_JPRB, 8.00E-03_JPRB, 2.04E-01_JPRB, 4.58E-01_JPRB, 5.00E-01_JPRB, &
- & 2.70E-01_JPRB, 8.00E-03_JPRB, -2.50E-01_JPRB, -1.86E-01_JPRB, 1.86E-01_JPRB, &
- & 5.32E-01_JPRB, 9.24E-01_JPRB, 1.20E+00_JPRB, 1.49E+00_JPRB, 1.91E+00_JPRB, &
- & 2.57E+00_JPRB, 3.65E+00_JPRB, 5.06E+00_JPRB, 3.00E+00_JPRB, 6.00E+00_JPRB, &
- & -6.00E+00_JPRB, 5.24E+00_JPRB, 1.36E+00_JPRB, 4.12E-01_JPRB, 1.66E-01_JPRB, &
- & 1.28E-01_JPRB, 1.38E-01_JPRB, 1.64E-01_JPRB, 2.08E-01_JPRB, 2.90E-01_JPRB, &
- & 3.78E-01_JPRB, 4.66E-01_JPRB, 5.70E-01_JPRB, 7.86E-01_JPRB, 1.16E+00_JPRB, &
- & 2.61E+00_JPRB, 6.00E+00_JPRB, -5.18E+00_JPRB, -3.69E+00_JPRB, -1.60E+00_JPRB, &
- & 2.92E-01_JPRB, 1.36E+00_JPRB, 2.35E+00_JPRB /)
- !
- Real(Kind=jprb), Parameter :: zhustac1(nvalhusta) = &
- & (/ 5.74E+01_JPRB, 2.35E+01_JPRB, 7.34E+01_JPRB, 7.03E+01_JPRB, 4.78E+01_JPRB, &
- & 1.52E+01_JPRB, -3.31E+01_JPRB, -9.66E+01_JPRB, -1.89E+02_JPRB, -3.88E+02_JPRB, &
- & -1.30E+03_JPRB, 4.41E+04_JPRB, 1.96E+03_JPRB, 9.55E+02_JPRB, 7.83E+02_JPRB, &
- & 1.11E+03_JPRB, 3.23E+04_JPRB, -9.02E+02_JPRB, -1.38E+03_JPRB, 1.95E+03_JPRB, &
- & 8.45E+02_JPRB, 5.82E+02_JPRB, 4.99E+02_JPRB, 4.43E+02_JPRB, 3.87E+02_JPRB, &
- & 3.35E+02_JPRB, 2.84E+02_JPRB, 2.48E+02_JPRB, 3.02E+02_JPRB, 1.95E+02_JPRB, &
- & 1.55E+02_JPRB, 1.40E+02_JPRB, 1.66E+02_JPRB, 3.51E+02_JPRB, 8.69E+02_JPRB, &
- & 1.20E+03_JPRB, 1.19E+03_JPRB, 1.07E+03_JPRB, 9.07E+02_JPRB, 7.28E+02_JPRB, &
- & 6.15E+02_JPRB, 5.41E+02_JPRB, 4.81E+02_JPRB, 4.02E+02_JPRB, 3.30E+02_JPRB, &
- & 2.37E+02_JPRB, 1.76E+02_JPRB, 1.44E+02_JPRB, 1.35E+02_JPRB, 1.39E+02_JPRB, &
- & -6.76E+01_JPRB, 2.87E+01_JPRB, 1.90E+01_JPRB /)
- !
- Real(Kind=jprb), Parameter :: zhustaa2(nvalhusta) = &
- & (/ 2.05E+03_JPRB, 2.02E+03_JPRB, 2.17E+03_JPRB, 2.24E+03_JPRB, 2.26E+03_JPRB, &
- & 2.28E+03_JPRB, 2.28E+03_JPRB, 2.28E+03_JPRB, 2.28E+03_JPRB, 2.28E+03_JPRB, &
- & 2.30E+03_JPRB, 2.34E+03_JPRB, 2.41E+03_JPRB, 2.76E+03_JPRB, 3.12E+03_JPRB, &
- & 2.92E+03_JPRB, 2.74E+03_JPRB, 2.61E+03_JPRB, 2.62E+03_JPRB, 2.76E+03_JPRB, &
- & 3.03E+03_JPRB, 3.56E+03_JPRB, 4.06E+03_JPRB, 4.74E+03_JPRB, 5.98E+03_JPRB, &
- & 8.00E+03_JPRB, 9.63E+03_JPRB, 8.53E+03_JPRB, 7.52E+03_JPRB, 2.37E+03_JPRB, &
- & 8.17E+02_JPRB, 7.94E+02_JPRB, 5.38E+02_JPRB, 7.11E+02_JPRB, 1.07E+03_JPRB, &
- & 1.28E+03_JPRB, 1.40E+03_JPRB, 1.50E+03_JPRB, 1.59E+03_JPRB, 1.73E+03_JPRB, &
- & 1.82E+03_JPRB, 1.89E+03_JPRB, 1.95E+03_JPRB, 2.02E+03_JPRB, 2.03E+03_JPRB, &
- & 1.69E+03_JPRB, 9.38E+02_JPRB, 1.19E+03_JPRB, -7.38E+02_JPRB, -9.44E+01_JPRB, &
- & -4.07E-01_JPRB, -1.90E-07_JPRB, -4.49E+03_JPRB /)
- !
- Real(Kind=jprb), Parameter :: zhustab2(nvalhusta) = &
- & (/ -1.09E+00_JPRB, -1.08E+00_JPRB, -1.10E+00_JPRB, -1.11E+00_JPRB, -1.12E+00_JPRB, &
- & -1.12E+00_JPRB, -1.11E+00_JPRB, -1.11E+00_JPRB, -1.11E+00_JPRB, -1.11E+00_JPRB, &
- & -1.11E+00_JPRB, -1.12E+00_JPRB, -1.13E+00_JPRB, -1.19E+00_JPRB, -1.24E+00_JPRB, &
- & -1.22E+00_JPRB, -1.19E+00_JPRB, -1.16E+00_JPRB, -1.16E+00_JPRB, -1.18E+00_JPRB, &
- & -1.22E+00_JPRB, -1.29E+00_JPRB, -1.34E+00_JPRB, -1.40E+00_JPRB, -1.49E+00_JPRB, &
- & -1.60E+00_JPRB, -1.66E+00_JPRB, -1.59E+00_JPRB, -1.55E+00_JPRB, -1.02E+00_JPRB, &
- & -4.24E-01_JPRB, -1.48E-01_JPRB, -2.88E-01_JPRB, -6.06E-01_JPRB, -7.94E-01_JPRB, &
- & -8.62E-01_JPRB, -8.94E-01_JPRB, -9.18E-01_JPRB, -9.38E-01_JPRB, -9.66E-01_JPRB, &
- & -9.82E-01_JPRB, -9.94E-01_JPRB, -1.00E+00_JPRB, -1.01E+00_JPRB, -1.00E+00_JPRB, &
- & -8.92E-01_JPRB, -5.44E-01_JPRB, -9.20E-02_JPRB, 8.00E-02_JPRB, 3.06E-01_JPRB, &
- & 1.48E+00_JPRB, 5.41E+00_JPRB, -1.84E+00_JPRB /)
- !
- Real(Kind=jprb), Parameter :: zhustac2(nvalhusta) = &
- & (/ 2.66E+00_JPRB, 2.24E+00_JPRB, 3.01E+00_JPRB, 3.32E+00_JPRB, 3.29E+00_JPRB, &
- & 3.16E+00_JPRB, 2.91E+00_JPRB, 2.66E+00_JPRB, 2.42E+00_JPRB, 2.19E+00_JPRB, &
- & 2.25E+00_JPRB, 2.60E+00_JPRB, 3.47E+00_JPRB, 6.82E+00_JPRB, 9.51E+00_JPRB, &
- & 8.24E+00_JPRB, 6.86E+00_JPRB, 5.49E+00_JPRB, 5.36E+00_JPRB, 6.34E+00_JPRB, &
- & 8.35E+00_JPRB, 1.16E+01_JPRB, 1.40E+01_JPRB, 1.65E+01_JPRB, 1.96E+01_JPRB, &
- & 2.25E+01_JPRB, 2.26E+01_JPRB, 1.83E+01_JPRB, 1.91E+01_JPRB, -1.69E+01_JPRB, &
- & -1.35E+02_JPRB, -4.23E+02_JPRB, -1.48E+02_JPRB, -3.72E+01_JPRB, -1.73E+01_JPRB, &
- & -1.27E+01_JPRB, -1.08E+01_JPRB, -9.58E+00_JPRB, -8.61E+00_JPRB, -7.26E+00_JPRB, &
- & -6.67E+00_JPRB, -6.18E+00_JPRB, -6.07E+00_JPRB, -6.14E+00_JPRB, -7.63E+00_JPRB, &
- & -2.02E+01_JPRB, -8.44E+01_JPRB, -8.08E+02_JPRB, 1.03E+03_JPRB, 3.34E+02_JPRB, &
- & 1.32E+02_JPRB, 8.89E+01_JPRB, 7.12E+01_JPRB /)
- !
- Real(Kind=jprb), Parameter :: zhustaa3(nvalhusta) = &
- & (/ 1.12E+03_JPRB, 1.12E+03_JPRB, 1.17E+03_JPRB, 1.20E+03_JPRB, 1.22E+03_JPRB, &
- & 1.23E+03_JPRB, 1.24E+03_JPRB, 1.26E+03_JPRB, 1.27E+03_JPRB, 1.28E+03_JPRB, &
- & 1.30E+03_JPRB, 1.31E+03_JPRB, 1.31E+03_JPRB, 1.32E+03_JPRB, 1.30E+03_JPRB, &
- & 1.27E+03_JPRB, 1.28E+03_JPRB, 1.30E+03_JPRB, 1.32E+03_JPRB, 1.35E+03_JPRB, &
- & 1.37E+03_JPRB, 1.39E+03_JPRB, 1.40E+03_JPRB, 1.41E+03_JPRB, 1.42E+03_JPRB, &
- & 1.44E+03_JPRB, 1.46E+03_JPRB, 1.50E+03_JPRB, 1.52E+03_JPRB, 1.96E+03_JPRB, &
- & 2.45E+03_JPRB, 1.68E+03_JPRB, 9.77E+02_JPRB, 8.92E+02_JPRB, 1.03E+03_JPRB, &
- & 1.13E+03_JPRB, 1.19E+03_JPRB, 1.24E+03_JPRB, 1.28E+03_JPRB, 1.35E+03_JPRB, &
- & 1.40E+03_JPRB, 1.44E+03_JPRB, 1.47E+03_JPRB, 1.53E+03_JPRB, 1.61E+03_JPRB, &
- & 1.81E+03_JPRB, 2.13E+03_JPRB, 1.86E+03_JPRB, 1.52E+03_JPRB, 1.54E+03_JPRB, &
- & 1.36E+03_JPRB, 6.85E+02_JPRB, -2.26E-01_JPRB /)
- !
- Real(Kind=jprb), Parameter :: zhustab3(nvalhusta) = &
- & (/ -8.52E-01_JPRB, -8.52E-01_JPRB, -8.64E-01_JPRB, -8.70E-01_JPRB, -8.74E-01_JPRB, &
- & -8.76E-01_JPRB, -8.78E-01_JPRB, -8.82E-01_JPRB, -8.84E-01_JPRB, -8.88E-01_JPRB, &
- & -8.92E-01_JPRB, -8.94E-01_JPRB, -8.94E-01_JPRB, -8.96E-01_JPRB, -8.92E-01_JPRB, &
- & -8.84E-01_JPRB, -8.86E-01_JPRB, -8.90E-01_JPRB, -8.94E-01_JPRB, -9.00E-01_JPRB, &
- & -9.04E-01_JPRB, -9.08E-01_JPRB, -9.10E-01_JPRB, -9.12E-01_JPRB, -9.14E-01_JPRB, &
- & -9.16E-01_JPRB, -9.20E-01_JPRB, -9.28E-01_JPRB, -9.30E-01_JPRB, -1.02E+00_JPRB, &
- & -1.09E+00_JPRB, -9.66E-01_JPRB, -7.88E-01_JPRB, -7.62E-01_JPRB, -8.08E-01_JPRB, &
- & -8.36E-01_JPRB, -8.50E-01_JPRB, -8.62E-01_JPRB, -8.72E-01_JPRB, -8.86E-01_JPRB, &
- & -8.96E-01_JPRB, -9.04E-01_JPRB, -9.10E-01_JPRB, -9.20E-01_JPRB, -9.34E-01_JPRB, &
- & -9.66E-01_JPRB, -1.01E+00_JPRB, -9.52E-01_JPRB, -8.72E-01_JPRB, -8.62E-01_JPRB, &
- & -7.90E-01_JPRB, -4.68E-01_JPRB, 1.29E+00_JPRB /)
- !
- Real(Kind=jprb), Parameter :: zhustac3(nvalhusta) = &
- & (/ -8.94E+00_JPRB, -8.99E+00_JPRB, -8.67E+00_JPRB, -8.51E+00_JPRB, -8.38E+00_JPRB, &
- & -8.35E+00_JPRB, -8.32E+00_JPRB, -8.19E+00_JPRB, -8.16E+00_JPRB, -8.03E+00_JPRB, &
- & -7.90E+00_JPRB, -7.86E+00_JPRB, -7.90E+00_JPRB, -7.82E+00_JPRB, -7.94E+00_JPRB, &
- & -8.20E+00_JPRB, -8.14E+00_JPRB, -8.04E+00_JPRB, -7.92E+00_JPRB, -7.76E+00_JPRB, &
- & -7.66E+00_JPRB, -7.56E+00_JPRB, -7.52E+00_JPRB, -7.48E+00_JPRB, -7.47E+00_JPRB, &
- & -7.48E+00_JPRB, -7.42E+00_JPRB, -7.15E+00_JPRB, -7.13E+00_JPRB, -3.73E+00_JPRB, &
- & -1.57E+00_JPRB, -5.84E+00_JPRB, -1.28E+01_JPRB, -1.35E+01_JPRB, -1.15E+01_JPRB, &
- & -1.05E+01_JPRB, -1.01E+01_JPRB, -9.66E+00_JPRB, -9.37E+00_JPRB, -8.97E+00_JPRB, &
- & -8.67E+00_JPRB, -8.42E+00_JPRB, -8.28E+00_JPRB, -8.01E+00_JPRB, -7.58E+00_JPRB, &
- & -6.71E+00_JPRB, -5.72E+00_JPRB, -8.68E+00_JPRB, -1.30E+01_JPRB, -1.45E+01_JPRB, &
- & -2.17E+01_JPRB, -6.75E+01_JPRB, 8.10E+01_JPRB /)
- !
- Real(Kind=jprb), Parameter :: zhustad1(nvalhusta) = &
- & (/ 2.00E+00_JPRB, -1.22E+00_JPRB, -5.94E-01_JPRB, 1.69E-01_JPRB, 1.40E-01_JPRB, &
- & 1.50E-01_JPRB, 1.40E-01_JPRB, 7.89E-02_JPRB, 3.83E-02_JPRB, 1.77E-02_JPRB, &
- & 6.96E-03_JPRB, 3.68E-03_JPRB, 2.29E-03_JPRB, 1.92E-03_JPRB, 9.32E-04_JPRB, &
- & 1.32E-04_JPRB, 2.13E-03_JPRB, 3.83E-02_JPRB, 3.56E-02_JPRB, 7.68E-03_JPRB, &
- & 2.28E-03_JPRB, 6.59E-04_JPRB, 2.80E-04_JPRB, 1.13E-04_JPRB, 2.67E-05_JPRB, &
- & 1.96E-06_JPRB, 1.91E-08_JPRB, 1.35E+02_JPRB, 2.69E-08_JPRB, 7.67E+00_JPRB, &
- & 1.70E+00_JPRB, 1.07E+00_JPRB, 9.80E-01_JPRB, 9.43E-01_JPRB, 8.57E-01_JPRB, &
- & 8.38E-01_JPRB, 8.36E-01_JPRB, 8.41E-01_JPRB, 8.53E-01_JPRB, 8.82E-01_JPRB, &
- & 9.18E-01_JPRB, 9.54E-01_JPRB, 1.00E+00_JPRB, 1.10E+00_JPRB, 1.22E+00_JPRB, &
- & 1.39E+00_JPRB, 1.38E+00_JPRB, 1.27E+00_JPRB, 1.92E+00_JPRB, -1.05E+01_JPRB, &
- & -3.03E-01_JPRB, -3.95E-02_JPRB, -1.37E-03_JPRB /)
- !
- Real(Kind=jprb), Parameter :: zhustae1(nvalhusta) = &
- & (/ 4.60E-02_JPRB, -1.90E+00_JPRB, -5.24E-01_JPRB, 2.84E-01_JPRB, 3.60E-01_JPRB, &
- & 4.04E-01_JPRB, 4.70E-01_JPRB, 6.28E-01_JPRB, 8.28E-01_JPRB, 1.06E+00_JPRB, &
- & 1.36E+00_JPRB, 1.57E+00_JPRB, 1.73E+00_JPRB, 1.87E+00_JPRB, 2.07E+00_JPRB, &
- & 2.61E+00_JPRB, 1.62E+00_JPRB, 7.74E-01_JPRB, 8.60E-01_JPRB, 1.41E+00_JPRB, &
- & 1.83E+00_JPRB, 2.26E+00_JPRB, 2.56E+00_JPRB, 2.87E+00_JPRB, 3.38E+00_JPRB, &
- & 4.33E+00_JPRB, 6.00E+00_JPRB, -6.00E+00_JPRB, 5.93E+00_JPRB, -3.08E+00_JPRB, &
- & -1.50E+00_JPRB, -8.10E-01_JPRB, -4.36E-01_JPRB, -3.90E-01_JPRB, -5.22E-01_JPRB, &
- & -6.18E-01_JPRB, -6.76E-01_JPRB, -7.32E-01_JPRB, -7.86E-01_JPRB, -8.72E-01_JPRB, &
- & -9.46E-01_JPRB, -1.01E+00_JPRB, -1.07E+00_JPRB, -1.17E+00_JPRB, -1.25E+00_JPRB, &
- & -1.23E+00_JPRB, -9.68E-01_JPRB, -5.24E-01_JPRB, -1.90E-01_JPRB, 2.40E-02_JPRB, &
- & 4.12E-01_JPRB, 9.70E-01_JPRB, 2.03E+00_JPRB /)
- !
- Real(Kind=jprb), Parameter :: zhustaf1(nvalhusta) = &
- & (/ -2.06E+00_JPRB, 4.93E-01_JPRB, 4.22E-01_JPRB, -2.17E-01_JPRB, -1.90E-01_JPRB, &
- & -2.07E-01_JPRB, -1.93E-01_JPRB, -1.08E-01_JPRB, -4.42E-02_JPRB, -3.46E-03_JPRB, &
- & 2.61E-02_JPRB, 3.91E-02_JPRB, 4.96E-02_JPRB, 1.16E-01_JPRB, 2.70E-01_JPRB, &
- & 3.96E-01_JPRB, 3.72E-01_JPRB, 2.31E-01_JPRB, 1.74E-01_JPRB, 1.63E-01_JPRB, &
- & 1.59E-01_JPRB, 1.67E-01_JPRB, 1.69E-01_JPRB, 1.72E-01_JPRB, 1.82E-01_JPRB, &
- & 1.96E-01_JPRB, 2.21E-01_JPRB, 2.47E-01_JPRB, 2.38E-01_JPRB, 2.96E-01_JPRB, &
- & 3.23E-01_JPRB, 3.27E-01_JPRB, 2.31E-01_JPRB, 2.32E-01_JPRB, 3.42E-01_JPRB, &
- & 3.88E-01_JPRB, 4.08E-01_JPRB, 4.25E-01_JPRB, 4.38E-01_JPRB, 4.55E-01_JPRB, &
- & 4.66E-01_JPRB, 4.73E-01_JPRB, 4.80E-01_JPRB, 4.86E-01_JPRB, 4.88E-01_JPRB, &
- & 4.71E-01_JPRB, 4.13E-01_JPRB, 2.35E-01_JPRB, -5.67E-01_JPRB, 1.18E+01_JPRB, &
- & 1.49E+00_JPRB, 1.12E+00_JPRB, 1.01E+00_JPRB /)
- !
- Real(Kind=jprb), Parameter :: zhustad2(nvalhusta) = &
- & (/ 5.92E-01_JPRB, -9.00E-05_JPRB, -2.76E+00_JPRB, 6.57E-02_JPRB, 1.44E-01_JPRB, &
- & 1.29E+00_JPRB, -1.27E+00_JPRB, -1.19E+00_JPRB, -1.27E+00_JPRB, -1.39E+00_JPRB, &
- & -1.48E+00_JPRB, -1.50E+00_JPRB, -1.35E+00_JPRB, -3.34E+00_JPRB, -1.59E+03_JPRB, &
- & -6.31E+04_JPRB, -1.05E-11_JPRB, -6.06E-10_JPRB, -6.27E+04_JPRB, -9.39E+01_JPRB, &
- & -2.36E+01_JPRB, -1.95E+01_JPRB, -1.79E+01_JPRB, -1.78E+01_JPRB, -2.00E+01_JPRB, &
- & -1.97E+01_JPRB, -1.40E+01_JPRB, -6.68E+00_JPRB, -1.55E+01_JPRB, -1.68E+00_JPRB, &
- & 8.00E-03_JPRB, 3.01E-08_JPRB, 4.73E+01_JPRB, 1.96E+00_JPRB, 1.09E+00_JPRB, &
- & 8.47E-01_JPRB, 7.25E-01_JPRB, 6.30E-01_JPRB, 5.55E-01_JPRB, 4.70E-01_JPRB, &
- & 4.34E-01_JPRB, 4.48E-01_JPRB, 6.34E-01_JPRB, -2.97E-01_JPRB, -2.33E-02_JPRB, &
- & -8.04E-04_JPRB, 6.00E+04_JPRB, 1.18E+02_JPRB, 9.23E+00_JPRB, 9.92E+00_JPRB, &
- & 4.12E+01_JPRB, 3.91E+01_JPRB, 1.06E+01_JPRB /)
- !
- Real(Kind=jprb), Parameter :: zhustae2(nvalhusta) = &
- & (/ 1.06E-01_JPRB, 1.40E+00_JPRB, -4.00E-02_JPRB, 4.66E-01_JPRB, 3.40E-01_JPRB, &
- & 8.80E-02_JPRB, -2.24E-01_JPRB, -2.94E-01_JPRB, -2.34E-01_JPRB, -1.92E-01_JPRB, &
- & -1.74E-01_JPRB, -1.74E-01_JPRB, -2.30E-01_JPRB, -1.14E+00_JPRB, -3.99E+00_JPRB, &
- & -6.00E+00_JPRB, 6.00E+00_JPRB, 4.87E+00_JPRB, -6.00E+00_JPRB, -2.84E+00_JPRB, &
- & -2.12E+00_JPRB, -1.96E+00_JPRB, -1.87E+00_JPRB, -1.83E+00_JPRB, -1.84E+00_JPRB, &
- & -1.79E+00_JPRB, -1.59E+00_JPRB, -1.23E+00_JPRB, -1.69E+00_JPRB, -2.14E-01_JPRB, &
- & 9.36E-01_JPRB, 4.04E+00_JPRB, -2.67E+00_JPRB, -1.16E+00_JPRB, -8.90E-01_JPRB, &
- & -7.82E-01_JPRB, -7.08E-01_JPRB, -6.34E-01_JPRB, -5.60E-01_JPRB, -4.34E-01_JPRB, &
- & -3.24E-01_JPRB, -2.24E-01_JPRB, -1.06E-01_JPRB, 1.08E-01_JPRB, 4.34E-01_JPRB, &
- & 1.05E+00_JPRB, -6.00E+00_JPRB, -3.02E+00_JPRB, -1.75E+00_JPRB, -1.74E+00_JPRB, &
- & -2.28E+00_JPRB, -2.12E+00_JPRB, -1.31E+00_JPRB /)
- !
- Real(Kind=jprb), Parameter :: zhustaf2(nvalhusta) = &
- & (/ -5.89E-01_JPRB, 4.85E-01_JPRB, 2.76E+00_JPRB, -8.47E-02_JPRB, -1.86E-01_JPRB, &
- & -1.41E+00_JPRB, 9.81E-01_JPRB, 8.33E-01_JPRB, 9.60E-01_JPRB, 1.10E+00_JPRB, &
- & 1.19E+00_JPRB, 1.19E+00_JPRB, 9.83E-01_JPRB, 5.09E-01_JPRB, 4.93E-01_JPRB, &
- & 5.02E-01_JPRB, 5.02E-01_JPRB, 5.00E-01_JPRB, 4.93E-01_JPRB, 4.87E-01_JPRB, &
- & 4.90E-01_JPRB, 4.91E-01_JPRB, 4.92E-01_JPRB, 4.93E-01_JPRB, 4.95E-01_JPRB, &
- & 5.01E-01_JPRB, 5.23E-01_JPRB, 5.66E-01_JPRB, 5.19E-01_JPRB, 1.28E+00_JPRB, &
- & 2.74E-01_JPRB, 4.57E-01_JPRB, 5.07E-01_JPRB, 4.82E-01_JPRB, 4.58E-01_JPRB, &
- & 4.47E-01_JPRB, 4.39E-01_JPRB, 4.31E-01_JPRB, 4.21E-01_JPRB, 3.95E-01_JPRB, &
- & 3.59E-01_JPRB, 2.94E-01_JPRB, 6.19E-02_JPRB, 9.35E-01_JPRB, 6.10E-01_JPRB, &
- & 5.44E-01_JPRB, 5.21E-01_JPRB, 5.23E-01_JPRB, 5.15E-01_JPRB, 5.15E-01_JPRB, &
- & 5.18E-01_JPRB, 5.02E-01_JPRB, 4.12E-01_JPRB /)
- !
- Real(Kind=jprb), Parameter :: zhustad3(nvalhusta) = &
- & (/ -1.13E+00_JPRB, 2.17E-01_JPRB, -1.17E+00_JPRB, -1.68E+00_JPRB, -1.55E+00_JPRB, &
- & -2.84E+00_JPRB, -8.65E+00_JPRB, -1.15E+01_JPRB, -8.50E+00_JPRB, -6.49E+00_JPRB, &
- & -5.09E+00_JPRB, -4.41E+00_JPRB, -4.50E+00_JPRB, -4.19E+01_JPRB, -1.15E-04_JPRB, &
- & 3.19E-01_JPRB, 4.34E-01_JPRB, 4.03E-01_JPRB, 1.82E-01_JPRB, -1.93E-12_JPRB, &
- & -6.01E+06_JPRB, -2.54E+04_JPRB, -2.77E+03_JPRB, -9.06E+02_JPRB, -5.94E+02_JPRB, &
- & -5.23E+02_JPRB, -1.45E+03_JPRB, -5.13E+03_JPRB, -4.70E+04_JPRB, -1.79E+05_JPRB, &
- & -6.31E+04_JPRB, -1.82E+04_JPRB, -3.52E-04_JPRB, 8.68E-01_JPRB, 1.05E+00_JPRB, &
- & 9.69E-01_JPRB, 9.26E-01_JPRB, 8.83E-01_JPRB, 8.43E-01_JPRB, 7.97E-01_JPRB, &
- & 7.58E-01_JPRB, 7.25E-01_JPRB, 6.95E-01_JPRB, 6.35E-01_JPRB, 5.41E-01_JPRB, &
- & 5.33E-01_JPRB, -1.42E-03_JPRB, -2.62E-04_JPRB, -9.94E-02_JPRB, -1.26E-01_JPRB, &
- & -4.56E-04_JPRB, 1.16E-01_JPRB, 1.62E+07_JPRB /)
- !
- Real(Kind=jprb), Parameter :: zhustae3(nvalhusta) = &
- & (/ -1.34E-01_JPRB, -7.48E-01_JPRB, -5.40E-01_JPRB, -1.64E-01_JPRB, -3.58E-01_JPRB, &
- & -7.66E-01_JPRB, -1.29E+00_JPRB, -1.41E+00_JPRB, -1.28E+00_JPRB, -1.16E+00_JPRB, &
- & -1.04E+00_JPRB, -9.76E-01_JPRB, -9.88E-01_JPRB, -2.02E+00_JPRB, 1.15E+00_JPRB, &
- & -6.20E-01_JPRB, -7.44E-01_JPRB, -7.22E-01_JPRB, -3.40E-01_JPRB, 5.20E+00_JPRB, &
- & -6.00E+00_JPRB, -4.21E+00_JPRB, -3.47E+00_JPRB, -3.09E+00_JPRB, -2.93E+00_JPRB, &
- & -2.87E+00_JPRB, -3.18E+00_JPRB, -3.55E+00_JPRB, -4.33E+00_JPRB, -4.55E+00_JPRB, &
- & -4.19E+00_JPRB, -3.99E+00_JPRB, 9.38E-01_JPRB, -8.10E-01_JPRB, -8.48E-01_JPRB, &
- & -8.14E-01_JPRB, -7.92E-01_JPRB, -7.68E-01_JPRB, -7.44E-01_JPRB, -7.12E-01_JPRB, &
- & -6.84E-01_JPRB, -6.60E-01_JPRB, -6.36E-01_JPRB, -5.86E-01_JPRB, -4.94E-01_JPRB, &
- & -1.28E-01_JPRB, 8.88E-01_JPRB, 1.22E+00_JPRB, 2.04E-01_JPRB, 1.86E-01_JPRB, &
- & 1.09E+00_JPRB, -3.16E-01_JPRB, -6.00E+00_JPRB /)
- !
- Real(Kind=jprb), Parameter :: zhustaf3(nvalhusta) = &
- & (/ 9.75E-01_JPRB, 4.57E-01_JPRB, 5.37E-01_JPRB, 1.20E+00_JPRB, 7.30E-01_JPRB, &
- & 5.42E-01_JPRB, 4.93E-01_JPRB, 4.90E-01_JPRB, 4.96E-01_JPRB, 5.03E-01_JPRB, &
- & 5.13E-01_JPRB, 5.20E-01_JPRB, 5.19E-01_JPRB, 4.82E-01_JPRB, 4.97E-01_JPRB, &
- & 4.59E-01_JPRB, 4.61E-01_JPRB, 4.57E-01_JPRB, 4.33E-01_JPRB, 4.82E-01_JPRB, &
- & 4.80E-01_JPRB, 4.80E-01_JPRB, 4.81E-01_JPRB, 4.82E-01_JPRB, 4.83E-01_JPRB, &
- & 4.85E-01_JPRB, 4.87E-01_JPRB, 4.89E-01_JPRB, 4.85E-01_JPRB, 4.96E-01_JPRB, &
- & 5.03E-01_JPRB, 5.05E-01_JPRB, 5.21E-01_JPRB, 4.64E-01_JPRB, 4.52E-01_JPRB, &
- & 4.45E-01_JPRB, 4.42E-01_JPRB, 4.39E-01_JPRB, 4.36E-01_JPRB, 4.32E-01_JPRB, &
- & 4.29E-01_JPRB, 4.27E-01_JPRB, 4.24E-01_JPRB, 4.19E-01_JPRB, 4.08E-01_JPRB, &
- & 1.71E-01_JPRB, 5.51E-01_JPRB, 5.44E-01_JPRB, 7.38E-01_JPRB, 7.78E-01_JPRB, &
- & 5.54E-01_JPRB, 4.91E-01_JPRB, 5.13E-01_JPRB /)
- !
- ! Lower and upper r_e limits (in microns) for the Hu & Stamnes water cloud scheme
- !
- Real(Kind=jprb), Parameter :: low_re(3) = &
- & (/ 2.5_JPRB, 12.5_JPRB, 30.0_JPRB /)
- Real(Kind=jprb), Parameter :: upp_re(3) = &
- & (/ 12.5_JPRB, 30.0_JPRB, 60.0_JPRB /)
- !
- ! Ice cloud coefficients for hexagonal columns and aggregates (Baran et al. references, etc.)
- !
- Integer(Kind=jpim), Parameter :: nvalice = 52 ! No. of wavelengths for tabulated ice cloud data (columns & aggregates)
- Real(Kind=jprb), Parameter :: ziceom(nvalice) = &
- & (/ 3030.30_JPRB, 2941.18_JPRB, 2857.14_JPRB, 2739.73_JPRB, 2631.58_JPRB, 2500.00_JPRB, &
- & 2352.94_JPRB, 2222.22_JPRB, 2105.26_JPRB, 2000.00_JPRB, 1904.76_JPRB, 1818.18_JPRB, &
- & 1739.13_JPRB, 1666.67_JPRB, 1600.00_JPRB, 1538.46_JPRB, 1481.48_JPRB, 1428.57_JPRB, &
- & 1379.31_JPRB, 1333.33_JPRB, 1290.32_JPRB, 1250.00_JPRB, 1212.12_JPRB, 1176.47_JPRB, &
- & 1142.86_JPRB, 1111.11_JPRB, 1081.08_JPRB, 1052.63_JPRB, 1025.64_JPRB, 1000.00_JPRB, &
- & 975.610_JPRB, 952.381_JPRB, 930.233_JPRB, 909.091_JPRB, 888.889_JPRB, 869.565_JPRB, &
- & 851.064_JPRB, 833.333_JPRB, 816.327_JPRB, 800.000_JPRB, 784.314_JPRB, 769.231_JPRB, &
- & 754.717_JPRB, 740.741_JPRB, 727.273_JPRB, 714.286_JPRB, 701.754_JPRB, 689.655_JPRB, &
- & 677.966_JPRB, 666.667_JPRB, 645.161_JPRB, 625.000_JPRB /)
- !
- Real(Kind=jprb), Parameter :: ziceclmna(nvalice) = &
- & (/ -2.730E-04_JPRB, 2.955E-03_JPRB, 8.551E-03_JPRB, 1.104E-02_JPRB, 1.142E-02_JPRB, &
- & 1.063E-02_JPRB, 6.645E-03_JPRB, 4.585E-03_JPRB, 7.438E-03_JPRB, 1.153E-02_JPRB, &
- & 1.118E-02_JPRB, 8.874E-03_JPRB, 4.290E-03_JPRB, 7.193E-05_JPRB, -2.919E-04_JPRB, &
- & 1.430E-03_JPRB, 1.499E-03_JPRB, 2.203E-03_JPRB, 2.854E-03_JPRB, 3.659E-03_JPRB, &
- & 4.395E-03_JPRB, 5.954E-03_JPRB, 8.233E-03_JPRB, 8.613E-03_JPRB, 8.671E-03_JPRB, &
- & 8.635E-03_JPRB, 8.579E-03_JPRB, 8.933E-03_JPRB, 9.294E-03_JPRB, 9.194E-03_JPRB, &
- & 6.983E-03_JPRB, 4.237E-03_JPRB, 8.328E-04_JPRB, -1.586E-03_JPRB, -3.119E-03_JPRB, &
- & -4.084E-03_JPRB, -4.778E-03_JPRB, -5.424E-03_JPRB, -5.775E-03_JPRB, -6.258E-03_JPRB, &
- & -6.650E-03_JPRB, -7.006E-03_JPRB, -7.293E-03_JPRB, -7.489E-03_JPRB, -7.606E-03_JPRB, &
- & -7.604E-03_JPRB, -7.290E-03_JPRB, -6.789E-03_JPRB, -6.010E-03_JPRB, -5.113E-03_JPRB, &
- & -3.079E-03_JPRB, -1.319E-03_JPRB /)
- !
- Real(Kind=jprb), Parameter :: ziceclmnb(nvalice) = &
- & (/ 1.15507_JPRB, 0.998864_JPRB, 0.648575_JPRB, 0.413856_JPRB, 0.357719_JPRB, 0.477263_JPRB, &
- & 0.801942_JPRB, 0.929286_JPRB, 0.748354_JPRB, 0.484662_JPRB, 0.532899_JPRB, 0.756074_JPRB, &
- & 1.06101_JPRB, 1.29158_JPRB, 1.31124_JPRB, 1.22431_JPRB, 1.22406_JPRB, 1.18912_JPRB, &
- & 1.15642_JPRB, 1.11504_JPRB, 1.06638_JPRB, 0.975032_JPRB, 0.839719_JPRB, 0.820845_JPRB, &
- & 0.817312_JPRB, 0.822945_JPRB, 0.824715_JPRB, 0.803417_JPRB, 0.776200_JPRB, 0.779677_JPRB, &
- & 0.905234_JPRB, 1.05443_JPRB, 1.22364_JPRB, 1.33783_JPRB, 1.41295_JPRB, 1.46198_JPRB, &
- & 1.49971_JPRB, 1.53374_JPRB, 1.56394_JPRB, 1.59190_JPRB, 1.61783_JPRB, 1.64190_JPRB, &
- & 1.66343_JPRB, 1.68113_JPRB, 1.69468_JPRB, 1.70311_JPRB, 1.70024_JPRB, 1.68537_JPRB, &
- & 1.65613_JPRB, 1.61908_JPRB, 1.52735_JPRB, 1.44473_JPRB /)
- !
- Real(Kind=jprb), Parameter :: ziceclmnc(nvalice) = &
- & (/ -1.26793_JPRB, -2.27565_JPRB, -1.96593_JPRB, -1.35472_JPRB, -1.18284_JPRB, -1.54074_JPRB, &
- & -2.25679_JPRB, -2.36525_JPRB, -2.17367_JPRB, -1.82730_JPRB, -2.00055_JPRB, -2.66083_JPRB, &
- & -3.22855_JPRB, -3.10677_JPRB, -3.16384_JPRB, -3.33039_JPRB, -3.34724_JPRB, -3.37792_JPRB, &
- & -3.39756_JPRB, -3.38943_JPRB, -3.22239_JPRB, -3.14114_JPRB, -2.88840_JPRB, -2.85444_JPRB, &
- & -2.85180_JPRB, -2.85761_JPRB, -2.86914_JPRB, -2.80742_JPRB, -2.72661_JPRB, -2.69076_JPRB, &
- & -2.82381_JPRB, -2.82896_JPRB, -2.48929_JPRB, -1.97028_JPRB, -1.58561_JPRB, -1.34155_JPRB, &
- & -1.19335_JPRB, -1.12488_JPRB, -1.14122_JPRB, -1.19303_JPRB, -1.34383_JPRB, -1.52861_JPRB, &
- & -1.76771_JPRB, -2.04851_JPRB, -2.34234_JPRB, -2.67892_JPRB, -3.03952_JPRB, -3.42093_JPRB, &
- & -3.78222_JPRB, -4.04325_JPRB, -4.34446_JPRB, -4.42520_JPRB /)
- !
- Real(Kind=jprb), Parameter :: ziceclmnd(nvalice) = &
- & (/ 1.999E-06_JPRB, -1.308E-05_JPRB, -3.710E-05_JPRB, -4.492E-05_JPRB, -4.540E-05_JPRB, &
- & -4.410E-05_JPRB, -2.943E-05_JPRB, -2.046E-05_JPRB, -3.272E-05_JPRB, -4.888E-05_JPRB, &
- & -4.826E-05_JPRB, -4.139E-05_JPRB, -2.206E-05_JPRB, -2.334E-06_JPRB, -7.321E-07_JPRB, &
- & -9.059E-06_JPRB, -9.474E-06_JPRB, -1.289E-05_JPRB, -1.603E-05_JPRB, -1.986E-05_JPRB, &
- & -2.281E-05_JPRB, -2.979E-05_JPRB, -3.992E-05_JPRB, -4.159E-05_JPRB, -4.172E-05_JPRB, &
- & -4.155E-05_JPRB, -4.107E-05_JPRB, -4.245E-05_JPRB, -4.362E-05_JPRB, -4.273E-05_JPRB, &
- & -3.247E-05_JPRB, -1.948E-05_JPRB, -3.936E-06_JPRB, 6.769E-06_JPRB, 1.342E-05_JPRB, &
- & 1.751E-05_JPRB, 2.041E-05_JPRB, 2.323E-05_JPRB, 2.422E-05_JPRB, 2.637E-05_JPRB, &
- & 2.814E-05_JPRB, 2.976E-05_JPRB, 3.107E-05_JPRB, 3.195E-05_JPRB, 3.244E-05_JPRB, &
- & 3.234E-05_JPRB, 3.050E-05_JPRB, 2.792E-05_JPRB, 2.396E-05_JPRB, 1.944E-05_JPRB, &
- & 9.359E-06_JPRB, 6.752E-07_JPRB /)
- !
- Real(Kind=jprb), Parameter :: ziceaggra(nvalice) = &
- & (/ -5.185e-05_JPRB, 4.493e-03_JPRB, 9.876e-03_JPRB, 1.049e-02_JPRB, 1.053e-02_JPRB, &
- & 1.069e-02_JPRB, 1.015e-02_JPRB, 7.414e-03_JPRB, 1.021e-02_JPRB, 1.086e-02_JPRB, &
- & 1.067e-02_JPRB, 9.625e-03_JPRB, 6.808e-03_JPRB, 2.553e-03_JPRB, 2.433e-03_JPRB, &
- & 4.034e-03_JPRB, 4.089e-03_JPRB, 4.599e-03_JPRB, 5.161e-03_JPRB, 5.677e-03_JPRB, &
- & 6.128e-03_JPRB, 7.258e-03_JPRB, 7.541e-03_JPRB, 7.768e-03_JPRB, 7.849e-03_JPRB, &
- & 7.810e-03_JPRB, 7.874e-03_JPRB, 8.063e-03_JPRB, 8.300e-03_JPRB, 8.178e-03_JPRB, &
- & 6.610e-03_JPRB, 4.199e-03_JPRB, 5.587e-05_JPRB, -3.759e-03_JPRB, -5.227e-03_JPRB, &
- & -6.710e-03_JPRB, -7.729e-03_JPRB, -8.106e-03_JPRB, -8.477e-03_JPRB, -8.424e-03_JPRB, &
- & -8.372e-03_JPRB, -8.584e-03_JPRB, -8.162e-03_JPRB, -7.566e-03_JPRB, -6.899e-03_JPRB, &
- & -6.173e-03_JPRB, -5.201e-03_JPRB, -3.949e-03_JPRB, -2.594e-03_JPRB, -1.514e-03_JPRB, &
- & 7.812e-04_JPRB, 2.239e-03_JPRB /)
- !
- Real(Kind=jprb), Parameter :: ziceaggrb(nvalice) = &
- & (/ 1.11934_JPRB, 0.847526_JPRB, 0.463047_JPRB, 0.259500_JPRB, 0.203728_JPRB, 0.279832_JPRB, &
- & 0.403984_JPRB, 0.650849_JPRB, 0.397133_JPRB, 0.264136_JPRB, 0.288991_JPRB, 0.422823_JPRB, &
- & 0.640145_JPRB, 0.877570_JPRB, 0.884022_JPRB, 0.789077_JPRB, 0.787059_JPRB, 0.755748_JPRB, &
- & 0.724099_JPRB, 0.689130_JPRB, 0.663811_JPRB, 0.587901_JPRB, 0.509921_JPRB, 0.498516_JPRB, &
- & 0.492339_JPRB, 0.498351_JPRB, 0.496686_JPRB, 0.488979_JPRB, 0.472445_JPRB, 0.482186_JPRB, &
- & 0.595324_JPRB, 0.757605_JPRB, 1.00574_JPRB, 1.21263_JPRB, 1.29811_JPRB, 1.38007_JPRB, &
- & 1.44194_JPRB, 1.46135_JPRB, 1.47735_JPRB, 1.48062_JPRB, 1.48395_JPRB, 1.49712_JPRB, &
- & 1.47944_JPRB, 1.45448_JPRB, 1.40992_JPRB, 1.37143_JPRB, 1.32063_JPRB, 1.25652_JPRB, &
- & 1.17969_JPRB, 1.11374_JPRB, 0.986506_JPRB, 0.896953_JPRB /)
- !
- Real(Kind=jprb), Parameter :: ziceaggrc(nvalice) = &
- & (/ -0.402978_JPRB, -0.993241_JPRB, -0.761126_JPRB, -0.510089_JPRB, -0.398976_JPRB, -0.560947_JPRB, &
- & -0.801117_JPRB, -1.17222_JPRB, -0.799439_JPRB, -0.543211_JPRB, -0.598025_JPRB, -0.851190_JPRB, &
- & -1.16924_JPRB, -1.39290_JPRB, -1.40250_JPRB, -1.38837_JPRB, -1.39815_JPRB, -1.38553_JPRB, &
- & -1.35820_JPRB, -1.32358_JPRB, -1.29793_JPRB, -1.19598_JPRB, -1.10910_JPRB, -1.09096_JPRB, &
- & -1.07515_JPRB, -1.08374_JPRB, -1.07629_JPRB, -1.06212_JPRB, -1.02335_JPRB, -1.02745_JPRB, &
- & -1.19042_JPRB, -1.38410_JPRB, -1.55130_JPRB, -1.55680_JPRB, -1.40604_JPRB, -1.38190_JPRB, &
- & -1.40931_JPRB, -1.33680_JPRB, -1.31955_JPRB, -1.38799_JPRB, -1.45670_JPRB, -1.58177_JPRB, &
- & -1.67483_JPRB, -1.78235_JPRB, -1.80958_JPRB, -1.90786_JPRB, -1.99872_JPRB, -2.06038_JPRB, &
- & -2.06921_JPRB, -2.04467_JPRB, -1.96709_JPRB, -1.87323_JPRB /)
- !
- Real(Kind=jprb), Parameter :: ziceaggrd(nvalice) = &
- & (/ 1.268e-06_JPRB, -1.567e-05_JPRB, -3.467e-05_JPRB, -3.147e-05_JPRB, -3.023e-05_JPRB, &
- & -3.283e-05_JPRB, -3.331e-05_JPRB, -2.502e-05_JPRB, -3.346e-05_JPRB, -3.312e-05_JPRB, &
- & -3.254e-05_JPRB, -3.033e-05_JPRB, -2.041e-05_JPRB, -2.780e-06_JPRB, -2.405e-06_JPRB, &
- & -8.877e-06_JPRB, -9.126e-06_JPRB, -1.115e-05_JPRB, -1.350e-05_JPRB, -1.542e-05_JPRB, &
- & -1.731e-05_JPRB, -2.160e-05_JPRB, -2.077e-05_JPRB, -2.169e-05_JPRB, -2.191e-05_JPRB, &
- & -2.180e-05_JPRB, -2.207e-05_JPRB, -2.286e-05_JPRB, -2.362e-05_JPRB, -2.300e-05_JPRB, &
- & -1.709e-05_JPRB, -7.907e-06_JPRB, 8.274e-06_JPRB, 2.344e-05_JPRB, 2.856e-05_JPRB, &
- & 3.424e-05_JPRB, 3.794e-05_JPRB, 3.926e-05_JPRB, 4.080e-05_JPRB, 4.030e-05_JPRB, &
- & 3.980e-05_JPRB, 4.075e-05_JPRB, 3.888e-05_JPRB, 3.623e-05_JPRB, 3.382e-05_JPRB, &
- & 3.086e-05_JPRB, 2.682e-05_JPRB, 2.155e-05_JPRB, 1.606e-05_JPRB, 1.188e-05_JPRB, &
- & 2.402e-06_JPRB, -3.311e-06_JPRB /)
-
- !
- !1.8 Hard limits for control of input profile
- !--------------------------------------------
- ! Temperature
- Real(Kind=jprb), Parameter :: tmax = 400.0_JPRB ! degK
- Real(Kind=jprb), Parameter :: tmin = 90.0_JPRB ! degK
- ! Water Vapour
- Real(Kind=jprb), Parameter :: qmax = 0.60E+06_JPRB ! ppmv 0.373_JPRB kg/kg
- Real(Kind=jprb), Parameter :: qmin = 0.00_JPRB ! ppmv
- ! Ozone
- Real(Kind=jprb), Parameter :: o3max = 1000.0_JPRB ! ppmv 1.657E-3_JPRB kg/kg
- Real(Kind=jprb), Parameter :: o3min = 0.0_JPRB ! ppmv
- ! CO2
- Real(Kind=jprb), Parameter :: co2max = 1000.0_JPRB ! ppmv
- Real(Kind=jprb), Parameter :: co2min = 0.0_JPRB ! ppmv
- ! Cloud Liquid Water
- Real(Kind=jprb), Parameter :: clwmax = 1.0_JPRB ! kg/kg
- Real(Kind=jprb), Parameter :: clwmin = 0.0_JPRB ! kg/kg
- ! Surface Pressure
- Real(Kind=jprb), Parameter :: pmax = 1100.0_JPRB ! surface pressure hPa
- Real(Kind=jprb), Parameter :: pmin = 400.0_JPRB ! hPa
- ! Surface Wind
- Real(Kind=jprb), Parameter :: wmax = 100.0_JPRB ! surface wind speed (m/s)
- ! Zenith Angle
- Real(Kind=jprb), Parameter :: zenmax = 75.0_JPRB ! zenith angle (Deg) = secant 3.86_JPRB
- ! Cloud Top Pressure
- Real(Kind=jprb), Parameter :: ctpmax = 1100.0_JPRB ! (hPa)
- Real(Kind=jprb), Parameter :: ctpmin = 50.0_JPRB ! (hPa)
-
-
- !1.9 Maximum Optical Depth
- !--------------------------
- ! maximum value of optical depth for transmittance calculation
- ! e(-30) -> 10**-14
- ! e(-50) -> 10**-22
- Real(Kind=jprb), Parameter :: max_optical_depth = 50._JPRB
-
- !2 RTTOV7 aux parameters
- !-------------------------
- Integer(Kind=jpim), Parameter :: fastem_sp = 5 ! max. number of fastem surface parameters
- Integer(Kind=jpim), Parameter :: mwcldtop = 25 ! Upper level for lwp calcs
- Real(Kind=jprb), Parameter :: pressure_top = 0.004985_JPRB ! Pressure of top level for
- ! Line/Line calculations (hPa)
- Real(Kind=jprb) , Dimension(8), Parameter :: dcoeff = & ! Debye coefs
- & (/ 17.1252_JPRB, 134.2450_JPRB, 310.2125_JPRB, 5.667_JPRB, &
- & 188.7979_JPRB, 80.5419_JPRB, 0.1157_JPRB, 4.8417_JPRB/)
-
- !2.1 Polarisation definitions
- !----------------------------
- ! 1 = 0.5 (V+H)
- ! 2 = QV
- ! 3 = QH
- ! 4 = V
- ! 5 = H
- ! 6 = V , H
- ! 7 = Stokes (i.e. V , H , U, RHC)
- Integer(Kind=jpim), Dimension(7), Parameter :: npolar_compute = &
- & (/ 2, 2, 2, 1, 1, 2, 4/)
- Integer(Kind=jpim), Dimension(7), Parameter :: npolar_return = &
- & (/ 1, 1, 1, 1, 1, 2, 4/)
- Real(Kind=jprb), Parameter :: pol_v(3,5) = Reshape( &
- & (/ 0.5_JPRB, 0.0_JPRB, 0.0_JPRB, &
- & 0.0_JPRB, 0.0_JPRB, 1.0_JPRB, &
- & 0.0_JPRB, 1.0_JPRB, 0.0_JPRB, &
- & 1.0_JPRB, 0.0_JPRB, 0.0_JPRB, &
- & 0.0_JPRB, 0.0_JPRB, 0.0_JPRB /), (/3,5/) )
- Real(Kind=jprb), Parameter :: pol_h(3,5) = Reshape( &
- & (/ 0.5_JPRB, 0.0_JPRB, 0.0_JPRB, &
- & 0.0_JPRB, 1.0_JPRB, 0.0_JPRB, &
- & 0.0_JPRB, 0.0_JPRB, 1.0_JPRB, &
- & 0.0_JPRB, 0.0_JPRB, 0.0_JPRB, &
- & 1.0_JPRB, 0.0_JPRB, 0.0_JPRB /), (/3,5/) )
-
- !3 RTTOVSCATT aux parameters
- !---------------------------
- ! Minimum cloud cover processed by rttov_scatt
- Real(Kind=jprb), Parameter :: ccthres = 0.05_JPRB
- ! Rain density (g.cm-1)
- Real(Kind=jprb), Parameter :: rho_rain = 1.0_JPRB
- ! Snow density (g.cm-1)
- Real(Kind=jprb), Parameter :: rho_snow = 0.1_JPRB
-
-
-End Module rttov_const
diff --git a/src/LIB/RTTOV/src/rttov_dealloc_coef.F90 b/src/LIB/RTTOV/src/rttov_dealloc_coef.F90
deleted file mode 100644
index 80e3f065d5ffee728b94e3b561ccc4ce6da00eed..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_dealloc_coef.F90
+++ /dev/null
@@ -1,226 +0,0 @@
-!
-Subroutine rttov_dealloc_coef (errorstatus, coef)
- ! Description:
- ! de-allocation of a coefficient structure
- ! The allocation is done by the readcoef subroutine called by the user
- ! this subroutine should be called once per coef structure when
- ! all rttov calls are completed.
- !
- ! Copyright:
- ! This software was developed within the context of
- ! the EUMETSAT Satellite Application Facility on
- ! Numerical Weather Prediction (NWP SAF), under the
- ! Cooperation Agreement dated 25 November 1998, between
- ! EUMETSAT and the Met Office, UK, by one or more partners
- ! within the NWP SAF. The partners in the NWP SAF are
- ! the Met Office, ECMWF, KNMI and MeteoFrance.
- !
- ! Copyright 2002, EUMETSAT, All Rights Reserved.
- !
- ! Method:
- !
- ! Current Code Owner: SAF NWP
- !
- ! History:
- ! Version Date Comment
- ! ------- ---- -------
- ! 1.0 01/12/2002 New F90 code with structures (P Brunel A Smith)
- ! 1.1 03/05/2004 Add specific RTTOV8 CO2 variable (P. Brunel)
- ! 1.2 02/06/2004 Update for RTTOV8 coefS (P. Brunel)
- !
- ! Code Description:
- ! Language: Fortran 90.
- ! Software Standards: "European Standards for Writing and
- ! Documenting Exchangeable Fortran 90 Code".
- !
- ! Declarations:
- ! Modules used:
- ! Imported Parameters:
- Use rttov_const, Only : &
- & sensor_id_mw ,&
- & errorstatus_info ,&
- & errorstatus_success ,&
- & errorstatus_fatal ,&
- & errorstatus_warning
-
- ! Imported Type Definitions:
- Use rttov_types, Only : &
- & rttov_coef
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
-#include "rttov_errorreport.interface"
-
- ! subroutine arguments
- ! scalar arguments with intent(out):
- Integer(Kind=jpim), Intent (out) :: errorstatus ! return code
- Type( rttov_coef ), Intent (inout) :: coef ! coefficients
-
-
-
- ! Local Arrays and Scalars:
- Integer(Kind=jpim), Parameter :: n_ios = 45
- Integer(Kind=jpim) :: io_status(n_ios)
- Integer(Kind=jpim) :: ios
- Character (len=80) :: errMessage
- Character (len=18) :: NameOfRoutine = 'rttov_dealloc_coef'
-
- !- End of header --------------------------------------------------------
-
- io_status(:) = 0
- errorstatus = errorstatus_success
-
- Deallocate ( coef % fmv_gas_id , stat=io_status( 1) )
- Deallocate ( coef % fmv_gas_pos, stat=io_status( 2) )
- Deallocate ( coef % fmv_var , stat=io_status( 3) )
- Deallocate ( coef % fmv_lvl , stat=io_status( 4) )
- Deallocate ( coef % ff_ori_chn , stat=io_status( 5) )
- Deallocate ( coef % ff_val_chn , stat=io_status( 6) )
- Deallocate ( coef % ff_cwn , stat=io_status( 7) )
- Deallocate ( coef % ff_bco , stat=io_status( 8) )
- Deallocate ( coef % ff_bcs , stat=io_status( 9) )
- Deallocate ( coef % ff_gam , stat=io_status(10) )
- Deallocate ( coef % gaz_units , stat=io_status(11) )
-
- If( coef % fastem_ver >= 1 ) Then
- Deallocate ( coef % fastem_coef , stat=io_status(12) )
- Deallocate ( coef % fastem_polar , stat=io_status(13) )
- End If
- If( coef % ssirem_ver >= 1 ) Then
- Deallocate ( coef % ssirem_chn , stat=io_status(14) )
- Deallocate ( coef % ssirem_a0 , stat=io_status(15) )
- Deallocate ( coef % ssirem_a1 , stat=io_status(16) )
- Deallocate ( coef % ssirem_a2 , stat=io_status(17) )
- Deallocate ( coef % ssirem_xzn1, stat=io_status(18) )
- Deallocate ( coef % ssirem_xzn2, stat=io_status(19) )
- End If
-
- Deallocate ( coef % ref_prfl_p , stat=io_status(20) )
- Deallocate ( coef % ref_prfl_t , stat=io_status(21) )
- Deallocate ( coef % ref_prfl_mr, stat=io_status(22) )
-
- Deallocate ( coef % lim_prfl_p , stat=io_status(23) )
- Deallocate ( coef % lim_prfl_tmax, stat=io_status(24) )
- Deallocate ( coef % lim_prfl_tmin, stat=io_status(25) )
- Deallocate ( coef % lim_prfl_gmin, stat=io_status(26) )
- Deallocate ( coef % lim_prfl_gmax, stat=io_status(27) )
-
-
- If ( coef % nmixed > 0 ) Then
- Deallocate ( coef % mixedgas , stat= io_status(28) )
- End If
-
-
- If ( coef % nwater > 0 ) Then
- Deallocate ( coef % watervapour, stat= io_status(29) )
- End If
-
- If ( coef % nozone > 0 ) Then
- Deallocate ( coef % ozone , stat= io_status(30) )
- End If
-
- If ( coef % nwvcont > 0 ) Then
- Deallocate ( coef % wvcont , stat= io_status(31) )
- End If
-
- If ( coef % nco2 > 0 ) Then
- Deallocate ( coef % co2 , stat= io_status(32) )
- End If
-
- If ( coef % nn2o > 0 ) Then
- Deallocate ( coef % n2o , stat= io_status(33) )
- End If
-
- If ( coef % nco > 0 ) Then
- Deallocate ( coef % co , stat= io_status(34) )
- End If
-
- If ( coef % nch4 > 0 ) Then
- Deallocate ( coef % ch4 , stat= io_status(35) )
- End If
-
- ! planck variables
- Deallocate ( coef % planck1 , stat= io_status(36) )
- Deallocate ( coef % planck2 , stat= io_status(37) )
- ! frequency in GHz for MicroWaves
- If( coef % id_sensor == sensor_id_mw ) Then
- Deallocate ( coef % frequency_ghz , stat= io_status(38) )
- Endif
-
- ! Compute specific variables for RTTOV7/8
- Deallocate ( coef % dp , stat= io_status(39) )
- Deallocate ( coef % dpp , stat= io_status(40) )
- Deallocate ( coef % tstar , stat= io_status(41) )
- Deallocate ( coef % to3star , stat= io_status(42) )
- Deallocate ( coef % wstar , stat= io_status(43) )
- Deallocate ( coef % ostar , stat= io_status(44) )
- ! Specific variables for RTTOV8
- If( coef % fmv_model_ver == 8 ) Then
- Deallocate ( coef % co2star , stat= io_status(45) )
- End If
-
- ! reinitialize coef structure for all single types
- coef % id_platform = 0
- coef % id_sat = 0
- coef % id_inst = 0
- coef % id_sensor = 0
- coef % id_comp_lvl = 0
- coef % id_creation_date = (/ 0, 0, 0 /)
- coef % id_creation = 'xxxx'
- coef % id_Common_name = 'xxxx'
- coef % fmv_model_def = 'xxxx'
- coef % fmv_model_ver = 0
- coef % fmv_chn = 0
- coef % fmv_gas = 0
- coef % nmixed = 0
- coef % nwater = 0
- coef % nozone = 0
- coef % nwvcont = 0
- coef % nco2 = 0
- coef % nn2o = 0
- coef % nco = 0
- coef % nch4 = 0
- coef % nlevels = 0
- coef % fc_speedl = 0._JPRB
- coef % fc_planck_c1 = 0._JPRB
- coef % fc_planck_c2 = 0._JPRB
- coef % fc_sat_height = 0._JPRB
- coef % fastem_ver = 0
- coef % fastem_coef_nb = 0
- coef % ssirem_ver = 0
- coef % ratoe = 0._JPRB
-
- ! Check if any deallocation statement failed
- ! In case of failure send an error report for each case
- ! If more than 2 cases then the error is "Fatal"
- If( Any(io_status /= errorstatus_success) ) Then
- Do ios = 1, n_ios
- If( io_status(ios) /= errorstatus_success ) Then
- errorstatus = errorstatus_info
- Write( errMessage, '( "deallocation of coefficent structure number",i3 )' ) ios
- Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine)
- End If
- End Do
- If ( Count(io_status /= errorstatus_success) <= 2 ) Then
- errorstatus = errorstatus_warning
- Else
- errorstatus = errorstatus_fatal
- End If
- Write( errMessage, '( "deallocation of coefficent structure" )' )
- Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine)
- End If
-
- Nullify(coef % gaz_units)
- Nullify(coef % mixedgas)
- Nullify(coef % watervapour)
- Nullify(coef % ozone)
- Nullify(coef % wvcont)
- Nullify(coef % co2)
- Nullify(coef % n2o)
- Nullify(coef % co)
- Nullify(coef % ch4)
-
-
-
-End Subroutine rttov_dealloc_coef
diff --git a/src/LIB/RTTOV/src/rttov_dealloc_coef.interface b/src/LIB/RTTOV/src/rttov_dealloc_coef.interface
deleted file mode 100644
index e0857ef2f91a3a523adc415649665062388aff2d..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_dealloc_coef.interface
+++ /dev/null
@@ -1,24 +0,0 @@
-Interface
-!
-Subroutine rttov_dealloc_coef (errorstatus, coef)
- Use rttov_const, Only : &
- & sensor_id_mw ,&
- & errorstatus_info ,&
- & errorstatus_success ,&
- & errorstatus_fatal ,&
- & errorstatus_warning
-
- Use rttov_types, Only : &
- rttov_coef
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
-
- Integer(Kind=jpim), Intent (out) :: errorstatus ! return code
- Type( rttov_coef ), Intent (inout) :: coef ! coefficients
-
-
-
-End Subroutine rttov_dealloc_coef
-End Interface
diff --git a/src/LIB/RTTOV/src/rttov_deletecomment.F90 b/src/LIB/RTTOV/src/rttov_deletecomment.F90
deleted file mode 100644
index f761c88ed25b3ce374504fd733fe3a8a2d13cbfe..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_deletecomment.F90
+++ /dev/null
@@ -1,71 +0,0 @@
-!
-Subroutine rttov_DeleteComment (String)
- ! Description:
- ! Routine delete comments from string
- !
- !
- ! This software was developed within the context of
- ! the EUMETSAT Satellite Application Facility on
- ! Numerical Weather Prediction (NWP SAF), under the
- ! Cooperation Agreement dated 25 November 1998, between
- ! EUMETSAT and the Met Office, UK, by one or more partners
- ! within the NWP SAF. The partners in the NWP SAF are
- ! the Met Office, ECMWF, KNMI and MeteoFrance.
- !
- ! Copyright 2002, EUMETSAT, All Rights Reserved.
- !
- ! Purpose:
- ! Delete comments and adjust left inside a character string
- ! Comments are starting by a '!' sign
- !
- ! Method:
- ! Check position of character !
- ! If found, change all characters starting at! position to the lenght
- ! of string by a space.
- ! Returns modifyed string adjusted left
- !
- ! Current Code Owner: P. Brunel
- !
- ! History:
- ! Version Date Comment
- ! 1.0 08/03/01 F90 Original P. Brunel
- !
- ! Code Description:
- ! FORTRAN 90
- !
- ! Declarations
- Use parkind1 , Only : jpim ,jprb
- Implicit None
- !
- ! Global variables:
- !
- ! Subroutine arguments
- ! Scalar arguments with intent(in/out):
- Character (len=*) , Intent (inout) :: string ! ..to check
-
-
-
- ! Local variables
- Character (len=1) :: comment = '!' ! character for starting comment
- Integer(Kind=jpim) :: pos_mark ! position of character '!' in current string
- Integer(Kind=jpim) :: lenght ! lenght of string
- Integer(Kind=jpim) :: i ! loop indice
- !- End of header
-
- ! find position of comment character in string
- pos_mark = Scan(string,comment)
- lenght = Len(string)
-
- ! if comment is present, replace comment by spaces
- If(pos_mark > 0) Then
- Do i = pos_mark, lenght
- string(i:i) = ' '
- End Do
- End If
-
- ! Adjust left string
- string = Adjustl(string)
-
-
-
-End Subroutine rttov_DeleteComment
diff --git a/src/LIB/RTTOV/src/rttov_deletecomment.interface b/src/LIB/RTTOV/src/rttov_deletecomment.interface
deleted file mode 100644
index f7f27640e8580cc34341c8f437e2f95128a00569..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_deletecomment.interface
+++ /dev/null
@@ -1,11 +0,0 @@
-Interface
-!
-Subroutine rttov_DeleteComment (String)
- Use parkind1, Only : jpim ,jprb
- Implicit None
- Character (len=*) , Intent (inout) :: string ! ..to check
-
-
-
-End Subroutine rttov_DeleteComment
-End Interface
diff --git a/src/LIB/RTTOV/src/rttov_direct.F90 b/src/LIB/RTTOV/src/rttov_direct.F90
deleted file mode 100644
index 5493bdaa4c240f880f4a2110b674377b8c60905c..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_direct.F90
+++ /dev/null
@@ -1,483 +0,0 @@
-!
-Subroutine rttov_direct( &
- & errorstatus, &! out
- & nfrequencies, &! in
- & nchannels, &! in
- & nbtout, &! in
- & nprofiles, &! in
- & channels, &! in
- & polarisations, &! in
- & lprofiles, &! in
- & profiles, &! in
- & coef, &! in
- & addcloud, &! in
- & calcemis, &! in
- & emissivity, &! inout
- & transmission, &! inout
- & radiancedata ) ! inout
- !
- ! Description:
- ! to compute multi-channel level to space transmittances,
- ! top of atmosphere and level to space radiances and brightness
- ! temperatures and optionally surface emissivities, for many
- ! profiles in a single call, for satellite
- ! infrared or microwave sensors. The code requires a coefficient file
- ! for each sensor for which simulated radiances are requested.
- !
- ! Copyright:
- ! This software was developed within the context of
- ! the EUMETSAT Satellite Application Facility on
- ! Numerical Weather Prediction (NWP SAF), under the
- ! Cooperation Agreement dated 25 November 1998, between
- ! EUMETSAT and the Met Office, UK, by one or more partners
- ! within the NWP SAF. The partners in the NWP SAF are
- ! the Met Office, ECMWF, KNMI and MeteoFrance.
- !
- ! Copyright 2002, EUMETSAT, All Rights Reserved.
- !
- ! Method: The methodology is described in the following:
- !
- ! Eyre J.R. and H.M. Woolf 1988 Transmittance of atmospheric gases
- ! in the microwave region: a fast model. Applied Optics 27 3244-3249
- !
- ! Eyre J.R. 1991 A fast radiative transfer model for satellite sounding
- ! systems. ECMWF Research Dept. Tech. Memo. 176 (available from the
- ! librarian at ECMWF).
- !
- ! Saunders R.W., M. Matricardi and P. Brunel 1999 An Improved Fast Radiative
- ! Transfer Model for Assimilation of Satellite Radiance Observations.
- ! QJRMS, 125, 1407-1425.
- !
- ! Matricardi, M., F. Chevallier and S. Tjemkes 2001 An improved general
- ! fast radiative transfer model for the assimilation of radiance
- ! observations. ECMWF Research Dept. Tech. Memo. 345
- ! (available from the librarian at ECMWF).
- !
- ! Current Code Owner: SAF NWP
- !
- ! History:
- ! Version Date Comment
- ! ------- ---- -------
- ! 13/8/92. For version 2.
- ! ksat added to argument list; ssu included;
- ! internal changes to move big arrays from commons to
- ! arguments and to introduce taskcommons
- ! 8/7/97 added ozone and extended water vapour in control vector
- ! 01/05/2000 F90 code
- ! 21/08/2000 Interface to rtint changed to include pref (surface reflectivity).
- ! (Stephen English)
- ! 31/01/2001 More cloud computations. stored in radov (F. Chevallier)
- ! 6/2/2001 pgrody and knav etc arrays removed from call (R Saunders)
- ! 18/01/2002 Thread safe (D.Salmond)
- ! 01/12/2002 New F90 code with structures (P Brunel A Smith)
- ! 02/01/2003 More comments added (R Saunders)
- ! 24/01/2003 Error return code by input profile (P Brunel)
- ! Add WV Continuum and CO2 capability
- ! 02/06/2004 Change tests on id_comp_lvl == 7 by tests on fmv_model_ver (P. Brunel)
- !
- ! Code Description:
- ! Language: Fortran 90.
- ! Software Standards: "European Standards for Writing and
- ! Documenting Exchangeable Fortran 90 Code".
- ! A user guide and technical documentation is available at
- ! http://www.metoffice.com/research/interproj/nwpsaf/rtm/index.html
- !
- ! Declarations:
- ! Modules used:
- ! Imported Parameters:
- Use rttov_const, Only : &
- & errorstatus_success ,&
- & errorstatus_warning ,&
- & errorstatus_fatal ,&
- & max_optical_depth ,&
- & sensor_id_mw ,&
- & sensor_id_ir
-
- ! Imported Type Definitions:
- Use rttov_types, Only : &
- & rttov_coef ,&
- & profile_Type ,&
- & geometry_Type ,&
- & predictors_Type,&
- & profile_aux ,&
- & transmission_type ,&
- & radiance_Type ,&
- & radiance_aux
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
-#include "rttov_errorreport.interface"
-#include "rttov_checkinput.interface"
-#include "rttov_profaux.interface"
-#include "rttov_setgeometry.interface"
-#include "rttov_setpredictors.interface"
-#include "rttov_setpredictors_8.interface"
-#include "rttov_transmit.interface"
-#include "rttov_calcemis_ir.interface"
-#include "rttov_calcemis_mw.interface"
-#include "rttov_integrate.interface"
-
- !subroutine arguments:
- Integer(Kind=jpim), Intent(in) :: nchannels ! Number of radiances computed
- Integer(Kind=jpim), Intent(in) :: nfrequencies ! Number of frequencies
- ! (= channels used * profiles)
- Integer(Kind=jpim), Intent(in) :: nbtout ! Number of BTs returned
- Integer(Kind=jpim), Intent(in) :: nprofiles ! Number of profiles
- Integer(Kind=jpim), Intent(in) :: channels(nfrequencies) ! Channel indices
- Integer(Kind=jpim), Intent(in) :: polarisations(nchannels,3) ! Channel indices
- Integer(Kind=jpim), Intent(in) :: lprofiles(nfrequencies) !#Profiles indices
- Logical, Intent(in) :: addcloud ! switch for cloud computations
- Type(profile_Type), Intent(in) :: profiles(nprofiles) ! Atmospheric profiles
- Type(rttov_coef), Intent(in) :: coef ! RT Coefficients
- Logical, Intent(in) :: calcemis(nchannels)! switch for emmissivity calc.
- Real(Kind=jprb), Intent(inout) :: emissivity(nchannels) ! surface emmissivity
- Type(transmission_type), Intent(inout) :: transmission ! transmittances and layer optical depths
- Type(radiance_Type), Intent(inout) :: radiancedata ! radiances (mw/cm-1/ster/sq.m) and degK
- Integer(Kind=jpim), Intent(out) :: errorstatus(nprofiles) ! return flag
-
-
-
- !local variables:
- Integer(Kind=jpim) :: i ! loop index
- Logical :: addcosmic ! switch for adding temp of cosmic background
- Integer(Kind=jpim) :: alloc_status(10) ! memory allocation status
- Real(Kind=jprb) :: reflectivity(nchannels) ! surface reflectivity
- Real(Kind=jprb) :: od_layer(coef%nlevels,nchannels) ! layer optical depth
- Real(Kind=jprb) :: opdp_ref(coef%nlevels,nfrequencies) ! layer optical depth before threshold
- ! from each standard pressure level
- Character (len=80) :: errMessage
- Character (len=12) :: NameOfRoutine = 'rttov_direct'
-
- Type(geometry_Type) :: angles(nprofiles) ! geometry angles
- Type(predictors_Type) :: predictors(nprofiles)! predictors
- Type(profile_aux) :: aux_prof(nprofiles) ! auxillary profiles informations
- Type(radiance_aux) :: auxrad ! auxillary radiances
-
- !- End of header --------------------------------------------------------
-
-
- !-------------
- !0. initialize
- !-------------
-
- errorstatus(:) = errorstatus_success
- alloc_status(:) = 0
-
- !------------------------------------------------------
- !1. check input data is within suitable physical limits
- !------------------------------------------------------
-
-
- Do i = 1, nprofiles
-
- Call rttov_checkinput( &
- & profiles( i ), &!in
- & coef, &!in
- & errorstatus(i) ) !out
-
- End Do
-
- ! 1.1 test check input return code
- !-----------------------------_---
- If ( any( errorstatus(:) == errorstatus_warning ) ) Then
- Do i = 1, nprofiles
- If ( errorstatus(i) == errorstatus_warning ) Then
- Write( errMessage, '( "checkinput warning error for profile",i4)' ) i
- Call Rttov_ErrorReport (errorstatus_warning, errMessage, NameOfRoutine)
- End If
- End Do
- End If
-
- If ( any( errorstatus(:) == errorstatus_fatal ) ) Then
- Do i = 1, nprofiles
- If ( errorstatus(i) == errorstatus_fatal ) Then
- ! Some unphysical values; Do not run RTTOV
- Write( errMessage, '( "checkinput fatal error for profile",i4)' ) i
- Call Rttov_ErrorReport (errorstatus_fatal, errMessage, NameOfRoutine)
- End If
- End Do
- ! nothing processed so all profiles get the fatal error code
- ! user will know which profile
- errorstatus(:) = errorstatus_fatal
- Return
- End If
-
-
-
- !-----------------------------------------
- !2. determine cloud top and surface levels
- !-----------------------------------------
- Do i = 1, nprofiles
- If( coef % id_sensor == sensor_id_mw ) Then
- Allocate( aux_prof(i) % debye_prof( 5 , coef%nlevels ), stat= alloc_status(1) )
- If( alloc_status(1) /= 0 ) Then
- errorstatus(:) = errorstatus_fatal
- Write( errMessage, '( "allocation of debye_prof")' )
- Call Rttov_ErrorReport (errorstatus_fatal, errMessage, NameOfRoutine)
- Return
- End If
- Endif
- Call rttov_profaux( &
- & profiles(i), &! in
- & coef, &! in
- & aux_prof(i)) ! inout
- End Do
-
-
- !------------------------------------------------------------------
- !3. set up common geometric variables for transmittance calculation
- !------------------------------------------------------------------
-
- Do i = 1, nprofiles
- Call rttov_setgeometry( &
- & profiles(i), &! in
- & coef, &! in
- & angles(i) ) ! out
- End Do
-
-
- !------------------------------------------
- !5. calculate transmittance path predictors
- !------------------------------------------
-
- Do i = 1, nprofiles
- predictors(i) % nlevels = coef % nlevels
- predictors(i) % nmixed = coef % nmixed
- predictors(i) % nwater = coef % nwater
- predictors(i) % nozone = coef % nozone
- predictors(i) % nwvcont = coef % nwvcont
- predictors(i) % nco2 = coef % nco2
- predictors(i) % ncloud = 0 ! (can be set to 1 inside setpredictors)
-
- Allocate( predictors(i) % mixedgas&
- & ( coef%nmixed , coef%nlevels ) ,stat= alloc_status(1))
- Allocate( predictors(i) % watervapour&
- & ( coef%nwater , coef%nlevels ) ,stat= alloc_status(2))
- Allocate( predictors(i) % clw&
- & ( coef%nlevels ) ,stat= alloc_status(3))
- If( coef%nozone > 0 ) Then
- Allocate( predictors(i) % ozone&
- & ( coef%nozone , coef%nlevels ) ,stat= alloc_status(4))
- End If
- If( coef%nwvcont > 0 ) Then
- Allocate( predictors(i) % wvcont&
- & ( coef%nwvcont , coef%nlevels ) ,stat= alloc_status(5))
- End If
- If( coef%nco2 > 0 ) Then
- Allocate( predictors(i) % co2&
- & ( coef%nco2 , coef%nlevels ) ,stat= alloc_status(6))
- End If
- If( Any(alloc_status /= 0) ) Then
- errorstatus(:) = errorstatus_fatal
- Write( errMessage, '( "allocation of predictors")' )
- Call Rttov_ErrorReport (errorstatus_fatal, errMessage, NameOfRoutine)
- Return
- End If
-
- If (coef%fmv_model_ver == 7) Then
- Call rttov_setpredictors( &
- & profiles(i), &! in
- & angles(i), &! in
- & coef, &! in
- & predictors(i) ) ! inout (in because of mem allocation)
-
- Else If (coef%fmv_model_ver == 8) Then
- Call rttov_setpredictors_8( &
- & profiles(i), &! in
- & angles(i), &! in
- & coef, &! in
- & predictors(i) ) ! inout (in because of mem allocation)
-
- Else
- errorstatus(:) = errorstatus_fatal
- Write( errMessage,&
- & '( "Unexpected RTTOV compatibility version number" )' )
- Call Rttov_ErrorReport (errorstatus_fatal, errMessage, NameOfRoutine)
- Return
- End If
-
- End Do ! Profile loop
-
-
- !----------------------------------------------
- !6. calculate optical depths and transmittances
- !----------------------------------------------
- Call rttov_transmit( &
- & nfrequencies, &! in
- & nchannels, &! in
- & nprofiles, &! in
- & coef%nlevels, &! in
- & channels, &! in
- & polarisations, &! in
- & lprofiles, &! in
- & predictors, &! in
- & aux_prof, &! in
- & coef, &! in
- & transmission, &! out
- & od_layer, &! out
- & opdp_ref) ! out
-
- !--------------------------------------
- !7. calculate channel emissivity values
- !--------------------------------------
-
- If ( Any(calcemis) ) Then
- ! calculate surface emissivity for selected channels
- ! and reflectivity
- If ( coef % id_sensor == sensor_id_ir ) Then
- !Infrared
- Call rttov_calcemis_ir( &
- & profiles, &! in
- & angles, &! in
- & coef, &! in
- & nfrequencies, &! in
- & nprofiles, &! in
- & channels, &! in
- & lprofiles, &! in
- & calcemis, &! in
- & emissivity ) ! inout
- reflectivity(:) = 1 - emissivity(:)
-
- Elseif ( coef % id_sensor == sensor_id_mw ) Then
- !Microwave
- Call rttov_calcemis_mw ( &
- & profiles, &! in
- & angles, &! in
- & coef, &! in
- & nfrequencies, &! in
- & nchannels, &! in
- & nprofiles, &! in
- & channels, &! in
- & polarisations, &! in
- & lprofiles, &! in
- & transmission, &! in
- & calcemis, &! in
- & emissivity, &! inout
- & reflectivity, &! out
- & errorstatus ) ! inout
- If ( Any( errorstatus == errorstatus_fatal ) ) Then
- errorstatus(:) = errorstatus_fatal
- Return
- End If
- Else
- ! Hires
- Call rttov_calcemis_ir( &
- & profiles, &! in
- & angles, &! in
- & coef, &! in
- & nfrequencies, &! in
- & nprofiles, &! in
- & channels, &! in
- & lprofiles, &! in
- & calcemis, &! in
- & emissivity ) ! inout
- reflectivity(:) = 1 - emissivity(:)
- End If
-
- ! reflectivity for other channels
- Where( .Not. calcemis(:) )
- reflectivity(:) = 1 - emissivity(:)
- End Where
-
- Else
- ! reflectivity for all channels
- reflectivity(:) = 1 - emissivity(:)
- End If
-
-
- !--------------------------------------------
- !8. integrate the radiative transfer equation
- !--------------------------------------------
- Allocate(auxrad % layer (coef % nlevels, nchannels) ,stat= alloc_status(1))
- Allocate(auxrad % surfair (nchannels) ,stat= alloc_status(2))
- Allocate(auxrad % skin (nchannels) ,stat= alloc_status(3))
- Allocate(auxrad % cosmic (nchannels) ,stat= alloc_status(4))
- Allocate(auxrad % up (coef % nlevels, nchannels) ,stat= alloc_status(5))
- Allocate(auxrad % down (coef % nlevels, nchannels) ,stat= alloc_status(6))
- If ( addcloud ) Then
- Allocate(auxrad % down_cloud (coef % nlevels, nchannels),stat= alloc_status(7))
- End If
- If( Any(alloc_status /= 0) ) Then
- errorstatus(:) = errorstatus_fatal
- Write( errMessage, '( "allocation of aux radiances")' )
- Call Rttov_ErrorReport (errorstatus_fatal, errMessage, NameOfRoutine)
- Return
- End If
-
- addcosmic = ( coef % id_sensor == sensor_id_mw )
- Call rttov_integrate( &
- & addcloud, &! in
- & addcosmic, &! in
- & nfrequencies, &! in
- & nchannels, &! in
- & nbtout, &! in
- & nprofiles, &! in
- & angles, &! in
- & channels, &! in
- & polarisations, &! in
- & lprofiles, &! in
- & emissivity, &! in
- & reflectivity, &! in
- & transmission, &! in
- & profiles, &! in
- & aux_prof, &! in
- & coef, &! in
- & radiancedata, &! inout
- & auxrad ) ! inout
-
- !--------------------
- !9. deallocate memory
- !--------------------
- Do i = 1, nprofiles
- Deallocate( predictors(i) % mixedgas ,stat= alloc_status(1))
- Deallocate( predictors(i) % watervapour ,stat= alloc_status(2))
- Deallocate( predictors(i) % clw ,stat= alloc_status(3))
- If( predictors(i) % nozone > 0 ) Then
- Deallocate( predictors(i) % ozone ,stat= alloc_status(4))
- End If
- If( predictors(i) % nwvcont > 0 ) Then
- Deallocate( predictors(i) % wvcont ,stat= alloc_status(5))
- End If
- If( predictors(i) % nco2 > 0 ) Then
- Deallocate( predictors(i) % co2 ,stat= alloc_status(6))
- End If
- If( Any(alloc_status /= 0) ) Then
- errorstatus(:) = errorstatus_fatal
- Write( errMessage, '( "deallocation of predictors")' )
- Call Rttov_ErrorReport (errorstatus_fatal, errMessage, NameOfRoutine)
- Return
- End If
- End Do
-
- Deallocate(auxrad % layer ,stat= alloc_status(1))
- Deallocate(auxrad % surfair ,stat= alloc_status(2))
- Deallocate(auxrad % skin ,stat= alloc_status(3))
- Deallocate(auxrad % cosmic ,stat= alloc_status(4))
- Deallocate(auxrad % up ,stat= alloc_status(5))
- Deallocate(auxrad % down ,stat= alloc_status(6))
- If ( addcloud ) Then
- Deallocate(auxrad % down_cloud ,stat= alloc_status(7))
- End If
- If( Any(alloc_status /= 0) ) Then
- errorstatus(:) = errorstatus_fatal
- Write( errMessage, '( "deallocation of aux radiances")' )
- Call Rttov_ErrorReport (errorstatus_fatal, errMessage, NameOfRoutine)
- Return
- End If
-
- If( coef % id_sensor == sensor_id_mw ) Then
- Do i = 1, nprofiles
- If( Associated( aux_prof(i) % debye_prof) ) Then
- Deallocate( aux_prof(i) % debye_prof ,stat= alloc_status(1))
- If( Any(alloc_status /= 0) ) Then
- errorstatus(:) = errorstatus_fatal
- Write( errMessage, '( "deallocation of debye profile")' )
- Call Rttov_ErrorReport (errorstatus_fatal, errMessage, NameOfRoutine)
- Return
- End If
- End If
- End Do
- Endif
-
-End Subroutine rttov_direct
diff --git a/src/LIB/RTTOV/src/rttov_direct.interface b/src/LIB/RTTOV/src/rttov_direct.interface
deleted file mode 100644
index 00188ea061d6e9cea58d412d73f1a981125c9d3e..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_direct.interface
+++ /dev/null
@@ -1,62 +0,0 @@
-Interface
-!
-Subroutine rttov_direct( &
- errorstatus, & ! out
- nfrequencies, & ! in
- nchannels, & ! in
- nbtout, & ! in
- nprofiles, & ! in
- channels, & ! in
- polarisations, & ! in
- lprofiles, & ! in
- profiles, & ! in
- coef, & ! in
- addcloud, & ! in
- calcemis, & ! in
- emissivity, & ! inout
- transmission, & ! inout
- radiancedata ) ! inout
-
- Use rttov_const, Only : &
- errorstatus_success ,&
- errorstatus_warning ,&
- errorstatus_fatal ,&
- max_optical_depth ,&
- sensor_id_mw ,&
- sensor_id_ir
-
- Use rttov_types, Only : &
- rttov_coef ,&
- profile_Type ,&
- geometry_Type ,&
- predictors_Type,&
- profile_aux ,&
- transmission_type ,&
- radiance_Type ,&
- radiance_aux
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
-
- Integer(Kind=jpim), Intent(in) :: nchannels ! Number of output radiances
- ! (= channels used * profiles)
- Integer(Kind=jpim), Intent(in) :: nfrequencies
- Integer(Kind=jpim), Intent(in) :: nbtout
- Integer(Kind=jpim), Intent(in) :: nprofiles
- Integer(Kind=jpim), Intent(in) :: channels(nfrequencies)
- Integer(Kind=jpim), Intent(in) :: polarisations(nchannels,3)
- Integer(Kind=jpim), Intent(in) :: lprofiles(nfrequencies)
- Logical, Intent(in) :: addcloud ! switch for cloud computations
- Type(profile_Type), Intent(in) :: profiles(nprofiles) ! Atmospheric profiles
- Type(rttov_coef), Intent(in) :: coef ! RT Coefficients
- Logical, Intent(in) :: calcemis(nchannels)! switch for emmissivity calc.
- Real(Kind=jprb), Intent(inout) :: emissivity(nchannels) ! surface emmissivity
- Type(transmission_type), Intent(inout) :: transmission ! transmittances and layer optical depths
- Type(radiance_Type), Intent(inout) :: radiancedata ! radiances (mw/cm-1/ster/sq.m) and degK
- Integer(Kind=jpim), Intent(out) :: errorstatus(nprofiles) ! return flag
-
-
-
-End Subroutine rttov_direct
-End Interface
diff --git a/src/LIB/RTTOV/src/rttov_distribcoeffs.F90 b/src/LIB/RTTOV/src/rttov_distribcoeffs.F90
deleted file mode 100644
index e3af17a70d05a7d55f128f987503ddef40f8361e..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_distribcoeffs.F90
+++ /dev/null
@@ -1,394 +0,0 @@
-!
-Subroutine rttov_distribcoeffs (&
- & kmyproc, &! id proc
- & kioproc, &! proc for io
- & coef )! inout
- ! Description:
- !
- ! Communicate the coefficient reading by proc 1 to other procs
- !
- ! Copyright:
- ! This software was developed within the context of
- ! the EUMETSAT Satellite Application Facility on
- ! Numerical Weather Prediction (NWP SAF), under the
- ! Cooperation Agreement dated 25 November 1998, between
- ! EUMETSAT and the Met Office, UK, by one or more partners
- ! within the NWP SAF. The partners in the NWP SAF are
- ! the Met Office, ECMWF, KNMI and MeteoFrance.
- !
- ! Copyright 2002, EUMETSAT, All Rights Reserved.
- !
- ! Method:
- !
- ! Current Code Owner: SAF NWP
- !
- ! History:
- ! Version Date Comment
- ! ------- ---- -------
- ! 1.0 13/05/2004 Original
- !
- ! Code Description:
- ! Language: Fortran 90.
- ! Software Standards: "European Standards for Writing and
- ! Documenting Exchangeable Fortran 90 Code".
- !
- ! Declarations:
- ! Modules used:
- ! Imported Parameters:
- Use rttov_const, Only : gas_id_mixed, ngases_max
-
- ! Imported Type Definitions:
- Use rttov_types, Only : &
- & rttov_coef
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
- ! subroutine arguments
- ! scalar arguments with intent(in):
- Integer(Kind=jpim), Intent(in) :: kmyproc ! logical processor id
- Integer(Kind=jpim), Intent(in) :: kioproc ! processor dedicated for io
-
- ! scalar arguments with intent(inout):
- Type( rttov_coef ), Intent (inout) :: coef ! coefficients
-
- ! Local Scalars:
- Integer(Kind=jpim) :: kcoef(57)
- Real(Kind=JPRB) :: zcoef(4)
- Character (len=144) :: ccoef
- Integer(Kind=jpim) :: kdim,itag
- Integer(Kind=jpim) :: i
- Logical :: lallo
-
- ! Functions:
-
- !- End of header --------------------------------------------------------
-
- ! 0 Initialise variables
- !---------------------------------------------
-
- kcoef(:) = 0
- zcoef(:) = 0.0
- ccoef = 'xxxx'
- lallo = kmyproc.ne.kioproc
-
- If (kmyproc == kioproc) Then
- kcoef(1)= coef % id_platform
- kcoef(2)= coef % id_sat
- kcoef(3)= coef % id_inst
- kcoef(4)= coef % id_sensor
- kcoef(5)= coef % id_comp_lvl
- kcoef(6:8)= coef % id_creation_date
- kcoef(9)= coef % fmv_chn
- kcoef(10)= coef % fmv_gas
- kcoef(11)= coef % nmixed
- kcoef(12)= coef % nwater
- kcoef(13)= coef % nozone
- kcoef(14)= coef % nwvcont
- kcoef(15)= coef % nco2
- kcoef(16)= coef % nn2o
- kcoef(17)= coef % nco
- kcoef(18)= coef % nch4
- kcoef(19)= coef % nlevels
- kcoef(20)= coef % fastem_ver
- kcoef(21)= coef % fastem_coef_nb
- kcoef(22)= coef % ssirem_ver
-
-! Check if array are associated in PE1 to send the information to other PEs
-
- kcoef(23:57)=0
-
- If (Associated( coef % fmv_gas_id)) kcoef(23)=1
- If (Associated( coef % fmv_gas_pos)) kcoef(24)=1
- If (Associated( coef % fmv_var)) kcoef(25)=1
- If (Associated( coef % fmv_lvl)) kcoef(26)=1
- If (Associated( coef % ff_ori_chn)) kcoef(27)=1
- If (Associated( coef % ff_val_chn)) kcoef(28)=1
- If (Associated( coef % ff_cwn)) kcoef(29)=1
- If (Associated( coef % ff_bco)) kcoef(30)=1
- If (Associated( coef % ff_bcs)) kcoef(31)=1
- If (Associated( coef % ff_gam)) kcoef(32)=1
- If (Associated( coef % fastem_polar)) kcoef(33)=1
- If (Associated( coef % ssirem_chn)) kcoef(34)=1
- If (Associated( coef % ssirem_a0)) kcoef(35)=1
- If (Associated( coef % ssirem_a1)) kcoef(36)=1
- If (Associated( coef % ssirem_a2)) kcoef(37)=1
- If (Associated( coef % ssirem_xzn1)) kcoef(38)=1
- If (Associated( coef % ssirem_xzn2)) kcoef(39)=1
- If (Associated( coef % fastem_coef)) kcoef(40)=1
- If (Associated( coef % gaz_units)) kcoef(41)=1
- If (Associated( coef % ref_prfl_t)) kcoef(42)=1
- If (Associated( coef % ref_prfl_mr)) kcoef(43)=1
- If (Associated( coef % lim_prfl_p)) kcoef(44)=1
- If (Associated( coef % lim_prfl_tmax)) kcoef(45)=1
- If (Associated( coef % lim_prfl_tmin)) kcoef(46)=1
- If (Associated( coef % lim_prfl_gmax)) kcoef(47)=1
- If (Associated( coef % lim_prfl_gmin)) kcoef(48)=1
- If (Associated( coef % mixedgas)) kcoef(49)=1
- If (Associated( coef % watervapour)) kcoef(50)=1
- If (Associated( coef % ozone)) kcoef(51)=1
- If (Associated( coef % wvcont)) kcoef(52)=1
- If (Associated( coef % co2)) kcoef(53)=1
- If (Associated( coef % n2o)) kcoef(54)=1
- If (Associated( coef % co)) kcoef(55)=1
- If (Associated( coef % ch4)) kcoef(56)=1
- If (Associated( coef % ref_prfl_p)) kcoef(57)=1
-
- ccoef= coef % id_creation//coef % id_Common_name//coef % fmv_model_def
-
- zcoef(1)= coef % fc_speedl
- zcoef(2)= coef % fc_planck_c1
- zcoef(3)= coef % fc_planck_c2
- zcoef(4)= coef % fc_sat_height
- End If
-
-! Send 'constant' information to other PEs
-
- itag=7000
-! Call broadcint(kcoef,57,kioproc,ITAG+1)
-! Call broadcreal(zcoef,4,kioproc,ITAG+2)
-! Call broadcchar(ccoef,144,kioproc,ITAG+3)
-
- If (kmyproc.ne.kioproc) Then
- coef % id_platform=kcoef(1)
- coef % id_sat=kcoef(2)
- coef % id_inst=kcoef(3)
- coef % id_sensor=kcoef(4)
- coef % id_comp_lvl=kcoef(5)
- coef % id_creation_date=kcoef(6:8)
- coef % fmv_chn=kcoef(9)
- coef % fmv_gas=kcoef(10)
- coef % nmixed=kcoef(11)
- coef % nwater=kcoef(12)
- coef % nozone=kcoef(13)
- coef % nwvcont=kcoef(14)
- coef % nco2=kcoef(15)
- coef % nn2o=kcoef(16)
- coef % nco=kcoef(17)
- coef % nch4=kcoef(18)
- coef % nlevels=kcoef(19)
- coef % fastem_ver=kcoef(20)
- coef % fastem_coef_nb=kcoef(21)
- coef % ssirem_ver=kcoef(22)
-
- coef % id_creation=ccoef(1:80)
- coef % id_Common_name=ccoef(81:112)
- coef % fmv_model_def=ccoef(113:144)
-
- coef % fc_speedl=zcoef(1)
- coef % fc_planck_c1=zcoef(2)
- coef % fc_planck_c2=zcoef(3)
- coef % fc_sat_height=zcoef(4)
- End If
-
-! Send 'arrays' information if associated to other PEs
-
- If( kcoef(23) == 1 ) Then
- if (lallo) Allocate(coef % fmv_gas_id ( coef % fmv_gas ))
- ! Call broadcint(coef % fmv_gas_id,coef % fmv_gas,kioproc,ITAG+23)
- End If
-
- If( kcoef(24) == 1 ) Then
- if (lallo) Allocate(coef % fmv_gas_pos ( ngases_max ))
- ! Call broadcint(coef % fmv_gas_pos, ngases_max,kioproc,ITAG+24)
- End If
-
- If( kcoef(25) == 1 ) Then
- if (lallo) Allocate(coef % fmv_var ( coef % fmv_gas ))
- ! Call broadcint(coef % fmv_var,coef % fmv_gas,kioproc,ITAG+25)
- End If
-
- If( kcoef(26) == 1 ) Then
- if (lallo) Allocate(coef % fmv_lvl ( coef % fmv_gas ))
- ! Call broadcint(coef % fmv_lvl,coef % fmv_gas,kioproc,ITAG+26)
- End If
-
- If( kcoef(27) == 1 ) Then
- if (lallo) Allocate(coef % ff_ori_chn ( coef % fmv_chn ))
- ! Call broadcint(coef % ff_ori_chn,coef % fmv_chn,kioproc,ITAG+27)
- End If
-
- If( kcoef(28) == 1 ) Then
- if (lallo) Allocate(coef % ff_val_chn ( coef % fmv_chn ))
- ! Call broadcint(coef % ff_val_chn,coef % fmv_chn,kioproc,ITAG+28)
- End If
-
- If( kcoef(29) == 1 ) Then
- if (lallo) Allocate(coef % ff_cwn ( coef % fmv_chn ))
- ! Call broadcreal(coef % ff_cwn,coef % fmv_chn,kioproc,ITAG+29)
- End If
-
- If( kcoef(30) == 1 ) Then
- if (lallo) Allocate(coef % ff_bco ( coef % fmv_chn ))
- ! Call broadcreal(coef % ff_bco,coef % fmv_chn,kioproc,ITAG+30)
- End If
-
- If( kcoef(31) == 1 ) Then
- if (lallo) Allocate(coef % ff_bcs ( coef % fmv_chn ))
- ! Call broadcreal(coef % ff_bcs,coef % fmv_chn,kioproc,ITAG+31)
- End If
-
- If( kcoef(32) == 1 ) Then
- if (lallo) Allocate(coef % ff_gam ( coef % fmv_chn ))
- ! Call broadcreal(coef % ff_gam,coef % fmv_chn,kioproc,ITAG+32)
- End If
-
- If( kcoef(33) == 1 ) Then
- if (lallo) Allocate(coef % fastem_polar ( coef % fmv_chn ))
- ! Call broadcint(coef % fastem_polar,coef % fmv_chn,kioproc,ITAG+33)
- End If
-
- If( kcoef(34) == 1 ) Then
- if (lallo) Allocate(coef % ssirem_chn ( coef % fmv_chn ))
- ! Call broadcint(coef % ssirem_chn,coef % fmv_chn,kioproc,ITAG+34)
- End If
-
- If( kcoef(35) == 1 ) Then
- if (lallo) Allocate(coef % ssirem_a0 ( coef % fmv_chn ))
- ! Call broadcreal(coef % ssirem_a0,coef % fmv_chn,kioproc,ITAG+35)
- End If
-
- If( kcoef(36) == 1 ) Then
- if (lallo) Allocate(coef % ssirem_a1 ( coef % fmv_chn ))
- ! Call broadcreal(coef % ssirem_a1,coef % fmv_chn,kioproc,ITAG+36)
- End If
-
- If( kcoef(37) == 1 ) Then
- if (lallo) Allocate(coef % ssirem_a2 ( coef % fmv_chn ))
- ! Call broadcreal(coef % ssirem_a2,coef % fmv_chn,kioproc,ITAG+37)
- End If
-
- If( kcoef(38) == 1 ) Then
- if (lallo) Allocate(coef % ssirem_xzn1 ( coef % fmv_chn ))
- ! Call broadcreal(coef % ssirem_xzn1,coef % fmv_chn,kioproc,ITAG+38)
- End If
-
- If( kcoef(39) == 1 ) Then
- if (lallo) Allocate(coef % ssirem_xzn2 ( coef % fmv_chn ))
- ! Call broadcreal(coef % ssirem_xzn2,coef % fmv_chn,kioproc,ITAG+39)
- End If
-
- If( kcoef(40) == 1 ) Then
- if (lallo) Allocate(coef % fastem_coef ( coef % fastem_coef_nb ))
- ! Call broadcreal(coef % fastem_coef,coef % fastem_coef_nb,kioproc,ITAG+40)
- End If
-
- If( kcoef(41) == 1 ) Then
- if (lallo) Allocate(coef % gaz_units ( coef % fmv_gas ))
- ! Call broadcint(coef % gaz_units,coef % fmv_gas,kioproc,ITAG+41)
- End If
-
- If( kcoef(42) == 1 ) Then
- if (lallo) Allocate(coef % ref_prfl_t ( &
- & coef % fmv_lvl(gas_id_mixed),coef % fmv_gas ) )
- Kdim= coef % fmv_lvl(gas_id_mixed)*coef % fmv_gas
- ! Call broadcreal(coef % ref_prfl_t,kdim,kioproc,ITAG+42)
- End If
-
- If( kcoef(43) == 1 ) Then
- if (lallo) Allocate(coef % ref_prfl_mr ( &
- & coef % fmv_lvl(gas_id_mixed),coef % fmv_gas ) )
- Kdim= coef % fmv_lvl(gas_id_mixed)*coef % fmv_gas
- ! Call broadcreal(coef % ref_prfl_mr,kdim,kioproc,ITAG+43)
- End If
-
- If( kcoef(44) == 1 ) Then
- if (lallo) Allocate(coef % lim_prfl_p ( &
- & coef % fmv_lvl(gas_id_mixed)))
- Kdim= coef % fmv_lvl(gas_id_mixed)
- ! Call broadcreal(coef % lim_prfl_p,kdim,kioproc,ITAG+44)
- End If
-
- If( kcoef(45) == 1 ) Then
- if (lallo) Allocate(coef % lim_prfl_tmax ( &
- & coef % fmv_lvl(gas_id_mixed)))
- Kdim= coef % fmv_lvl(gas_id_mixed)
- ! Call broadcreal(coef % lim_prfl_tmax,kdim,kioproc,ITAG+45)
- End If
-
- If( kcoef(46) == 1 ) Then
- if (lallo) Allocate(coef % lim_prfl_tmin ( &
- & coef % fmv_lvl(gas_id_mixed)))
- Kdim= coef % fmv_lvl(gas_id_mixed)
- ! Call broadcreal(coef % lim_prfl_tmin,kdim,kioproc,ITAG+46)
- End If
-
- If( kcoef(47) == 1 ) Then
- if (lallo) Allocate(coef % lim_prfl_gmax ( &
- & coef % fmv_lvl(gas_id_mixed),coef % fmv_gas ) )
- Kdim= coef % fmv_lvl(gas_id_mixed)*coef % fmv_gas
- ! Call broadcreal(coef % lim_prfl_gmax,kdim,kioproc,ITAG+47)
- End If
-
- If( kcoef(48) == 1 ) Then
- if (lallo) Allocate(coef % lim_prfl_gmin ( &
- & coef % fmv_lvl(gas_id_mixed),coef % fmv_gas ) )
- Kdim= coef % fmv_lvl(gas_id_mixed)*coef % fmv_gas
- ! Call broadcreal(coef % lim_prfl_gmin,kdim,kioproc,ITAG+48)
- End If
-
- If( kcoef(49) == 1 ) Then
- if (lallo) Allocate(coef % mixedgas ( coef % nlevels, &
- & coef % fmv_chn, coef % nmixed))
- Kdim= coef % nlevels*coef % fmv_chn*coef % nmixed
- ! Call broadcreal(coef % mixedgas,kdim,kioproc,ITAG+49)
- End If
-
- If( kcoef(50) == 1 ) Then
- if (lallo) Allocate(coef % watervapour ( coef % nlevels, &
- & coef % fmv_chn, coef % nwater))
- Kdim= coef % nlevels*coef % fmv_chn*coef % nwater
- ! Call broadcreal(coef % watervapour,kdim,kioproc,ITAG+50)
- End If
-
- If( kcoef(51) == 1 ) Then
- if (lallo) Allocate(coef % ozone ( coef % nlevels, &
- & coef % fmv_chn, coef % nozone))
- Kdim= coef % nlevels*coef % fmv_chn*coef % nozone
- ! Call broadcreal(coef % ozone,kdim,kioproc,ITAG+51)
- End If
-
- If( kcoef(52) == 1 ) Then
- if (lallo) Allocate(coef % wvcont ( coef % nlevels, &
- & coef % fmv_chn, coef % nwvcont))
- Kdim= coef % nlevels*coef % fmv_chn*coef % nwvcont
- ! Call broadcreal(coef % wvcont,kdim,kioproc,ITAG+52)
- End If
-
- If( kcoef(53) == 1 ) Then
- if (lallo) Allocate(coef % co2 ( coef % nlevels, &
- & coef % fmv_chn, coef % nco2))
- Kdim= coef % nlevels*coef % fmv_chn*coef % nco2
- ! Call broadcreal(coef % co2,kdim,kioproc,ITAG+53)
- End If
-
- If( kcoef(54) == 1 ) Then
- if (lallo) Allocate(coef % n2o ( coef % nlevels, &
- & coef % fmv_chn, coef % nn2o))
- Kdim= coef % nlevels*coef % fmv_chn*coef % nn2o
- ! Call broadcreal(coef % n2o,kdim,kioproc,ITAG+54)
- End If
-
- If( kcoef(55) == 1 ) Then
- if (lallo) Allocate(coef % co ( coef % nlevels, &
- & coef % fmv_chn, coef % nco))
- Kdim= coef % nlevels*coef % fmv_chn*coef % nco
- ! Call broadcreal(coef % co,kdim,kioproc,ITAG+55)
- End If
-
- If( kcoef(56) == 1 ) Then
- if (lallo) Allocate(coef % ch4 ( coef % nlevels, &
- & coef % fmv_chn, coef % nch4))
- Kdim= coef % nlevels*coef % fmv_chn*coef % nch4
- ! Call broadcreal(coef % ch4,kdim,kioproc,ITAG+56)
- End If
-
- If( kcoef(57) == 1 ) Then
- if (lallo) Allocate(coef % ref_prfl_p ( &
- & coef % fmv_lvl(gas_id_mixed)))
- Kdim= coef % fmv_lvl(gas_id_mixed)
- ! Call broadcreal(coef % ref_prfl_p,kdim,kioproc,ITAG+57)
- End If
-
-
-End Subroutine rttov_distribcoeffs
diff --git a/src/LIB/RTTOV/src/rttov_distribcoeffs.interface b/src/LIB/RTTOV/src/rttov_distribcoeffs.interface
deleted file mode 100644
index 297c7e485ee57b91772c755a60833f1c934d4462..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_distribcoeffs.interface
+++ /dev/null
@@ -1,25 +0,0 @@
-Interface
-!
-Subroutine rttov_distribcoeffs (&
- & kmyproc, &! id proc
- & kioproc, &! io proc
- & coef )! inout
-Use rttov_const, Only : gas_id_mixed
-
- ! Imported Type Definitions:
- Use rttov_types, Only : &
- & rttov_coef
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
- ! subroutine arguments
- ! scalar arguments with intent(in):
- Integer(Kind=jpim), Intent(in) :: kmyproc ! logical processor id
- Integer(Kind=jpim), Intent(in) :: kioproc ! processor dedicated for io
-
- ! scalar arguments with intent(inout):
- Type( rttov_coef ), Intent (inout) :: coef ! coefficients
-
-End Subroutine rttov_distribcoeffs
-End Interface
diff --git a/src/LIB/RTTOV/src/rttov_eddington.F90 b/src/LIB/RTTOV/src/rttov_eddington.F90
deleted file mode 100644
index 2871affdf90d62b2fd2e9641d17315a5b4529f9e..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_eddington.F90
+++ /dev/null
@@ -1,172 +0,0 @@
-!
-Subroutine rttov_eddington ( &
- & nwp_levels, &! in
- & nchannels, &! in
- & nprofiles, &! in
- & lprofiles, &! in
- & angles, &! in
- & profiles, &! in
- & cld_profiles, &! in
- & scatt_aux, &! in
- & cld_radiance) ! inout
-
- ! Description:
- ! to compute Eddington approximation to RT
- !
- ! Copyright:
- ! This software was developed within the context of
- ! the EUMETSAT Satellite Application Facility on
- ! Numerical Weather Prediction (NWP SAF), under the
- ! Cooperation Agreement dated 25 November 1998, between
- ! EUMETSAT and the Met Office, UK, by one or more partners
- ! within the NWP SAF. The partners in the NWP SAF are
- ! the Met Office, ECMWF, KNMI and MeteoFrance.
- !
- ! Copyright 2002, EUMETSAT, All Rights Reserved.
- !
- ! Method:
- ! - Bauer, P., 2002: Microwave radiative transfer modeling in clouds and precipitation.
- ! Part I: Model description.
- ! NWP SAF Report No. NWPSAF-EC-TR-005, 27 pp.
- ! - Chevallier, F., and P. Bauer, 2003:
- ! Model rain and clouds over oceans: comparison with SSM/I observations.
- ! Mon. Wea. Rev., 131, 1240-1255.
- ! - Moreau, E., P. Bauer and F. Chevallier, 2002: Microwave radiative transfer modeling in clouds and precipitation.
- ! Part II: Model evaluation.
- ! NWP SAF Report No. NWPSAF-EC-TR-006, 27 pp.
- !
- ! Current Code Owner: SAF NWP
- !
- ! History:
- ! Version Date Comment
- ! ------- ---- -------
- ! 1.0 09/2002 Initial version (P. Bauer, E. Moreau)
- ! 1.1 05/2003 RTTOV7.3 compatible (F. Chevallier)
- ! 1.2 03/2004 Added polarimetry (R. Saunders)
- ! 1.3 08/2004 Polarimetry fixes (U. O'Keefe)
- ! 1.4 11/2004 Clean-up (P. Bauer)
- !
- ! Code Description:
- ! Language: Fortran 90.
- ! Software Standards: "European Standards for Writing and
- ! Documenting Exchangeable Fortran 90 Code".
- !
- ! Declarations:
- ! Modules used:
- ! Imported Type Definitions:
-
- Use rttov_types, Only : &
- & geometry_Type ,&
- & profile_Type ,&
- & profile_cloud_Type ,&
- & profile_scatt_aux ,&
- & radiance_cloud_Type
-
- Use rttov_const, Only: &
- & tcosmic
-
- Use parkind1, Only : jpim ,jprb
-
- Implicit None
-
-#include "rttov_boundaryconditions.interface"
-#include "rttov_integratesource.interface"
-
-!* Subroutine arguments:
- Integer (Kind=jpim), Intent (in) :: nwp_levels ! Number of NWP levels
- Integer (Kind=jpim), Intent (in) :: nprofiles ! Number of profiles
- Integer (Kind=jpim), Intent (in) :: nchannels ! Number of channels*profiles=radiances
- Integer (Kind=jpim), Intent (in) :: lprofiles (nchannels) ! Profile indices
-
- Type (geometry_Type), Intent (in) :: angles (nprofiles) ! Zenith angles
- Type (profile_Type), Intent (in) :: profiles (nprofiles) ! Profiles on RTTOV levels
- Type (profile_cloud_Type), Intent (in) :: cld_profiles (nprofiles) ! Cloud profiles on NWP levels
- Type (profile_scatt_aux), Intent (in) :: scatt_aux ! Auxiliary profile variables for RTTOV_SCATT
- Type (radiance_cloud_Type), Intent (inout) :: cld_radiance ! Radiances
-
-!* Local variables
- Real (Kind=jprb), Dimension (nchannels,nwp_levels) :: dp ! D+ for boundary conditions
- Real (Kind=jprb), Dimension (nchannels,nwp_levels) :: dm ! D- for boundary conditions
- Real (Kind=jprb), Dimension (nchannels,nwp_levels) :: j_up ! Upward radiance source terms
- Real (Kind=jprb), Dimension (nchannels,nwp_levels) :: j_do ! Downward radiance source terms
-
- Real (Kind=jprb), Dimension (nchannels) :: irad_do, ftop ! Downward radiances
- Real (Kind=jprb), Dimension (nchannels) :: irad_up ! Upward radiances
- Real (Kind=jprb), Dimension (nchannels) :: irad_sfc ! Inward radiances at surface
- Real (Kind=jprb), Dimension (nchannels) :: irad_space ! Inward radiances from space
- Real (Kind=jprb), Dimension (nchannels) :: tau_t ! Total transmittancs
-
- Integer (Kind=jpim) :: ilayer, jlayer, iprof, ichan
-
- !- End of header --------------------------------------------------------
-
- cld_radiance % bt (:) = 0.0_JPRB
-
-!* Channels * Profiles
- do ichan = 1, nchannels
- iprof = lprofiles (ichan)
-
-!* Top/bottom
- irad_sfc (ichan) = scatt_aux % ems_cld (ichan) * profiles(iprof) % skin % t
- irad_space (ichan) = tcosmic
-
-!* Clear-sky source terms
- j_up (ichan,:) = scatt_aux % b0 (iprof,:) * (1.0_JPRB - scatt_aux % tau (ichan,:))
- j_do (ichan,:) = scatt_aux % b0 (iprof,:) * (1.0_JPRB - scatt_aux % tau (ichan,:))
-
-!* Downward radiance at cloud top
- irad_do (ichan) = irad_space (ichan)
-
- Do ilayer = 1, scatt_aux % mclayer (ichan) - 1
- irad_do (ichan) = irad_do (ichan) * scatt_aux % tau (ichan,ilayer) + j_do (ichan,ilayer)
- End do
-
- ftop (ichan) = irad_do (ichan)
- End do
-
- If (maxval (scatt_aux % mclayer) > 0) Then
-
-!* Get D+, D- from boundary conditions
- Call rttov_boundaryconditions (&
-& nwp_levels, &! in
-& nchannels, &! in
-& nprofiles, &! in
-& lprofiles, &! in
-& scatt_aux, &! in
-& profiles , &! in
-& ftop, &! in
-& dp, &! out
-& dm) ! out
-
-!* Integrate radiance source terms
- Call rttov_integratesource (&
-& nwp_levels, &! in
-& nchannels, &! in
-& nprofiles, &! in
-& lprofiles, &! in
-& angles, &! in
-& scatt_aux, &! in
-& dp, &! in
-& dm, &! in
-& j_do, &! inout
-& j_up) ! inout
-
- Endif
-
-!* Integrate downward radiances/transmittance
- irad_do (:) = irad_space (:)
- irad_up (:) = irad_sfc (:)
- tau_t (:) = 1.0_JPRB
-
- Do ilayer = 1, nwp_levels
- jlayer = nwp_levels + 1 - ilayer
-
- irad_do (:) = irad_do (:) * scatt_aux % tau (:,ilayer) + j_do (:,ilayer)
- irad_up (:) = irad_up (:) * scatt_aux % tau (:,jlayer) + j_up (:,jlayer)
-
- tau_t (:) = tau_t (:) * scatt_aux % tau (:,jlayer)
- Enddo
-
- cld_radiance % bt (:) = irad_up (:) + scatt_aux % ref_cld (:) * irad_do (:) * tau_t (:)
-
-End Subroutine rttov_eddington
diff --git a/src/LIB/RTTOV/src/rttov_eddington.interface b/src/LIB/RTTOV/src/rttov_eddington.interface
deleted file mode 100644
index 2f79fd5766b39134b6b0a4d29f0beda9519c3f66..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_eddington.interface
+++ /dev/null
@@ -1,29 +0,0 @@
-INTERFACE
-Subroutine rttov_eddington (&
- & nwp_levels,&
- & nchannels,&
- & nprofiles,&
- & lprofiles,&
- & angles,&
- & profiles,&
- & cld_profiles,&
- & scatt_aux,&
- & cld_radiance)
- Use rttov_types, Only :&
- & geometry_Type ,&
- & profile_Type ,&
- & profile_cloud_Type ,&
- & profile_scatt_aux ,&
- & radiance_cloud_Type
- Use parkind1, Only : jpim ,jprb
- Integer (Kind=jpim), Intent (in) :: nwp_levels
- Integer (Kind=jpim), Intent (in) :: nprofiles
- Integer (Kind=jpim), Intent (in) :: nchannels
- Integer (Kind=jpim), Intent (in) :: lprofiles (nchannels)
- Type (geometry_Type), Intent (in) :: angles (nprofiles)
- Type (profile_Type), Intent (in) :: profiles (nprofiles)
- Type (profile_cloud_Type), Intent (in) :: cld_profiles (nprofiles)
- Type (profile_scatt_aux), Intent (in) :: scatt_aux
- Type (radiance_cloud_Type), Intent (inout) :: cld_radiance
-End Subroutine rttov_eddington
-END INTERFACE
diff --git a/src/LIB/RTTOV/src/rttov_eddington_ad.F90 b/src/LIB/RTTOV/src/rttov_eddington_ad.F90
deleted file mode 100644
index d5c8395f5c3149ff6a2958b0967fec443adbefe0..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_eddington_ad.F90
+++ /dev/null
@@ -1,315 +0,0 @@
-!
-Subroutine rttov_eddington_ad ( &
- & nwp_levels, &! in
- & nchannels, &! in
- & nprofiles, &! in
- & lprofiles, &! in
- & angles, &! in
- & profiles, &! in
- & profiles_ad, &! inout
- & cld_profiles, &! in
- & scatt_aux, &! in
- & scatt_aux_ad, &! inout
- & cld_radiance, &! inout
- & cld_radiance_ad) ! inout
-
- ! Description:
- ! AD of routine
- ! to compute Eddington approximation to RT
- !
- ! Copyright:
- ! This software was developed within the context of
- ! the EUMETSAT Satellite Application Facility on
- ! Numerical Weather Prediction (NWP SAF), under the
- ! Cooperation Agreement dated 25 November 1998, between
- ! EUMETSAT and the Met Office, UK, by one or more partners
- ! within the NWP SAF. The partners in the NWP SAF are
- ! the Met Office, ECMWF, KNMI and MeteoFrance.
- !
- ! Copyright 2002, EUMETSAT, All Rights Reserved.
- !
- ! Method:
- ! - Bauer, P., 2002: Microwave radiative transfer modeling in clouds and precipitation.
- ! Part I: Model description.
- ! NWP SAF Report No. NWPSAF-EC-TR-005, 27 pp.
- ! - Chevallier, F., and P. Bauer, 2003:
- ! Model rain and clouds over oceans: comparison with SSM/I observations.
- ! Mon. Wea. Rev., 131, 1240-1255.
- ! - Moreau, E., P. Bauer and F. Chevallier, 2002: Microwave radiative transfer modeling in clouds and precipitation.
- ! Part II: Model evaluation.
- ! NWP SAF Report No. NWPSAF-EC-TR-006, 27 pp.
- !
- ! Current Code Owner: SAF NWP
- !
- ! History:
- ! Version Date Comment
- ! ------- ---- -------
- ! 1.0 09/2002 Initial version (P. Bauer, E. Moreau)
- ! 1.1 05/2003 RTTOV7.3 compatible (F. Chevallier)
- ! 1.2 03/2004 Added polarimetry (R. Saunders)
- ! 1.3 08/2004 Polarimetry fixes (U. O'Keefe)
- ! 1.4 11/2004 Clean-up (P. Bauer)
- ! 1.5 11/2005 Limit lines to 132 characters (J. Cameron)
- !
- ! Code Description:
- ! Language: Fortran 90.
- ! Software Standards: "European Standards for Writing and
- ! Documenting Exchangeable Fortran 90 Code".
- !
- ! Declarations:
- ! Modules used:
- ! Imported Type Definitions:
-
- Use rttov_types, Only : &
- & geometry_Type ,&
- & profile_Type ,&
- & profile_cloud_Type ,&
- & profile_scatt_aux ,&
- & radiance_cloud_Type
-
- Use rttov_const, Only: &
- & tcosmic
-
- Use parkind1, Only : jpim ,jprb
-
- Implicit None
-
-#include "rttov_boundaryconditions.interface"
-#include "rttov_integratesource.interface"
-#include "rttov_boundaryconditions_ad.interface"
-#include "rttov_integratesource_ad.interface"
-
-!* Subroutine arguments:
- Integer (Kind=jpim), Intent (in) :: nwp_levels ! Number of NWP-levels
- Integer (Kind=jpim), Intent (in) :: nprofiles ! Number of profiles
- Integer (Kind=jpim), Intent (in) :: nchannels ! Number of channels*profiles=radiances
- Integer (Kind=jpim), Intent (in) :: lprofiles (nchannels) ! Profile indices
-
- Type (geometry_Type), Intent (in) :: angles (nprofiles) ! Zenith angles
- Type (profile_Type), Intent (in) :: profiles (nprofiles) ! Profiles on RTTOV levels
- Type (profile_Type), Intent (inout) :: profiles_ad (nprofiles) ! Profiles on RTTOV levels
- Type (profile_cloud_Type), Intent (in) :: cld_profiles (nprofiles) ! Cloud profiles on NWP levels
- Type (profile_scatt_aux), Intent (inout) :: scatt_aux ! Auxiliary profile variables for RTTOV_SCATT
- Type (profile_scatt_aux), Intent (inout) :: scatt_aux_ad ! Auxiliary profile variables for RTTOV_SCATT
- Type (radiance_cloud_Type), Intent (inout) :: cld_radiance ! Radiances
- Type (radiance_cloud_Type), Intent (inout) :: cld_radiance_ad ! Radiances
-
-!* Local variables
- Real (Kind=jprb), Dimension (nchannels,nwp_levels) :: dp ! D+ for boundary conditions
- Real (Kind=jprb), Dimension (nchannels,nwp_levels) :: dm ! D- for boundary conditions
- Real (Kind=jprb), Dimension (nchannels,nwp_levels) :: j_up ! Upward radiance source terms
- Real (Kind=jprb), Dimension (nchannels,nwp_levels) :: j_do ! Downward radiance source terms
- Real (Kind=jprb), Dimension (nchannels,nwp_levels) :: dp_ad ! D+ for boundary conditions
- Real (Kind=jprb), Dimension (nchannels,nwp_levels) :: dm_ad ! D- for boundary conditions
- Real (Kind=jprb), Dimension (nchannels,nwp_levels) :: j_up_ad ! Upward radiance source terms
- Real (Kind=jprb), Dimension (nchannels,nwp_levels) :: j_do_ad ! Downward radiance source terms
-
-
- Real (Kind=jprb), Dimension (nchannels,0:nwp_levels) :: irad_do1 ! Downward radiances
- Real (Kind=jprb), Dimension (nchannels,0:nwp_levels) :: irad_do2 ! Downward radiances
- Real (Kind=jprb), Dimension (nchannels,nwp_levels+1) :: irad_up ! Downward radiances
- Real (Kind=jprb), Dimension (nchannels) :: irad_sfc ! Inward radiances at surface
- Real (Kind=jprb), Dimension (nchannels) :: irad_space ! Inward radiances from space
- Real (Kind=jprb), Dimension (nchannels,nwp_levels+1) :: tau_t ! Transmittances integrated over all levels
- Real (Kind=jprb), Dimension (nchannels) :: ftop, ftop_ad ! Downward radiances
- Real (Kind=jprb), Dimension (nchannels,0:nwp_levels) :: irad_do2_ad ! Downward radiances
- Real (Kind=jprb), Dimension (nchannels,0:nwp_levels) :: irad_do1_ad ! Downward radiances
- Real (Kind=jprb), Dimension (nchannels,nwp_levels+1) :: irad_up_ad ! Upward radiances
- Real (Kind=jprb), Dimension (nchannels) :: irad_sfc_ad ! Inward radiances at surface
- Real (Kind=jprb), Dimension (nchannels) :: irad_space_ad ! Inward radiances from space
- Real (Kind=jprb), Dimension (nchannels,nwp_levels+1) :: tau_t_ad ! Transmittances integrated over all levels
-
- Integer (Kind=jpim) :: ilayer, jlayer, iprof, ichan
-
- !- End of header --------------------------------------------------------
-
-!* Channels * Profiles
- do ichan = 1, nchannels
- iprof = lprofiles (ichan)
-
-!* Top/bottom
- irad_sfc (ichan) = scatt_aux % ems_cld (ichan) * profiles (iprof) % skin % t
- irad_space (ichan) = tcosmic
-
-!* Clear-sky source terms
- j_up (ichan,:) = scatt_aux % b0 (iprof,:) * (1.0_JPRB - scatt_aux % tau (ichan,:))
- j_do (ichan,:) = scatt_aux % b0 (iprof,:) * (1.0_JPRB - scatt_aux % tau (ichan,:))
-
-!* Downward radiance at cloud top
- irad_do1 (ichan,0) = irad_space (ichan)
-
- Do ilayer = 1, scatt_aux % mclayer (ichan) - 1
- irad_do1 (ichan,ilayer) = irad_do1 (ichan,ilayer-1) * scatt_aux % tau (ichan,ilayer) + j_do (ichan,ilayer)
- End do
-
- ftop (ichan) = irad_do1 (ichan,scatt_aux % mclayer (ichan) - 1)
- End do
-
- If (maxval(scatt_aux % mclayer) > 0) Then
-!* Get D+, D- from boundary conditions
-
- Call rttov_boundaryconditions (&
- & nwp_levels, &! in
- & nchannels, &! in
- & nprofiles, &! in
- & lprofiles, &! in
- & scatt_aux, &! in
- & profiles, &! in
- & ftop, &! in
- & dp, &! out
- & dm) ! out
-
-!* Integrate radiance source terms
- Call rttov_integratesource (&
- & nwp_levels, &! in
- & nchannels, &! in
- & nprofiles, &! in
- & lprofiles, &! in
- & angles, &! in
- & scatt_aux, &! in
- & dp, &! in
- & dm, &! in
- & j_do, &! inout
- & j_up) ! inout
-
- Endif
-
-!* Integrate downward radiances/transmittance
- irad_do2 (:,0) = irad_space (:)
- irad_up (:,nwp_levels+1) = irad_sfc (:)
- tau_t (:,nwp_levels+1) = 1.0_JPRB
-
- Do ilayer = 1, nwp_levels
- jlayer = nwp_levels + 1 - ilayer
-
- irad_do2 (:,ilayer) = irad_do2 (:,ilayer-1) * scatt_aux % tau (:,ilayer) + j_do (:,ilayer)
- irad_up (:,jlayer) = irad_up (:,jlayer+1) * scatt_aux % tau (:,jlayer) + j_up (:,jlayer)
-
- tau_t (:,jlayer) = tau_t (:,jlayer+1) * scatt_aux % tau (:,jlayer)
- Enddo
-
- cld_radiance % bt (:) = irad_up (:,1) + scatt_aux % ref_cld (:) * irad_do2 (:,nwp_levels) * tau_t (:,1)
-
-!* ADJOINT PART
- irad_up_ad (:,:) = 0.0_JPRB
- irad_do1_ad (:,:) = 0.0_JPRB
- irad_do2_ad (:,:) = 0.0_JPRB
- tau_t_ad (:,:) = 0.0_JPRB
- j_up_ad (:,:) = 0.0_JPRB
- j_do_ad (:,:) = 0.0_JPRB
- irad_sfc_ad (:) = 0.0_JPRB
- irad_space_ad (:) = 0.0_JPRB
- dp_ad (:,:) = 0.0_JPRB
- dm_ad (:,:) = 0.0_JPRB
- ftop_ad (:) = 0.0_JPRB
-
-!* Integrate downward radiances/transmittance
- irad_up_ad (:,1) = irad_up_ad (:,1) + cld_radiance_ad % bt (:)
- scatt_aux_ad % ref_cld (:) = scatt_aux_ad % ref_cld (:) + &
- irad_do2 (:,nwp_levels) * tau_t (:,1) * cld_radiance_ad % bt (:)
- irad_do2_ad (:,nwp_levels) = irad_do2_ad (:,nwp_levels) + &
- scatt_aux % ref_cld (:) * tau_t (:,1) * cld_radiance_ad % bt (:)
- tau_t_ad (:,1) = tau_t_ad (:,1) + &
- scatt_aux % ref_cld (:) * irad_do2 (:,nwp_levels) * cld_radiance_ad % bt (:)
- cld_radiance_ad % bt (:) = 0.0_JPRB
-
- Do ilayer = nwp_levels, 1, -1
- jlayer = nwp_levels + 1 - ilayer
-
- tau_t_ad (:,jlayer+1) = tau_t_ad (:,jlayer+1) + scatt_aux % tau (:,jlayer) * tau_t_ad (:,jlayer)
- scatt_aux_ad % tau (:,jlayer) = scatt_aux_ad % tau (:,jlayer) + tau_t (:,jlayer+1) * tau_t_ad (:,jlayer)
- tau_t_ad (:,jlayer) = 0.0_JPRB
-
- irad_up_ad (:,jlayer+1) = irad_up_ad (:,jlayer+1) + scatt_aux % tau (:,jlayer) * irad_up_ad (:,jlayer)
- scatt_aux_ad % tau (:,jlayer) = scatt_aux_ad % tau (:,jlayer) + irad_up (:,jlayer+1) * irad_up_ad (:,jlayer)
- j_up_ad (:,jlayer) = j_up_ad (:,jlayer) + irad_up_ad (:,jlayer)
- irad_up_ad (:,jlayer) = 0.0_JPRB
-
- irad_do2_ad (:,ilayer-1) = irad_do2_ad (:,ilayer-1) + scatt_aux % tau (:,ilayer) * irad_do2_ad (:,ilayer)
- scatt_aux_ad % tau (:,ilayer) = scatt_aux_ad % tau (:,ilayer) + irad_do2 (:,ilayer-1) * irad_do2_ad (:,ilayer)
- j_do_ad (:,ilayer) = j_do_ad (:,ilayer) + irad_do2_ad (:,ilayer)
- irad_do2_ad (:,ilayer) = 0.0_JPRB
- Enddo
-
- tau_t_ad (:,nwp_levels+1) = 0.0_JPRB
-
- irad_sfc_ad (:) = irad_sfc_ad (:) + irad_up_ad (:,nwp_levels+1)
- irad_up_ad (:,nwp_levels+1) = 0.0_JPRB
-
- irad_space_ad (:) = irad_space_ad (:) + irad_do2_ad (:,0)
- irad_do2_ad (:,0) = 0.0_JPRB
-
- If (maxval(scatt_aux % mclayer) > 0) Then
-!* Get D+, D- from boundary conditions
-
- Call rttov_integratesource_ad (&
- & nwp_levels, &! in
- & nchannels, &! in
- & nprofiles, &! in
- & lprofiles, &! in
- & angles, &! in
- & scatt_aux, &! in
- & scatt_aux_ad, &! in
- & dp, &! in
- & dp_ad, &! in
- & dm, &! in
- & dm_ad, &! in
- & j_do, &! inout
- & j_do_ad, &! inout
- & j_up, &! inout
- & j_up_ad) ! inout
-
- Call rttov_boundaryconditions_ad (&
- & nwp_levels, &! in
- & nchannels, &! in
- & nprofiles, &! in
- & lprofiles, &! in
- & scatt_aux, &! in
- & scatt_aux_ad, &! in
- & profiles, &! in
- & profiles_ad , &! in
- & ftop, &! in
- & ftop_ad, &! in
- & dp, &! out
- & dp_ad, &! out
- & dm, &! out
- & dm_ad) ! out
- Endif
-
-!* Channels * Profiles
- do ichan = 1, nchannels
- iprof = lprofiles (ichan)
-
-!* Downward radiance at cloud top
- irad_do1_ad (ichan,scatt_aux % mclayer (ichan) - 1) = irad_do1_ad (ichan,scatt_aux % mclayer (ichan) - 1) + ftop_ad (ichan)
- ftop_ad (ichan) = 0.0_JPRB
-
- Do ilayer = scatt_aux % mclayer (ichan) - 1, 1, -1
- irad_do1_ad (ichan,ilayer-1) = irad_do1_ad (ichan,ilayer-1) + scatt_aux % tau (ichan,ilayer) &
- & * irad_do1_ad (ichan,ilayer)
- scatt_aux_ad % tau (ichan,ilayer) = scatt_aux_ad % tau (ichan,ilayer) + irad_do1 (ichan,ilayer-1) &
- & * irad_do1_ad (ichan,ilayer)
- j_do_ad (ichan,ilayer) = j_do_ad (ichan,ilayer) + irad_do1_ad (ichan,ilayer)
- irad_do1_ad (ichan,ilayer) = 0.0_JPRB
- End do
-
- irad_space_ad (ichan) = irad_space_ad (ichan) + irad_do1_ad (ichan,0)
- irad_do1_ad (ichan,0) = 0.0_JPRB
-
-!* Clear-sky source terms
- j_up_ad (ichan,:) = j_up_ad (ichan,:) + j_do_ad (ichan,:)
- j_do_ad (ichan,:) = 0.0_JPRB
-
- scatt_aux_ad % b0 (iprof,:) = scatt_aux_ad % b0 (iprof,:) + (1.0_JPRB - scatt_aux % tau (ichan,:)) * j_up_ad (ichan,:)
- scatt_aux_ad % tau (ichan,:) = scatt_aux_ad % tau (ichan,:) - scatt_aux % b0 (iprof,:) * j_up_ad (ichan,:)
- j_up_ad (ichan,:) = 0.0_JPRB
-
-!* Top/bottom
- irad_space_ad (ichan) = 0.0_JPRB
-
- scatt_aux_ad % ems_cld (ichan) = scatt_aux_ad % ems_cld (ichan) + profiles (iprof) % skin % t * irad_sfc_ad (ichan)
- profiles_ad (iprof) % skin % t = profiles_ad (iprof) % skin % t + scatt_aux % ems_cld (ichan) * irad_sfc_ad (ichan)
- irad_sfc_ad (ichan) = 0.0_JPRB
- End do
-
-End Subroutine rttov_eddington_ad
diff --git a/src/LIB/RTTOV/src/rttov_eddington_ad.interface b/src/LIB/RTTOV/src/rttov_eddington_ad.interface
deleted file mode 100644
index f906ede1730b1102dfdf92d275338f635cde2f51..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_eddington_ad.interface
+++ /dev/null
@@ -1,35 +0,0 @@
-INTERFACE
-Subroutine rttov_eddington_ad (&
- & nwp_levels,&
- & nchannels,&
- & nprofiles,&
- & lprofiles,&
- & angles,&
- & profiles,&
- & profiles_ad,&
- & cld_profiles,&
- & scatt_aux,&
- & scatt_aux_ad,&
- & cld_radiance,&
- & cld_radiance_ad)
- Use rttov_types, Only :&
- & geometry_Type ,&
- & profile_Type ,&
- & profile_cloud_Type ,&
- & profile_scatt_aux ,&
- & radiance_cloud_Type
- Use parkind1, Only : jpim ,jprb
- Integer (Kind=jpim), Intent (in) :: nwp_levels
- Integer (Kind=jpim), Intent (in) :: nprofiles
- Integer (Kind=jpim), Intent (in) :: nchannels
- Integer (Kind=jpim), Intent (in) :: lprofiles (nchannels)
- Type (geometry_Type), Intent (in) :: angles (nprofiles)
- Type (profile_Type), Intent (in) :: profiles (nprofiles)
- Type (profile_Type), Intent (inout) :: profiles_ad (nprofiles)
- Type (profile_cloud_Type), Intent (in) :: cld_profiles (nprofiles)
- Type (profile_scatt_aux), Intent (in) :: scatt_aux
- Type (profile_scatt_aux), Intent (inout) :: scatt_aux_ad
- Type (radiance_cloud_Type), Intent (inout) :: cld_radiance
- Type (radiance_cloud_Type), Intent (inout) :: cld_radiance_ad
-End Subroutine rttov_eddington_ad
-END INTERFACE
diff --git a/src/LIB/RTTOV/src/rttov_eddington_k.F90 b/src/LIB/RTTOV/src/rttov_eddington_k.F90
deleted file mode 100644
index 2441d2724c32d81fc9c77e80c2aa7ad04156da47..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_eddington_k.F90
+++ /dev/null
@@ -1,313 +0,0 @@
-!
-Subroutine rttov_eddington_k ( &
- & nwp_levels, &! in
- & nchannels, &! in
- & nprofiles, &! in
- & lprofiles, &! in
- & angles, &! in
- & profiles, &! in
- & profiles_k, &! inout
- & cld_profiles, &! in
- & scatt_aux, &! in
- & scatt_aux_k, &! inout
- & cld_radiance, &! inout
- & cld_radiance_k) ! inout
-
- ! Description:
- ! AD of routine
- ! to compute Eddington approximation to RT
- !
- ! Copyright:
- ! This software was developed within the context of
- ! the EUMETSAT Satellite Application Facility on
- ! Numerical Weather Prediction (NWP SAF), under the
- ! Cooperation Agreement dated 25 November 1998, between
- ! EUMETSAT and the Met Office, UK, by one or more partners
- ! within the NWP SAF. The partners in the NWP SAF are
- ! the Met Office, ECMWF, KNMI and MeteoFrance.
- !
- ! Copyright 2002, EUMETSAT, All Rights Reserved.
- !
- ! Method:
- ! - Bauer, P., 2002: Microwave radiative transfer modeling in clouds and precipitation.
- ! Part I: Model description.
- ! NWP SAF Report No. NWPSAF-EC-TR-005, 27 pp.
- ! - Chevallier, F., and P. Bauer, 2003:
- ! Model rain and clouds over oceans: comparison with SSM/I observations.
- ! Mon. Wea. Rev., 131, 1240-1255.
- ! - Moreau, E., P. Bauer and F. Chevallier, 2002: Microwave radiative transfer modeling in clouds and precipitation.
- ! Part II: Model evaluation.
- ! NWP SAF Report No. NWPSAF-EC-TR-006, 27 pp.
- !
- ! Current Code Owner: SAF NWP
- !
- ! History:
- ! Version Date Comment
- ! ------- ---- -------
- ! 1.0 09/2002 Initial version (P. Bauer, E. Moreau)
- ! 1.1 05/2003 RTTOV7.3 compatible (F. Chevallier)
- ! 1.2 03/2004 Added polarimetry (R. Saunders)
- ! 1.3 08/2004 Polarimetry fixes (U. O'Keefe)
- ! 1.4 11/2004 Clean-up (P. Bauer)
- ! 1.5 02/2005 K-code (A. Collard)
- !
- ! Code Description:
- ! Language: Fortran 90.
- ! Software Standards: "European Standards for Writing and
- ! Documenting Exchangeable Fortran 90 Code".
- !
- ! Declarations:
- ! Modules used:
- ! Imported Type Definitions:
-
- Use rttov_types, Only : &
- & geometry_Type ,&
- & profile_Type ,&
- & profile_cloud_Type ,&
- & profile_scatt_aux ,&
- & radiance_cloud_Type
-
- Use rttov_const, Only: &
- & tcosmic
-
- Use parkind1, Only : jpim ,jprb
-
- Implicit None
-
-#include "rttov_boundaryconditions.interface"
-#include "rttov_integratesource.interface"
-#include "rttov_boundaryconditions_k.interface"
-#include "rttov_integratesource_k.interface"
-
-!* Subroutine arguments:
- Integer (Kind=jpim), Intent (in) :: nwp_levels ! Number of NWP-levels
- Integer (Kind=jpim), Intent (in) :: nprofiles ! Number of profiles
- Integer (Kind=jpim), Intent (in) :: nchannels ! Number of channels*profiles=radiances
- Integer (Kind=jpim), Intent (in) :: lprofiles (nchannels) ! Profile indices
-
- Type (geometry_Type), Intent (in) :: angles (nprofiles) ! Zenith angles
- Type (profile_Type), Intent (in) :: profiles (nprofiles) ! Profiles on RTTOV levels
- Type (profile_Type), Intent (inout) :: profiles_k (nchannels) ! Profiles on RTTOV levels
- Type (profile_cloud_Type), Intent (in) :: cld_profiles (nprofiles) ! Cloud profiles on NWP levels
- Type (profile_scatt_aux), Intent (inout) :: scatt_aux ! Auxiliary profile variables for RTTOV_SCATT
- Type (profile_scatt_aux), Intent (inout) :: scatt_aux_k ! Auxiliary profile variables for RTTOV_SCATT
- Type (radiance_cloud_Type), Intent (inout) :: cld_radiance ! Radiances
- Type (radiance_cloud_Type), Intent (inout) :: cld_radiance_k ! Radiances
-
-!* Local variables
- Real (Kind=jprb), Dimension (nchannels,nwp_levels) :: dp ! D+ for boundary conditions
- Real (Kind=jprb), Dimension (nchannels,nwp_levels) :: dm ! D- for boundary conditions
- Real (Kind=jprb), Dimension (nchannels,nwp_levels) :: j_up ! Upward radiance source terms
- Real (Kind=jprb), Dimension (nchannels,nwp_levels) :: j_do ! Downward radiance source terms
- Real (Kind=jprb), Dimension (nchannels,nwp_levels) :: dp_k ! D+ for boundary conditions
- Real (Kind=jprb), Dimension (nchannels,nwp_levels) :: dm_k ! D- for boundary conditions
- Real (Kind=jprb), Dimension (nchannels,nwp_levels) :: j_up_k ! Upward radiance source terms
- Real (Kind=jprb), Dimension (nchannels,nwp_levels) :: j_do_k ! Downward radiance source terms
-
-
- Real (Kind=jprb), Dimension (nchannels,0:nwp_levels) :: irad_do1 ! Downward radiances
- Real (Kind=jprb), Dimension (nchannels,0:nwp_levels) :: irad_do2 ! Downward radiances
- Real (Kind=jprb), Dimension (nchannels,nwp_levels+1) :: irad_up ! Downward radiances
- Real (Kind=jprb), Dimension (nchannels) :: irad_sfc ! Inward radiances at surface
- Real (Kind=jprb), Dimension (nchannels) :: irad_space ! Inward radiances from space
- Real (Kind=jprb), Dimension (nchannels,nwp_levels+1) :: tau_t ! Transmittances integrated over all levels
- Real (Kind=jprb), Dimension (nchannels) :: ftop, ftop_k ! Downward radiances
- Real (Kind=jprb), Dimension (nchannels,0:nwp_levels) :: irad_do2_k ! Downward radiances
- Real (Kind=jprb), Dimension (nchannels,0:nwp_levels) :: irad_do1_k ! Downward radiances
- Real (Kind=jprb), Dimension (nchannels,nwp_levels+1) :: irad_up_k ! Upward radiances
- Real (Kind=jprb), Dimension (nchannels) :: irad_sfc_k ! Inward radiances at surface
- Real (Kind=jprb), Dimension (nchannels) :: irad_space_k ! Inward radiances from space
- Real (Kind=jprb), Dimension (nchannels,nwp_levels+1) :: tau_t_k ! Transmittances integrated over all levels
-
- Integer (Kind=jpim) :: ilayer, jlayer, iprof, ichan
-
- !- End of header --------------------------------------------------------
-
-!* Channels * Profiles
- do ichan = 1, nchannels
- iprof = lprofiles (ichan)
-
-!* Top/bottom
- irad_sfc (ichan) = scatt_aux % ems_cld (ichan) * profiles (iprof) % skin % t
- irad_space (ichan) = tcosmic
-
-!* Clear-sky source terms
- j_up (ichan,:) = scatt_aux % b0 (iprof,:) * (1.0_JPRB - scatt_aux % tau (ichan,:))
- j_do (ichan,:) = scatt_aux % b0 (iprof,:) * (1.0_JPRB - scatt_aux % tau (ichan,:))
-
-!* Downward radiance at cloud top
- irad_do1 (ichan,0) = irad_space (ichan)
-
- Do ilayer = 1, scatt_aux % mclayer (ichan) - 1
- irad_do1 (ichan,ilayer) = irad_do1 (ichan,ilayer-1) * scatt_aux % tau (ichan,ilayer) + j_do (ichan,ilayer)
- End do
-
- ftop (ichan) = irad_do1 (ichan,scatt_aux % mclayer (ichan) - 1)
- End do
-
- If (maxval(scatt_aux % mclayer) > 0) Then
-!* Get D+, D- from boundary conditions
-
- Call rttov_boundaryconditions (&
- & nwp_levels, &! in
- & nchannels, &! in
- & nprofiles, &! in
- & lprofiles, &! in
- & scatt_aux, &! in
- & profiles, &! in
- & ftop, &! in
- & dp, &! out
- & dm) ! out
-
-!* Integrate radiance source terms
- Call rttov_integratesource (&
- & nwp_levels, &! in
- & nchannels, &! in
- & nprofiles, &! in
- & lprofiles, &! in
- & angles, &! in
- & scatt_aux, &! in
- & dp, &! in
- & dm, &! in
- & j_do, &! inout
- & j_up) ! inout
-
- Endif
-
-!* Integrate downward radiances/transmittance
- irad_do2 (:,0) = irad_space (:)
- irad_up (:,nwp_levels+1) = irad_sfc (:)
- tau_t (:,nwp_levels+1) = 1.0_JPRB
-
- Do ilayer = 1, nwp_levels
- jlayer = nwp_levels + 1 - ilayer
-
- irad_do2 (:,ilayer) = irad_do2 (:,ilayer-1) * scatt_aux % tau (:,ilayer) + j_do (:,ilayer)
- irad_up (:,jlayer) = irad_up (:,jlayer+1) * scatt_aux % tau (:,jlayer) + j_up (:,jlayer)
-
- tau_t (:,jlayer) = tau_t (:,jlayer+1) * scatt_aux % tau (:,jlayer)
- Enddo
-
- cld_radiance % bt (:) = irad_up (:,1) + scatt_aux % ref_cld (:) * irad_do2 (:,nwp_levels) * tau_t (:,1)
-
-!* ADJOINT PART
- irad_up_k (:,:) = 0.0_JPRB
- irad_do1_k (:,:) = 0.0_JPRB
- irad_do2_k (:,:) = 0.0_JPRB
- tau_t_k (:,:) = 0.0_JPRB
- j_up_k (:,:) = 0.0_JPRB
- j_do_k (:,:) = 0.0_JPRB
- irad_sfc_k (:) = 0.0_JPRB
- irad_space_k (:) = 0.0_JPRB
- dp_k (:,:) = 0.0_JPRB
- dm_k (:,:) = 0.0_JPRB
- ftop_k (:) = 0.0_JPRB
-
-!* Integrate downward radiances/transmittance
- irad_up_k (:,1) = irad_up_k (:,1) + cld_radiance_k % bt (:)
- scatt_aux_k % ref_cld (:) = scatt_aux_k % ref_cld (:) + irad_do2 (:,nwp_levels) * tau_t (:,1) * cld_radiance_k % bt (:)
- irad_do2_k (:,nwp_levels) = irad_do2_k (:,nwp_levels) + scatt_aux % ref_cld (:) * tau_t (:,1) * cld_radiance_k % bt (:)
- tau_t_k (:,1) = tau_t_k (:,1) + scatt_aux % ref_cld (:) &
- & * irad_do2 (:,nwp_levels) * cld_radiance_k % bt (:)
- cld_radiance_k % bt (:) = 0.0_JPRB
-
- Do ilayer = nwp_levels, 1, -1
- jlayer = nwp_levels + 1 - ilayer
-
- tau_t_k (:,jlayer+1) = tau_t_k (:,jlayer+1) + scatt_aux % tau (:,jlayer) * tau_t_k (:,jlayer)
- scatt_aux_k % tau (:,jlayer) = scatt_aux_k % tau (:,jlayer) + tau_t (:,jlayer+1) * tau_t_k (:,jlayer)
- tau_t_k (:,jlayer) = 0.0_JPRB
-
- irad_up_k (:,jlayer+1) = irad_up_k (:,jlayer+1) + scatt_aux % tau (:,jlayer) * irad_up_k (:,jlayer)
- scatt_aux_k % tau (:,jlayer) = scatt_aux_k % tau (:,jlayer) + irad_up (:,jlayer+1) * irad_up_k (:,jlayer)
- j_up_k (:,jlayer) = j_up_k (:,jlayer) + irad_up_k (:,jlayer)
- irad_up_k (:,jlayer) = 0.0_JPRB
-
- irad_do2_k (:,ilayer-1) = irad_do2_k (:,ilayer-1) + scatt_aux % tau (:,ilayer) * irad_do2_k (:,ilayer)
- scatt_aux_k % tau (:,ilayer) = scatt_aux_k % tau (:,ilayer) + irad_do2 (:,ilayer-1) * irad_do2_k (:,ilayer)
- j_do_k (:,ilayer) = j_do_k (:,ilayer) + irad_do2_k (:,ilayer)
- irad_do2_k (:,ilayer) = 0.0_JPRB
- Enddo
-
- tau_t_k (:,nwp_levels+1) = 0.0_JPRB
-
- irad_sfc_k (:) = irad_sfc_k (:) + irad_up_k (:,nwp_levels+1)
- irad_up_k (:,nwp_levels+1) = 0.0_JPRB
-
- irad_space_k (:) = irad_space_k (:) + irad_do2_k (:,0)
- irad_do2_k (:,0) = 0.0_JPRB
-
- If (maxval(scatt_aux % mclayer) > 0) Then
-!* Get D+, D- from boundary conditions
-
- Call rttov_integratesource_k (&
- & nwp_levels, &! in
- & nchannels, &! in
- & nprofiles, &! in
- & lprofiles, &! in
- & angles, &! in
- & scatt_aux, &! in
- & scatt_aux_k, &! in
- & dp, &! in
- & dp_k, &! in
- & dm, &! in
- & dm_k, &! in
- & j_do, &! inout
- & j_do_k, &! inout
- & j_up, &! inout
- & j_up_k) ! inout
-
- Call rttov_boundaryconditions_k (&
- & nwp_levels, &! in
- & nchannels, &! in
- & nprofiles, &! in
- & lprofiles, &! in
- & scatt_aux, &! in
- & scatt_aux_k, &! in
- & profiles, &! in
- & profiles_k , &! in
- & ftop, &! in
- & ftop_k, &! in
- & dp, &! out
- & dp_k, &! out
- & dm, &! out
- & dm_k) ! out
- Endif
-
-!* Channels * Profiles
- do ichan = 1, nchannels
- iprof = lprofiles (ichan)
-
-!* Downward radiance at cloud top
- irad_do1_k (ichan,scatt_aux % mclayer (ichan) - 1) = irad_do1_k (ichan,scatt_aux % mclayer (ichan) - 1) + ftop_k (ichan)
- ftop_k (ichan) = 0.0_JPRB
-
- Do ilayer = scatt_aux % mclayer (ichan) - 1, 1, -1
- irad_do1_k (ichan,ilayer-1) = irad_do1_k (ichan,ilayer-1) &
- & + scatt_aux % tau (ichan,ilayer) * irad_do1_k (ichan,ilayer)
- scatt_aux_k % tau (ichan,ilayer) = scatt_aux_k % tau (ichan,ilayer) &
- & + irad_do1 (ichan,ilayer-1) * irad_do1_k (ichan,ilayer)
- j_do_k (ichan,ilayer) = j_do_k (ichan,ilayer) + irad_do1_k (ichan,ilayer)
- irad_do1_k (ichan,ilayer) = 0.0_JPRB
- End do
-
- irad_space_k (ichan) = irad_space_k (ichan) + irad_do1_k (ichan,0)
- irad_do1_k (ichan,0) = 0.0_JPRB
-
-!* Clear-sky source terms
- j_up_k (ichan,:) = j_up_k (ichan,:) + j_do_k (ichan,:)
- j_do_k (ichan,:) = 0.0_JPRB
-
- scatt_aux_k % b0 (ichan,:) = scatt_aux_k % b0 (ichan,:) + (1.0_JPRB - scatt_aux % tau (ichan,:)) * j_up_k (ichan,:)
- scatt_aux_k % tau (ichan,:) = scatt_aux_k % tau (ichan,:) - scatt_aux % b0 (iprof,:) * j_up_k (ichan,:)
- j_up_k (ichan,:) = 0.0_JPRB
-
-!* Top/bottom
- irad_space_k (ichan) = 0.0_JPRB
-
- scatt_aux_k % ems_cld (ichan) = scatt_aux_k % ems_cld (ichan) + profiles (iprof) % skin % t * irad_sfc_k (ichan)
- profiles_k (ichan) % skin % t = profiles_k (ichan) % skin % t + scatt_aux % ems_cld (ichan) * irad_sfc_k (ichan)
- irad_sfc_k (ichan) = 0.0_JPRB
- End do
-
-End Subroutine rttov_eddington_k
diff --git a/src/LIB/RTTOV/src/rttov_eddington_k.interface b/src/LIB/RTTOV/src/rttov_eddington_k.interface
deleted file mode 100644
index b5346d3e058c47a8d7fcc527728f77cbd1fec9ed..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_eddington_k.interface
+++ /dev/null
@@ -1,35 +0,0 @@
-INTERFACE
-Subroutine rttov_eddington_k (&
- & nwp_levels,&
- & nchannels,&
- & nprofiles,&
- & lprofiles,&
- & angles,&
- & profiles,&
- & profiles_k,&
- & cld_profiles,&
- & scatt_aux,&
- & scatt_aux_k,&
- & cld_radiance,&
- & cld_radiance_k)
- Use rttov_types, Only :&
- & geometry_Type ,&
- & profile_Type ,&
- & profile_cloud_Type ,&
- & profile_scatt_aux ,&
- & radiance_cloud_Type
- Use parkind1, Only : jpim ,jprb
- Integer (Kind=jpim), Intent (in) :: nwp_levels
- Integer (Kind=jpim), Intent (in) :: nprofiles
- Integer (Kind=jpim), Intent (in) :: nchannels
- Integer (Kind=jpim), Intent (in) :: lprofiles (nchannels)
- Type (geometry_Type), Intent (in) :: angles (nprofiles)
- Type (profile_Type), Intent (in) :: profiles (nprofiles)
- Type (profile_Type), Intent (inout) :: profiles_k (nchannels)
- Type (profile_cloud_Type), Intent (in) :: cld_profiles (nprofiles)
- Type (profile_scatt_aux), Intent (in) :: scatt_aux
- Type (profile_scatt_aux), Intent (inout) :: scatt_aux_k
- Type (radiance_cloud_Type), Intent (inout) :: cld_radiance
- Type (radiance_cloud_Type), Intent (inout) :: cld_radiance_k
-End Subroutine rttov_eddington_k
-END INTERFACE
diff --git a/src/LIB/RTTOV/src/rttov_eddington_tl.F90 b/src/LIB/RTTOV/src/rttov_eddington_tl.F90
deleted file mode 100644
index 1df2672bf94f18fb3f728743b249fa1fa4b72be7..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_eddington_tl.F90
+++ /dev/null
@@ -1,225 +0,0 @@
-!
-Subroutine rttov_eddington_tl ( &
- & nwp_levels, &! in
- & nchannels, &! in
- & nprofiles, &! in
- & lprofiles, &! in
- & angles, &! in
- & profiles, &! in
- & profiles_tl, &! in
- & cld_profiles, &! in
- & scatt_aux, &! in
- & scatt_aux_tl, &! in
- & cld_radiance, &! inout
- & cld_radiance_tl) ! inout
-
- ! Description:
- ! to compute Eddington approximation to RT
- !
- ! Copyright:
- ! This software was developed within the context of
- ! the EUMETSAT Satellite Application Facility on
- ! Numerical Weather Prediction (NWP SAF), under the
- ! Cooperation Agreement dated 25 November 1998, between
- ! EUMETSAT and the Met Office, UK, by one or more partners
- ! within the NWP SAF. The partners in the NWP SAF are
- ! the Met Office, ECMWF, KNMI and MeteoFrance.
- !
- ! Copyright 2002, EUMETSAT, All Rights Reserved.
- !
- ! Method:
- ! - Bauer, P., 2002: Microwave radiative transfer modeling in clouds and precipitation.
- ! Part I: Model description.
- ! NWP SAF Report No. NWPSAF-EC-TR-005, 27 pp.
- ! - Chevallier, F., and P. Bauer, 2003:
- ! Model rain and clouds over oceans: comparison with SSM/I observations.
- ! Mon. Wea. Rev., 131, 1240-1255.
- ! - Moreau, E., P. Bauer and F. Chevallier, 2002: Microwave radiative transfer modeling in clouds and precipitation.
- ! Part II: Model evaluation.
- ! NWP SAF Report No. NWPSAF-EC-TR-006, 27 pp.
- !
- ! Current Code Owner: SAF NWP
- !
- ! History:
- ! Version Date Comment
- ! ------- ---- -------
- ! 1.0 09/2002 Initial version (P. Bauer, E. Moreau)
- ! 1.1 05/2003 RTTOV7.3 compatible (F. Chevallier)
- ! 1.2 03/2004 Added polarimetry (R. Saunders)
- ! 1.3 08/2004 Polarimetry fixes (U. O'Keefe)
- ! 1.4 11/2004 Clean-up (P. Bauer)
- !
- ! Code Description:
- ! Language: Fortran 90.
- ! Software Standards: "European Standards for Writing and
- ! Documenting Exchangeable Fortran 90 Code".
- !
- ! Declarations:
- ! Modules used:
- ! Imported Type Definitions:
-
- Use rttov_types, Only : &
- & geometry_Type ,&
- & profile_Type ,&
- & profile_cloud_Type ,&
- & profile_scatt_aux ,&
- & radiance_cloud_Type
-
- Use rttov_const, Only: &
- & tcosmic
-
- Use parkind1, Only : jpim ,jprb
-
- Implicit None
-
-#include "rttov_boundaryconditions_tl.interface"
-#include "rttov_integratesource_tl.interface"
-
-!* Subroutine arguments:
- Integer (Kind=jpim), Intent (in) :: nwp_levels ! Number of NWP-levels
- Integer (Kind=jpim), Intent (in) :: nprofiles ! Number of profiles
- Integer (Kind=jpim), Intent (in) :: nchannels ! Number of channels*profiles=radiances
- Integer (Kind=jpim), Intent (in) :: lprofiles (nchannels) ! Profile indices
-
- Type (geometry_Type), Intent (in) :: angles (nprofiles) ! Zenith angles
- Type (profile_Type), Intent (in) :: profiles (nprofiles) ! Profiles on RTTOV levels
- Type (profile_Type), Intent (in) :: profiles_tl (nprofiles) ! Profiles on RTTOV levels
- Type (profile_cloud_Type), Intent (in) :: cld_profiles (nprofiles) ! Cloud profiles on NWP levels
- Type (profile_scatt_aux), Intent (inout) :: scatt_aux ! Auxiliary profile variables for RTTOV_SCATT
- Type (profile_scatt_aux), Intent (inout) :: scatt_aux_tl ! Auxiliary profile variables for RTTOV_SCATT
- Type (radiance_cloud_Type), Intent (inout) :: cld_radiance ! Radiances
- Type (radiance_cloud_Type), Intent (inout) :: cld_radiance_tl ! Radiances
-
-!* Local variables
- Real (Kind=jprb), Dimension (nchannels,nwp_levels) :: dp ! D+ for boundary conditions
- Real (Kind=jprb), Dimension (nchannels,nwp_levels) :: dm ! D- for boundary conditions
- Real (Kind=jprb), Dimension (nchannels,nwp_levels) :: j_up ! Upward radiance source terms
- Real (Kind=jprb), Dimension (nchannels,nwp_levels) :: j_do ! Downward radiance source terms
- Real (Kind=jprb), Dimension (nchannels,nwp_levels) :: dp_tl ! D+ for boundary conditions
- Real (Kind=jprb), Dimension (nchannels,nwp_levels) :: dm_tl ! D- for boundary conditions
- Real (Kind=jprb), Dimension (nchannels,nwp_levels) :: j_up_tl ! Upward radiance source terms
- Real (Kind=jprb), Dimension (nchannels,nwp_levels) :: j_do_tl ! Downward radiance source terms
-
- Real (Kind=jprb), Dimension (nchannels) :: irad_do, ftop ! Downward radiances
- Real (Kind=jprb), Dimension (nchannels) :: irad_up ! Upward radiances
- Real (Kind=jprb), Dimension (nchannels) :: irad_sfc ! Inward radiances at surface
- Real (Kind=jprb), Dimension (nchannels) :: irad_space ! Inward radiances from space
- Real (Kind=jprb), Dimension (nchannels) :: tau_t ! Transmittances integrated over all levels
- Real (Kind=jprb), Dimension (nchannels) :: irad_do_tl, ftop_tl ! Downward radiances
- Real (Kind=jprb), Dimension (nchannels) :: irad_up_tl ! Upward radiances
- Real (Kind=jprb), Dimension (nchannels) :: irad_sfc_tl ! Inward radiances at surface
- Real (Kind=jprb), Dimension (nchannels) :: irad_space_tl ! Inward radiances from space
- Real (Kind=jprb), Dimension (nchannels) :: tau_t_tl ! Transmittances integrated over all levels
-
- Integer(Kind=jpim) :: ilayer, jlayer, iprof, ichan
-
- !- End of header --------------------------------------------------------
-
- cld_radiance_tl % bt (:) = 0.0_JPRB
- cld_radiance % bt (:) = 0.0_JPRB
-
-!* Channels * Profiles
- do ichan = 1, nchannels
- iprof = lprofiles (ichan)
-
-!* Top/bottom
- irad_sfc_tl (ichan) = scatt_aux_tl % ems_cld (ichan) * profiles (iprof) % skin % t &
- & + scatt_aux % ems_cld (ichan) * profiles_tl (iprof) % skin % t
- irad_sfc (ichan) = scatt_aux % ems_cld (ichan) * profiles (iprof) % skin % t
-
- irad_space_tl (ichan) = 0.0_JPRB
- irad_space (ichan) = tcosmic
-
-!* Clear-sky source terms
- j_up_tl (ichan,:) = scatt_aux_tl % b0 (iprof,:) * (1.0_JPRB - scatt_aux % tau (ichan,:)) &
- & - scatt_aux % b0 (iprof,:) * scatt_aux_tl % tau (ichan,:)
- j_up (ichan,:) = scatt_aux % b0 (iprof,:) * (1.0_JPRB - scatt_aux % tau (ichan,:))
-
- j_do_tl (ichan,:) = j_up_tl (ichan,:)
- j_do (ichan,:) = j_up (ichan,:)
-
-!* Downward radiance at cloud top
- irad_do_tl (ichan) = irad_space_tl (ichan)
- irad_do (ichan) = irad_space (ichan)
-
- Do ilayer = 1, scatt_aux % mclayer (ichan) - 1
- irad_do_tl (ichan) = irad_do_tl (ichan) * scatt_aux % tau (ichan,ilayer) &
- & + irad_do (ichan) * scatt_aux_tl % tau (ichan,ilayer) + j_do_tl (ichan,ilayer)
- irad_do (ichan) = irad_do (ichan) * scatt_aux % tau (ichan,ilayer) + j_do (ichan,ilayer)
- End do
-
- ftop (ichan) = irad_do (ichan)
- ftop_tl (ichan) = irad_do_tl (ichan)
- End do
-
- If (maxval(scatt_aux % mclayer) > 0) Then
-
-!* Get D+, D- from boundary conditions
- Call rttov_boundaryconditions_tl (&
- & nwp_levels, &! in
- & nchannels, &! in
- & nprofiles, &! in
- & lprofiles, &! in
- & scatt_aux, &! in
- & scatt_aux_tl, &! in
- & profiles, &! in
- & profiles_tl , &! in
- & ftop, &! in
- & ftop_tl, &! in
- & dp, &! out
- & dp_tl, &! out
- & dm, &! out
- & dm_tl) ! out
-
-!* Integrate radiance source terms
- Call rttov_integratesource_tl (&
- & nwp_levels, &! in
- & nchannels, &! in
- & nprofiles, &! in
- & lprofiles, &! in
- & angles, &! in
- & scatt_aux, &! in
- & scatt_aux_tl, &! in
- & dp, &! in
- & dp_tl, &! in
- & dm, &! in
- & dm_tl, &! in
- & j_do, &! inout
- & j_do_tl, &! inout
- & j_up, &! inout
- & j_up_tl) ! inout
-
- Endif
-
-!* Integrate downward radiances/transmittance
- irad_do_tl (:) = 0.0_JPRB
- irad_do (:) = irad_space (:)
-
- irad_up_tl (:) = irad_sfc_tl (:)
- irad_up (:) = irad_sfc (:)
-
- tau_t_tl (:) = 0.0_JPRB
- tau_t (:) = 1.0_JPRB
-
- Do ilayer = 1, nwp_levels
- jlayer = nwp_levels + 1 - ilayer
-
- irad_do_tl (:) = irad_do_tl (:) * scatt_aux % tau (:,ilayer) &
- & + irad_do (:) * scatt_aux_tl % tau (:,ilayer) + j_do_tl (:,ilayer)
- irad_do (:) = irad_do (:) * scatt_aux % tau (:,ilayer) + j_do (:,ilayer)
-
- irad_up_tl (:) = irad_up_tl (:) * scatt_aux % tau (:,jlayer) &
- & + irad_up (:) * scatt_aux_tl % tau (:,jlayer) + j_up_tl (:,jlayer)
- irad_up (:) = irad_up (:) * scatt_aux % tau (:,jlayer) + j_up (:,jlayer)
-
- tau_t_tl (:) = tau_t_tl (:) * scatt_aux % tau (:,jlayer) &
- & + tau_t (:) * scatt_aux_tl % tau (:,jlayer)
- tau_t (:) = tau_t (:) * scatt_aux % tau (:,jlayer)
- Enddo
-
- cld_radiance_tl % bt (:) = irad_up_tl (:) + (scatt_aux_tl % ref_cld (:) * irad_do (:) &
- & + scatt_aux % ref_cld (:) * irad_do_tl (:)) * tau_t (:) &
- & + (scatt_aux % ref_cld (:) * irad_do (:)) * tau_t_tl (:)
- cld_radiance % bt (:) = irad_up (:) + scatt_aux % ref_cld (:) * irad_do (:) * tau_t (:)
-
-End Subroutine rttov_eddington_tl
diff --git a/src/LIB/RTTOV/src/rttov_eddington_tl.interface b/src/LIB/RTTOV/src/rttov_eddington_tl.interface
deleted file mode 100644
index ed9c56237eea4aefda594584a0296fe4f37ccd1d..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_eddington_tl.interface
+++ /dev/null
@@ -1,35 +0,0 @@
-INTERFACE
-Subroutine rttov_eddington_tl (&
- & nwp_levels,&
- & nchannels,&
- & nprofiles,&
- & lprofiles,&
- & angles,&
- & profiles,&
- & profiles_tl,&
- & cld_profiles,&
- & scatt_aux,&
- & scatt_aux_tl,&
- & cld_radiance,&
- & cld_radiance_tl)
- Use rttov_types, Only :&
- & geometry_Type ,&
- & profile_Type ,&
- & profile_cloud_Type ,&
- & profile_scatt_aux ,&
- & radiance_cloud_Type
- Use parkind1, Only : jpim ,jprb
- Integer (Kind=jpim), Intent (in) :: nwp_levels
- Integer (Kind=jpim), Intent (in) :: nprofiles
- Integer (Kind=jpim), Intent (in) :: nchannels
- Integer (Kind=jpim), Intent (in) :: lprofiles (nchannels)
- Type (geometry_Type), Intent (in) :: angles (nprofiles)
- Type (profile_Type), Intent (in) :: profiles (nprofiles)
- Type (profile_Type), Intent (in) :: profiles_tl (nprofiles)
- Type (profile_cloud_Type), Intent (in) :: cld_profiles (nprofiles)
- Type (profile_scatt_aux), Intent (in) :: scatt_aux
- Type (profile_scatt_aux), Intent (in) :: scatt_aux_tl
- Type (radiance_cloud_Type), Intent (inout) :: cld_radiance
- Type (radiance_cloud_Type), Intent (inout) :: cld_radiance_tl
-End Subroutine rttov_eddington_tl
-END INTERFACE
diff --git a/src/LIB/RTTOV/src/rttov_emiscld.F90 b/src/LIB/RTTOV/src/rttov_emiscld.F90
deleted file mode 100644
index 2d67303ea949fb0a71c19bf23734d47705e5dc6f..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_emiscld.F90
+++ /dev/null
@@ -1,543 +0,0 @@
-!
-Subroutine rttov_emiscld( &
- & errorstatus, &! out
- & nfrequencies, &! in
- & nchannels, &! in
- & nprofiles, &! in
- & nlevels , &! in
- & channels, &! in
- & polarisations, &! in
- & lprofiles, &! in
- & profiles, &! in (surftype and zenangle)
- & coef, &! in (frequencies mw/ir/hi)
- & cld_profiles, &! in
- & cld_radiance) ! inout (only cldemis calculated)
- ! Description:
- ! To compute cloud emissivity in the micro-wave (0-200 GHz)
- ! and in the infrared (50-2860 cm-1)
- ! spectral ranges
- !
- ! Copyright:
- ! This software was developed within the context of
- ! the EUMETSAT Satellite Application Facility on
- ! Numerical Weather Prediction (NWP SAF), under the
- ! Cooperation Agreement dated 25 November 1998, between
- ! EUMETSAT and the Met Office, UK, by one or more partners
- ! within the NWP SAF. The partners in the NWP SAF are
- ! the Met Office, ECMWF, KNMI and MeteoFrance.
- !
- ! Copyright 2002, EUMETSAT, All Rights Reserved.
- !
- ! Method:
- ! See references in the comments
- !
- ! Current Code Owner: SAF NWP
- !
- ! History:
- ! Version Date Comment
- ! ------- ---- -------
- ! 1 03/2000 Original code (F. Chevallier and P. Bauer)
- ! 2 03/2001 Fortran 90 (F. Chevallier)
- ! 2.1 01/12/2002 New F90 code with structures (P Brunel A Smith)
- ! 3 18/9/2003 New absorption properties for water and ice clouds added (P. Francis)
- ! 4 24/2/04 Polarimetry options added
- ! 5 06/10/04 Added errorstatus to arguments.
- ! Changed stop statements to returns. (J Cameron)
- !
- ! Code Description:
- ! Language: Fortran 90.
- ! Software Standards: "European Standards for Writing and
- ! Documenting Exchangeable Fortran 90 Code".
- !
- ! Declarations:
- ! Modules used:
- ! Imported Parameters:
- Use rttov_const, Only : &
- & pi ,&
- & gravity ,&
- & surftype_land ,&
- & nvalhusta ,&
- & zhustaom , &
- & zhustaa1 , &
- & zhustaa2 , &
- & zhustaa3 , &
- & zhustab1 , &
- & zhustab2 , &
- & zhustab3 , &
- & zhustac1 , &
- & zhustac2 , &
- & zhustac3 , &
- & zhustad1 , &
- & zhustad2 , &
- & zhustad3 , &
- & zhustae1 , &
- & zhustae2 , &
- & zhustae3 , &
- & zhustaf1 , &
- & zhustaf2 , &
- & zhustaf3 , &
- & low_re , &
- & upp_re , &
- & nvalice , &
- & ziceom , &
- & ziceclmna , ziceclmnb , &
- & ziceclmnc , ziceclmnd , &
- & ziceaggra , ziceaggrb , &
- & ziceaggrc , ziceaggrd , &
- & sensor_id_ir ,&
- & sensor_id_mw ,&
- & sensor_id_hi ,&
- & errorstatus_success ,&
- & errorstatus_fatal
-
- ! Imported Type Definitions:
- Use rttov_types, Only : &
- & rttov_coef ,&
- & profile_Type ,&
- & profile_cloud_Type ,&
- & radiance_cloud_Type
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
- !subroutine arguments:
- Integer(Kind=jpim), Intent(in) :: nfrequencies ! Number of chans*profs
- Integer(Kind=jpim), Intent(in) :: nchannels ! Number of output radiances
- ! (= channels used * profiles)
- Integer(Kind=jpim), Intent(in) :: nprofiles ! Number of profiles
- Integer(Kind=jpim), Intent(in) :: nlevels ! Number of levels
- Integer(Kind=jpim), Intent(out) :: errorstatus(nprofiles) ! Error return code
- Integer(Kind=jpim), Intent(in) :: polarisations(nchannels,3) ! Channel indices
- Integer(Kind=jpim), Intent(in) :: channels(nfrequencies) ! Channel indices
- Integer(Kind=jpim), Intent(in) :: lprofiles(nfrequencies)! Profiles indices
- Type(profile_Type), Intent(in) :: profiles(nprofiles) ! Profiles on RTTOV levels
- Type(profile_cloud_Type), Intent(in) :: cld_profiles(nprofiles)! Cloud profiles on NWP levels
- Type(rttov_coef), Intent(in) :: coef ! Coefficients
- Type(radiance_cloud_Type), Intent(inout) :: cld_radiance ! radiances (mw/cm-1/ster/sq.m)
-
-
- ! Local parameters:
- !
- Real(Kind=jprb), Parameter :: rtt = 273.15_JPRB
- Real(Kind=jprb), Parameter :: rgp = 8.314510_JPRB, rm = 0.0289644_JPRB
- Real(Kind=jprb), Parameter :: repsc = 1.e-12_JPRB
- Real(Kind=jprb), Parameter :: hundred = 100.0_JPRB
- Real(Kind=jprb), Parameter :: rtou_upp=-20._JPRB
- Real(Kind=jprb), Parameter :: rtou_low=-60._JPRB
-
-
- !local variables:
- Integer(Kind=jpim) :: jc, jk, jl, jo, ido, idp, idq, idh
- Integer(Kind=jpim) :: freq
- Real(Kind=jprb) :: zomega, zfreq
- Real(Kind=jprb) :: zlwgkg, ziwgkg, ztempc, zdp, p1, p2
- Real(Kind=jprb) :: zmsaiu, zdom, zmin, zmultl, zmsalu
- Real(Kind=jprb) :: zdz, zodw, zodi, zhelp, zbeta
- Real(Kind=jprb) :: fac1, fac2, fac3, fac4, fac5, fac6
- Real(Kind=jprb) :: eps0, eps1, eps2, fp, fs, theta
- Real(Kind=jprb) :: a, b, tk
- Real(Kind=jprb) :: zeps_r, zeps_i
- Real(Kind=jprb) :: co_ssa_1, kext_hu_1, kabs_hu_1
- Real(Kind=jprb) :: co_ssa_2, kext_hu_2, kabs_hu_2
- Real(Kind=jprb) :: kabs_ice_1, kabs_ice_2
- Real(Kind=jprb) :: zradipou_upp, zradipou_low
- Real(Kind=jprb) :: bwyser, nft
- Real(Kind=jprb) :: amcfarq, bmcfarq, cmcfarq, zmcfarq
-
- Character (len=80) :: errMessage
- Character (len=13) :: NameOfRoutine = 'rttov_emiscld'
- !
-
- ! Local arrays:
- !
- Integer(Kind=jpim), Dimension(nchannels) :: indh
- Integer(Kind=jpim), Dimension(nchannels) :: indi
- Real(Kind=jprb), Dimension(nprofiles) :: zradlp, zradip
- Real(Kind=jprb), Dimension(nprofiles) :: zflwp, zfiwp, zlwc, ziwc
- Real(Kind=jprb), Dimension(nprofiles) :: zview
- Real(Kind=jprb) :: zdzst(nprofiles, nlevels)
-
- !- End of header --------------------------------------------------------
- !All input NWP profiles have the same number of levels
-
- errorstatus(:) = errorstatus_success
-
-
- ! All channels are IR or MW according to the coefficient
- ! structure information
-
- !
- ! Calculate upper and lower limits for Ou-Liou effective size
- !
- zradipou_upp=326.3_JPRB + rtou_upp*(12.42_JPRB + rtou_upp*(0.197_JPRB + rtou_upp*0.0012_JPRB))
- zradipou_low=326.3_JPRB + rtou_low*(12.42_JPRB + rtou_low*(0.197_JPRB + rtou_low*0.0012_JPRB))
- !
- ! and convert these to the "generalized" effective size used here (using McFarquhar et al 2003 equation),
- ! not forgetting the factor of 2 to convert from McFarquhar's radius to a diameter
- !
- zradipou_upp=-1.56_JPRB + zradipou_upp*(0.388_JPRB + zradipou_upp*0.00051_JPRB)
- zradipou_upp=2.0_JPRB*zradipou_upp
- zradipou_low=-1.56_JPRB + zradipou_low*(0.388_JPRB + zradipou_low*0.00051_JPRB)
- zradipou_low=2.0_JPRB*zradipou_low
-
- !
- ! nearest Hu & Stamnes and ice cloud coefficients
- ! For IR and Hires only
- If( coef % id_sensor == sensor_id_ir .Or. &
- & coef % id_sensor == sensor_id_hi ) Then
- Do jc = 1, nfrequencies
- ido = channels(jc)
- zomega = coef % ff_cwn(ido)
- zmin = 1.e+06_JPRB
- Do jo = 1, nvalhusta
- zdom = Abs( zomega - zhustaom(jo) )
- If (zdom < zmin) Then
- indh(jc) = jo
- zmin = zdom
- End If
- End Do
- zmin = 1.e+06_JPRB
- Do jo = 1, nvalice
- zdom = Abs( zomega - ziceom(jo) )
- If (zdom < zmin) Then
- indi(jc) = jo
- zmin = zdom
- End If
- End Do
- End Do
- End If
-
- ! secant of zenith angle
- !
- zview(:) = 1._JPRB / Cos( profiles(:)%zenangle /180._JPRB * pi )
-
- ! pressure layering (Pa)
- !
- Do jl = 1, nprofiles
- Do jk = 1, nlevels
- p1 = Max( cld_profiles(jl)%ph(jk) *hundred, repsc )
- p2 = Max( cld_profiles(jl)%ph(jk+1)*hundred, repsc )
- zdzst(jl,jk) = -1._JPRB *rgp /gravity /rm *Log(p1/p2)
- End Do
- End Do
-
-
- Do jk = 1, nlevels
- Do jl = 1, nprofiles
-
- zlwgkg = Max(cld_profiles(jl)%clw(jk)*1000._JPRB,0._JPRB)
- ziwgkg = Max(cld_profiles(jl)%ciw(jk)*1000._JPRB,0._JPRB)
- If (cld_profiles(jl)%cc(jk) > (2._JPRB*repsc)) Then
- zlwgkg = zlwgkg / cld_profiles(jl)%cc(jk)
- ziwgkg = ziwgkg / cld_profiles(jl)%cc(jk)
- Else
- zlwgkg=0._JPRB
- ziwgkg=0._JPRB
- End If
-
- ! Liquid and ice water paths (g.m-2)
- zdp = cld_profiles(jl)%ph(jk+1) - cld_profiles(jl)%ph(jk)
- zdp = zdp * 100._JPRB
- zflwp(jl) = zlwgkg*zdp / gravity
- zfiwp(jl) = ziwgkg*zdp / gravity
-
- ! Liquid and ice water contents (kg.m-3)
- zlwc(jl) = (zlwgkg/1000._JPRB) * (cld_profiles(jl)%p(jk)*100._JPRB * rm) /&
- & (rgp *cld_profiles(jl)%t(jk))
- ziwc(jl) = (ziwgkg/1000._JPRB) * (cld_profiles(jl)%p(jk)*100._JPRB * rm) /&
- & (rgp *cld_profiles(jl)%t(jk))
-
- zradip(jl) = 1._JPRB
- zradlp(jl) = 1._JPRB
- zmultl = 0._JPRB
-
- If (zflwp(jl) > 0._JPRB) Then
-
- ! Liquid particle radius (micro-meters)
-
- If ( profiles(jl)%skin%surftype == surftype_land ) Then
- zradlp(jl)=10._JPRB
- Else
- zradlp(jl)=13._JPRB
- End If
-
- !
- ! Extra check that droplet r_e goes neither below 2.5 microns nor above 60 microns (Hu & Stamnes limits)
- !
- zradlp(jl)=Max(zradlp(jl),low_re(1))
- zradlp(jl)=Min(zradlp(jl),upp_re(3))
- Endif
-
- If (zfiwp(jl) > 0._JPRB) Then
- ! Ice particle radius (micro-meters)
- !
- If (cld_profiles(jl)%kradip == 0) Then ! Ou-Liou
- !
- ! Ou and Liou, 1995, Atmos. Res., 35, 127-138.
- !
- ztempc = cld_profiles(jl)%t(jk) - rtt
- zradip(jl)=326.3_JPRB+ &
- & ztempc*(12.42_JPRB + ztempc*(0.197_JPRB + ztempc*0.0012_JPRB))
- ! and convert this to the "generalized" effective diameter (see McFarquhar et al 2003)
- zradip(jl)=-1.56_JPRB + zradip(jl)*(0.388_JPRB + zradip(jl)*0.00051_JPRB)
- zradip(jl)=2.0_JPRB*zradip(jl)
- !
- ! Take Ou-Liou scheme as being valid only between -20C and -60C
- !
- zradip(jl)=max(zradip(jl),zradipou_low)
- zradip(jl)=min(zradip(jl),zradipou_upp)
- !
- Elseif (cld_profiles(jl)%kradip == 1) Then ! Wyser
- !
- ! Wyser et al., reference details here..., McFarquhar et al. (2003)
- ! Note two typos in McFarquhar paper:
- ! (a) reference to "r" should be "4" in final equation
- ! (b) T_k should be (273-T_k) (see original Wyser paper)
- !
- bwyser=-2.0_JPRB
- ! Wyser's IWC is in g.m-3
- if (cld_profiles(jl)%t(jk) < 273._JPRB) bwyser = bwyser &
- & +(0.001_JPRB*((273._JPRB-cld_profiles(jl)%t(jk))**1.5_JPRB)*Log10(1000._JPRB*ziwc(jl)/50._JPRB))
- zradip(jl)=377.4_JPRB + bwyser*(203.3_JPRB + bwyser*(37.91_JPRB + bwyser*2.3696_JPRB)) ! Wyser definition
- nft=(sqrt(3._JPRB)+4._JPRB)/(3._JPRB*sqrt(3._JPRB))
- zradip(jl)=zradip(jl)/nft ! convert to intermediate definition (see Table 1 of McFarquhar et al.)
- zradip(jl)=2._JPRB*4._JPRB*zradip(jl)*sqrt(3._JPRB)/9._JPRB ! includes factor of 2 to convert McFarquhar"s r_ge to D_ge
- !
- Elseif (cld_profiles(jl)%kradip == 2) Then ! Boudala et al.
- !
- ! Boudala et al., 2002, Int. J. Climatol., 22, 1267-1284.
- !
- ztempc=cld_profiles(jl)%t(jk)-rtt
- zradip(jl)=53.005_JPRB*((ziwc(jl)*1000._JPRB)**0.06_JPRB)*exp(0.013_JPRB*ztempc)
- !
- Elseif (cld_profiles(jl)%kradip == 3) Then ! McFarquhar
- !
- ! McFarquhar et al. (2003)
- !
- amcfarq=1.78449_JPRB
- bmcfarq=0.281301_JPRB
- cmcfarq=0.0177166_JPRB
- zmcfarq=1000.0_JPRB*ziwc(jl) ! Put IWC in g.m-3
- zradip(jl)=10.0_JPRB**(amcfarq+(bmcfarq*Log10(zmcfarq))+&
- & (cmcfarq*Log10(zmcfarq)*Log10(zmcfarq)))
- zradip(jl)=2.0_JPRB*zradip(jl) ! Includes factor of 2 to convert McFarquhar's r_ge to D_ge
- !
-! Else
-! errMessage = 'Wrong kradip'
-! errorstatus(:) = errorstatus_fatal
-! Call Rttov_ErrorReport (errorstatus_fatal, errMessage, NameOfRoutine)
-! Return
- End If
- !
- End If
- End Do ! profiles
-
- Do jc = 1, nchannels
- freq = polarisations(jc,2)
- ido = channels(freq)
- idp = lprofiles(freq)
-
- ! Micro Waves
- If( coef % id_sensor == sensor_id_mw ) Then
- zdz = zdzst(idp,jk) * cld_profiles(idp)%t(jk)
- zfreq = coef%frequency_ghz (ido)
- ! Water
- ! Liebe et al., 1989, IEEE Trans. Antennas Propag., 37, 1617-1623.
- theta = 300.0_JPRB / cld_profiles(idp)%t(jk)
- fac1 = theta - 1.0_JPRB
- fac2 = fac1 * fac1
-
- eps0 = 77.66_JPRB + 103.3_JPRB * fac1
- eps1 = 5.48_JPRB
- eps2 = 3.51_JPRB
-
- fp = 20.09_JPRB - 142.0_JPRB * fac1 + 294.0_JPRB * fac2
- fs = 590.0_JPRB - 1500.0_JPRB * fac1
-
- fac3 = zfreq / fp
- fac4 = 1.0_JPRB + fac3 * fac3
- fac5 = zfreq / fs
- fac6 = 1.0_JPRB + fac5 * fac5
-
- zeps_r = (eps0 - eps1) / fac4 + (eps1 - eps2) / fac6 + eps2
- zeps_i = (eps0 - eps1) * fac3 / fac4 + (eps1 - eps2) * fac5 / fac6
-
- zhelp = zeps_i / ( (zeps_r + 2.0_JPRB)**2 + zeps_i**2 )
- zbeta = 0.18851441_JPRB * zfreq * zlwc(idp) * zhelp
- zodw = zbeta * zview(idp) * zdz
-
- ! Ice
- ! Hufford, 1991, Int. J. Infrared Millimeter Waves, 12, 677-681.
- zeps_r = 3.15_JPRB
- tk = cld_profiles(idp)%t(jk)
-
- If (tk > 273.16_JPRB) tk = 273.16_JPRB
- theta = 300.0_JPRB / tk
- a = 1.0e-04_JPRB * (50.4_JPRB + 62.0_JPRB * (theta - 1.0_JPRB)) &
- & * Exp (-22.1_JPRB * (theta - 1.0_JPRB))
- b = 1.0e-04_JPRB * (0.633_JPRB / theta - 0.131_JPRB) &
- & + (7.36e-04_JPRB * theta / (theta - 0.9927_JPRB)) ** 2
- zeps_i = a / zfreq + b * zfreq
-
- zhelp = zeps_i / ( (zeps_r + 2.0_JPRB)**2 + zeps_i**2 )
- zbeta = 0.18851441_JPRB * zfreq * ziwc(idp) * zhelp
- zodi = zbeta * zview(idp) * zdz
-
- cld_radiance % cldemis(jk,jc) = 1._JPRB - Exp( - zodw - zodi )
-
- ! Infra Red
- Elseif( coef % id_sensor == sensor_id_ir .Or. &
- & coef % id_sensor == sensor_id_hi ) Then
-
- If (zflwp(idp) > 0._JPRB) Then
-
- !
- ! Water cloud coefficients
- ! from Hu and Stamnes, 1993, J. Climate, Vol. 6, pp. 728-742
- !
- idh = indh(jc)
- zomega = coef % ff_cwn(ido)
- zdom = zomega - zhustaom(idh)
- !
- If (zdom >= 0.0_JPRB) Then ! Better to interpolate the single-scattering properties
- If (zradlp(idp) < upp_re(1)) Then ! themselves rather than the coefficients
- kext_hu_1=(zhustaa1(idh)*(zradlp(idp)**zhustab1(idh)))+zhustac1(idh)
- co_ssa_1=(zhustad1(idh)*(zradlp(idp)**zhustae1(idh)))+zhustaf1(idh)
- kext_hu_2=(zhustaa1(idh-1)*(zradlp(idp)**zhustab1(idh-1)))+zhustac1(idh-1)
- co_ssa_2=(zhustad1(idh-1)*(zradlp(idp)**zhustae1(idh-1)))+zhustaf1(idh-1)
- Elseif (zradlp(idp) >= low_re(2) .AND. zradlp(idp) < upp_re(2)) Then
- kext_hu_1=(zhustaa2(idh)*(zradlp(idp)**zhustab2(idh)))+zhustac2(idh)
- co_ssa_1=(zhustad2(idh)*(zradlp(idp)**zhustae2(idh)))+zhustaf2(idh)
- kext_hu_2=(zhustaa2(idh-1)*(zradlp(idp)**zhustab2(idh-1)))+zhustac2(idh-1)
- co_ssa_2=(zhustad2(idh-1)*(zradlp(idp)**zhustae2(idh-1)))+zhustaf2(idh-1)
- Elseif (zradlp(idp) >= low_re(3)) Then
- kext_hu_1=(zhustaa3(idh)*(zradlp(idp)**zhustab3(idh)))+zhustac3(idh)
- co_ssa_1=(zhustad3(idh)*(zradlp(idp)**zhustae3(idh)))+zhustaf3(idh)
- kext_hu_2=(zhustaa3(idh-1)*(zradlp(idp)**zhustab3(idh-1)))+zhustac3(idh-1)
- co_ssa_2=(zhustad3(idh-1)*(zradlp(idp)**zhustae3(idh-1)))+zhustaf3(idh-1)
- End If
- kabs_hu_1=kext_hu_1*co_ssa_1
- kabs_hu_2=kext_hu_2*co_ssa_2
- !
- ! Do the interpolation
- zmsalu = ((zdom)*(kabs_hu_2-kabs_hu_1)/(zhustaom(idh-1)-zhustaom(idh))) + kabs_hu_1
- !
- Elseif (zdom < 0.0_JPRB) Then
- If (zradlp(idp) < upp_re(1)) Then
- kext_hu_1=(zhustaa1(idh)*(zradlp(idp)**zhustab1(idh)))+zhustac1(idh)
- co_ssa_1=(zhustad1(idh)*(zradlp(idp)**zhustae1(idh)))+zhustaf1(idh)
- kext_hu_2=(zhustaa1(idh+1)*(zradlp(idp)**zhustab1(idh+1)))+zhustac1(idh+1)
- co_ssa_2=(zhustad1(idh+1)*(zradlp(idp)**zhustae1(idh+1)))+zhustaf1(idh+1)
- Elseif (zradlp(idp) >= low_re(2) .AND. zradlp(idp) < upp_re(2)) Then
- kext_hu_1=(zhustaa2(idh)*(zradlp(idp)**zhustab2(idh)))+zhustac2(idh)
- co_ssa_1=(zhustad2(idh)*(zradlp(idp)**zhustae2(idh)))+zhustaf2(idh)
- kext_hu_2=(zhustaa2(idh+1)*(zradlp(idp)**zhustab2(idh+1)))+zhustac2(idh+1)
- co_ssa_2=(zhustad2(idh+1)*(zradlp(idp)**zhustae2(idh+1)))+zhustaf2(idh+1)
- Elseif (zradlp(idp) >= low_re(3)) Then
- kext_hu_1=(zhustaa3(idh)*(zradlp(idp)**zhustab3(idh)))+zhustac3(idh)
- co_ssa_1=(zhustad3(idh)*(zradlp(idp)**zhustae3(idh)))+zhustaf3(idh)
- kext_hu_2=(zhustaa3(idh+1)*(zradlp(idp)**zhustab3(idh+1)))+zhustac3(idh+1)
- co_ssa_2=(zhustad3(idh+1)*(zradlp(idp)**zhustae3(idh+1)))+zhustaf3(idh+1)
- End If
- kabs_hu_1=kext_hu_1*co_ssa_1
- kabs_hu_2=kext_hu_2*co_ssa_2
- !
- ! Do the interpolation
- zmsalu = ((zdom)*(kabs_hu_2-kabs_hu_1)/(zhustaom(idh+1)-zhustaom(idh))) + kabs_hu_1
- End If
- !
- zmsalu = zview(idp) * (0.001_JPRB*zmsalu) ! Convert Hu/Stamnes to m^2g^-1 and put in viewing angle dependence
-
- Else
-
- zmsalu = 0._JPRB
-
- End If
-
- !
- ! Ice cloud emissivity
- ! See Baran et al. JAS, 417-427, 2003; Baran et al. JQSRT, 549-567, 2003; Baran & Francis QJRMS, 2004.
-
- If (zfiwp(idp) > 0._JPRB) Then
-
- idq = indi(jc)
- zomega = coef % ff_cwn(ido)
- zdom = zomega - ziceom(idq)
- If (zdom >= 0.0_JPRB) Then
- If (cld_profiles(idp)%kice == 0) Then ! Hexagonal columns
- kabs_ice_1=ziceclmna(idq)+(ziceclmnb(idq)/zradip(idp))+ &
- & (ziceclmnc(idq)/(zradip(idp)*zradip(idp)))+(ziceclmnd(idq)*zradip(idp))
- kabs_ice_2=ziceclmna(idq-1)+(ziceclmnb(idq-1)/zradip(idp))+ &
- & (ziceclmnc(idq-1)/(zradip(idp)*zradip(idp)))+(ziceclmnd(idq-1)*zradip(idp))
- Elseif (cld_profiles(idp)%kice == 1) Then ! Aggregates
- kabs_ice_1=ziceaggra(idq)+(ziceaggrb(idq)/zradip(idp))+ &
- & (ziceaggrc(idq)/(zradip(idp)*zradip(idp)))+(ziceaggrd(idq)*zradip(idp))
- kabs_ice_2=ziceaggra(idq-1)+(ziceaggrb(idq-1)/zradip(idp))+ &
- & (ziceaggrc(idq-1)/(zradip(idp)*zradip(idp)))+(ziceaggrd(idq-1)*zradip(idp))
-! Else
-! errMessage = 'Wrong kice'
-! errorstatus(:) = errorstatus_fatal
-! Call Rttov_ErrorReport (errorstatus_fatal, errMessage, NameOfRoutine)
-! Return
- End If
- !
- ! Do the interpolation
- zmsaiu = ((zdom)*(kabs_ice_2-kabs_ice_1)/(ziceom(idq-1)-ziceom(idq))) + kabs_ice_1
- !
- Elseif (zdom < 0.0_JPRB) Then
- If (cld_profiles(idp)%kice == 0) Then ! Hexagonal columns
- kabs_ice_1=ziceclmna(idq)+(ziceclmnb(idq)/zradip(idp))+ &
- & (ziceclmnc(idq)/(zradip(idp)*zradip(idp)))+(ziceclmnd(idq)*zradip(idp))
- kabs_ice_2=ziceclmna(idq+1)+(ziceclmnb(idq+1)/zradip(idp))+ &
- & (ziceclmnc(idq+1)/(zradip(idp)*zradip(idp)))+(ziceclmnd(idq+1)*zradip(idp))
- Elseif (cld_profiles(idp)%kice == 1) Then ! Aggregates
- kabs_ice_1=ziceaggra(idq)+(ziceaggrb(idq)/zradip(idp))+ &
- & (ziceaggrc(idq)/(zradip(idp)*zradip(idp)))+(ziceaggrd(idq)*zradip(idp))
- kabs_ice_2=ziceaggra(idq+1)+(ziceaggrb(idq+1)/zradip(idp))+ &
- & (ziceaggrc(idq+1)/(zradip(idp)*zradip(idp)))+(ziceaggrd(idq+1)*zradip(idp))
-! Else
-! errMessage = 'Wrong kice'
-! errorstatus(:) = errorstatus_fatal
-! Call Rttov_ErrorReport (errorstatus_fatal, errMessage, NameOfRoutine)
-! Return
- End If
- !
- ! Do the interpolation
- zmsaiu = ((zdom)*(kabs_ice_2-kabs_ice_1)/(ziceom(idq+1)-ziceom(idq))) + kabs_ice_1
- End If
- zmsaiu = zview(idp) * zmsaiu ! Add in viewing angle dependence
-
- Else
-
- zmsaiu = 0._JPRB
-
- End If
-
- !
- ! Cloud layer emissivity
-
- if(zflwp(idp) > 1200._JPRB)zflwp(idp)=1200._JPRB
- if(zflwp(idp) < 0._JPRB)zflwp(idp)=0._JPRB
- if(zfiwp(idp) > 1200._JPRB)zfiwp(idp)=1200._JPRB
- if(zfiwp(idp) < 0._JPRB)zfiwp(idp)=0._JPRB
- if(zmsalu < 0._JPRB )zmsalu = 0._JPRB
- if(zmsalu > 10._JPRB )zmsalu = 10._JPRB
- if(zmsaiu < 0._JPRB )zmsaiu = 0._JPRB
- if(zmsaiu > 10._JPRB )zmsaiu = 10._JPRB
-
- cld_radiance % cldemis(jk,jc) =&
- & 1._JPRB - Exp( -zmsalu*zflwp(idp) -zmsaiu*zfiwp(idp) )
-
- ! if(cld_radiance % cldemis(jk,jc) > 1._JPRB )cld_radiance % cldemis(jk,jc)=1._JPRB
- ! if(cld_radiance % cldemis(jk,jc) < 0._JPRB )cld_radiance % cldemis(jk,jc)=0._JPRB
-
- Else
- cld_radiance % cldemis(jk,jc) = 0._JPRB
-
- End If
-
- End Do ! channels
- !
- End Do ! Levels
-
-End Subroutine rttov_emiscld
diff --git a/src/LIB/RTTOV/src/rttov_emiscld.interface b/src/LIB/RTTOV/src/rttov_emiscld.interface
deleted file mode 100644
index 8896fe93baaeee3deb96afc5eb5a87b39c4b6de5..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_emiscld.interface
+++ /dev/null
@@ -1,83 +0,0 @@
-Interface
-!
-Subroutine rttov_emiscld( &
- & errorstatus, &! out
- & nfrequencies, & ! in
- & nchannels, & ! in
- & nprofiles, & ! in
- & nlevels , & ! in
- & channels, & ! in
- & polarisations, & ! in
- & lprofiles, & ! in
- & profiles, & ! in (surftype and zenangle)
- & coef, & ! in (frequencies mw/ir/hi)
- & cld_profiles, & ! in
- & cld_radiance) ! inout (only cldemis calculated)
- Use rttov_const, Only : &
- pi ,&
- gravity ,&
- surftype_land ,&
- nvalhusta ,&
- zhustaom ,&
- zhustaa1 ,&
- zhustaa2 ,&
- zhustaa3 ,&
- zhustab1 ,&
- zhustab2 ,&
- zhustab3 ,&
- zhustac1 ,&
- zhustac2 ,&
- zhustac3 ,&
- zhustad1 ,&
- zhustad2 ,&
- zhustad3 ,&
- zhustae1 ,&
- zhustae2 ,&
- zhustae3 ,&
- zhustaf1 ,&
- zhustaf2 ,&
- zhustaf3 ,&
- low_re ,&
- upp_re ,&
- nvalice ,&
- ziceom ,&
- ziceclmna ,&
- ziceclmnb ,&
- ziceclmnc ,&
- ziceclmnd ,&
- ziceaggra ,&
- ziceaggrb ,&
- ziceaggrc ,&
- ziceaggrd ,&
- sensor_id_ir ,&
- sensor_id_mw ,&
- sensor_id_hi
-
- Use rttov_types, Only : &
- rttov_coef ,&
- profile_Type ,&
- profile_cloud_Type ,&
- radiance_cloud_Type
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
-
- Integer(Kind=jpim), Intent(in) :: nfrequencies ! Number of freqs*profs
- Integer(Kind=jpim), Intent(in) :: nchannels! Number of computed radiances
- ! (= channels used * profiles)
- Integer(Kind=jpim), Intent(in) :: nprofiles ! Number of profiles
- Integer(Kind=jpim), Intent(in) :: nlevels ! Number of levels
- Integer(Kind=jpim), Intent(out) :: errorstatus(nprofiles) ! Error return code
- Integer(Kind=jpim), Intent(in) :: channels(nfrequencies) ! Channel indices
- Integer(Kind=jpim), Intent(in) :: lprofiles(nfrequencies)! Profiles indices
- Integer(Kind=jpim), Intent(in) :: polarisations(nchannels,3) ! Channel indices
- Type(profile_Type), Intent(in) :: profiles(nprofiles) ! Profiles on RTTOV levels
- Type(profile_cloud_Type), Intent(in) :: cld_profiles(nprofiles)! Cloud profiles on NWP levels
- Type(rttov_coef), Intent(in) :: coef ! Coefficients
- Type(radiance_cloud_Type), Intent(inout) :: cld_radiance ! radiances (mw/cm-1/ster/sq.m)
-
-
-
-End Subroutine rttov_emiscld
-End Interface
diff --git a/src/LIB/RTTOV/src/rttov_emiscld_ad.F90 b/src/LIB/RTTOV/src/rttov_emiscld_ad.F90
deleted file mode 100644
index fda827661fce54abe7c5551e777795089b38ab86..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_emiscld_ad.F90
+++ /dev/null
@@ -1,1009 +0,0 @@
-Subroutine rttov_emiscld_ad( &
- & errorstatus, &! out
- & nfrequencies, &! in
- & nchannels, &! in
- & nprofiles, &! in
- & nlevels, &! in
- & channels, &! in
- & polarisations, &! in
- & lprofiles, &! in
- & profiles, &! in (surftype and zenangle)
- & coef, &! in (frequencies mw/ir/hi)
- & cld_profiles, &! in
- & cld_profiles_ad, &! inout
- & cld_radiance, &! inout (cldemis part only)
- & cld_radiance_ad) ! inout (cldemis part only)
- !
- ! Description:
- ! To compute adjoint of cloud emissivity in the micro-wave (0-200 GHz)
- ! and in the infrared (50-2860 cm-1)
- ! spectral ranges
- !
- ! Copyright:
- ! This software was developed within the context of
- ! the EUMETSAT Satellite Application Facility on
- ! Numerical Weather Prediction (NWP SAF), under the
- ! Cooperation Agreement dated 25 November 1998, between
- ! EUMETSAT and the Met Office, UK, by one or more partners
- ! within the NWP SAF. The partners in the NWP SAF are
- ! the Met Office, ECMWF, KNMI and MeteoFrance.
- !
- ! Copyright 2002, EUMETSAT, All Rights Reserved.
- !
- ! Method:
- ! See references in the comments
- !
- ! Current Code Owner: SAF NWP
- !
- ! History:
- ! Version Date Comment
- ! ------- ---- -------
- ! ?+0.1 06/10/04 Added errorstatus to the arguments.
- ! Changed stop statements to returns.
- ! Added description/method/history header. (J Cameron)
- ! 1.2 29/03/2005 Add end of header comment (J. Cameron)
- !
- ! Code Description:
- ! Language: Fortran 90.
- ! Software Standards: "European Standards for Writing and
- ! Documenting Exchangeable Fortran 90 Code".
- ! A user guide and technical documentation is available at
- ! http://www.metoffice.com/research/interproj/nwpsaf/rtm/index.html
- !
- ! Declarations:
- ! Modules used:
-
- Use rttov_const, Only : &
- & pi ,&
- & gravity ,&
- & surftype_land ,&
- & nvalhusta ,&
- & zhustaom ,&
- & zhustaa1 ,&
- & zhustaa2 ,&
- & zhustaa3 ,&
- & zhustab1 ,&
- & zhustab2 ,&
- & zhustab3 ,&
- & zhustac1 ,&
- & zhustac2 ,&
- & zhustac3 ,&
- & zhustad1 ,&
- & zhustad2 ,&
- & zhustad3 ,&
- & zhustae1 ,&
- & zhustae2 ,&
- & zhustae3 ,&
- & zhustaf1 ,&
- & zhustaf2 ,&
- & zhustaf3 ,&
- & low_re ,&
- & upp_re ,&
- & nvalice ,&
- & ziceom ,&
- & ziceclmna , ziceclmnb ,&
- & ziceclmnc , ziceclmnd ,&
- & ziceaggra , ziceaggrb ,&
- & ziceaggrc , ziceaggrd ,&
- & sensor_id_ir ,&
- & sensor_id_mw ,&
- & sensor_id_hi ,&
- & errorstatus_success ,&
- & errorstatus_fatal
-
- Use rttov_types, Only : &
- & rttov_coef ,&
- & profile_Type ,&
- & profile_cloud_Type ,&
- & radiance_cloud_Type
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
- !subroutine arguments:
- Integer(Kind=jpim), Intent(in) :: nfrequencies
- Integer(Kind=jpim), Intent(in) :: nchannels
- Integer(Kind=jpim), Intent(in) :: nprofiles
- Integer(Kind=jpim), Intent(in) :: nlevels
- Integer(Kind=jpim), Intent(out) :: errorstatus(nprofiles)
- Integer(Kind=jpim), Intent(in) :: channels(nfrequencies)
- Integer(Kind=jpim), Intent(in) :: polarisations(nchannels,3)
- Integer(Kind=jpim), Intent(in) :: lprofiles(nfrequencies)
- Type(profile_Type), Intent(in) :: profiles(nprofiles)
- Type(profile_cloud_Type), Intent(in) :: cld_profiles(nprofiles)
- Type(rttov_coef), Intent(in) :: coef
- Type(radiance_cloud_Type), Intent(inout) :: cld_radiance
-
- Type(profile_cloud_Type), Intent(inout) :: cld_profiles_ad(nprofiles)
- Type(radiance_cloud_Type), Intent(inout) :: cld_radiance_ad
-
-
-
- ! Local parameters:
- !
- Real(Kind=jprb), Parameter :: rtt=273.15_JPRB
- Real(Kind=jprb), Parameter :: rgp = 8.314510_JPRB, rm = 0.0289644_JPRB
- Real(Kind=jprb), Parameter :: repsc=1.e-12_JPRB
- Real(Kind=jprb), Parameter :: rtice=rtt-23._JPRB
- Real(Kind=jprb), Parameter :: hundred=100.0_JPRB
- Real(Kind=jprb), Parameter :: rtou_upp=-20._JPRB
- Real(Kind=jprb), Parameter :: rtou_low=-60
-
-
-
- !local variables:
- Integer(Kind=jpim) :: jc, jk, jl, jo, ido, idp, idq, idh, freq
- Real(Kind=jprb) :: zomega, zfreq
- Real(Kind=jprb) :: p1, p2
- Real(Kind=jprb) :: zmsaiu, zdom, zmin, zmultl, zmsalu
- Real(Kind=jprb) :: zdz, zodw, zodi
- Real(Kind=jprb) :: fac1, fac2, fac3, fac4, fac5, fac6
- Real(Kind=jprb) :: eps0, eps1, eps2, fp, fs, theta
- Real(Kind=jprb) :: a, b, tk
-
- Real(Kind=jprb) :: zlwgkg_ad, ziwgkg_ad, ztempc_ad, zdp_ad, p1_ad, p2_ad
- Real(Kind=jprb) :: zmsaiu_ad
- Real(Kind=jprb) :: zdz_ad, zodw_ad, zodi_ad, zhelp_ad, zbeta_ad
- Real(Kind=jprb) :: fac1_ad, fac2_ad, fac3_ad, fac4_ad, fac5_ad, fac6_ad
- Real(Kind=jprb) :: eps0_ad, fp_ad, fs_ad, theta_ad
- Real(Kind=jprb) :: a_ad, b_ad, tk_ad
- Real(Kind=jprb) :: zeps_r_ad, zeps_i_ad
- Real(Kind=jprb) :: kabs_ice_1_ad, kabs_ice_2_ad, bwyser_ad, zmcfarq_ad
-
- Real(Kind=jprb) :: znum_ad, zden_ad
- Real(Kind=jprb) :: value, value1, value2
- Real(Kind=jprb) :: co_ssa_1, kext_hu_1, kabs_hu_1
- Real(Kind=jprb) :: co_ssa_2, kext_hu_2, kabs_hu_2
- Real(Kind=jprb) :: kabs_ice_1, kabs_ice_2
- Real(Kind=jprb) :: zradipou_upp, zradipou_low
- Real(Kind=jprb) :: nft
- Real(Kind=jprb) :: amcfarq, bmcfarq, cmcfarq
-
- Real(Kind=jprb) :: zeps_r_1, zeps_i_1
- Real(Kind=jprb) :: zeps_r_2, zeps_i_2
- Real(Kind=jprb) :: znum_3, zden_3
- Real(Kind=jprb) :: znum_4, zden_4
- Real(Kind=jprb) :: zhelp_1, zbeta_1
- Real(Kind=jprb) :: zhelp_2, zbeta_2
-
- Character (len=80) :: errMessage
- Character (len=16) :: NameOfRoutine = 'rttov_emiscld_ad'
- !
-
-
- ! Local arrays:
- !
- Integer(Kind=jpim), DIMENSION(nchannels) :: indh
- Integer(Kind=jpim), DIMENSION(nchannels) :: indi
- Real(Kind=jprb), DIMENSION(nprofiles) :: zradlp, zradip
- Real(Kind=jprb), DIMENSION(nprofiles) :: zlwgkg, ziwgkg, ztempc, zdp
- Real(Kind=jprb), DIMENSION(nprofiles) :: zflwp, zfiwp, zlwc, ziwc
- Real(Kind=jprb), DIMENSION(nprofiles) :: zview, bwyser, zmcfarq
- Real(Kind=jprb) :: zdzst(nprofiles, nlevels)
- Real(Kind=jprb), DIMENSION(nprofiles) :: znum_1, zden_1, znum_2, zden_2
-
- Real(Kind=jprb), DIMENSION(nprofiles) :: zradip_ad
- Real(Kind=jprb), DIMENSION(nprofiles) :: zflwp_ad, zfiwp_ad, zlwc_ad, ziwc_ad
- Real(Kind=jprb), DIMENSION(nprofiles,nlevels) :: zdzst_ad
- Real(Kind=jprb), DIMENSION(nprofiles) :: zradip0, zradip1
-
- !- End of header --------------------------------------------------------
-
- !---------------------------------------------------------------------------
- !All input NWP profiles have the same number of levels
-
- errorstatus(:) = errorstatus_success
-
-
- ! All channels are IR or MW according to the coefficient
- ! structure information
-
- ! repeat direct code
-
- !
- ! Calculate upper and lower limits for Ou-Liou effective size
- !
- zradipou_upp=326.3_JPRB + rtou_upp*(12.42_JPRB + rtou_upp*(0.197_JPRB + rtou_upp*0.0012_JPRB))
- zradipou_low=326.3_JPRB + rtou_low*(12.42_JPRB + rtou_low*(0.197_JPRB + rtou_low*0.0012_JPRB))
- !
- ! and convert these to the "generalized" effective size used here (using McFarquhar et al 2003 equation),
- ! not forgetting the factor of 2 to convert from McFarquhar's radius to a diameter
- !
- zradipou_upp=-1.56_JPRB + zradipou_upp*(0.388_JPRB + zradipou_upp*0.00051_JPRB)
- zradipou_upp=2.0_JPRB*zradipou_upp
- zradipou_low=-1.56_JPRB + zradipou_low*(0.388_JPRB + zradipou_low*0.00051_JPRB)
- zradipou_low=2.0_JPRB*zradipou_low
-
- !
- ! nearest Hu & Stamnes and ice cloud coefficients
- ! For IR and Hires only
- If( coef % id_sensor == sensor_id_ir .Or. &
- & coef % id_sensor == sensor_id_hi ) Then
- Do jc = 1, nchannels
- ido = channels(jc)
- zomega = coef % ff_cwn(ido)
- zmin = 1.e+06_JPRB
- Do jo = 1, nvalhusta
- zdom = Abs( zomega - zhustaom(jo) )
- If (zdom < zmin) Then
- indh(jc) = jo
- zmin = zdom
- End If
- End Do
- zmin = 1.e+06_JPRB
- Do jo = 1, nvalice
- zdom = Abs( zomega - ziceom(jo) )
- If (zdom < zmin) Then
- indi(jc) = jo
- zmin = zdom
- End If
- End Do
- End Do
- End If
-
- ! secant of zenith angle
- !
- zview(:) = 1._JPRB / Cos( profiles(:)%zenangle /180._JPRB * pi )
-
- ! pressure layering (Pa)
- !
- Do jl = 1, nprofiles
- Do jk = 1, nlevels
- ! For TL coding replace Min/Max functions by tests
- !p1 = Max( cld_profiles(jl)%ph(jk) *hundred, repsc )
- !p2 = Max( cld_profiles(jl)%ph(jk+1)*hundred, repsc )
- value = cld_profiles(jl)%ph(jk) *hundred
- If ( value < repsc ) Then
- p1 = repsc
- Else
- p1 = value
- End if
-
- value = cld_profiles(jl)%ph(jk+1) *hundred
- If ( value < repsc ) Then
- p2 = repsc
- Else
- p2 = value
- End if
-
- zdzst(jl,jk) = -1._JPRB *rgp /gravity /rm *Log(p1/p2)
- End Do
- End Do
-
- ! Loop on levels is external to direct and AD codes
- Do jk = 1, nlevels
-
- !
- ! -- Direct computation for jk
- !
- Do jl = 1, nprofiles
-
- value = cld_profiles(jl)%clw(jk)*1000._JPRB
- If( value < 0._JPRB ) Then
- zlwgkg(jl) = 0._JPRB
- Else
- zlwgkg(jl) = value
- End If
-
- value = cld_profiles(jl)%ciw(jk)*1000._JPRB
- If( value < 0._JPRB ) Then
- ziwgkg(jl) = 0._JPRB
- Else
- ziwgkg(jl) = value
- End If
-
- If (cld_profiles(jl)%cc(jk) > (2._JPRB*repsc)) Then
- zlwgkg(jl) = zlwgkg(jl) / cld_profiles(jl)%cc(jk)
- ziwgkg(jl) = ziwgkg(jl) / cld_profiles(jl)%cc(jk)
- Else
- zlwgkg(jl) = 0._JPRB
- ziwgkg(jl) = 0._JPRB
- End If
-
- ! Liquid and ice water paths (g.m-2)
- zdp(jl) = cld_profiles(jl)%ph(jk+1) - cld_profiles(jl)%ph(jk)
-
- zdp(jl) = zdp(jl) * 100._JPRB
-
- zflwp(jl) = zlwgkg(jl)*zdp(jl) / gravity
-
- zfiwp(jl) = ziwgkg(jl)*zdp(jl) / gravity
-
- ! Liquid and ice water contents (kg.m-3)
- znum_1(jl) = zlwgkg(jl)/1000._JPRB * cld_profiles(jl)%p(jk)*100._JPRB * rm
- zden_1(jl) = rgp *cld_profiles(jl)%t(jk)
- zlwc(jl) = znum_1(jl) / zden_1(jl)
-
- znum_2(jl) = ziwgkg(jl)/1000._JPRB * cld_profiles(jl)%p(jk)*100._JPRB * rm
- zden_2(jl) = rgp *cld_profiles(jl)%t(jk)
- ziwc(jl) = znum_2(jl) / zden_2(jl)
-
- zradip(jl) = 1._JPRB
- zradlp(jl) = 1._JPRB
- zmultl = 0._JPRB
-
- If (zflwp(jl) > 0._JPRB) Then
-
- ! Liquid particle radius (micro-meters)
-
- If ( profiles(jl)%skin%surftype == surftype_land ) Then
- zradlp(jl)=10._JPRB
- Else
- zradlp(jl)=13._JPRB
- End If
-
- !
- ! Extra check that droplet r_e goes neither below 2.5 microns nor above 60 microns (Hu & Stamnes limits)
- !
- zradlp(jl)=Max(zradlp(jl),low_re(1))
- zradlp(jl)=Min(zradlp(jl),upp_re(3))
- Endif
-
- If (zfiwp(jl) > 0._JPRB) Then
- ! Ice particle radius (micro-meters)
- !
- If (cld_profiles(jl)%kradip == 0) Then ! Ou-Liou
- !
- ! Ou and Liou, 1995, Atmos. Res., 35, 127-138.
- !
- ztempc(jl) = cld_profiles(jl)%t(jk) - rtt
- zradip(jl)=326.3_JPRB+ &
- & ztempc(jl)*(12.42_JPRB + ztempc(jl)*(0.197_JPRB + ztempc(jl)*0.0012_JPRB))
- ! and convert this to the "generalized" effective diameter (see McFarquhar et al 2003)
- zradip0(jl) = zradip(jl)
- zradip(jl)=-1.56_JPRB + zradip(jl)*(0.388_JPRB + zradip(jl)*0.00051_JPRB)
- zradip(jl)=2.0_JPRB*zradip(jl)
- !
- ! Take Ou-Liou scheme as being valid only between -20C and -60C
- !
- zradip1(jl) = zradip(jl)
- zradip(jl)=max(zradip(jl),zradipou_low)
- zradip(jl)=min(zradip(jl),zradipou_upp)
- !
- Elseif (cld_profiles(jl)%kradip == 1) Then ! Wyser
- !
- ! Wyser et al., reference details here..., McFarquhar et al. (2003)
- ! Note two typos in McFarquhar paper:
- ! (a) reference to "r" should be "4" in final equation
- ! (b) T_k should be (273-T_k) (see original Wyser paper)
- !
- bwyser(jl)=-2.0_JPRB
- ! Wyser's IWC is in g.m-3
- if (cld_profiles(jl)%t(jk) < 273._JPRB) bwyser(jl) = bwyser(jl) &
- & +(0.001_JPRB*((273._JPRB-cld_profiles(jl)%t(jk))**1.5_JPRB)*Log10(1000._JPRB*ziwc(jl)/50._JPRB))
- zradip(jl)=377.4_JPRB + bwyser(jl)*(203.3_JPRB + bwyser(jl)*(37.91_JPRB + bwyser(jl)*2.3696_JPRB)) ! Wyser definition
- nft=(sqrt(3._JPRB)+4._JPRB)/(3._JPRB*sqrt(3._JPRB))
- zradip(jl)=zradip(jl)/nft ! convert to intermediate definition (see Table 1 of McFarquhar et al.)
- zradip(jl)=2._JPRB*4._JPRB*zradip(jl)*sqrt(3._JPRB)/9._JPRB ! includes factor of 2 to convert McFarquhar"s r_ge to D_ge
- !
- Elseif (cld_profiles(jl)%kradip == 2) Then ! Boudala et al.
- !
- ! Boudala et al., 2002, Int. J. Climatol., 22, 1267-1284.
- !
- ztempc(jl)=cld_profiles(jl)%t(jk)-rtt
- zradip(jl)=53.005_JPRB*((ziwc(jl)*1000._JPRB)**0.06_JPRB)*exp(0.013_JPRB*ztempc(jl))
- !
- Elseif (cld_profiles(jl)%kradip == 3) Then ! McFarquhar
- !
- ! McFarquhar et al. (2003)
- !
- amcfarq=1.78449_JPRB
- bmcfarq=0.281301_JPRB
- cmcfarq=0.0177166_JPRB
- zmcfarq(jl) =1000.0_JPRB*ziwc(jl) ! Put IWC in g.m-3
- zradip(jl)=10.0_JPRB**(amcfarq+(bmcfarq*Log10(zmcfarq(jl) ))+&
- & (cmcfarq*Log10(zmcfarq(jl) )*Log10(zmcfarq(jl) )))
- zradip(jl)=2.0_JPRB*zradip(jl) ! Includes factor of 2 to convert McFarquhar's r_ge to D_ge
- !
-! Else
-! errMessage = 'Wrong kradip'
-! errorstatus(:) = errorstatus_fatal
-! Call Rttov_ErrorReport (errorstatus_fatal, errMessage, NameOfRoutine)
-! Return
- End If
- !
- End If
- End Do ! profiles
-
- zradip_ad(:) = 0._JPRB
- zflwp_ad(:) = 0._JPRB
- zfiwp_ad(:) = 0._JPRB
- ziwc_ad(:) = 0._JPRB
- zlwc_ad(:) = 0._JPRB
- zdzst_ad(:,jk) = 0._JPRB
-
- !
- ! -- Direct computation for jk and jc
- !
- Do jc = 1, nchannels
- freq = polarisations(jc,2)
- ido = channels(freq)
- idp = lprofiles(freq)
-
- ! Micro Waves
- If( coef % id_sensor == sensor_id_mw ) Then
-
- zdz = zdzst(idp,jk) * cld_profiles(idp)%t(jk)
- zfreq = coef%frequency_ghz (ido)
-
- ! Water
- ! Liebe et al., 1989, IEEE Trans. Antennas Propag., 37, 1617-1623.
- theta = 300.0_JPRB / cld_profiles(idp)%t(jk)
- fac1 = theta - 1.0_JPRB
- fac2 = fac1 * fac1
-
- eps0 = 77.66_JPRB + 103.3_JPRB * fac1
- eps1 = 5.48_JPRB
- eps2 = 3.51_JPRB
-
- fp = 20.09_JPRB - 142.0_JPRB * fac1 + 294.0_JPRB * fac2
- fs = 590.0_JPRB - 1500.0_JPRB * fac1
-
- fac3 = zfreq / fp
- fac4 = 1.0_JPRB + fac3 * fac3
- fac5 = zfreq / fs
- fac6 = 1.0_JPRB + fac5 * fac5
-
- zeps_r_1 = (eps0 - eps1) / fac4 + (eps1 - eps2) / fac6 + eps2
- zeps_i_1 = (eps0 - eps1) * fac3 / fac4 +&
- & (eps1 - eps2) * fac5 / fac6
-
- znum_3 = zeps_i_1
- zden_3 = (zeps_r_1 + 2.0_JPRB)**2 + zeps_i_1**2
-
- zhelp_1 = znum_3 / zden_3
- zbeta_1 = 0.18851441_JPRB * zfreq * zlwc(idp) * zhelp_1
- zodw = zbeta_1 * zview(idp) * zdz
-
- ! Ice
- ! Hufford, 1991, Int. J. Infrared Millimeter Waves, 12, 677-681.
- zeps_r_2 = 3.15_JPRB
- tk = cld_profiles(idp)%t(jk)
-
- If (tk > 273.16_JPRB) Then
- tk = 273.16_JPRB
- End if
-
- theta = 300.0_JPRB / tk
- a = 1.0e-04_JPRB * (50.4_JPRB + 62.0_JPRB * (theta - 1.0_JPRB)) &
- & * Exp (-22.1_JPRB * (theta - 1.0_JPRB))
- b = 1.0e-04_JPRB * (0.633_JPRB / theta - 0.131_JPRB) &
- & + (7.36e-04_JPRB * theta / (theta - 0.9927_JPRB)) ** 2
- zeps_i_2 = a / zfreq + b * zfreq
-
- znum_4 = zeps_i_2
- zden_4 = (zeps_r_2 + 2.0_JPRB)**2 + zeps_i_2**2
- zhelp_2 = znum_4 / zden_4
- zbeta_2 = 0.18851441_JPRB * zfreq * ziwc(idp) * zhelp_2
- zodi = zbeta_2 * zview(idp) * zdz
-
- cld_radiance % cldemis(jk,jc) = 1._JPRB - Exp( - zodw - zodi )
-
- ! Infra Red
- Elseif( coef % id_sensor == sensor_id_ir .Or. &
- & coef % id_sensor == sensor_id_hi ) Then
-
- If (zflwp(idp) > 0._JPRB) Then
-
- !
- ! Water cloud coefficients
- ! from Hu and Stamnes, 1993, J. Climate, Vol. 6, pp. 728-742
- !
- idh = indh(jc)
- zomega = coef % ff_cwn(ido)
- zdom = zomega - zhustaom(idh)
- !
- If (zdom >= 0.0_JPRB) Then ! Better to interpolate the single-scattering properties
- If (zradlp(idp) < upp_re(1)) Then ! themselves rather than the coefficients
- kext_hu_1=(zhustaa1(idh)*(zradlp(idp)**zhustab1(idh)))+zhustac1(idh)
- co_ssa_1=(zhustad1(idh)*(zradlp(idp)**zhustae1(idh)))+zhustaf1(idh)
- kext_hu_2=(zhustaa1(idh-1)*(zradlp(idp)**zhustab1(idh-1)))+zhustac1(idh-1)
- co_ssa_2=(zhustad1(idh-1)*(zradlp(idp)**zhustae1(idh-1)))+zhustaf1(idh-1)
- Elseif (zradlp(idp) >= low_re(2) .AND. zradlp(idp) < upp_re(2)) Then
- kext_hu_1=(zhustaa2(idh)*(zradlp(idp)**zhustab2(idh)))+zhustac2(idh)
- co_ssa_1=(zhustad2(idh)*(zradlp(idp)**zhustae2(idh)))+zhustaf2(idh)
- kext_hu_2=(zhustaa2(idh-1)*(zradlp(idp)**zhustab2(idh-1)))+zhustac2(idh-1)
- co_ssa_2=(zhustad2(idh-1)*(zradlp(idp)**zhustae2(idh-1)))+zhustaf2(idh-1)
- Elseif (zradlp(idp) >= low_re(3)) Then
- kext_hu_1=(zhustaa3(idh)*(zradlp(idp)**zhustab3(idh)))+zhustac3(idh)
- co_ssa_1=(zhustad3(idh)*(zradlp(idp)**zhustae3(idh)))+zhustaf3(idh)
- kext_hu_2=(zhustaa3(idh-1)*(zradlp(idp)**zhustab3(idh-1)))+zhustac3(idh-1)
- co_ssa_2=(zhustad3(idh-1)*(zradlp(idp)**zhustae3(idh-1)))+zhustaf3(idh-1)
- End If
- kabs_hu_1=kext_hu_1*co_ssa_1
- kabs_hu_2=kext_hu_2*co_ssa_2
- !
- ! Do the interpolation
- zmsalu = ((zdom)*(kabs_hu_2-kabs_hu_1)/(zhustaom(idh-1)-zhustaom(idh))) + kabs_hu_1
- !
- Elseif (zdom < 0.0_JPRB) Then
- If (zradlp(idp) < upp_re(1)) Then
- kext_hu_1=(zhustaa1(idh)*(zradlp(idp)**zhustab1(idh)))+zhustac1(idh)
- co_ssa_1=(zhustad1(idh)*(zradlp(idp)**zhustae1(idh)))+zhustaf1(idh)
- kext_hu_2=(zhustaa1(idh+1)*(zradlp(idp)**zhustab1(idh+1)))+zhustac1(idh+1)
- co_ssa_2=(zhustad1(idh+1)*(zradlp(idp)**zhustae1(idh+1)))+zhustaf1(idh+1)
- Elseif (zradlp(idp) >= low_re(2) .AND. zradlp(idp) < upp_re(2)) Then
- kext_hu_1=(zhustaa2(idh)*(zradlp(idp)**zhustab2(idh)))+zhustac2(idh)
- co_ssa_1=(zhustad2(idh)*(zradlp(idp)**zhustae2(idh)))+zhustaf2(idh)
- kext_hu_2=(zhustaa2(idh+1)*(zradlp(idp)**zhustab2(idh+1)))+zhustac2(idh+1)
- co_ssa_2=(zhustad2(idh+1)*(zradlp(idp)**zhustae2(idh+1)))+zhustaf2(idh+1)
- Elseif (zradlp(idp) >= low_re(3)) Then
- kext_hu_1=(zhustaa3(idh)*(zradlp(idp)**zhustab3(idh)))+zhustac3(idh)
- co_ssa_1=(zhustad3(idh)*(zradlp(idp)**zhustae3(idh)))+zhustaf3(idh)
- kext_hu_2=(zhustaa3(idh+1)*(zradlp(idp)**zhustab3(idh+1)))+zhustac3(idh+1)
- co_ssa_2=(zhustad3(idh+1)*(zradlp(idp)**zhustae3(idh+1)))+zhustaf3(idh+1)
- End If
- kabs_hu_1=kext_hu_1*co_ssa_1
- kabs_hu_2=kext_hu_2*co_ssa_2
- !
- ! Do the interpolation
- zmsalu = ((zdom)*(kabs_hu_2-kabs_hu_1)/(zhustaom(idh+1)-zhustaom(idh))) + kabs_hu_1
- End If
- !
- zmsalu = zview(idp) * (0.001_JPRB*zmsalu) ! Convert Hu/Stamnes to m^2g^-1 and put in viewing angle dependence
-
- Else
-
- zmsalu = 0._JPRB
-
- End If
-
- !
- ! Ice cloud emissivity
- ! See Baran et al. JAS, 417-427, 2003; Baran et al. JQSRT, 549-567, 2003.
-
- If (zfiwp(idp) > 0._JPRB) Then
-
- idq = indi(jc)
- zomega = coef % ff_cwn(ido)
- zdom = zomega - ziceom(idq)
- If (zdom >= 0.0_JPRB) Then
- If (cld_profiles(idp)%kice == 0) Then ! Hexagonal columns
- kabs_ice_1=ziceclmna(idq)+(ziceclmnb(idq)/zradip(idp))+ &
- & (ziceclmnc(idq)/(zradip(idp)*zradip(idp)))+(ziceclmnd(idq)*zradip(idp))
- kabs_ice_2=ziceclmna(idq-1)+(ziceclmnb(idq-1)/zradip(idp))+ &
- & (ziceclmnc(idq-1)/(zradip(idp)*zradip(idp)))+(ziceclmnd(idq-1)*zradip(idp))
- Elseif (cld_profiles(idp)%kice == 1) Then ! Aggregates
- kabs_ice_1=ziceaggra(idq)+(ziceaggrb(idq)/zradip(idp))+ &
- & (ziceaggrc(idq)/(zradip(idp)*zradip(idp)))+(ziceaggrd(idq)*zradip(idp))
- kabs_ice_2=ziceaggra(idq-1)+(ziceaggrb(idq-1)/zradip(idp))+ &
- & (ziceaggrc(idq-1)/(zradip(idp)*zradip(idp)))+(ziceaggrd(idq-1)*zradip(idp))
-! Else
-! errMessage = 'Wrong kice'
-! errorstatus(:) = errorstatus_fatal
-! Call Rttov_ErrorReport (errorstatus_fatal, errMessage, NameOfRoutine)
-! Return
- End If
- !
- ! Do the interpolation
- zmsaiu = ((zdom)*(kabs_ice_2-kabs_ice_1)/(ziceom(idq-1)-ziceom(idq))) + kabs_ice_1
- !
- Elseif (zdom < 0.0_JPRB) Then
- If (cld_profiles(idp)%kice == 0) Then ! Hexagonal columns
- kabs_ice_1=ziceclmna(idq)+(ziceclmnb(idq)/zradip(idp))+ &
- & (ziceclmnc(idq)/(zradip(idp)*zradip(idp)))+(ziceclmnd(idq)*zradip(idp))
- kabs_ice_2=ziceclmna(idq+1)+(ziceclmnb(idq+1)/zradip(idp))+ &
- & (ziceclmnc(idq+1)/(zradip(idp)*zradip(idp)))+(ziceclmnd(idq+1)*zradip(idp))
- Elseif (cld_profiles(idp)%kice == 1) Then ! Aggregates
- kabs_ice_1=ziceaggra(idq)+(ziceaggrb(idq)/zradip(idp))+ &
- & (ziceaggrc(idq)/(zradip(idp)*zradip(idp)))+(ziceaggrd(idq)*zradip(idp))
- kabs_ice_2=ziceaggra(idq+1)+(ziceaggrb(idq+1)/zradip(idp))+ &
- & (ziceaggrc(idq+1)/(zradip(idp)*zradip(idp)))+(ziceaggrd(idq+1)*zradip(idp))
-! Else
-! errMessage = 'Wrong kice'
-! errorstatus(:) = errorstatus_fatal
-! Call Rttov_ErrorReport (errorstatus_fatal, errMessage, NameOfRoutine)
-! Return
- End If
- !
- ! Do the interpolation
- zmsaiu = ((zdom)*(kabs_ice_2-kabs_ice_1)/(ziceom(idq+1)-ziceom(idq))) + kabs_ice_1
- End If
- zmsaiu = zview(idp) * zmsaiu ! Add in viewing angle dependence
-
- Else
-
- zmsaiu = 0._JPRB
-
- End If
-
- !
- ! Cloud layer emissivity
- cld_radiance % cldemis(jk,jc) =&
- & 1._JPRB - Exp( -zmsalu*zflwp(idp) -zmsaiu*zfiwp(idp) )
- !
- Else
- cld_radiance % cldemis(jk,jc) = 0._JPRB
-
- End If
-
- !
- ! -- Adjoint computation for jk and jc
- !
- ! Micro Waves
- If( coef % id_sensor == sensor_id_mw ) Then
-
- ! Ice
- ! Hufford, 1991, Int. J. Infrared Millimeter Waves, 12, 677-681.
- zodw_ad = cld_radiance_ad % cldemis(jk,jc) * Exp( - zodw - zodi )
- zodi_ad = cld_radiance_ad % cldemis(jk,jc) * Exp( - zodw - zodi )
- cld_radiance_ad % cldemis(jk,jc) = 0._JPRB
-
- zbeta_ad = zodi_ad * zview(idp) * zdz
- zdz_ad = zodi_ad * zbeta_2 * zview(idp)
- zodi_ad = 0._JPRB
-
- ziwc_ad(idp) = ziwc_ad(idp) + zbeta_ad * 0.18851441_JPRB * zfreq * zhelp_2
- zhelp_ad = zbeta_ad * 0.18851441_JPRB * zfreq * ziwc(idp)
-
-
- znum_ad = zhelp_ad / zden_4
- zden_ad = -zhelp_ad * znum_4 / zden_4**2
- zhelp_ad = 0._JPRB
-
- zeps_i_ad = zden_ad * 2._JPRB * zeps_i_2
- zden_ad = 0._JPRB
-
- zeps_i_ad = zeps_i_ad + znum_ad
- znum_ad = 0._JPRB
-
-
- a_ad = zeps_i_ad / zfreq
- b_ad = zeps_i_ad * zfreq
- zeps_i_ad = 0._JPRB
-
- theta_ad = &
- & - 1.0e-04_JPRB * 0.633_JPRB / (theta**2) * b_ad &
- & - 2*(7.36e-04_JPRB * theta / (theta - 0.9927_JPRB)) &
- & * 7.36e-04_JPRB * 0.9927_JPRB / ((theta - 0.9927_JPRB)**2) * b_ad
- b_ad = 0._JPRB
-
- theta_ad = theta_ad &
- & + 1.0e-04_JPRB * 62.0_JPRB * exp (-22.1_JPRB * (theta - 1.0_JPRB)) * a_ad &
- & - 22.1_JPRB * 1.0e-04_JPRB * (50.4_JPRB + 62.0_JPRB * (theta - 1.0_JPRB)) &
- & * exp (-22.1_JPRB * (theta - 1.0_JPRB)) * a_ad
- a_ad = 0._JPRB
-
- If (cld_profiles(idp)%t(jk) > 273.16_JPRB) Then
- tk_ad = 0._JPRB
- Else
- tk = cld_profiles(idp)%t(jk)
- tk_ad = -300.0_JPRB * theta_ad / tk**2
- End if
- theta_ad = 0._JPRB
-
- cld_profiles_ad(idp)%t(jk) = cld_profiles_ad(idp)%t(jk) + tk_ad
-
- ! Water
- ! Liebe et al., 1989, IEEE Trans. Antennas Propag., 37, 1617-1623.
-
-
-
- zbeta_ad = zodw_ad * zview(idp) * zdz
- zdz_ad = zdz_ad + zodw_ad * zview(idp) * zbeta_1
- zodw_ad = 0._JPRB
-
-
- zlwc_ad(idp) = zlwc_ad(idp) + zbeta_ad * 0.18851441_JPRB * zfreq * zhelp_1
- zhelp_ad = zbeta_ad * 0.18851441_JPRB * zfreq * zlwc(idp)
-
- znum_ad = zhelp_ad / zden_3
- zden_ad = -zhelp_ad * znum_3/ zden_3**2
- zhelp_ad = 0._JPRB
-
-
- zeps_r_ad = zden_ad * 2._JPRB * (zeps_r_1 + 2.0_JPRB)
- zeps_i_ad = zden_ad * 2._JPRB * zeps_i_1
- zden_ad = 0._JPRB
-
- zeps_i_ad = zeps_i_ad + znum_ad
- znum_ad = 0._JPRB
-
- eps0_ad = zeps_i_ad * fac3 / fac4
- fac3_ad = zeps_i_ad * (eps0 - eps1) / fac4
- fac4_ad =-zeps_i_ad * (eps0 - eps1) * fac3 / fac4**2
- fac5_ad = zeps_i_ad * (eps1 - eps2) / fac6
- fac6_ad =-zeps_i_ad * (eps1 - eps2) * fac5 / fac6**2
- zeps_i_ad = 0._JPRB
-
- eps0_ad = eps0_ad + zeps_r_ad / fac4
- fac4_ad = fac4_ad - zeps_r_ad * (eps0 - eps1) / fac4**2
- fac6_ad = fac6_ad - zeps_r_ad * (eps1 - eps2) / fac6**2
- zeps_r_ad = 0._JPRB
-
-
- fac5_ad = fac5_ad + 2._JPRB * fac6_ad * fac5
- fac6_ad = 0._JPRB
-
- fs_ad = -zfreq * fac5_ad / fs**2
- fac5_ad = 0._JPRB
-
-
- fac3_ad = fac3_ad + 2._JPRB * fac4_ad * fac3
- fac4_ad = 0._JPRB
-
- fp_ad = -zfreq * fac3_ad / fp**2
- fac3_ad = 0._JPRB
-
-
- fac1_ad = - 1500.0_JPRB * fs_ad
- fs_ad = 0._JPRB
-
- fac1_ad = fac1_ad - 142.0_JPRB * fp_ad
- fac2_ad = 294.0_JPRB * fp_ad
- fp_ad = 0._JPRB
-
- fac1_ad = fac1_ad + 103.3_JPRB * eps0_ad
- eps0_ad = 0._JPRB
-
- fac1_ad = fac1_ad + 2._JPRB * fac2_ad * fac1
- fac2_ad = 0._JPRB
-
- theta_ad = fac1_ad
-
- cld_profiles_ad(idp)%t(jk) = cld_profiles_ad(idp)%t(jk) -&
- & 300.0_JPRB * theta_ad / cld_profiles(idp)%t(jk)**2
- theta_ad = 0._JPRB
-
-
- cld_profiles_ad(idp)%t(jk) = cld_profiles_ad(idp)%t(jk) +&
- & zdz_ad * zdzst(idp,jk)
- zdzst_ad(idp,jk) = zdzst_ad(idp,jk) + zdz_ad * cld_profiles(idp)%t(jk)
-
-
- Elseif( coef % id_sensor == sensor_id_ir .Or. &
- & coef % id_sensor == sensor_id_hi ) Then
- !
- ! Cloud layer emissivity
- !
-
- zmsaiu_ad = cld_radiance_ad % cldemis(jk,jc) * zfiwp(idp) * &
- & (1 - cld_radiance % cldemis(jk,jc))
- zflwp_ad(idp) = zflwp_ad(idp) + &
- & cld_radiance_ad % cldemis(jk,jc) * zmsalu * &
- & (1 - cld_radiance % cldemis(jk,jc))
- zfiwp_ad(idp) = zfiwp_ad(idp) + &
- & cld_radiance_ad % cldemis(jk,jc) * zmsaiu * &
- & (1 - cld_radiance % cldemis(jk,jc))
- cld_radiance_ad % cldemis(jk,jc) = 0._JPRB
-
- !
- ! Ice cloud emissivity
- ! See Baran et al. JAS, 417-427, 2003; Baran et al. JQSRT, 549-567, 2003.
-
- If (zfiwp(idp) > 0._JPRB) Then
-
- idq = indi(jc)
- zdom = zomega - ziceom(idq)
- zmsaiu_ad = zview(idp) * zmsaiu_ad ! Add in viewing angle dependence
- If (zdom >= 0.0_JPRB) Then
- !
- ! Do the interpolation
- kabs_ice_2_ad = zdom/(ziceom(idq-1)-ziceom(idq))*zmsaiu_ad
- kabs_ice_1_ad = (1-zdom/(ziceom(idq-1)-ziceom(idq)))*zmsaiu_ad
- If (cld_profiles(idp)%kice == 0) Then ! Hexagonal columns
- zradip_ad(idp) = zradip_ad(idp) + &
- & ( ziceclmnd(idq) &
- & - ziceclmnb(idq)/(zradip(idp)*zradip(idp)) &
- & - 2*ziceclmnc(idq)/(zradip(idp)*zradip(idp)*zradip(idp)) ) * kabs_ice_1_ad + &
- & ( ziceclmnd(idq-1) &
- & - ziceclmnb(idq-1)/(zradip(idp)*zradip(idp)) &
- & - 2*ziceclmnc(idq-1)/(zradip(idp)*zradip(idp)*zradip(idp)) ) * kabs_ice_2_ad
- Elseif (cld_profiles(idp)%kice == 1) Then ! Aggregates
- zradip_ad(idp) = zradip_ad(idp) + &
- & ( ziceaggrd(idq) &
- & - ziceaggrb(idq)/(zradip(idp)*zradip(idp)) &
- & - 2*ziceaggrc(idq)/(zradip(idp)*zradip(idp)*zradip(idp)) ) * kabs_ice_1_ad + &
- & ( ziceaggrd(idq-1) &
- & - ziceaggrb(idq-1)/(zradip(idp)*zradip(idp)) &
- & - 2*ziceaggrc(idq-1)/(zradip(idp)*zradip(idp)*zradip(idp)) ) * kabs_ice_2_ad
- End If
- !
- Elseif (zdom < 0.0_JPRB) Then
- !
- ! Do the interpolation
- kabs_ice_2_ad = zdom/(ziceom(idq+1)-ziceom(idq))*zmsaiu_ad
- kabs_ice_1_ad = (1-zdom/(ziceom(idq+1)-ziceom(idq)))*zmsaiu_ad
- If (cld_profiles(idp)%kice == 0) Then ! Hexagonal columns
- zradip_ad(idp) = zradip_ad(idp) + &
- & ( ziceclmnd(idq) &
- & - ziceclmnb(idq)/(zradip(idp)*zradip(idp)) &
- & - 2*ziceclmnc(idq)/(zradip(idp)*zradip(idp)*zradip(idp)) ) * kabs_ice_1_ad + &
- & ( ziceclmnd(idq+1) &
- & - ziceclmnb(idq+1)/(zradip(idp)*zradip(idp)) &
- & - 2*ziceclmnc(idq+1)/(zradip(idp)*zradip(idp)*zradip(idp)) ) * kabs_ice_2_ad
- Elseif (cld_profiles(idp)%kice == 1) Then ! Aggregates
- zradip_ad(idp) = zradip_ad(idp) + &
- & ( ziceaggrd(idq) &
- & - ziceaggrb(idq)/(zradip(idp)*zradip(idp)) &
- & - 2*ziceaggrc(idq)/(zradip(idp)*zradip(idp)*zradip(idp)) ) * kabs_ice_1_ad + &
- & ( ziceaggrd(idq+1) &
- & - ziceaggrb(idq+1)/(zradip(idp)*zradip(idp)) &
- & - 2*ziceaggrc(idq+1)/(zradip(idp)*zradip(idp)*zradip(idp)) ) * kabs_ice_2_ad
- End If
-
- End If
-
- !
- ! zradlp_ad = 0. since zradlp is constant for each geotype
- !
- End If
- Else
- cld_radiance_ad % cldemis(jk,jc) = 0._JPRB
- End If
-
- End Do ! channels
-
- ! -- Adjoint computation for jk (remaining)
- !
- Do jl = 1, nprofiles
- If (zfiwp(jl) > 0._JPRB) Then
- ! Ice particle radius (micro-meters)
- !
- If (cld_profiles(jl)%kradip == 0) Then ! Ou-Liou
- !
- ! Ou and Liou, 1995, Atmos. Res., 35, 127-138.
- !
-
- If (zradip1(jl) > zradipou_upp .or. zradip1(jl) < zradipou_low) zradip_ad(jl) = 0._JPRB
- ! and convert this to the "generalized" effective diameter (see McFarquhar et al 2003)
- zradip_ad(jl)=2.0_JPRB*zradip_ad(jl)
- zradip_ad(jl)=0.388_JPRB*zradip_ad(jl)+2._JPRB*0.00051_JPRB*zradip0(jl)*zradip_ad(jl)
-
- ztempc_ad = ( 12.42_JPRB + 2._JPRB*0.197_JPRB*ztempc(jl) + 3._JPRB*0.0012_JPRB*ztempc(jl)*ztempc(jl) )*zradip_ad(jl)
- cld_profiles_ad(jl)%t(jk) = cld_profiles_ad(jl)%t(jk) + ztempc_ad
- Elseif (cld_profiles(jl)%kradip == 1) Then ! Wyser
- !
- ! Wyser et al., reference details here..., McFarquhar et al. (2003)
- ! Note two typos in McFarquhar paper:
- ! (a) reference to "r" should be "4" in final equation
- ! (b) T_k should be (273-T_k) (see original Wyser paper)
- !
- zradip_ad(jl) = 2._JPRB*4._JPRB*zradip_ad(jl)*sqrt(3._JPRB)/9._JPRB
- zradip_ad(jl)=zradip_ad(jl)/nft
- bwyser_ad = ( 203.3_JPRB + 2*bwyser(jl)*37.91_JPRB + 3*bwyser(jl)*bwyser(jl)*2.3696_JPRB ) * zradip_ad(jl)
- If (cld_profiles(jl)%t(jk) < 273._JPRB) Then
- cld_profiles_ad(jl)%t(jk) = cld_profiles_ad(jl)%t(jk) &
- & - 1.5_JPRB * 0.001_JPRB*((273._JPRB-cld_profiles(jl)%t(jk))**0.5_JPRB)*&
- & Log10(1000._JPRB*ziwc(jl)/50._JPRB) * bwyser_ad
- ziwc_ad(jl) = ziwc_ad(jl) &
- & + 0.001_JPRB*((273._JPRB-cld_profiles(jl)%t(jk))**1.5_JPRB) / ziwc(jl) / log(10._JPRB) &
- & * bwyser_ad
- Endif
- Elseif (cld_profiles(jl)%kradip == 2) Then ! Boudala et al.
- !
- ! Boudala et al., 2002, Int. J. Climatol., 22, 1267-1284.
- !
- ziwc_ad(jl) = ziwc_ad(jl) &
- & + 53.005_JPRB*(1000._JPRB**0.06_JPRB)*(ziwc(jl)**(0.06_JPRB-1._JPRB))*exp(0.013_JPRB*ztempc(jl))*zradip_ad(jl)
- ztempc_ad = 53.005_JPRB*((ziwc(jl)*1000._JPRB)**0.06_JPRB)*exp(0.013_JPRB*ztempc(jl))*0.013_JPRB*zradip_ad(jl)
- cld_profiles_ad(jl)%t(jk) = cld_profiles_ad(jl)%t(jk) + ztempc_ad
- !
- Elseif (cld_profiles(jl)%kradip == 3) Then ! McFarquhar
- !
- ! McFarquhar et al. (2003)
- !
- zradip_ad(jl)=2.0_JPRB*zradip_ad(jl)
- zmcfarq_ad = 10.0_JPRB**(amcfarq+(bmcfarq*Log10(zmcfarq(jl) ))+ cmcfarq*Log10(zmcfarq(jl))*Log10(zmcfarq(jl)) ) &
- & * (bmcfarq + 2._JPRB*cmcfarq*Log10(zmcfarq(jl))) / zmcfarq(jl) *zradip_ad(jl)
- ziwc_ad(jl) = ziwc_ad(jl) + 1000._JPRB*zmcfarq_ad
- End If
- End If
-
- ! Liquid and ice water contents (kg.m-3)
- znum_ad = ziwc_ad(jl) / zden_2(jl)
- zden_ad = -ziwc_ad(jl) * znum_2(jl) / zden_2(jl)**2
- ziwc_ad(jl) = 0._JPRB
-
- cld_profiles_ad(jl)%t(jk) = cld_profiles_ad(jl)%t(jk) + zden_ad * rgp
- zden_ad = 0._JPRB
-
- ziwgkg_ad = znum_ad/1000._JPRB * cld_profiles(jl)%p(jk)*100._JPRB * rm
- cld_profiles_ad(jl)%p(jk) = cld_profiles_ad(jl)%p(jk) + znum_ad *&
- & ziwgkg(jl)/1000._JPRB * 100._JPRB * rm
- znum_ad = 0._JPRB
-
- znum_ad = zlwc_ad(jl) / zden_1(jl)
- zden_ad = -zlwc_ad(jl) * znum_1(jl) / zden_1(jl)**2
- zlwc_ad(jl) = 0._JPRB
-
- cld_profiles_ad(jl)%t(jk) = cld_profiles_ad(jl)%t(jk) + zden_ad * rgp
- zden_ad = 0._JPRB
-
- zlwgkg_ad = znum_ad/1000._JPRB * cld_profiles(jl)%p(jk)*100._JPRB * rm
- cld_profiles_ad(jl)%p(jk) = cld_profiles_ad(jl)%p(jk) +&
- & znum_ad * zlwgkg(jl)/1000._JPRB *100._JPRB * rm
- znum_ad = 0._JPRB
-
- ! Liquid and ice water paths (g.m-2)
- zdp_ad = 0._JPRB
- zdp_ad = zdp_ad + zfiwp_ad(jl) * ziwgkg(jl) / gravity
- ziwgkg_ad = ziwgkg_ad + zfiwp_ad(jl) * zdp(jl) / gravity
- zfiwp_ad(jl) = 0._JPRB
-
- zdp_ad = zdp_ad + zflwp_ad(jl) * zlwgkg(jl) / gravity
- zlwgkg_ad = zlwgkg_ad + zflwp_ad(jl) * zdp(jl) / gravity
- zflwp_ad(jl) = 0._JPRB
-
- zdp_ad = zdp_ad * 100._JPRB
-
- cld_profiles_ad(jl)%ph(jk+1) = cld_profiles_ad(jl)%ph(jk+1) + zdp_ad
- cld_profiles_ad(jl)%ph(jk) = cld_profiles_ad(jl)%ph(jk) - zdp_ad
- zdp_ad = 0._JPRB
-
- value = cld_profiles(jl)%clw(jk)*1000._JPRB
- If( value < 0._JPRB ) Then
- zlwgkg(jl) = 0._JPRB
- Else
- zlwgkg(jl) = value
- End If
-
- value = cld_profiles(jl)%ciw(jk)*1000._JPRB
- If( value < 0._JPRB ) Then
- ziwgkg(jl) = 0._JPRB
- Else
- ziwgkg(jl) = value
- End If
-
- If (cld_profiles(jl)%cc(jk) > (2._JPRB*repsc)) Then
-
- cld_profiles_ad(jl)%cc(jk) = cld_profiles_ad(jl)%cc(jk) -&
- & zlwgkg_ad * zlwgkg(jl) / cld_profiles(jl)%cc(jk)**2
- zlwgkg_ad = zlwgkg_ad / cld_profiles(jl)%cc(jk)
-
- cld_profiles_ad(jl)%cc(jk) = cld_profiles_ad(jl)%cc(jk) -&
- & ziwgkg_ad * ziwgkg(jl) / cld_profiles(jl)%cc(jk)**2
- ziwgkg_ad = ziwgkg_ad / cld_profiles(jl)%cc(jk)
-
- Else
- zlwgkg_ad = 0._JPRB
- ziwgkg_ad = 0._JPRB
- End If
-
- cld_profiles_ad(jl)%ciw(jk) = cld_profiles_ad(jl)%ciw(jk) + ziwgkg_ad * 1000._JPRB
-
- cld_profiles_ad(jl)%clw(jk) = cld_profiles_ad(jl)%clw(jk) + zlwgkg_ad * 1000._JPRB
-
- End Do ! profiles
-
- End Do ! Levels
-
-
- ! pressure layering (Pa)
- !
- Do jl = 1, nprofiles
- Do jk = nlevels, 1, -1
-
- value1 = cld_profiles(jl)%ph(jk) *hundred
- If ( value1 < repsc ) Then
- p1 = repsc
- Else
- p1 = value1
- End if
-
- value2 = cld_profiles(jl)%ph(jk+1) *hundred
- If ( value2 < repsc ) Then
- p2 = repsc
- Else
- p2 = value2
- End if
-
- p1_ad = -zdzst_ad(jl,jk) * rgp /gravity /rm /p1
- p2_ad = zdzst_ad(jl,jk) * rgp /gravity /rm /p2
- zdzst_ad(jl,jk) = 0._JPRB
-
- If ( value2 >= repsc ) Then
- cld_profiles_ad(jl)%ph(jk+1) = cld_profiles_ad(jl)%ph(jk+1) +&
- & p2_ad * hundred
- End if
-
- If ( value1 >= repsc ) Then
- cld_profiles_ad(jl)%ph(jk) = cld_profiles_ad(jl)%ph(jk) +&
- & p1_ad * hundred
- End if
-
- End Do
- End Do
-
-
-End Subroutine rttov_emiscld_ad
diff --git a/src/LIB/RTTOV/src/rttov_emiscld_ad.interface b/src/LIB/RTTOV/src/rttov_emiscld_ad.interface
deleted file mode 100644
index 21ed11df171befff0eeaa4a78df6cbc7c6f334e2..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_emiscld_ad.interface
+++ /dev/null
@@ -1,86 +0,0 @@
-Interface
-Subroutine rttov_emiscld_ad( &
- & errorstatus, & ! out
- & nfrequencies, & ! in
- & nchannels, & ! in
- & nprofiles, & ! in
- & nlevels, & ! in
- & channels, & ! in
- & polarisations,& ! in
- & lprofiles, & ! in
- & profiles, & ! in (surftype and zenangle)
- & coef, & ! in (frequencies mw/ir/hi)
- & cld_profiles, & ! in
- & cld_profiles_ad, & ! inout
- & cld_radiance, & ! inout (cldemis part only)
- & cld_radiance_ad) ! inout (cldemis part only)
-
- Use rttov_const, Only : &
- pi ,&
- gravity ,&
- surftype_land ,&
- nvalhusta ,&
- zhustaom ,&
- zhustaa1 ,&
- zhustaa2 ,&
- zhustaa3 ,&
- zhustab1 ,&
- zhustab2 ,&
- zhustab3 ,&
- zhustac1 ,&
- zhustac2 ,&
- zhustac3 ,&
- zhustad1 ,&
- zhustad2 ,&
- zhustad3 ,&
- zhustae1 ,&
- zhustae2 ,&
- zhustae3 ,&
- zhustaf1 ,&
- zhustaf2 ,&
- zhustaf3 ,&
- low_re ,&
- upp_re ,&
- nvalice ,&
- ziceom ,&
- ziceclmna ,&
- ziceclmnb ,&
- ziceclmnc ,&
- ziceclmnd ,&
- ziceaggra ,&
- ziceaggrb ,&
- ziceaggrc ,&
- ziceaggrd ,&
- sensor_id_ir ,&
- sensor_id_mw ,&
- sensor_id_hi
-
- Use rttov_types, Only : &
- rttov_coef ,&
- profile_Type ,&
- profile_cloud_Type ,&
- radiance_cloud_Type
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
- Integer(Kind=jpim), Intent(in) :: nfrequencies
- Integer(Kind=jpim), Intent(in) :: nchannels
- Integer(Kind=jpim), Intent(in) :: nprofiles
- Integer(Kind=jpim), Intent(in) :: nlevels
- Integer(Kind=jpim), Intent(out) :: errorstatus(nprofiles)
- Integer(Kind=jpim), Intent(in) :: channels(nfrequencies)
- Integer(Kind=jpim), Intent(in) :: polarisations(nchannels,3)
- Integer(Kind=jpim), Intent(in) :: lprofiles(nfrequencies)
- Type(profile_Type), Intent(in) :: profiles(nprofiles)
- Type(profile_cloud_Type), Intent(in) :: cld_profiles(nprofiles)
- Type(rttov_coef), Intent(in) :: coef
- Type(radiance_cloud_Type), Intent(inout) :: cld_radiance
-
- Type(profile_cloud_Type), Intent(inout) :: cld_profiles_ad(nprofiles)
- Type(radiance_cloud_Type), Intent(inout) :: cld_radiance_ad
-
-
-
-
-End Subroutine rttov_emiscld_ad
-End Interface
diff --git a/src/LIB/RTTOV/src/rttov_emiscld_tl.F90 b/src/LIB/RTTOV/src/rttov_emiscld_tl.F90
deleted file mode 100644
index 97ea684b73f824b956458bee5edde34e9dc9f763..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_emiscld_tl.F90
+++ /dev/null
@@ -1,748 +0,0 @@
-Subroutine rttov_emiscld_tl( &
- & errorstatus, &! out
- & nfrequencies, &! in
- & nchannels, &! in
- & nprofiles, &! in
- & nlevels, &! in
- & channels, &! in
- & polarisations, &! in
- & lprofiles, &! in
- & profiles, &! in (surftype and zenangle)
- & coef, &! in (frequencies mw/ir/hi)
- & cld_profiles, &! in
- & cld_profiles_tl, &! in
- & cld_radiance, &! inout (cldemis part only)
- & cld_radiance_tl) ! inout (cldemis part only)
- !
- ! Description:
- ! To compute tangent linear of cloud emissivity
- ! in the micro-wave (0-200 GHz)
- ! and in the infrared (50-2860 cm-1)
- ! spectral ranges
- !
- ! Copyright:
- ! This software was developed within the context of
- ! the EUMETSAT Satellite Application Facility on
- ! Numerical Weather Prediction (NWP SAF), under the
- ! Cooperation Agreement dated 25 November 1998, between
- ! EUMETSAT and the Met Office, UK, by one or more partners
- ! within the NWP SAF. The partners in the NWP SAF are
- ! the Met Office, ECMWF, KNMI and MeteoFrance.
- !
- ! Copyright 2002, EUMETSAT, All Rights Reserved.
- !
- ! Method:
- ! See references in the comments
- !
- ! Current Code Owner: SAF NWP
- !
- ! History:
- ! Version Date Comment
- ! ------- ---- -------
- ! ?+0.1 06/10/04 Added errorstatus to the arguments.
- ! Changed stop statements to returns.
- ! Added description/method/history header. (J Cameron)
- ! 1.2 29/03/2005 Add end of header comment (J. Cameron)
- !
- ! Code Description:
- ! Language: Fortran 90.
- ! Software Standards: "European Standards for Writing and
- ! Documenting Exchangeable Fortran 90 Code".
- ! A user guide and technical documentation is available at
- ! http://www.metoffice.com/research/interproj/nwpsaf/rtm/index.html
- !
- ! Declarations:
- ! Modules used:
-
- Use rttov_const, Only : &
- & pi ,&
- & gravity ,&
- & surftype_land ,&
- & nvalhusta ,&
- & zhustaom ,&
- & zhustaa1 ,&
- & zhustaa2 ,&
- & zhustaa3 ,&
- & zhustab1 ,&
- & zhustab2 ,&
- & zhustab3 ,&
- & zhustac1 ,&
- & zhustac2 ,&
- & zhustac3 ,&
- & zhustad1 ,&
- & zhustad2 ,&
- & zhustad3 ,&
- & zhustae1 ,&
- & zhustae2 ,&
- & zhustae3 ,&
- & zhustaf1 ,&
- & zhustaf2 ,&
- & zhustaf3 ,&
- & low_re ,&
- & upp_re ,&
- & nvalice ,&
- & ziceom ,&
- & ziceclmna , ziceclmnb ,&
- & ziceclmnc , ziceclmnd ,&
- & ziceaggra , ziceaggrb ,&
- & ziceaggrc , ziceaggrd ,&
- & sensor_id_ir ,&
- & sensor_id_mw ,&
- & sensor_id_hi ,&
- & errorstatus_success ,&
- & errorstatus_fatal
-
- Use rttov_types, Only : &
- & rttov_coef ,&
- & profile_Type ,&
- & profile_cloud_Type ,&
- & radiance_cloud_Type
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
- !subroutine arguments:
- Integer(Kind=jpim), Intent(in) :: nfrequencies
- Integer(Kind=jpim), Intent(in) :: nchannels
- Integer(Kind=jpim), Intent(in) :: nprofiles
- Integer(Kind=jpim), Intent(in) :: nlevels
- Integer(Kind=jpim), Intent(out) :: errorstatus(nprofiles)
- Integer(Kind=jpim), Intent(in) :: channels(nfrequencies)
- Integer(Kind=jpim), Intent(in) :: lprofiles(nfrequencies)
- Integer(Kind=jpim), Intent(in) :: polarisations(nchannels,3) ! Channel indices
- Type(profile_Type), Intent(in) :: profiles(nprofiles)
- Type(profile_cloud_Type), Intent(in) :: cld_profiles(nprofiles)
- Type(rttov_coef), Intent(in) :: coef
- Type(radiance_cloud_Type), Intent(inout) :: cld_radiance
- Type(profile_cloud_Type), Intent(in) :: cld_profiles_tl(nprofiles)
- Type(radiance_cloud_Type), Intent(inout) :: cld_radiance_tl
-
-
- ! Local parameters:
- !
- Real(Kind=jprb), Parameter :: rtt=273.15_JPRB
- Real(Kind=jprb), Parameter :: rgp = 8.314510_JPRB, rm = 0.0289644_JPRB
- Real(Kind=jprb), Parameter :: repsc=1.e-12_JPRB
- Real(Kind=jprb), Parameter :: rtice=rtt-23._JPRB
- Real(Kind=jprb), Parameter :: hundred=100.0_JPRB
- Real(Kind=jprb), Parameter :: rtou_upp=-20._JPRB
- Real(Kind=jprb), Parameter :: rtou_low=-60._JPRB
-
-
-
- !local variables:
- Integer(Kind=jpim) :: jc, jk, jl, jo, ido, idp, idq, idh
- Integer(Kind=jpim) :: freq
- Real(Kind=jprb) :: zomega, zfreq
- Real(Kind=jprb) :: zlwgkg, ziwgkg, ztempc, zdp, p1, p2
- Real(Kind=jprb) :: zmsaiu, zdom, zmin, zmultl, zmsalu, zmsalu_tl
- Real(Kind=jprb) :: zdz, zodw, zodi, zhelp, zbeta
- Real(Kind=jprb) :: fac1, fac2, fac3, fac4, fac5, fac6
- Real(Kind=jprb) :: eps0, eps1, eps2, fp, fs, theta
- Real(Kind=jprb) :: a, b, tk
- Real(Kind=jprb) :: zeps_r, zeps_i
- Real(Kind=jprb) :: co_ssa_1, kext_hu_1, kabs_hu_1
- Real(Kind=jprb) :: co_ssa_2, kext_hu_2, kabs_hu_2
- Real(Kind=jprb) :: kabs_ice_1, kabs_ice_2
- Real(Kind=jprb) :: kabs_ice_1_tl, kabs_ice_2_tl
- Real(Kind=jprb) :: zradipou_upp, zradipou_low
- Real(Kind=jprb) :: bwyser, bwyser_tl, nft
- Real(Kind=jprb) :: amcfarq, bmcfarq, cmcfarq, zmcfarq, zmcfarq_tl
-
- Real(Kind=jprb) :: zlwgkg_tl, ziwgkg_tl, ztempc_tl, zdp_tl, p1_tl, p2_tl
- Real(Kind=jprb) :: zmsaiu_tl
- Real(Kind=jprb) :: zdz_tl, zodw_tl, zodi_tl, zhelp_tl, zbeta_tl
- Real(Kind=jprb) :: fac1_tl, fac2_tl, fac3_tl, fac4_tl, fac5_tl, fac6_tl
- Real(Kind=jprb) :: eps0_tl, fp_tl, fs_tl, theta_tl
- Real(Kind=jprb) :: a_tl, b_tl, tk_tl
- Real(Kind=jprb) :: zeps_r_tl, zeps_i_tl
-
- Real(Kind=jprb) :: znum, zden
- Real(Kind=jprb) :: znum_tl, zden_tl
- Real(Kind=jprb) :: value
-
- Character (len=80) :: errMessage
- Character (len=16) :: NameOfRoutine = 'rttov_emiscld_tl'
- !
-
- ! Local arrays:
- !
- Integer(Kind=jpim), Dimension(nchannels) :: indh
- Integer(Kind=jpim), Dimension(nchannels) :: indi
- Real(Kind=jprb), DIMENSION(nprofiles) :: zradlp, zradip
- Real(Kind=jprb), DIMENSION(nprofiles) :: zflwp, zfiwp, zlwc, ziwc
- Real(Kind=jprb), DIMENSION(nprofiles) :: zview
- Real(Kind=jprb) :: zdzst(nprofiles, nlevels)
-
- Real(Kind=jprb), DIMENSION(nprofiles) :: zradip_tl
- Real(Kind=jprb), DIMENSION(nprofiles) :: zflwp_tl, zfiwp_tl, zlwc_tl, ziwc_tl
- Real(Kind=jprb) :: zdzst_tl(nprofiles, nlevels)
-
- !- End of header --------------------------------------------------------
-
- !---------------------------------------------------------------------------
- !All input NWP profiles have the same number of levels
-
- errorstatus(:) = errorstatus_success
-
- ! All channels are IR or MW according to the coefficient
- ! structure information
-
- !
- ! Calculate upper and lower limits for Ou-Liou effective size
- !
- zradipou_upp=326.3_JPRB + rtou_upp*(12.42_JPRB + rtou_upp*(0.197_JPRB + rtou_upp*0.0012_JPRB))
- zradipou_low=326.3_JPRB + rtou_low*(12.42_JPRB + rtou_low*(0.197_JPRB + rtou_low*0.0012_JPRB))
- !
- ! and convert these to the "generalized" effective size used here (using McFarquhar et al 2003 equation),
- ! not forgetting the factor of 2 to convert from McFarquhar's radius to a diameter
- !
- zradipou_upp=-1.56_JPRB + zradipou_upp*(0.388_JPRB + zradipou_upp*0.00051_JPRB)
- zradipou_upp=2.0_JPRB*zradipou_upp
- zradipou_low=-1.56_JPRB + zradipou_low*(0.388_JPRB + zradipou_low*0.00051_JPRB)
- zradipou_low=2.0_JPRB*zradipou_low
-
- !
- ! nearest Hu & Stamnes and ice cloud coefficients
- ! For IR and Hires only
- If( coef % id_sensor == sensor_id_ir .Or. &
- & coef % id_sensor == sensor_id_hi ) Then
- Do jc = 1, nchannels
- ido = channels(jc)
- zomega = coef % ff_cwn(ido)
- zmin = 1.e+06_JPRB
- Do jo = 1, nvalhusta
- zdom = Abs( zomega - zhustaom(jo) )
- If (zdom < zmin) Then
- indh(jc) = jo
- zmin = zdom
- End If
- End Do
- zmin = 1.e+06_JPRB
- Do jo = 1, nvalice
- zdom = Abs( zomega - ziceom(jo) )
- If (zdom < zmin) Then
- indi(jc) = jo
- zmin = zdom
- End If
- End Do
- End Do
- End If
-
- !
- ! secant of zenith angle
- !
- zview(:) = 1._JPRB / Cos( profiles(:)%zenangle /180._JPRB * pi )
-
- ! pressure layering (Pa)
- !
- Do jl = 1, nprofiles
- Do jk = 1, nlevels
- value = cld_profiles(jl)%ph(jk) *hundred
- If ( value < repsc ) Then
- p1_tl = 0._JPRB
- p1 = repsc
- Else
- p1_tl = cld_profiles_tl(jl)%ph(jk) *hundred
- p1 = value
- End if
-
- value = cld_profiles(jl)%ph(jk+1) *hundred
- If ( value < repsc ) Then
- p2_tl = 0._JPRB
- p2 = repsc
- Else
- p2_tl = cld_profiles_tl(jl)%ph(jk+1) *hundred
- p2 = value
- End if
-
-
- zdzst_tl(jl,jk) = -1._JPRB *rgp /gravity /rm * ( p1_tl/p1 - p2_tl/p2 )
- zdzst(jl,jk) = -1._JPRB *rgp /gravity /rm *Log(p1/p2)
- End Do
- End Do
-
- Do jk = 1, nlevels
- Do jl = 1, nprofiles
-
- value = cld_profiles(jl)%clw(jk)*1000._JPRB
- If( value < 0._JPRB ) Then
- zlwgkg_tl = 0._JPRB
- zlwgkg = 0._JPRB
- Else
- zlwgkg_tl = cld_profiles_tl(jl)%clw(jk)*1000._JPRB
- zlwgkg = value
- End If
-
- value = cld_profiles(jl)%ciw(jk)*1000._JPRB
- If( value < 0._JPRB ) Then
- ziwgkg_tl = 0._JPRB
- ziwgkg = 0._JPRB
- Else
- ziwgkg_tl = cld_profiles_tl(jl)%ciw(jk)*1000._JPRB
- ziwgkg = value
- End If
-
- If (cld_profiles(jl)%cc(jk) > (2._JPRB*repsc)) Then
-
- zlwgkg_tl = (zlwgkg_tl * cld_profiles(jl)%cc(jk) -&
- & zlwgkg * cld_profiles_tl(jl)%cc(jk) ) /&
- & cld_profiles(jl)%cc(jk)**2
- ziwgkg_tl = (ziwgkg_tl * cld_profiles(jl)%cc(jk) -&
- & ziwgkg * cld_profiles_tl(jl)%cc(jk) ) /&
- & cld_profiles(jl)%cc(jk)**2
-
- zlwgkg = zlwgkg / cld_profiles(jl)%cc(jk)
- ziwgkg = ziwgkg / cld_profiles(jl)%cc(jk)
- Else
- zlwgkg_tl = 0._JPRB
- ziwgkg_tl = 0._JPRB
- zlwgkg = 0._JPRB
- ziwgkg = 0._JPRB
- End If
-
- ! Liquid and ice water paths (g.m-2)
- zdp_tl = cld_profiles_tl(jl)%ph(jk+1) - cld_profiles_tl(jl)%ph(jk)
- zdp = cld_profiles(jl)%ph(jk+1) - cld_profiles(jl)%ph(jk)
-
- zdp_tl = zdp_tl * 100._JPRB
- zdp = zdp * 100._JPRB
-
- zflwp_tl(jl) = ( zlwgkg_tl*zdp + zlwgkg*zdp_tl ) / gravity
- zflwp(jl) = zlwgkg*zdp / gravity
-
- zfiwp_tl(jl) = ( ziwgkg_tl*zdp + ziwgkg*zdp_tl ) / gravity
- zfiwp(jl) = ziwgkg*zdp / gravity
-
- ! Liquid and ice water contents (kg.m-3)
- znum_tl = zlwgkg_tl/1000._JPRB * cld_profiles(jl)%p(jk)*100._JPRB * rm + &
- & zlwgkg/1000._JPRB * cld_profiles_tl(jl)%p(jk)*100._JPRB * rm
- znum = zlwgkg/1000._JPRB * cld_profiles(jl)%p(jk)*100._JPRB * rm
- zden_tl = rgp *cld_profiles_tl(jl)%t(jk)
- zden = rgp *cld_profiles(jl)%t(jk)
-
- zlwc_tl(jl) = (znum_tl * zden - znum * zden_tl) / zden**2
- zlwc(jl) = znum / zden
-
- znum_tl = ziwgkg_tl/1000._JPRB * cld_profiles(jl)%p(jk)*100._JPRB * rm + &
- & ziwgkg/1000._JPRB * cld_profiles_tl(jl)%p(jk)*100._JPRB * rm
- znum = ziwgkg/1000._JPRB * cld_profiles(jl)%p(jk)*100._JPRB * rm
- ziwc_tl(jl) = (znum_tl * zden - znum * zden_tl) / zden**2
- ziwc(jl) = znum / zden
-
- zradip(jl) = 1._JPRB
- zradlp(jl) = 1._JPRB
- zmultl = 0._JPRB
- zmsalu = 0._JPRB
-
- zradip_tl(jl) = 0._JPRB
-
- If (zflwp(jl) > 0._JPRB) Then
- ! Liquid particle radius (micro-meters)
-
- If ( profiles(jl)%skin%surftype == surftype_land ) Then
- zradlp(jl)=10._JPRB
- Else
- zradlp(jl)=13._JPRB
- End If
- End If
-
-
- If (zfiwp(jl) > 0._JPRB) Then
- ! Ice particle radius (micro-meters)
- !
- If (cld_profiles(jl)%kradip == 0) Then ! Ou-Liou
- !
- ! Ou and Liou, 1995, Atmos. Res., 35, 127-138.
- !
- ztempc_tl = cld_profiles_tl(jl)%t(jk)
- ztempc = cld_profiles(jl)%t(jk) - rtt
- zradip_tl(jl)= ( 12.42_JPRB + 2._JPRB*0.197_JPRB*ztempc + 3._JPRB*0.0012_JPRB*ztempc*ztempc )*ztempc_tl
- zradip(jl)=326.3_JPRB+ &
- & ztempc*(12.42_JPRB + ztempc*(0.197_JPRB + ztempc*0.0012_JPRB))
- ! and convert this to the "generalized" effective diameter (see McFarquhar et al 2003)
- zradip_tl(jl)=0.388_JPRB*zradip_tl(jl) + 0.00051_JPRB*2*zradip(jl)*zradip_tl(jl)
- zradip(jl)=-1.56_JPRB + zradip(jl)*(0.388_JPRB + zradip(jl)*0.00051_JPRB)
- zradip_tl(jl)=2.0_JPRB*zradip_tl(jl)
- zradip(jl)=2.0_JPRB*zradip(jl)
- !
- ! Take Ou-Liou scheme as being valid only between 20C and 60C
- !
- If (zradip(jl) < zradipou_low .or. zradip(jl) > zradipou_upp) zradip_tl(jl) = 0._JPRB
- zradip(jl)=max(zradip(jl),zradipou_low)
- zradip(jl)=min(zradip(jl),zradipou_upp)
- !
- Elseif (cld_profiles(jl)%kradip == 1) Then ! Wyser
- !
- ! Wyser et al., reference details here..., McFarquhar et al. (2003)
- ! Note two typos in McFarquhar paper:
- ! (a) reference to "r" should be "4" in final equation
- ! (b) T_k should be (273-T_k) (see original Wyser paper)
- !
- bwyser_tl = 0._JPRB
- bwyser=-2.0_JPRB
- If (cld_profiles(jl)%t(jk) < 273._JPRB) Then
- bwyser_tl = - 0.001_JPRB*1.5_JPRB*((273._JPRB-cld_profiles(jl)%t(jk))**0.5_JPRB)*cld_profiles_tl(jl)%t(jk) &
- & *Log10(1000._JPRB*ziwc(jl)/50._JPRB) &
- & + 0.001_JPRB*((273._JPRB-cld_profiles(jl)%t(jk))**1.5_JPRB)*ziwc_tl(jl) / ziwc(jl) / log(10._JPRB)
- ! Wyser's IWC is in g.m-3
- bwyser=bwyser+(0.001_JPRB*((273._JPRB-cld_profiles(jl)%t(jk))**1.5_JPRB)*Log10(1000._JPRB*ziwc(jl)/50._JPRB))
- Endif
- zradip_tl(jl)=( 203.3_JPRB + 2*bwyser*37.91_JPRB + 3*bwyser*bwyser*2.3696_JPRB ) *bwyser_tl
- zradip(jl)=377.4_JPRB + bwyser*(203.3_JPRB + bwyser*(37.91_JPRB + bwyser*2.3696_JPRB)) ! Wyser definition
- nft=(sqrt(3._JPRB)+4._JPRB)/(3._JPRB*sqrt(3._JPRB))
- zradip_tl(jl)=zradip_tl(jl)/nft
- zradip(jl)=zradip(jl)/nft ! convert to intermediate definition (see Table 1 of McFarquhar et al.)
- zradip_tl(jl)=2._JPRB*4._JPRB*zradip_tl(jl)*sqrt(3._JPRB)/9._JPRB
- zradip(jl)=2._JPRB*4._JPRB*zradip(jl)*sqrt(3._JPRB)/9._JPRB ! includes factor of 2 to convert McFarquhar"s r_ge to D_ge
- !
- Elseif (cld_profiles(jl)%kradip == 2) Then ! Boudala et al.
- !
- ! Boudala et al., 2002, Int. J. Climatol., 22, 1267-1284.
- !
- ztempc_tl=cld_profiles_tl(jl)%t(jk)
- ztempc=cld_profiles(jl)%t(jk)-rtt
- zradip_tl(jl)=53.005_JPRB*(1000._JPRB**0.06_JPRB)*(ziwc(jl)**(0.06_JPRB-1))*ziwc_tl(jl)*exp(0.013_JPRB*ztempc)&
- & +53.005_JPRB*((ziwc(jl)*1000._JPRB)**0.06_JPRB)*0.013_JPRB*ztempc_tl*exp(0.013_JPRB*ztempc)
- zradip(jl)=53.005_JPRB*((ziwc(jl)*1000._JPRB)**0.06_JPRB)*exp(0.013_JPRB*ztempc)
- !
- Elseif (cld_profiles(jl)%kradip == 3) Then ! McFarquhar
- !
- ! McFarquhar et al. (2003)
- !
- amcfarq=1.78449_JPRB
- bmcfarq=0.281301_JPRB
- cmcfarq=0.0177166_JPRB
- zmcfarq_tl=1000.0_JPRB*ziwc_tl(jl)
- zmcfarq=1000.0_JPRB*ziwc(jl) ! Put IWC in g.m-3
- zradip_tl(jl)= 10.0_JPRB**(amcfarq+bmcfarq*Log10(zmcfarq)+cmcfarq*Log10(zmcfarq)*Log10(zmcfarq) ) &
- & * ( bmcfarq + 2._JPRB*cmcfarq*Log10(zmcfarq) ) / zmcfarq * zmcfarq_tl
- zradip(jl)=10.0_JPRB**(amcfarq+(bmcfarq*Log10(zmcfarq))+&
- & (cmcfarq*Log10(zmcfarq)*Log10(zmcfarq)))
- zradip_tl(jl)=2.0_JPRB*zradip_tl(jl)
- zradip(jl)=2.0_JPRB*zradip(jl) ! Includes factor of 2 to convert McFarquhar's r_ge to D_ge
- !
-! Else
-! errMessage = 'Wrong kradip'
-! errorstatus(:) = errorstatus_fatal
-! Call Rttov_ErrorReport (errorstatus_fatal, errMessage, NameOfRoutine)
-! Return
- End If
- !
- End If
- End Do ! profiles
-
-
- Do jc = 1, nchannels
- freq = polarisations(jc,2)
- ido = channels(freq)
- idp = lprofiles(freq)
-
- ! Micro Waves
- If( coef % id_sensor == sensor_id_mw ) Then
-
- zdz = zdzst(idp,jk) * cld_profiles(idp)%t(jk)
- zdz_tl = zdzst_tl(idp,jk) * cld_profiles(idp)%t(jk) +&
- & zdzst(idp,jk) * cld_profiles_tl(idp)%t(jk)
-
- zfreq = coef%frequency_ghz (ido)
-
- ! Water
- ! Liebe et al., 1989, IEEE Trans. Antennas Propag., 37, 1617-1623.
- theta = 300.0_JPRB / cld_profiles(idp)%t(jk)
- theta_tl =-300.0_JPRB * cld_profiles_tl(idp)%t(jk) /&
- & cld_profiles(idp)%t(jk)**2
-
- fac1 = theta - 1.0_JPRB
- fac1_tl = theta_tl
-
- fac2 = fac1 * fac1
- fac2_tl = 2._JPRB * fac1_tl * fac1
-
- eps0 = 77.66_JPRB + 103.3_JPRB * fac1
- eps0_tl = 103.3_JPRB * fac1_tl
-
- eps1 = 5.48_JPRB
- eps2 = 3.51_JPRB
-
- fp = 20.09_JPRB - 142.0_JPRB * fac1 + 294.0_JPRB * fac2
- fp_tl = -142.0_JPRB * fac1_tl + 294.0_JPRB * fac2_tl
-
- fs = 590.0_JPRB - 1500.0_JPRB * fac1
- fs_tl = - 1500.0_JPRB * fac1_tl
-
- fac3 = zfreq / fp
- fac3_tl = -zfreq * fp_tl / fp**2
-
- fac4 = 1.0_JPRB + fac3 * fac3
- fac4_tl = 2._JPRB * fac3_tl * fac3
-
- fac5 = zfreq / fs
- fac5_tl = -zfreq * fs_tl / fs**2
-
- fac6 = 1.0_JPRB + fac5 * fac5
- fac6_tl = 2._JPRB * fac5_tl * fac5
-
- zeps_r = (eps0 - eps1) / fac4 + (eps1 - eps2) / fac6 + eps2
- zeps_r_tl = (eps0_tl * fac4 - (eps0 - eps1) * fac4_tl) / fac4**2 - &
- & (eps1 - eps2) * fac6_tl / fac6**2
-
- zeps_i = (eps0 - eps1) * fac3 / fac4 +&
- & (eps1 - eps2) * fac5 / fac6
- zeps_i_tl = ((eps0_tl*fac3 + (eps0 - eps1)*fac3_tl)* fac4 - &
- & (eps0 - eps1) * fac3 * fac4_tl ) / fac4**2 &
- & + &
- & (eps1 - eps2) * (fac5_tl * fac6 - fac5 * fac6_tl ) /&
- & fac6**2
-
- znum = zeps_i
- znum_tl = zeps_i_tl
- zden = (zeps_r + 2.0_JPRB)**2 + zeps_i**2
- zden_tl = 2._JPRB * zeps_r_tl * (zeps_r + 2.0_JPRB) + &
- & 2._JPRB * zeps_i_tl * zeps_i
-
- zhelp = znum / zden
- zhelp_tl = (znum_tl * zden - znum * zden_tl) / zden**2
-
-
- zbeta = 0.18851441_JPRB * zfreq * zlwc(idp) * zhelp
- zbeta_tl = 0.18851441_JPRB * zfreq *&
- & (zlwc_tl(idp) * zhelp + zlwc(idp) * zhelp_tl)
-
- zodw = zbeta * zview(idp) * zdz
- zodw_tl = zbeta_tl * zview(idp) * zdz +&
- & zbeta * zview(idp) * zdz_tl
-
- ! Ice
- ! Hufford, 1991, Int. J. Infrared Millimeter Waves, 12, 677-681.
- zeps_r = 3.15_JPRB
- zeps_r_tl =0._JPRB
-
- tk = cld_profiles(idp)%t(jk)
- tk_tl = cld_profiles_tl(idp)%t(jk)
-
- If (tk > 273.16_JPRB) Then
- tk = 273.16_JPRB
- tk_tl = 0._JPRB
- End if
-
- theta = 300.0_JPRB / tk
- theta_tl = -300.0_JPRB * tk_tl / tk**2
-
- a = 1.0e-04_JPRB * (50.4_JPRB + 62.0_JPRB * (theta - 1.0_JPRB)) &
- & * Exp (-22.1_JPRB * (theta - 1.0_JPRB))
- a_tl = 1.0e-04_JPRB * Exp (-22.1_JPRB * (theta - 1.0_JPRB)) * &
- & ( 62.0_JPRB * theta_tl +&
- & (50.4_JPRB + 62.0_JPRB * (theta - 1.0_JPRB)) * (-22.1_JPRB * theta_tl) )
-
- b = 1.0e-04_JPRB * (0.633_JPRB / theta - 0.131_JPRB) &
- & + (7.36e-04_JPRB * theta / (theta - 0.9927_JPRB)) ** 2
- b_tl = - 1.0e-04_JPRB * 0.633_JPRB * theta_tl / (theta **2) &
- & - 7.36e-04_JPRB**2 * 2 * theta / (theta - 0.9927_JPRB) &
- & * 0.9927_JPRB / ((theta - 0.9927_JPRB)**2) * theta_tl
-
- zeps_i = a / zfreq + b * zfreq
- zeps_i_tl = a_tl / zfreq + b_tl * zfreq
-
- znum = zeps_i
- znum_tl = zeps_i_tl
- zden = (zeps_r + 2.0_JPRB)**2 + zeps_i**2
- ! note that zeps_r_tl is 0.
- zden_tl = 2._JPRB * zeps_r_tl * (zeps_r + 2.0_JPRB) +&
- & 2._JPRB * zeps_i_tl * zeps_i
-
- zhelp = znum / zden
- zhelp_tl = (znum_tl * zden - znum * zden_tl) / zden**2
-
-
- zbeta = 0.18851441_JPRB * zfreq * ziwc(idp) * zhelp
- zbeta_tl = 0.18851441_JPRB * zfreq *&
- & (ziwc_tl(idp) * zhelp + ziwc(idp) * zhelp_tl)
-
- zodi = zbeta * zview(idp) * zdz
- zodi_tl = zbeta_tl * zview(idp) * zdz + &
- & zbeta * zview(idp) * zdz_tl
-
- cld_radiance % cldemis(jk,jc) = 1._JPRB - Exp( - zodw - zodi )
- cld_radiance_tl % cldemis(jk,jc) = ( zodw_tl + zodi_tl ) *&
- & Exp( - zodw - zodi )
-
- ! Infra Red
- Elseif( coef % id_sensor == sensor_id_ir .Or. &
- & coef % id_sensor == sensor_id_hi ) Then
-
- If (zflwp(idp) > 0._JPRB) Then
-
- !
- ! Water cloud coefficients
- ! from Hu and Stamnes, 1993, J. Climate, Vol. 6, pp. 728-742
- !
- idh = indh(jc)
- zomega = coef % ff_cwn(ido)
- zdom = zomega - zhustaom(idh)
- !
- If (zdom >= 0.0_JPRB) Then ! Better to interpolate the single-scattering properties
- If (zradlp(idp) < upp_re(1)) Then ! themselves rather than the coefficients
- kext_hu_1=(zhustaa1(idh)*(zradlp(idp)**zhustab1(idh)))+zhustac1(idh)
- co_ssa_1=(zhustad1(idh)*(zradlp(idp)**zhustae1(idh)))+zhustaf1(idh)
- kext_hu_2=(zhustaa1(idh-1)*(zradlp(idp)**zhustab1(idh-1)))+zhustac1(idh-1)
- co_ssa_2=(zhustad1(idh-1)*(zradlp(idp)**zhustae1(idh-1)))+zhustaf1(idh-1)
- Elseif (zradlp(idp) >= low_re(2) .AND. zradlp(idp) < upp_re(2)) Then
- kext_hu_1=(zhustaa2(idh)*(zradlp(idp)**zhustab2(idh)))+zhustac2(idh)
- co_ssa_1=(zhustad2(idh)*(zradlp(idp)**zhustae2(idh)))+zhustaf2(idh)
- kext_hu_2=(zhustaa2(idh-1)*(zradlp(idp)**zhustab2(idh-1)))+zhustac2(idh-1)
- co_ssa_2=(zhustad2(idh-1)*(zradlp(idp)**zhustae2(idh-1)))+zhustaf2(idh-1)
- Elseif (zradlp(idp) >= low_re(3)) Then
- kext_hu_1=(zhustaa3(idh)*(zradlp(idp)**zhustab3(idh)))+zhustac3(idh)
- co_ssa_1=(zhustad3(idh)*(zradlp(idp)**zhustae3(idh)))+zhustaf3(idh)
- kext_hu_2=(zhustaa3(idh-1)*(zradlp(idp)**zhustab3(idh-1)))+zhustac3(idh-1)
- co_ssa_2=(zhustad3(idh-1)*(zradlp(idp)**zhustae3(idh-1)))+zhustaf3(idh-1)
- End If
- kabs_hu_1=kext_hu_1*co_ssa_1
- kabs_hu_2=kext_hu_2*co_ssa_2
- !
- ! Do the interpolation
- zmsalu = ((zdom)*(kabs_hu_2-kabs_hu_1)/(zhustaom(idh-1)-zhustaom(idh))) + kabs_hu_1
- !
- Elseif (zdom < 0.0_JPRB) Then
- If (zradlp(idp) < upp_re(1)) Then
- kext_hu_1=(zhustaa1(idh)*(zradlp(idp)**zhustab1(idh)))+zhustac1(idh)
- co_ssa_1=(zhustad1(idh)*(zradlp(idp)**zhustae1(idh)))+zhustaf1(idh)
- kext_hu_2=(zhustaa1(idh+1)*(zradlp(idp)**zhustab1(idh+1)))+zhustac1(idh+1)
- co_ssa_2=(zhustad1(idh+1)*(zradlp(idp)**zhustae1(idh+1)))+zhustaf1(idh+1)
- Elseif (zradlp(idp) >= low_re(2) .AND. zradlp(idp) < upp_re(2)) Then
- kext_hu_1=(zhustaa2(idh)*(zradlp(idp)**zhustab2(idh)))+zhustac2(idh)
- co_ssa_1=(zhustad2(idh)*(zradlp(idp)**zhustae2(idh)))+zhustaf2(idh)
- kext_hu_2=(zhustaa2(idh+1)*(zradlp(idp)**zhustab2(idh+1)))+zhustac2(idh+1)
- co_ssa_2=(zhustad2(idh+1)*(zradlp(idp)**zhustae2(idh+1)))+zhustaf2(idh+1)
- Elseif (zradlp(idp) >= low_re(3)) Then
- kext_hu_1=(zhustaa3(idh)*(zradlp(idp)**zhustab3(idh)))+zhustac3(idh)
- co_ssa_1=(zhustad3(idh)*(zradlp(idp)**zhustae3(idh)))+zhustaf3(idh)
- kext_hu_2=(zhustaa3(idh+1)*(zradlp(idp)**zhustab3(idh+1)))+zhustac3(idh+1)
- co_ssa_2=(zhustad3(idh+1)*(zradlp(idp)**zhustae3(idh+1)))+zhustaf3(idh+1)
- End If
- kabs_hu_1=kext_hu_1*co_ssa_1
- kabs_hu_2=kext_hu_2*co_ssa_2
- !
- ! Do the interpolation
- zmsalu = ((zdom)*(kabs_hu_2-kabs_hu_1)/(zhustaom(idh+1)-zhustaom(idh))) + kabs_hu_1
- End If
- !
- zmsalu_tl = 0._JPRB ! since no liquid particle radius perturbations
- zmsalu = zview(idp) * (0.001_JPRB*zmsalu) ! Convert Hu/Stamnes to m^2g^-1 and put in viewing angle dependence
-
- Else
-
- zmsalu_tl = 0._JPRB
- zmsalu = 0._JPRB
-
- End If
-
- !
- ! Ice cloud emissivity
- ! See Baran et al. JAS, 417-427, 2003; Baran et al. JQSRT, 549-567, 2003.
-
- If (zfiwp(idp) > 0._JPRB) Then
-
- idq = indi(jc)
- zomega = coef % ff_cwn(ido)
- zdom = zomega - ziceom(idq)
- If (zdom >= 0.0_JPRB) Then
- If (cld_profiles(idp)%kice == 0) Then ! Hexagonal columns
- kabs_ice_1_tl= ( ziceclmnd(idq) &
- & - ziceclmnb(idq)/(zradip(idp)*zradip(idp)) &
- & - 2*ziceclmnc(idq)/(zradip(idp)*zradip(idp)*zradip(idp)) )*zradip_tl(idp)
- kabs_ice_1=ziceclmna(idq)+(ziceclmnb(idq)/zradip(idp))+ &
- & (ziceclmnc(idq)/(zradip(idp)*zradip(idp)))+(ziceclmnd(idq)*zradip(idp))
- kabs_ice_2_tl= ( ziceclmnd(idq-1) &
- & - ziceclmnb(idq-1)/(zradip(idp)*zradip(idp)) &
- & - 2*ziceclmnc(idq-1)/(zradip(idp)*zradip(idp)*zradip(idp)) )*zradip_tl(idp)
- kabs_ice_2=ziceclmna(idq-1)+(ziceclmnb(idq-1)/zradip(idp))+ &
- & (ziceclmnc(idq-1)/(zradip(idp)*zradip(idp)))+(ziceclmnd(idq-1)*zradip(idp))
- Elseif (cld_profiles(idp)%kice == 1) Then ! Aggregates
- kabs_ice_1_tl= ( ziceaggrd(idq) &
- & - ziceaggrb(idq)/(zradip(idp)*zradip(idp)) &
- & - 2*ziceaggrc(idq)/(zradip(idp)*zradip(idp)*zradip(idp)) )*zradip_tl(idp)
- kabs_ice_1=ziceaggra(idq)+(ziceaggrb(idq)/zradip(idp))+ &
- & (ziceaggrc(idq)/(zradip(idp)*zradip(idp)))+(ziceaggrd(idq)*zradip(idp))
- kabs_ice_2_tl= ( ziceaggrd(idq-1) &
- & - ziceaggrb(idq-1)/(zradip(idp)*zradip(idp)) &
- & - 2*ziceaggrc(idq-1)/(zradip(idp)*zradip(idp)*zradip(idp)) )*zradip_tl(idp)
- kabs_ice_2=ziceaggra(idq-1)+(ziceaggrb(idq-1)/zradip(idp))+ &
- & (ziceaggrc(idq-1)/(zradip(idp)*zradip(idp)))+(ziceaggrd(idq-1)*zradip(idp))
-! Else
-! errMessage = 'Wrong kice'
-! errorstatus(:) = errorstatus_fatal
-! Call Rttov_ErrorReport (errorstatus_fatal, errMessage, NameOfRoutine)
-! Return
- End If
- !
- ! Do the interpolation
- zmsaiu_tl = ((zdom)*(kabs_ice_2_tl-kabs_ice_1_tl)/(ziceom(idq-1)-ziceom(idq))) + kabs_ice_1_tl
- zmsaiu = ((zdom)*(kabs_ice_2-kabs_ice_1)/(ziceom(idq-1)-ziceom(idq))) + kabs_ice_1
- !
- Elseif (zdom < 0.0_JPRB) Then
- If (cld_profiles(idp)%kice == 0) Then ! Hexagonal columns
- kabs_ice_1_tl= ( ziceclmnd(idq) &
- & - ziceclmnb(idq)/(zradip(idp)*zradip(idp)) &
- & - 2*ziceclmnc(idq)/(zradip(idp)*zradip(idp)*zradip(idp)) )*zradip_tl(idp)
- kabs_ice_1=ziceclmna(idq)+(ziceclmnb(idq)/zradip(idp))+ &
- & (ziceclmnc(idq)/(zradip(idp)*zradip(idp)))+(ziceclmnd(idq)*zradip(idp))
- kabs_ice_2_tl= ( ziceclmnd(idq+1) &
- & - ziceclmnb(idq+1)/(zradip(idp)*zradip(idp)) &
- & - 2*ziceclmnc(idq+1)/(zradip(idp)*zradip(idp)*zradip(idp)) )*zradip_tl(idp)
- kabs_ice_2=ziceclmna(idq+1)+(ziceclmnb(idq+1)/zradip(idp))+ &
- & (ziceclmnc(idq+1)/(zradip(idp)*zradip(idp)))+(ziceclmnd(idq+1)*zradip(idp))
- Elseif (cld_profiles(idp)%kice == 1) Then ! Aggregates
- kabs_ice_1_tl= ( ziceaggrd(idq) &
- & - ziceaggrb(idq)/(zradip(idp)*zradip(idp)) &
- & - 2*ziceaggrc(idq)/(zradip(idp)*zradip(idp)*zradip(idp)) )*zradip_tl(idp)
- kabs_ice_1=ziceaggra(idq)+(ziceaggrb(idq)/zradip(idp))+ &
- & (ziceaggrc(idq)/(zradip(idp)*zradip(idp)))+(ziceaggrd(idq)*zradip(idp))
- kabs_ice_2_tl= ( ziceaggrd(idq+1) &
- & - ziceaggrb(idq+1)/(zradip(idp)*zradip(idp)) &
- & - 2*ziceaggrc(idq+1)/(zradip(idp)*zradip(idp)*zradip(idp)) )*zradip_tl(idp)
- kabs_ice_2=ziceaggra(idq+1)+(ziceaggrb(idq+1)/zradip(idp))+ &
- & (ziceaggrc(idq+1)/(zradip(idp)*zradip(idp)))+(ziceaggrd(idq+1)*zradip(idp))
-! Else
-! errMessage = 'Wrong kice'
-! errorstatus(:) = errorstatus_fatal
-! Call Rttov_ErrorReport (errorstatus_fatal, errMessage, NameOfRoutine)
-! Return
- End If
- !
- ! Do the interpolation
- zmsaiu_tl = ((zdom)*(kabs_ice_2_tl-kabs_ice_1_tl)/(ziceom(idq+1)-ziceom(idq))) + kabs_ice_1_tl
- zmsaiu = ((zdom)*(kabs_ice_2-kabs_ice_1)/(ziceom(idq+1)-ziceom(idq))) + kabs_ice_1
- End If
- zmsaiu_tl = zview(idp) * zmsaiu_tl
- zmsaiu = zview(idp) * zmsaiu ! Add in viewing angle dependence
-
- Else
-
- zmsaiu_tl = 0._JPRB
- zmsaiu = 0._JPRB
-
- End If
-
- !
- ! Cloud layer emissivity
- cld_radiance % cldemis(jk,jc) =&
- & 1._JPRB - Exp( -zmsalu*zflwp(idp) -zmsaiu*zfiwp(idp) )
- cld_radiance_tl % cldemis(jk,jc) =&
- & ( zmsalu * zflwp_tl(idp) +&
- & zmsaiu_tl * zfiwp(idp) + zmsaiu * zfiwp_tl(idp) ) *&
- & Exp( -zmsalu*zflwp(idp) -zmsaiu*zfiwp(idp) )
- !
- Else
- cld_radiance % cldemis(jk,jc) = 0._JPRB
- cld_radiance_tl % cldemis(jk,jc) = 0._JPRB
-
- End If
-
- End Do ! channels
- !
- End Do ! Levels
-
-
-End Subroutine rttov_emiscld_tl
diff --git a/src/LIB/RTTOV/src/rttov_emiscld_tl.interface b/src/LIB/RTTOV/src/rttov_emiscld_tl.interface
deleted file mode 100644
index fbb17c0f1b9fdc3f633dd64afbf20e53ce13a07a..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_emiscld_tl.interface
+++ /dev/null
@@ -1,86 +0,0 @@
-Interface
-Subroutine rttov_emiscld_tl( &
- & errorstatus, &! out
- & nfrequencies, & ! in
- & nchannels, & ! in
- & nprofiles, & ! in
- & nlevels, & ! in
- & channels, & ! in
- & polarisations,& ! in
- & lprofiles, & ! in
- & profiles, & ! in (surftype and zenangle)
- & coef, & ! in (frequencies mw/ir/hi)
- & cld_profiles, & ! in
- & cld_profiles_tl, & ! in
- & cld_radiance, & ! inout (cldemis part only)
- & cld_radiance_tl) ! inout (cldemis part only)
-
- Use rttov_const, Only : &
- pi ,&
- gravity ,&
- surftype_land ,&
- nvalhusta ,&
- zhustaom ,&
- zhustaa1 ,&
- zhustaa2 ,&
- zhustaa3 ,&
- zhustab1 ,&
- zhustab2 ,&
- zhustab3 ,&
- zhustac1 ,&
- zhustac2 ,&
- zhustac3 ,&
- zhustad1 ,&
- zhustad2 ,&
- zhustad3 ,&
- zhustae1 ,&
- zhustae2 ,&
- zhustae3 ,&
- zhustaf1 ,&
- zhustaf2 ,&
- zhustaf3 ,&
- low_re ,&
- upp_re ,&
- nvalice ,&
- ziceom ,&
- ziceclmna ,&
- ziceclmnb ,&
- ziceclmnc ,&
- ziceclmnd ,&
- ziceaggra ,&
- ziceaggrb ,&
- ziceaggrc ,&
- ziceaggrd ,&
- sensor_id_ir ,&
- sensor_id_mw ,&
- sensor_id_hi
-
- Use rttov_types, Only : &
- rttov_coef ,&
- profile_Type ,&
- profile_cloud_Type ,&
- radiance_cloud_Type
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
- Integer(Kind=jpim), Intent(in) :: nfrequencies
- Integer(Kind=jpim), Intent(in) :: nchannels
- Integer(Kind=jpim), Intent(in) :: nprofiles
- Integer(Kind=jpim), Intent(in) :: nlevels
- Integer(Kind=jpim), Intent(out) :: errorstatus(nprofiles)
- Integer(Kind=jpim), Intent(in) :: channels(nfrequencies)
- Integer(Kind=jpim), Intent(in) :: lprofiles(nfrequencies)
- Integer(Kind=jpim), Intent(in) :: polarisations(nchannels,3) ! Channel indices
- Type(profile_Type), Intent(in) :: profiles(nprofiles)
- Type(profile_cloud_Type), Intent(in) :: cld_profiles(nprofiles)
- Type(rttov_coef), Intent(in) :: coef
- Type(radiance_cloud_Type), Intent(inout) :: cld_radiance
-
- Type(profile_cloud_Type), Intent(in) :: cld_profiles_tl(nprofiles)
- Type(radiance_cloud_Type), Intent(inout) :: cld_radiance_tl
-
-
-
-
-End Subroutine rttov_emiscld_tl
-End Interface
diff --git a/src/LIB/RTTOV/src/rttov_errorhandling.F90 b/src/LIB/RTTOV/src/rttov_errorhandling.F90
deleted file mode 100644
index eb832c5ace74bb2f54f9b05e3a0f270c67fd252e..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_errorhandling.F90
+++ /dev/null
@@ -1,118 +0,0 @@
-!
-Subroutine rttov_errorhandling (Err_unit, verbosity_level)
-
- ! Description:
- ! Handling of error messages.
- ! Error messages will be sent on the optional unit number errunit.
- ! Default is the value defined in the module for constants.
- !
- ! The levels of verbosity are
- ! 0 = no error messages output
- ! 1 = FATAL errors only printed. these are errors which
- ! mean that profile should be aborted (e.g. unphysical
- ! profile input)
- ! 2 = WARNING errors only printed. Errors which can allow
- ! the computation to continue but the results may be
- ! suspect (e.g. profile outside basis profile limits)
- ! 3 = INFORMATION messages which inform the user about
- ! the computation
- !
- ! Copyright:
- !
- ! This software was developed within the context of
- ! the EUMETSAT Satellite Application Facility on
- ! Numerical Weather Prediction (NWP SAF), under the
- ! Cooperation Agreement dated 25 November 1998, between
- ! EUMETSAT and the Met Office, UK, by one or more partners
- ! within the NWP SAF. The partners in the NWP SAF are
- ! the Met Office, ECMWF, KNMI and MeteoFrance.
- !
- ! Copyright 2002, EUMETSAT, All Rights Reserved.
- !
- !
- !
- ! Current Code Owner: SAF NWP
- !
- ! History:
- ! Version Date Comment
- ! 1.0 10/03/2003 Original code (P Brunel)
- !
- ! Code Description:
- ! FORTRAN 90, following AAPP standards
- !
- ! Declarations
- !
- ! Global variables:
- ! Modules used:
- !
- Use rttov_const, Only : &
- & errorstatus_info ,&
- & errorstatus_success ,&
- & errorstatus_fatal ,&
- & errorstatus_warning ,&
- & ErrorStatus_text, &
- & NerrorStatus, &
- & default_err_unit
-
- Use rttov_global, Only: &
- & verbose_message, &
- & err_init, &
- & error_unit
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
- !
- ! Subroutine arguments
- ! Scalar arguments with intent(in):
- Integer(Kind=jpim), Intent (in) :: Err_Unit ! Logical error unit
- Integer(Kind=jpim), Intent (in) :: verbosity_level
-
-
- ! local
- !- End of header --------------------------------------------------------
-
-
- ! According to the user defined verbosity level
- ! defines the verbose flag for each error level
- ! Default is to output all messages
- Select Case ( verbosity_level )
- Case ( 0_jpim )
- verbose_message( errorstatus_success ) = .false.
- verbose_message( errorstatus_warning ) = .false.
- verbose_message( errorstatus_fatal ) = .false.
- verbose_message( errorstatus_info ) = .false.
- Case ( 1_jpim )
- verbose_message( errorstatus_success ) = .false.
- verbose_message( errorstatus_warning ) = .false.
- verbose_message( errorstatus_fatal ) = .true.
- verbose_message( errorstatus_info ) = .false.
- Case ( 2_jpim )
- verbose_message( errorstatus_success ) = .false.
- verbose_message( errorstatus_warning ) = .true.
- verbose_message( errorstatus_fatal ) = .true.
- verbose_message( errorstatus_info ) = .false.
- Case ( 3_jpim )
- verbose_message( errorstatus_success ) = .true.
- verbose_message( errorstatus_warning ) = .true.
- verbose_message( errorstatus_fatal ) = .true.
- verbose_message( errorstatus_info ) = .true.
- Case Default
- verbose_message( errorstatus_success ) = .true.
- verbose_message( errorstatus_warning ) = .true.
- verbose_message( errorstatus_fatal ) = .true.
- verbose_message( errorstatus_info ) = .true.
- End Select
-
- ! Definition of the error message logical unit
- ! default is taken from the module for constants
- If( Err_Unit >= 0 ) then
- error_unit = err_unit
- Else
- error_unit = default_err_unit
- EndIf
-
- ! setup initialisation flag
- ! This flag is tested by errorreprt subroutine
- err_init = .true.
-
-End Subroutine rttov_errorhandling
diff --git a/src/LIB/RTTOV/src/rttov_errorhandling.interface b/src/LIB/RTTOV/src/rttov_errorhandling.interface
deleted file mode 100644
index 22eba852ea05ec833a96868c04cade6208072b14..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_errorhandling.interface
+++ /dev/null
@@ -1,26 +0,0 @@
-Interface
-!
-Subroutine rttov_errorhandling (Err_unit, verbosity_level)
-
- Use rttov_const, Only : &
- errorstatus_info ,&
- errorstatus_success ,&
- errorstatus_fatal ,&
- errorstatus_warning ,&
- ErrorStatus_text, &
- NerrorStatus, &
- default_err_unit
-
- Use rttov_global, Only: &
- verbose_message, &
- err_init, &
- error_unit
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
- Integer(Kind=jpim), Intent (in) :: Err_Unit ! Logical error unit
- Integer(Kind=jpim), Intent (in) :: verbosity_level
-
-
-End Subroutine rttov_errorhandling
-End Interface
diff --git a/src/LIB/RTTOV/src/rttov_errorreport.F90 b/src/LIB/RTTOV/src/rttov_errorreport.F90
deleted file mode 100644
index 94a400d75c10f82009c6c2b98b260b7f1aa80091..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_errorreport.F90
+++ /dev/null
@@ -1,102 +0,0 @@
-!
-Subroutine rttov_ErrorReport (ErrStatus, ErrMessage, NameOfRoutine)
- ! Description:
- ! Write out fatal and warning error messages to unit 6.
- ! Execution is stopped in the event of a fatal error.
- !
- !
- ! Copyright:
- !
- ! This software was developed within the context of
- ! the EUMETSAT Satellite Application Facility on
- ! Numerical Weather Prediction (NWP SAF), under the
- ! Cooperation Agreement dated 25 November 1998, between
- ! EUMETSAT and the Met Office, UK, by one or more partners
- ! within the NWP SAF. The partners in the NWP SAF are
- ! the Met Office, ECMWF, KNMI and MeteoFrance.
- !
- ! Copyright 2002, EUMETSAT, All Rights Reserved.
- !
- !
- !
- ! Current Code Owner: SAF NWP
- !
- ! History:
- ! Version Date Comment
- !
- ! 1.0 2/2/96 Original code. (R.J.Renshaw)
- ! - based on routine of same name in Met Office VAR project.
- ! 1.1 27/11/96 STOP 999 changed to CALL EXIT to alert
- ! unix that program has failed. (R.J.Renshaw)
- ! 1.2 08/03/01 F90 and negative integer P. Brunel
- ! 1.3 01/12/02 New F90 code with structures (P Brunel A Smith)
- ! 1.4 10/01/03 Use verbosity level (P Brunel)
- ! and change varaibles in order to use the
- ! module rttov_global
- !
- ! Code Description:
- ! FORTRAN 90, following AAPP standards
- !
- ! Declarations
- !
- ! Global variables:
- ! Modules used:
- !
- Use rttov_const, Only : &
- & ErrorStatus_text, &
- & NerrorStatus
-
- Use rttov_global, Only: &
- & verbose_message, &
- & err_init, &
- & error_unit
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
-#include "rttov_errorhandling.interface"
-
- !
- ! Subroutine arguments
- ! Scalar arguments with intent(in):
- Integer(Kind=jpim) , Intent (in) :: ErrStatus ! +ve => fatal error, -ve => warning
- Character (len=*) , Intent (in) :: ErrMessage ! ..to output
- Character (len=*) , Intent (in) :: NameOfRoutine ! ..calling this one
-
-
-
- ! local
- Character (len=8) :: date
- Character (len=10):: time
- !- End of header --------------------------------------------------------
-
- Call DATE_AND_Time(date, time)
-
- ! If globlal variables not defined then use default values
- if( .not. err_init ) then
- call rttov_errorhandling ( -1_jpim , -1_jpim )
- endif
-
-
- If ( ErrStatus >= 0 .And. ErrStatus <=nerrorstatus ) Then
- ! Display message only if allowed by verbose_message flag
- if( verbose_message (ErrStatus) ) then
- Write(Error_Unit,"(1X,a4,'/',a2,'/',a2,2x,2(a2,':'),a2,2x,a,a,a)") &
- & date(1:4), date(5:6), date(7:8), &
- & time(1:2), time(3:4), time(5:6), &
- & ErrorStatus_text(errstatus),&
- & " in module ",Trim(NameOfRoutine)
- Write(Error_Unit,"(5X,A)") Trim(ErrMessage)
- Endif
- Else
- ! This error level is different from predefined
- ! Output it anyway
- Write(Error_Unit,"(1X,a4,'/',a2,'/',a2,2x,2(a2,':'),a2,2x,i6,a,a)") &
- & date(1:4), date(5:6), date(7:8), &
- & time(1:2), time(3:4), time(5:6), &
- & errstatus ,&
- & " in module ",Trim(NameOfRoutine)
- Write(Error_Unit,"(5X,A)") Trim(ErrMessage)
- Endif
-
-End Subroutine rttov_ErrorReport
diff --git a/src/LIB/RTTOV/src/rttov_errorreport.interface b/src/LIB/RTTOV/src/rttov_errorreport.interface
deleted file mode 100644
index eefb15ee05f5341dbdc4c5c19e6c95dc509591cf..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_errorreport.interface
+++ /dev/null
@@ -1,22 +0,0 @@
-Interface
-!
-Subroutine rttov_ErrorReport (ErrStatus, ErrMessage, NameOfRoutine)
- Use rttov_const, Only : &
- ErrorStatus_text, &
- NerrorStatus
-
- Use rttov_global, Only: &
- verbose_message, &
- err_init, &
- error_unit
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
- Integer(Kind=jpim) , Intent (in) :: ErrStatus ! +ve => fatal error, -ve => warning
- Character (len=*) , Intent (in) :: ErrMessage ! ..to output
- Character (len=*) , Intent (in) :: NameOfRoutine ! ..calling this one
-
-
-
-End Subroutine rttov_ErrorReport
-End Interface
diff --git a/src/LIB/RTTOV/src/rttov_findnextsection.F90 b/src/LIB/RTTOV/src/rttov_findnextsection.F90
deleted file mode 100644
index 5ae4ae9493d26f84ce79baea1896fbc2d9c16824..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_findnextsection.F90
+++ /dev/null
@@ -1,86 +0,0 @@
-!
-Subroutine rttov_findnextsection( fileunit,readstatus,section )
- ! Description:
- ! Read file (unit fileunit) until reach next section of
- ! coefficient file
- !
- ! Copyright:
- ! This software was developed within the context of
- ! the EUMETSAT Satellite Application Facility on
- ! Numerical Weather Prediction (NWP SAF), under the
- ! Cooperation Agreement dated 25 November 1998, between
- ! EUMETSAT and the Met Office, UK, by one or more partners
- ! within the NWP SAF. The partners in the NWP SAF are
- ! the Met Office, ECMWF, KNMI and MeteoFrance.
- !
- ! Copyright 2002, EUMETSAT, All Rights Reserved.
- !
- ! Method:
- !
- ! Current Code Owner: SAF NWP
- !
- ! History:
- ! Version Date Comment
- ! ------- ---- -------
- ! 1.0 01/12/2002 New F90 code with structures (P Brunel A Smith)
- !
- ! Code Description:
- ! Language: Fortran 90.
- ! Software Standards: "European Standards for Writing and
- ! Documenting Exchangeable Fortran 90 Code".
- !
- ! Declarations:
- ! Modules used:
- ! Imported Parameters:
- Use rttov_const, Only : &
- & nsections ,&
- & section_types
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
- !subroutine arguments:
- Integer(Kind=jpim), Intent(in) :: fileunit
- Integer(Kind=jpim), Intent(out) :: readstatus
- Character(len=21), Intent(out) :: section
-
-
-
- !local variables:
- Integer(Kind=jpim) :: i
- Logical :: sectionfound
- Character(len=80) :: line
- !- End of header --------------------------------------------------------
-
-
- section = ''
- sectionfound = .False.
-
- readfile: Do
-
- Read( unit=fileunit,fmt='(a)',iostat=readstatus ) line
- If ( readstatus /= 0 ) Exit
-
- line = Adjustl(line)
- If ( line(1:1) == '!' .Or. line == '' ) Then
- Cycle !skip blank/comment lines
- Else If ( .Not. sectionfound ) Then
- !check for a section name
- Do i = 1, nsections
- If ( section_types(i) == line ) Then
- sectionfound = .True.
- section = section_types(i)
- Exit
- End If
- End Do
- Else
- !reposition file at the start of the line and exit
- Backspace( fileunit )
- Exit readfile
- End If
-
- End Do readfile
-
-
-
-End Subroutine rttov_findnextsection
diff --git a/src/LIB/RTTOV/src/rttov_findnextsection.interface b/src/LIB/RTTOV/src/rttov_findnextsection.interface
deleted file mode 100644
index 83b8b7729bb2f64107d4377869f83af0c1d5ed3a..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_findnextsection.interface
+++ /dev/null
@@ -1,18 +0,0 @@
-Interface
-!
-Subroutine rttov_findnextsection( fileunit,readstatus,section )
- Use rttov_const, Only : &
- nsections ,&
- section_types
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
- Integer(Kind=jpim), Intent(in) :: fileunit
- Integer(Kind=jpim), Intent(out) :: readstatus
- Character(len=21), Intent(out) :: section
-
-
-
-End Subroutine rttov_findnextsection
-End Interface
diff --git a/src/LIB/RTTOV/src/rttov_global.F90 b/src/LIB/RTTOV/src/rttov_global.F90
deleted file mode 100644
index bdaa50dc4c17648cc91c1a3bd0f6b41584835b03..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_global.F90
+++ /dev/null
@@ -1,39 +0,0 @@
-!
-Module rttov_global
- ! Description:
- ! Definition of global variables) for RTTOV
- !
- ! Copyright:
- ! This software was developed within the context of
- ! the EUMETSAT Satellite Application Facility on
- ! Numerical Weather Prediction (NWP SAF), under the
- ! Cooperation Agreement dated 25 November 1998, between
- ! EUMETSAT and the Met Office, UK, by one or more partners
- ! within the NWP SAF. The partners in the NWP SAF are
- ! the Met Office, ECMWF, KNMI and MeteoFrance.
- !
- ! Copyright 2002, EUMETSAT, All Rights Reserved.
- !
- ! History:
- ! Version Date Comment
- ! ------- ---- -------
- ! 1.0 10/01/2003 Original (P Brunel)
- !
- Use rttov_const, Only : &
- NerrorStatus
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
- !- End of header --------------------------------------------------------
-
- !1. error reporting
- !------------------
- Integer(Kind=jpim) :: error_unit ! logical unit for the error messages
-
- Logical :: verbose_message(0:nerrorstatus) !verbose flag for each error level
-
- Logical :: err_init ! true if module already initialised
-
- Data err_init/.false./
-
-End Module rttov_global
diff --git a/src/LIB/RTTOV/src/rttov_iniedd.F90 b/src/LIB/RTTOV/src/rttov_iniedd.F90
deleted file mode 100644
index 3ff956a3b2b6e26335c6dd39613e382ce1a02936..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_iniedd.F90
+++ /dev/null
@@ -1,125 +0,0 @@
-Subroutine rttov_iniedd (&
- & nwp_levels, &! in
- & nchannels , &! in
- & nprofiles , &! in
- & lprofiles , &! in
- & angles , &! in
- & coef_scatt, &! in
- & scatt_aux) ! inout
-
- ! Description:
- ! to compute variables specific to Eddington approximation to RT
- !
- ! Copyright:
- ! This software was developed within the context of
- ! the EUMETSAT Satellite Application Facility on
- ! Numerical Weather Prediction (NWP SAF), under the
- ! Cooperation Agreement dated 25 November 1998, between
- ! EUMETSAT and the Met Office, UK, by one or more partners
- ! within the NWP SAF. The partners in the NWP SAF are
- ! the Met Office, ECMWF, KNMI and MeteoFrance.
- !
- ! Copyright 2002, EUMETSAT, All Rights Reserved.
- !
- ! Method:
- ! - Bauer, P., 2002: Microwave radiative transfer modeling in clouds and precipitation.
- ! Part I: Model description.
- ! NWP SAF Report No. NWPSAF-EC-TR-005, 27 pp.
- ! - Chevallier, F., and P. Bauer, 2003:
- ! Model rain and clouds over oceans: comparison with SSM/I observations.
- ! Mon. Wea. Rev., 131, 1240-1255.
- ! - Moreau, E., P. Bauer and F. Chevallier, 2002: Microwave radiative transfer modeling in clouds and precipitation.
- ! Part II: Model evaluation.
- ! NWP SAF Report No. NWPSAF-EC-TR-006, 27 pp.
- !
- ! Current Code Owner: SAF NWP
- !
- ! History:
- ! Version Date Comment
- ! ------- ---- -------
- ! 1.0 09/2002 Initial version (P. Bauer, E. Moreau)
- ! 1.1 05/2003 RTTOV7.3 compatible (F. Chevallier)
- ! 1.2 03/2004 Added polarimetry (R. Saunders)
- ! 1.3 08/2004 Polarimetry fixes (U. O'Keefe)
- ! 1.4 11/2004 Clean-up (P. Bauer)
- !
- ! Code Description:
- ! Language: Fortran 90.
- ! Software Standards: "European Standards for Writing and
- ! Documenting Exchangeable Fortran 90 Code".
- !
- ! Declarations:
- ! Modules used:
- ! Imported Type Definitions:
-
- Use rttov_types, Only : &
- & geometry_Type ,&
- & profile_cloud_Type ,&
- & rttov_scatt_coef ,&
- & profile_scatt_aux
-
- Use parkind1, Only : jpim ,jprb
-
- Implicit None
-
-!* Subroutine arguments:
- Integer (Kind=jpim), Intent (in) :: nwp_levels ! Number of levels
- Integer (Kind=jpim), Intent (in) :: nprofiles ! Number of profiles
- Integer (Kind=jpim), Intent (in) :: nchannels ! Number of channels*profiles=radiances
- Integer (Kind=jpim), Intent (in) :: lprofiles (nchannels) ! Profile indices
-
- Type (geometry_Type), Intent (in) :: angles (nprofiles) ! Zenith angles
- Type (rttov_scatt_coef), Intent (in) :: coef_scatt ! RTTOV_SCATT Coefficients
- Type (profile_scatt_aux), Intent (inout) :: scatt_aux ! Auxiliary profile variables
-
-!* Local variables
- Integer (Kind=jpim) :: ilayer, iprof, ichan
-
- !- End of header --------------------------------------------------------
-
- scatt_aux % delta = 0.0_JPRB
- scatt_aux % lambda = 0.0_JPRB
- scatt_aux % h = 0.0_JPRB
- scatt_aux % tau = 1.0_JPRB
-
- scatt_aux % mclayer = 0
-
-!* Layer interface temperatures, lapse rates
- do ilayer = 1, nwp_levels
- scatt_aux % b0 (:,ilayer) = scatt_aux % tbd (:,ilayer+1)
- scatt_aux % bn (:,ilayer) = scatt_aux % tbd (:,ilayer )
- scatt_aux % b1 (:,ilayer) = (scatt_aux % bn (:,ilayer) - scatt_aux % b0 (:,ilayer)) / scatt_aux % dz (:,ilayer)
- end do
-
-!* Delta-scaling
- do ichan = 1, nchannels
- iprof = lprofiles (ichan)
-
- scatt_aux % ext (ichan,:) = (1.0_JPRB - scatt_aux % ssa (ichan,:) * scatt_aux % asm (ichan,:) &
- & * scatt_aux % asm (ichan,:)) * scatt_aux % ext (ichan,:)
- scatt_aux % ssa (ichan,:) = (1.0_JPRB - scatt_aux % asm (ichan,:) * scatt_aux % asm (ichan,:)) &
- & * scatt_aux % ssa (ichan,:) / (1.0_JPRB - scatt_aux % asm (ichan,:) &
- & * scatt_aux % asm (ichan,:) * scatt_aux % ssa (ichan,:))
- scatt_aux % asm (ichan,:) = scatt_aux % asm (ichan,:) / (1.0_JPRB + scatt_aux % asm (ichan,:))
-
- scatt_aux % delta (ichan,:) = (scatt_aux % ext (ichan,:) * scatt_aux % dz (iprof,:)) / angles (iprof) % coszen
-
- where (scatt_aux % delta (ichan,:) >= 30.0_JPRB) scatt_aux % delta (ichan,:) = 30.0_JPRB
-
- scatt_aux % tau (ichan,:) = 1.0_JPRB / exp (scatt_aux % delta (ichan,:))
- scatt_aux % lambda (ichan,:) = sqrt (3.0_JPRB * scatt_aux % ext (ichan,:) * scatt_aux % ext (ichan,:) &
- & * (1.0_JPRB - scatt_aux % ssa (ichan,:)) &
- & * (1.0_JPRB - scatt_aux % ssa (ichan,:) * scatt_aux % asm (ichan,:)))
- scatt_aux % h (ichan,:) = 1.5_JPRB * scatt_aux % ext (ichan,:) * (1.0_JPRB - scatt_aux % ssa (ichan,:) &
- & * scatt_aux % asm (ichan,:))
- where (scatt_aux % h (ichan,:) <= 0.00001_JPRB) scatt_aux % h (ichan,:) = 0.00001_JPRB
-
-!* Cloud top level index
- scatt_aux % mclayer (ichan) = nwp_levels - 2
- do ilayer = 1, nwp_levels - 2
- if (scatt_aux % ssa (ichan,ilayer) > 0.0_JPRB .and. ilayer < scatt_aux % mclayer (ichan)) &
- scatt_aux % mclayer (ichan) = ilayer
- end do
- end do
-
-End subroutine rttov_iniedd
diff --git a/src/LIB/RTTOV/src/rttov_iniedd.interface b/src/LIB/RTTOV/src/rttov_iniedd.interface
deleted file mode 100644
index 0b8cbb60c28f78fbd540a0fe6186dafba5dd8500..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_iniedd.interface
+++ /dev/null
@@ -1,24 +0,0 @@
-INTERFACE
-Subroutine rttov_iniedd (&
- & nwp_levels,&
- & nchannels ,&
- & nprofiles ,&
- & lprofiles ,&
- & angles ,&
- & coef_scatt,&
- & scatt_aux)
- Use rttov_types, Only :&
- & geometry_Type ,&
- & profile_cloud_Type ,&
- & rttov_scatt_coef ,&
- & profile_scatt_aux
- Use parkind1, Only : jpim ,jprb
- Integer (Kind=jpim), Intent (in) :: nwp_levels
- Integer (Kind=jpim), Intent (in) :: nprofiles
- Integer (Kind=jpim), Intent (in) :: nchannels
- Integer (Kind=jpim), Intent (in) :: lprofiles (nchannels)
- Type (geometry_Type), Intent (in) :: angles (nprofiles)
- Type (rttov_scatt_coef), Intent (in) :: coef_scatt
- Type (profile_scatt_aux), Intent (inout) :: scatt_aux
-End subroutine rttov_iniedd
-END INTERFACE
diff --git a/src/LIB/RTTOV/src/rttov_iniedd_ad.F90 b/src/LIB/RTTOV/src/rttov_iniedd_ad.F90
deleted file mode 100644
index 7dc93da2c58bc717d649b9eb38e1fe1fb3a6c13a..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_iniedd_ad.F90
+++ /dev/null
@@ -1,206 +0,0 @@
-Subroutine rttov_iniedd_ad (&
- & nwp_levels, &! in
- & nchannels , &! in
- & nprofiles , &! in
- & lprofiles , &! in
- & angles , &! in
- & coef_scatt, &! in
- & scatt_aux, &! inout
- & scatt_aux_ad) ! inout
-
- ! Description:
- ! AD of routine
- ! to compute variables specific to Eddington approximation to RT
- !
- ! Copyright:
- ! This software was developed within the context of
- ! the EUMETSAT Satellite Application Facility on
- ! Numerical Weather Prediction (NWP SAF), under the
- ! Cooperation Agreement dated 25 November 1998, between
- ! EUMETSAT and the Met Office, UK, by one or more partners
- ! within the NWP SAF. The partners in the NWP SAF are
- ! the Met Office, ECMWF, KNMI and MeteoFrance.
- !
- ! Copyright 2002, EUMETSAT, All Rights Reserved.
- !
- ! Method:
- ! - Bauer, P., 2002: Microwave radiative transfer modeling in clouds and precipitation.
- ! Part I: Model description.
- ! NWP SAF Report No. NWPSAF-EC-TR-005, 27 pp.
- ! - Chevallier, F., and P. Bauer, 2003:
- ! Model rain and clouds over oceans: comparison with SSM/I observations.
- ! Mon. Wea. Rev., 131, 1240-1255.
- ! - Moreau, E., P. Bauer and F. Chevallier, 2002: Microwave radiative transfer modeling in clouds and precipitation.
- ! Part II: Model evaluation.
- ! NWP SAF Report No. NWPSAF-EC-TR-006, 27 pp.
- !
- ! Current Code Owner: SAF NWP
- !
- ! History:
- ! Version Date Comment
- ! ------- ---- -------
- ! 1.0 09/2002 Initial version (P. Bauer, E. Moreau)
- ! 1.1 05/2003 RTTOV7.3 compatible (F. Chevallier)
- ! 1.2 03/2004 Added polarimetry (R. Saunders)
- ! 1.3 08/2004 Polarimetry fixes (U. O'Keefe)
- ! 1.4 11/2004 Clean-up (P. Bauer)
- !
- ! Code Description:
- ! Language: Fortran 90.
- ! Software Standards: "European Standards for Writing and
- ! Documenting Exchangeable Fortran 90 Code".
- !
- ! Declarations:
- ! Modules used:
- ! Imported Type Definitions:
-
- Use rttov_types, Only : &
- & geometry_Type ,&
- & profile_cloud_Type ,&
- & rttov_scatt_coef ,&
- & profile_scatt_aux
-
- Use parkind1, Only : jpim ,jprb
-
- Implicit None
-
-!* Subroutine arguments:
- Integer (Kind=jpim), Intent (in) :: nwp_levels ! Number of levels
- Integer (Kind=jpim), Intent (in) :: nprofiles ! Number of profiles
- Integer (Kind=jpim), Intent (in) :: nchannels ! Number of radiances
- Integer (Kind=jpim), Intent (in) :: lprofiles (nchannels) ! Profile indices
-
- Type (geometry_Type), Intent (in) :: angles (nprofiles) ! Zenith angles
- Type (rttov_scatt_coef), Intent (in) :: coef_scatt ! RTTOV_SCATT Coefficients
- Type (profile_scatt_aux), Intent (inout) :: scatt_aux ! Auxiliary profile variables
- Type (profile_scatt_aux), Intent (inout) :: scatt_aux_ad ! Auxiliary profile variables
-
-!* Local variables
- Real (Kind=jprb), dimension (nchannels,nwp_levels) :: ext_in, ssa_in, asm_in
- Real (Kind=jprb), dimension (nwp_levels) :: fac
- Integer (Kind=jpim) :: ilayer, iprof, ichan
-
- !- End of header --------------------------------------------------------
-
- scatt_aux % delta = 0.0_JPRB
- scatt_aux % lambda = 0.0_JPRB
- scatt_aux % h = 0.0_JPRB
- scatt_aux % tau = 1.0_JPRB
-
- scatt_aux % mclayer = 0
-
- ext_in (:,:) = scatt_aux % ext (:,:)
- ssa_in (:,:) = scatt_aux % ssa (:,:)
- asm_in (:,:) = scatt_aux % asm (:,:)
-
-!* Layer interface temperatures, lapse rates
- do ilayer = nwp_levels, 1, -1
- scatt_aux % b0 (:,ilayer) = scatt_aux % tbd (:,ilayer+1)
- scatt_aux % bn (:,ilayer) = scatt_aux % tbd (:,ilayer )
- scatt_aux % b1 (:,ilayer) = (scatt_aux % bn (:,ilayer) - scatt_aux % b0 (:,ilayer)) / scatt_aux % dz (:,ilayer)
-
- scatt_aux_ad % bn (:,ilayer) = scatt_aux_ad % bn (:,ilayer) + scatt_aux_ad % b1 (:,ilayer) / scatt_aux % dz (:,ilayer)
- scatt_aux_ad % b0 (:,ilayer) = scatt_aux_ad % b0 (:,ilayer) - scatt_aux_ad % b1 (:,ilayer) / scatt_aux % dz (:,ilayer)
- scatt_aux_ad % dz (:,ilayer) = scatt_aux_ad % dz (:,ilayer) - scatt_aux_ad % b1 (:,ilayer) * (scatt_aux % bn (:,ilayer) &
- & - scatt_aux % b0 (:,ilayer)) / (scatt_aux % dz (:,ilayer) * scatt_aux % dz (:,ilayer))
- scatt_aux_ad % b1 (:,ilayer) = 0.0_JPRB
-
- scatt_aux_ad % tbd (:,ilayer ) = scatt_aux_ad % tbd (:,ilayer ) + scatt_aux_ad % bn (:,ilayer)
- scatt_aux_ad % bn (:,ilayer) = 0.0_JPRB
-
- scatt_aux_ad % tbd (:,ilayer+1) = scatt_aux_ad % tbd (:,ilayer+1) + scatt_aux_ad % b0 (:,ilayer)
- scatt_aux_ad % b0 (:,ilayer) = 0.0_JPRB
- end do
-
-!* Delta-scaling
- do ichan = 1, nchannels
- iprof = lprofiles (ichan)
-
- scatt_aux % ext (ichan,:) = (1.0_JPRB - scatt_aux % ssa (ichan,:) * scatt_aux % asm (ichan,:) &
- & * scatt_aux % asm (ichan,:)) * scatt_aux % ext (ichan,:)
- scatt_aux % ssa (ichan,:) = (1.0_JPRB - scatt_aux % asm (ichan,:) * scatt_aux % asm (ichan,:)) &
- & * scatt_aux % ssa (ichan,:) / (1.0_JPRB - scatt_aux % asm (ichan,:) &
- & * scatt_aux % asm (ichan,:) * scatt_aux % ssa (ichan,:))
- scatt_aux % asm (ichan,:) = scatt_aux % asm (ichan,:) / (1.0_JPRB + scatt_aux % asm (ichan,:))
-
- scatt_aux % delta (ichan,:) = (scatt_aux % ext (ichan,:) * scatt_aux % dz (iprof,:)) / angles (iprof) % coszen
-
- where (scatt_aux % delta (ichan,:) >= 30.0_JPRB) scatt_aux % delta (ichan,:) = 30.0_JPRB
-
- scatt_aux % tau (ichan,:) = 1.0_JPRB / exp (scatt_aux % delta (ichan,:))
-
- scatt_aux % lambda (ichan,:) = sqrt (3.0_JPRB * scatt_aux % ext (ichan,:) * scatt_aux % ext (ichan,:) &
- & * (1.0_JPRB - scatt_aux % ssa (ichan,:)) &
- & * (1.0_JPRB - scatt_aux % ssa (ichan,:) * scatt_aux % asm (ichan,:)))
- scatt_aux % h (ichan,:) = 1.5_JPRB * scatt_aux % ext (ichan,:) * (1.0_JPRB - scatt_aux % ssa (ichan,:) &
- & * scatt_aux % asm (ichan,:))
-
- where (scatt_aux % h (ichan,:) < 0.00001_JPRB)
- scatt_aux % h (ichan,:) = 0.00001_JPRB
- scatt_aux_ad % h (ichan,:) = 0.0_JPRB
- endwhere
-
-!* Cloud top level index
- scatt_aux % mclayer (ichan) = nwp_levels - 2
- do ilayer = 1, nwp_levels - 2
- if (scatt_aux % ssa (ichan,ilayer) > 0.0_JPRB .and. ilayer < scatt_aux % mclayer (ichan)) &
- scatt_aux % mclayer (ichan) = ilayer
- end do
-
-!* h
- scatt_aux_ad % ext (ichan,:) = scatt_aux_ad % ext (ichan,:) + 1.5_JPRB * scatt_aux_ad % h (ichan,:) &
- & * (1.0_JPRB - scatt_aux % ssa (ichan,:) * scatt_aux % asm (ichan,:))
- scatt_aux_ad % ssa (ichan,:) = scatt_aux_ad % ssa (ichan,:) - 1.5_JPRB * scatt_aux_ad % h (ichan,:) &
- & * scatt_aux % ext (ichan,:) * scatt_aux % asm (ichan,:)
- scatt_aux_ad % asm (ichan,:) = scatt_aux_ad % asm (ichan,:) - 1.5_JPRB * scatt_aux_ad % h (ichan,:) &
- & * scatt_aux % ext (ichan,:) * scatt_aux % ssa (ichan,:)
- scatt_aux_ad % h (ichan,:) = 0.0_JPRB
-
-!* lambda
- fac (:) = (1.0_JPRB / ( 2.0_JPRB * sqrt (3.0_JPRB * scatt_aux % ext (ichan,:) * scatt_aux % ext (ichan,:) &
- & * (1.0_JPRB - scatt_aux % ssa (ichan,:)) * (1.0_JPRB - scatt_aux % ssa (ichan,:) * scatt_aux % asm (ichan,:)))))
- scatt_aux_ad % ext (ichan,:) = scatt_aux_ad % ext (ichan,:) + fac(:) * 6.0_JPRB * scatt_aux_ad % lambda (ichan,:) &
- & * scatt_aux % ext (ichan,:) * (1.0_JPRB - scatt_aux % ssa (ichan,:)) &
- & * (1.0_JPRB - scatt_aux % ssa (ichan,:) * scatt_aux % asm (ichan,:))
- scatt_aux_ad % ssa (ichan,:) = scatt_aux_ad % ssa (ichan,:) - fac (:) * 3.0_JPRB &
- & * scatt_aux_ad % lambda (ichan,:) &
- & * scatt_aux % ext (ichan,:) * scatt_aux % ext (ichan,:) &
- & * (1.0_JPRB + scatt_aux % asm (ichan,:) - 2.0_JPRB * scatt_aux % ssa (ichan,:) &
- & * scatt_aux % asm (ichan,:))
- scatt_aux_ad % asm (ichan,:) = scatt_aux_ad % asm (ichan,:) - fac(:) * 3.0_JPRB &
- & * scatt_aux_ad % lambda (ichan,:) &
- & * scatt_aux % ext (ichan,:) * scatt_aux % ext (ichan,:) &
- & * (1.0_JPRB - scatt_aux % ssa (ichan,:)) * scatt_aux % ssa (ichan,:)
- scatt_aux_ad % lambda (ichan,:) = 0.0_JPRB
-
-!* tau
- scatt_aux_ad % delta (ichan,:) = scatt_aux_ad % delta (ichan,:) - scatt_aux_ad % tau (ichan,:) * scatt_aux % tau (ichan,:)
- scatt_aux_ad % tau (ichan,:) = 0.0_JPRB
-
-!* delta
- where (scatt_aux % delta (ichan,:) == 30.0_JPRB) scatt_aux_ad % delta (ichan,:) = 0.0_JPRB
-
- scatt_aux_ad % ext (ichan,:) = scatt_aux_ad % ext (ichan,:) + scatt_aux_ad % delta (ichan,:) &
- & * scatt_aux % dz (iprof,:) / angles (iprof) % coszen
- scatt_aux_ad % dz (iprof,:) = scatt_aux_ad % dz (iprof,:) + scatt_aux_ad % delta (ichan,:) &
- & * scatt_aux % ext (ichan,:) / angles (iprof) % coszen
- scatt_aux_ad % delta (ichan,:) = 0.0_JPRB
-
-!* ext,ssa,asm
- scatt_aux_ad % asm (ichan,:) = scatt_aux_ad % asm (ichan,:) / (1.0_JPRB + asm_in (ichan,:)) / (1.0_JPRB + asm_in (ichan,:))
- fac (:) = 1.0_JPRB - asm_in (ichan,:) * asm_in (ichan,:) * ssa_in (ichan,:)
- scatt_aux_ad % asm (ichan,:) = scatt_aux_ad % asm (ichan,:) - scatt_aux_ad % ssa (ichan,:) * (1.0_JPRB - ssa_in (ichan,:)) &
- & * 2.0_JPRB * asm_in (ichan,:) * ssa_in (ichan,:) / fac (:) / fac (:)
- scatt_aux_ad % ssa (ichan,:) = scatt_aux_ad % ssa (ichan,:) * (1.0_JPRB - asm_in (ichan,:) &
- & * asm_in(ichan,:)) / fac (:) / fac (:)
-
- scatt_aux_ad % asm (ichan,:) = scatt_aux_ad % asm (ichan,:) - 2.0_JPRB * scatt_aux_ad % ext (ichan,:) * ext_in (ichan,:) &
- & * asm_in (ichan,:) * ssa_in (ichan,:)
- scatt_aux_ad % ssa (ichan,:) = scatt_aux_ad % ssa (ichan,:) - scatt_aux_ad % ext (ichan,:) * ext_in(ichan,:) &
- & * asm_in (ichan,:) * asm_in (ichan,:)
- scatt_aux_ad % ext (ichan,:) = scatt_aux_ad % ext (ichan,:) * (1.0_JPRB - ssa_in (ichan,:) &
- & * asm_in(ichan,:) * asm_in (ichan,:))
- end do
-
-End subroutine rttov_iniedd_ad
-
diff --git a/src/LIB/RTTOV/src/rttov_iniedd_ad.interface b/src/LIB/RTTOV/src/rttov_iniedd_ad.interface
deleted file mode 100644
index 9a3d569b43950588a8b7ae075ce97958df113dbe..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_iniedd_ad.interface
+++ /dev/null
@@ -1,26 +0,0 @@
-INTERFACE
-Subroutine rttov_iniedd_ad (&
- & nwp_levels,&
- & nchannels ,&
- & nprofiles ,&
- & lprofiles ,&
- & angles ,&
- & coef_scatt,&
- & scatt_aux,&
- & scatt_aux_ad)
- Use rttov_types, Only :&
- & geometry_Type ,&
- & profile_cloud_Type ,&
- & rttov_scatt_coef ,&
- & profile_scatt_aux
- Use parkind1, Only : jpim ,jprb
- Integer (Kind=jpim), Intent (in) :: nwp_levels
- Integer (Kind=jpim), Intent (in) :: nprofiles
- Integer (Kind=jpim), Intent (in) :: nchannels
- Integer (Kind=jpim), Intent (in) :: lprofiles (nchannels)
- Type (geometry_Type), Intent (in) :: angles (nprofiles)
- Type (rttov_scatt_coef), Intent (in) :: coef_scatt
- Type (profile_scatt_aux), Intent (inout) :: scatt_aux
- Type (profile_scatt_aux), Intent (inout) :: scatt_aux_ad
-End subroutine rttov_iniedd_ad
-END INTERFACE
diff --git a/src/LIB/RTTOV/src/rttov_iniedd_k.F90 b/src/LIB/RTTOV/src/rttov_iniedd_k.F90
deleted file mode 100644
index aa30fc7279d3416140ba234804fbb3ff3c69cf89..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_iniedd_k.F90
+++ /dev/null
@@ -1,217 +0,0 @@
-Subroutine rttov_iniedd_k (&
- & nwp_levels, &! in
- & nchannels , &! in
- & nprofiles , &! in
- & lprofiles , &! in
- & angles , &! in
- & coef_scatt, &! in
- & scatt_aux, &! inout
- & scatt_aux_k) ! inout
-
- ! Description:
- ! AD of routine
- ! to compute variables specific to Eddington approximation to RT
- !
- ! Copyright:
- ! This software was developed within the context of
- ! the EUMETSAT Satellite Application Facility on
- ! Numerical Weather Prediction (NWP SAF), under the
- ! Cooperation Agreement dated 25 November 1998, between
- ! EUMETSAT and the Met Office, UK, by one or more partners
- ! within the NWP SAF. The partners in the NWP SAF are
- ! the Met Office, ECMWF, KNMI and MeteoFrance.
- !
- ! Copyright 2002, EUMETSAT, All Rights Reserved.
- !
- ! Method:
- ! - Bauer, P., 2002: Microwave radiative transfer modeling in clouds and precipitation.
- ! Part I: Model description.
- ! NWP SAF Report No. NWPSAF-EC-TR-005, 27 pp.
- ! - Chevallier, F., and P. Bauer, 2003:
- ! Model rain and clouds over oceans: comparison with SSM/I observations.
- ! Mon. Wea. Rev., 131, 1240-1255.
- ! - Moreau, E., P. Bauer and F. Chevallier, 2002: Microwave radiative transfer modeling in clouds and precipitation.
- ! Part II: Model evaluation.
- ! NWP SAF Report No. NWPSAF-EC-TR-006, 27 pp.
- !
- ! Current Code Owner: SAF NWP
- !
- ! History:
- ! Version Date Comment
- ! ------- ---- -------
- ! 1.0 09/2002 Initial version (P. Bauer, E. Moreau)
- ! 1.1 05/2003 RTTOV7.3 compatible (F. Chevallier)
- ! 1.2 03/2004 Added polarimetry (R. Saunders)
- ! 1.3 08/2004 Polarimetry fixes (U. O'Keefe)
- ! 1.4 11/2004 Clean-up (P. Bauer)
- ! 1.5 02/2005 K-Code (A. Collard)
- !
- ! Code Description:
- ! Language: Fortran 90.
- ! Software Standards: "European Standards for Writing and
- ! Documenting Exchangeable Fortran 90 Code".
- !
- ! Declarations:
- ! Modules used:
- ! Imported Type Definitions:
-
- Use rttov_types, Only : &
- & geometry_Type ,&
- & profile_cloud_Type ,&
- & rttov_scatt_coef ,&
- & profile_scatt_aux
-
- Use parkind1, Only : jpim ,jprb
-
- Implicit None
-
-!* Subroutine arguments:
- Integer (Kind=jpim), Intent (in) :: nwp_levels ! Number of levels
- Integer (Kind=jpim), Intent (in) :: nprofiles ! Number of profiles
- Integer (Kind=jpim), Intent (in) :: nchannels ! Number of radiances
- Integer (Kind=jpim), Intent (in) :: lprofiles (nchannels) ! Profile indices
-
- Type (geometry_Type), Intent (in) :: angles (nprofiles) ! Zenith angles
- Type (rttov_scatt_coef), Intent (in) :: coef_scatt ! RTTOV_SCATT Coefficients
- Type (profile_scatt_aux), Intent (inout) :: scatt_aux ! Auxiliary profile variables
- Type (profile_scatt_aux), Intent (inout) :: scatt_aux_k ! Auxiliary profile variables
-
-!* Local variables
- Real (Kind=jprb), dimension (nchannels,nwp_levels) :: ext_in, ssa_in, asm_in
- Real (Kind=jprb), dimension (nwp_levels) :: fac
- Integer (Kind=jpim) :: ilayer, iprof, ichan
-
- !- End of header --------------------------------------------------------
-
- scatt_aux % delta = 0.0_JPRB
- scatt_aux % lambda = 0.0_JPRB
- scatt_aux % h = 0.0_JPRB
- scatt_aux % tau = 1.0_JPRB
-
- scatt_aux % mclayer = 0
-
- ext_in (:,:) = scatt_aux % ext (:,:)
- ssa_in (:,:) = scatt_aux % ssa (:,:)
- asm_in (:,:) = scatt_aux % asm (:,:)
-
-!* Layer interface temperatures, lapse rates
- do ilayer = nwp_levels, 1, -1
- do ichan = 1, nchannels
- iprof = lprofiles (ichan)
- scatt_aux % b0 (iprof,ilayer) = scatt_aux % tbd (iprof,ilayer+1)
- scatt_aux % bn (iprof,ilayer) = scatt_aux % tbd (iprof,ilayer )
- scatt_aux % b1 (iprof,ilayer) = (scatt_aux % bn (iprof,ilayer) - scatt_aux % b0 (iprof,ilayer)) &
- & / scatt_aux % dz (iprof,ilayer)
-
- scatt_aux_k % bn (ichan,ilayer) = scatt_aux_k % bn (ichan,ilayer) &
- & + scatt_aux_k % b1 (ichan,ilayer) / scatt_aux % dz (iprof,ilayer)
- scatt_aux_k % b0 (ichan,ilayer) = scatt_aux_k % b0 (ichan,ilayer) &
- & - scatt_aux_k % b1 (ichan,ilayer) / scatt_aux % dz (iprof,ilayer)
- scatt_aux_k % dz (ichan,ilayer) = scatt_aux_k % dz (ichan,ilayer) &
- & - scatt_aux_k % b1 (ichan,ilayer) * (scatt_aux % bn (iprof,ilayer) &
- & - scatt_aux % b0 (iprof,ilayer)) / (scatt_aux % dz (iprof,ilayer) &
- & * scatt_aux % dz (iprof,ilayer))
- scatt_aux_k % b1 (ichan,ilayer) = 0.0_JPRB
-
- scatt_aux_k % tbd (ichan,ilayer ) = scatt_aux_k % tbd (ichan,ilayer ) + scatt_aux_k % bn (ichan,ilayer)
- scatt_aux_k % bn (ichan,ilayer) = 0.0_JPRB
-
- scatt_aux_k % tbd (ichan,ilayer+1) = scatt_aux_k % tbd (ichan,ilayer+1) + scatt_aux_k % b0 (ichan,ilayer)
- scatt_aux_k % b0 (ichan,ilayer) = 0.0_JPRB
- end do
- end do
-
-!* Delta-scaling
- do ichan = 1, nchannels
- iprof = lprofiles (ichan)
-
- scatt_aux % ext (ichan,:) = (1.0_JPRB - scatt_aux % ssa (ichan,:) * scatt_aux % asm (ichan,:) &
- & * scatt_aux % asm (ichan,:)) * scatt_aux % ext (ichan,:)
- scatt_aux % ssa (ichan,:) = (1.0_JPRB - scatt_aux % asm (ichan,:) * scatt_aux % asm (ichan,:)) &
- & * scatt_aux % ssa (ichan,:) / (1.0_JPRB - scatt_aux % asm (ichan,:) &
- & * scatt_aux % asm (ichan,:) * scatt_aux % ssa (ichan,:))
- scatt_aux % asm (ichan,:) = scatt_aux % asm (ichan,:) / (1.0_JPRB + scatt_aux % asm (ichan,:))
-
- scatt_aux % delta (ichan,:) = (scatt_aux % ext (ichan,:) * scatt_aux % dz (iprof,:)) / angles (iprof) % coszen
-
- where (scatt_aux % delta (ichan,:) >= 30.0_JPRB) scatt_aux % delta (ichan,:) = 30.0_JPRB
-
- scatt_aux % tau (ichan,:) = 1.0_JPRB / exp (scatt_aux % delta (ichan,:))
-
- scatt_aux % lambda (ichan,:) = sqrt (3.0_JPRB * scatt_aux % ext (ichan,:) * scatt_aux % ext (ichan,:) &
- & * (1.0_JPRB - scatt_aux % ssa (ichan,:)) &
- & * (1.0_JPRB - scatt_aux % ssa (ichan,:) * scatt_aux % asm (ichan,:)))
- scatt_aux % h (ichan,:) = 1.5_JPRB * scatt_aux % ext (ichan,:) * (1.0_JPRB - scatt_aux % ssa (ichan,:) &
- & * scatt_aux % asm (ichan,:))
-
- where (scatt_aux % h (ichan,:) < 0.00001_JPRB)
- scatt_aux % h (ichan,:) = 0.00001_JPRB
- scatt_aux_k % h (ichan,:) = 0.0_JPRB
- endwhere
-
-!* Cloud top level index
- scatt_aux % mclayer (ichan) = nwp_levels - 2
- do ilayer = 1, nwp_levels - 2
- if (scatt_aux % ssa (ichan,ilayer) > 0.0_JPRB .and. ilayer < scatt_aux % mclayer (ichan)) &
- scatt_aux % mclayer (ichan) = ilayer
- end do
-
-!* h
- scatt_aux_k % ext (ichan,:) = scatt_aux_k % ext (ichan,:) + 1.5_JPRB * scatt_aux_k % h (ichan,:) &
- & * (1.0_JPRB - scatt_aux % ssa (ichan,:) * scatt_aux % asm (ichan,:))
- scatt_aux_k % ssa (ichan,:) = scatt_aux_k % ssa (ichan,:) - 1.5_JPRB * scatt_aux_k % h (ichan,:) &
- & * scatt_aux % ext (ichan,:) * scatt_aux % asm (ichan,:)
- scatt_aux_k % asm (ichan,:) = scatt_aux_k % asm (ichan,:) - 1.5_JPRB * scatt_aux_k % h (ichan,:) &
- & * scatt_aux % ext (ichan,:) * scatt_aux % ssa (ichan,:)
- scatt_aux_k % h (ichan,:) = 0.0_JPRB
-
-!* lambda
- fac (:) = (1.0_JPRB / ( 2.0_JPRB * sqrt (3.0_JPRB * scatt_aux % ext (ichan,:) * scatt_aux % ext (ichan,:) &
- & * (1.0_JPRB - scatt_aux % ssa (ichan,:)) * (1.0_JPRB - scatt_aux % ssa (ichan,:) * scatt_aux % asm (ichan,:)))))
- scatt_aux_k % ext (ichan,:) = scatt_aux_k % ext (ichan,:) + fac(:) * 6.0_JPRB * scatt_aux_k % lambda (ichan,:) &
- & * scatt_aux % ext (ichan,:) * (1.0_JPRB - scatt_aux % ssa (ichan,:)) &
- & * (1.0_JPRB - scatt_aux % ssa (ichan,:) * scatt_aux % asm (ichan,:))
- scatt_aux_k % ssa (ichan,:) = scatt_aux_k % ssa (ichan,:) - fac (:) * 3.0_JPRB &
- & * scatt_aux_k % lambda (ichan,:) &
- & * scatt_aux % ext (ichan,:) * scatt_aux % ext (ichan,:) &
- & * (1.0_JPRB + scatt_aux % asm (ichan,:) - 2.0_JPRB * scatt_aux % ssa (ichan,:) &
- & * scatt_aux % asm (ichan,:))
- scatt_aux_k % asm (ichan,:) = scatt_aux_k % asm (ichan,:) - fac(:) * 3.0_JPRB &
- & * scatt_aux_k % lambda (ichan,:) &
- & * scatt_aux % ext (ichan,:) * scatt_aux % ext (ichan,:) &
- & * (1.0_JPRB - scatt_aux % ssa (ichan,:)) * scatt_aux % ssa (ichan,:)
- scatt_aux_k % lambda (ichan,:) = 0.0_JPRB
-
-!* tau
- scatt_aux_k % delta (ichan,:) = scatt_aux_k % delta (ichan,:) - scatt_aux_k % tau (ichan,:) * scatt_aux % tau (ichan,:)
- scatt_aux_k % tau (ichan,:) = 0.0_JPRB
-
-!* delta
- where (scatt_aux % delta (ichan,:) == 30.0_JPRB) scatt_aux_k % delta (ichan,:) = 0.0_JPRB
-
- scatt_aux_k % ext (ichan,:) = scatt_aux_k % ext (ichan,:) + scatt_aux_k % delta (ichan,:) &
- & * scatt_aux % dz (iprof,:) / angles (iprof) % coszen
- scatt_aux_k % dz (ichan,:) = scatt_aux_k % dz (ichan,:) + scatt_aux_k % delta (ichan,:) &
- & * scatt_aux % ext (ichan,:) / angles (iprof) % coszen
- scatt_aux_k % delta (ichan,:) = 0.0_JPRB
-
-!* ext,ssa,asm
- scatt_aux_k % asm (ichan,:) = scatt_aux_k % asm (ichan,:) / (1.0_JPRB + asm_in (ichan,:)) &
- & / (1.0_JPRB + asm_in (ichan,:))
- fac (:) = 1.0_JPRB - asm_in (ichan,:) * asm_in (ichan,:) * ssa_in (ichan,:)
- scatt_aux_k % asm (ichan,:) = scatt_aux_k % asm (ichan,:) - scatt_aux_k % ssa (ichan,:) &
- & * (1.0_JPRB - ssa_in (ichan,:)) &
- & * 2.0_JPRB * asm_in (ichan,:) * ssa_in (ichan,:) / fac (:) / fac (:)
- scatt_aux_k % ssa (ichan,:) = scatt_aux_k % ssa (ichan,:) * (1.0_JPRB - asm_in (ichan,:) &
- & * asm_in(ichan,:)) / fac (:) / fac (:)
-
- scatt_aux_k % asm (ichan,:) = scatt_aux_k % asm (ichan,:) - 2.0_JPRB * scatt_aux_k % ext (ichan,:) * ext_in (ichan,:) &
- & * asm_in (ichan,:) * ssa_in (ichan,:)
- scatt_aux_k % ssa (ichan,:) = scatt_aux_k % ssa (ichan,:) - scatt_aux_k % ext (ichan,:) * ext_in(ichan,:) &
- & * asm_in (ichan,:) * asm_in (ichan,:)
- scatt_aux_k % ext (ichan,:) = scatt_aux_k % ext (ichan,:) * (1.0_JPRB - ssa_in (ichan,:) &
- & * asm_in(ichan,:) * asm_in (ichan,:))
- end do
-
-End subroutine rttov_iniedd_k
-
diff --git a/src/LIB/RTTOV/src/rttov_iniedd_k.interface b/src/LIB/RTTOV/src/rttov_iniedd_k.interface
deleted file mode 100644
index 6b45f51fd8eb3f349111813102d2d370af134984..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_iniedd_k.interface
+++ /dev/null
@@ -1,26 +0,0 @@
-INTERFACE
-Subroutine rttov_iniedd_k (&
- & nwp_levels,&
- & nchannels ,&
- & nprofiles ,&
- & lprofiles ,&
- & angles ,&
- & coef_scatt,&
- & scatt_aux,&
- & scatt_aux_k)
- Use rttov_types, Only :&
- & geometry_Type ,&
- & profile_cloud_Type ,&
- & rttov_scatt_coef ,&
- & profile_scatt_aux
- Use parkind1, Only : jpim ,jprb
- Integer (Kind=jpim), Intent (in) :: nwp_levels
- Integer (Kind=jpim), Intent (in) :: nprofiles
- Integer (Kind=jpim), Intent (in) :: nchannels
- Integer (Kind=jpim), Intent (in) :: lprofiles (nchannels)
- Type (geometry_Type), Intent (in) :: angles (nprofiles)
- Type (rttov_scatt_coef), Intent (in) :: coef_scatt
- Type (profile_scatt_aux), Intent (inout) :: scatt_aux
- Type (profile_scatt_aux), Intent (inout) :: scatt_aux_k
-End subroutine rttov_iniedd_k
-END INTERFACE
diff --git a/src/LIB/RTTOV/src/rttov_iniedd_tl.F90 b/src/LIB/RTTOV/src/rttov_iniedd_tl.F90
deleted file mode 100644
index cdd9b6e1a55bd402302d408d2a8fa5cbd12813f9..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_iniedd_tl.F90
+++ /dev/null
@@ -1,191 +0,0 @@
-Subroutine rttov_iniedd_tl (&
- & nwp_levels, &! in
- & nchannels , &! in
- & nprofiles , &! in
- & lprofiles , &! in
- & angles , &! in
- & coef_scatt, &! in
- & scatt_aux, &! inout
- & scatt_aux_tl) ! inout
-
- ! Description:
- ! to compute variables specific to Eddington approximation to RT
- !
- ! Copyright:
- ! This software was developed within the context of
- ! the EUMETSAT Satellite Application Facility on
- ! Numerical Weather Prediction (NWP SAF), under the
- ! Cooperation Agreement dated 25 November 1998, between
- ! EUMETSAT and the Met Office, UK, by one or more partners
- ! within the NWP SAF. The partners in the NWP SAF are
- ! the Met Office, ECMWF, KNMI and MeteoFrance.
- !
- ! Copyright 2002, EUMETSAT, All Rights Reserved.
- !
- ! Method:
- ! - Bauer, P., 2002: Microwave radiative transfer modeling in clouds and precipitation.
- ! Part I: Model description.
- ! NWP SAF Report No. NWPSAF-EC-TR-005, 27 pp.
- ! - Chevallier, F., and P. Bauer, 2003:
- ! Model rain and clouds over oceans: comparison with SSM/I observations.
- ! Mon. Wea. Rev., 131, 1240-1255.
- ! - Moreau, E., P. Bauer and F. Chevallier, 2002: Microwave radiative transfer modeling in clouds and precipitation.
- ! Part II: Model evaluation.
- ! NWP SAF Report No. NWPSAF-EC-TR-006, 27 pp.
- !
- ! Current Code Owner: SAF NWP
- !
- ! History:
- ! Version Date Comment
- ! ------- ---- -------
- ! 1.0 09/2002 Initial version (P. Bauer, E. Moreau)
- ! 1.1 05/2003 RTTOV7.3 compatible (F. Chevallier)
- ! 1.2 03/2004 Added polarimetry (R. Saunders)
- ! 1.3 08/2004 Polarimetry fixes (U. O'Keefe)
- ! 1.4 11/2004 Clean-up (P. Bauer)
- !
- ! Code Description:
- ! Language: Fortran 90.
- ! Software Standards: "European Standards for Writing and
- ! Documenting Exchangeable Fortran 90 Code".
- !
- ! Declarations:
- ! Modules used:
- ! Imported Type Definitions:
-
- Use rttov_types, Only : &
- & geometry_Type ,&
- & rttov_scatt_coef ,&
- & profile_scatt_aux
-
- Use parkind1, Only : jpim ,jprb
-
- Implicit None
-
-!* Subroutine arguments:
- Integer (Kind=jpim), Intent (in) :: nwp_levels ! Number of levels
- Integer (Kind=jpim), Intent (in) :: nprofiles ! Number of profiles
- Integer (Kind=jpim), Intent (in) :: nchannels ! Number of radiances
- Integer (Kind=jpim), Intent (in) :: lprofiles (nchannels) ! Profile indices
-
- Type (geometry_Type), Intent (in) :: angles (nprofiles) ! Zenith angles
- Type (rttov_scatt_coef), Intent (in) :: coef_scatt ! RTTOV_SCATT Coefficients
- Type (profile_scatt_aux), Intent (inout) :: scatt_aux ! Auxiliary profile variables
- Type (profile_scatt_aux), Intent (inout) :: scatt_aux_tl ! Auxiliary profile variables
-
-!* Local variables
- Integer(Kind=jpim) :: ilayer, iprof, ichan
-
- !- End of header --------------------------------------------------------
-
- scatt_aux_tl % delta = 0.0_JPRB
- scatt_aux_tl % lambda = 0.0_JPRB
- scatt_aux_tl % h = 0.0_JPRB
- scatt_aux_tl % tau = 0.0_JPRB
-
- scatt_aux % delta = 0.0_JPRB
- scatt_aux % lambda = 0.0_JPRB
- scatt_aux % h = 0.0_JPRB
- scatt_aux % tau = 1.0_JPRB
-
- scatt_aux % mclayer = 0
-
-!* Layer interface temperatures, lapse rates
- do ilayer = 1, nwp_levels
- scatt_aux_tl % b0 (:,ilayer) = scatt_aux_tl % tbd (:,ilayer+1)
- scatt_aux % b0 (:,ilayer) = scatt_aux % tbd (:,ilayer+1)
- scatt_aux_tl % bn (:,ilayer) = scatt_aux_tl % tbd (:,ilayer )
- scatt_aux % bn (:,ilayer) = scatt_aux % tbd (:,ilayer )
- scatt_aux_tl % b1 (:,ilayer) = (scatt_aux_tl % bn (:,ilayer) - scatt_aux_tl % b0 (:,ilayer)) &
- & / scatt_aux % dz (:,ilayer) - (scatt_aux % bn (:,ilayer) &
- & - scatt_aux % b0 (:,ilayer)) * scatt_aux_tl % dz (:,ilayer) &
- & / scatt_aux % dz (:,ilayer) / scatt_aux % dz (:,ilayer)
- scatt_aux % b1 (:,ilayer) = (scatt_aux % bn (:,ilayer) - scatt_aux % b0 (:,ilayer)) &
- & / scatt_aux % dz (:,ilayer)
- end do
-
-!* Delta-scaling
- do ichan = 1, nchannels
- iprof = lprofiles (ichan)
-
- scatt_aux_tl % ext (ichan,:) = (1.0_JPRB - scatt_aux % ssa (ichan,:) * scatt_aux % asm (ichan,:) &
- & * scatt_aux % asm (ichan,:)) * scatt_aux_tl % ext (ichan,:) &
- & + scatt_aux % ext (ichan,:) * scatt_aux % asm (ichan,:) &
- & * (-1.0_JPRB * scatt_aux_tl % ssa (ichan,:) * scatt_aux % asm (ichan,:) &
- & -2.0_JPRB * scatt_aux % ssa (ichan,:) * scatt_aux_tl % asm (ichan,:))
- scatt_aux % ext (ichan,:) = (1.0_JPRB - scatt_aux % ssa (ichan,:) * scatt_aux % asm (ichan,:) &
- & * scatt_aux % asm (ichan,:)) * scatt_aux % ext (ichan,:)
- scatt_aux_tl % ssa (ichan,:) = (1.0_JPRB / (1.0_JPRB - scatt_aux % asm (ichan,:) * scatt_aux % asm (ichan,:) &
- & * scatt_aux % ssa (ichan,:))**2.0_JPRB ) * ( (1.0_JPRB - scatt_aux % asm (ichan,:) &
- & * scatt_aux % asm (ichan,:) * scatt_aux % ssa (ichan,:)) &
- & * (( 1.0_JPRB - scatt_aux % asm (ichan,:) * scatt_aux % asm (ichan,:)) &
- & * scatt_aux_tl % ssa (ichan,:) &
- & + (-2.0_JPRB * scatt_aux % asm (ichan,:) * scatt_aux_tl % asm (ichan,:) &
- & * scatt_aux % ssa (ichan,:)) ) &
- & - (1.0_JPRB - scatt_aux % asm (ichan,:) * scatt_aux % asm (ichan,:)) &
- & * scatt_aux % ssa (ichan,:) &
- & * ( (-1.0_JPRB * scatt_aux % asm (ichan,:) * scatt_aux % asm (ichan,:) &
- & * scatt_aux_tl % ssa (ichan,:)) &
- & + (-2.0_JPRB * scatt_aux % asm (ichan,:) * scatt_aux_tl % asm (ichan,:) &
- & * scatt_aux % ssa (ichan,:)) ) )
- scatt_aux % ssa (ichan,:) = (1.0_JPRB - scatt_aux % asm (ichan,:) * scatt_aux % asm (ichan,:)) &
- & * scatt_aux % ssa (ichan,:) / (1.0_JPRB - scatt_aux % asm (ichan,:) &
- & * scatt_aux % asm (ichan,:) * scatt_aux % ssa (ichan,:))
- scatt_aux_tl % asm (ichan,:) = scatt_aux_tl % asm (ichan,:) / (1.0_JPRB + scatt_aux % asm (ichan,:)) &
- & - scatt_aux % asm (ichan,:) * scatt_aux_tl % asm (ichan,:) &
- & / (1.0_JPRB + scatt_aux % asm (ichan,:)) &
- & / (1.0_JPRB + scatt_aux % asm (ichan,:))
- scatt_aux % asm (ichan,:) = scatt_aux % asm (ichan,:) / (1.0_JPRB + scatt_aux % asm (ichan,:))
-
-
- scatt_aux_tl % delta (ichan,:) = (scatt_aux_tl % ext (ichan,:) * scatt_aux % dz (iprof,:) &
- & + scatt_aux % ext (ichan,:) * scatt_aux_tl % dz (iprof,:)) / angles (iprof) % coszen
- scatt_aux % delta (ichan,:) = (scatt_aux % ext (ichan,:) * scatt_aux % dz (iprof,:)) / angles (iprof) % coszen
-
- where (scatt_aux % delta (:,:) >= 30.0_JPRB)
- scatt_aux % delta (:,:) = 30.0_JPRB
- scatt_aux_tl % delta (:,:) = 0.0_JPRB
- endwhere
-
- scatt_aux % tau (ichan,:) = 1.0_JPRB / exp (scatt_aux % delta (ichan,:))
- scatt_aux_tl % tau (ichan,:) = -1.0_JPRB * scatt_aux_tl % delta (ichan,:) * scatt_aux % tau (ichan,:)
- scatt_aux_tl % lambda (ichan,:) = (1.0_JPRB / ( 2._JPRB * sqrt (3.0_JPRB * scatt_aux % ext (ichan,:) &
- & * scatt_aux % ext (ichan,:) &
- & * (1.0_JPRB - scatt_aux % ssa (ichan,:)) &
- & * (1.0_JPRB - scatt_aux % ssa (ichan,:) * scatt_aux % asm (ichan,:))))) &
- & * ( 6.0_JPRB * scatt_aux % ext (ichan,:) * scatt_aux_tl % ext (ichan,:) &
- & * (1.0_JPRB - scatt_aux % ssa (ichan,:)) * (1.0_JPRB - scatt_aux % ssa (ichan,:) &
- & * scatt_aux % asm (ichan,:)) &
- & - 3.0_JPRB * scatt_aux % ext (ichan,:) * scatt_aux % ext(ichan,:) &
- & * scatt_aux_tl % ssa (ichan,:) * (1.0_JPRB - scatt_aux % ssa (ichan,:) &
- & * scatt_aux % asm (ichan,:)) &
- & - 3.0_JPRB * scatt_aux % ext (ichan,:) * scatt_aux % ext (ichan,:) &
- & * (1.0_JPRB - scatt_aux % ssa (ichan,:)) &
- & * (scatt_aux % ssa (ichan,:) * scatt_aux_tl % asm (ichan,:)+ scatt_aux_tl % ssa (ichan,:) &
- & * scatt_aux % asm (ichan,:)) )
-
- scatt_aux % lambda (ichan,:) = sqrt (3.0_JPRB * scatt_aux % ext (ichan,:) * scatt_aux % ext (ichan,:) &
- & * (1.0_JPRB - scatt_aux % ssa (ichan,:)) &
- & * (1.0_JPRB - scatt_aux % ssa (ichan,:) * scatt_aux % asm (ichan,:)))
- scatt_aux_tl % h (ichan,:) = 1.5_JPRB * scatt_aux_tl % ext (ichan,:) &
- & * (1.0_JPRB - scatt_aux % ssa (ichan,:) * scatt_aux % asm (ichan,:)) &
- & -1.5_JPRB * scatt_aux % ext (ichan,:) &
- & * (scatt_aux_tl % ssa (ichan,:) * scatt_aux % asm (ichan,:) + scatt_aux % ssa (ichan,:) &
- & * scatt_aux_tl % asm (ichan,:))
- scatt_aux % h (ichan,:) = 1.5_JPRB * scatt_aux % ext (ichan,:) &
- & * (1.0_JPRB - scatt_aux % ssa (ichan,:) * scatt_aux % asm (ichan,:))
-
- where (scatt_aux % h (ichan,:) < 0.00001_JPRB)
- scatt_aux_tl % h (ichan,:) = 0.0_JPRB
- scatt_aux % h (ichan,:) = 0.00001_JPRB
- endwhere
-
-!* Cloud top level index
- scatt_aux % mclayer (ichan) = nwp_levels - 2
- do ilayer = 1, nwp_levels - 2
- if (scatt_aux % ssa (ichan,ilayer) > 0.0_JPRB .and. ilayer < scatt_aux % mclayer(ichan)) &
- scatt_aux % mclayer(ichan) = ilayer
- end do
- end do
-
-End subroutine rttov_iniedd_tl
diff --git a/src/LIB/RTTOV/src/rttov_iniedd_tl.interface b/src/LIB/RTTOV/src/rttov_iniedd_tl.interface
deleted file mode 100644
index 169ae241b253821d8054055d610f60d024cb6086..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_iniedd_tl.interface
+++ /dev/null
@@ -1,25 +0,0 @@
-INTERFACE
-Subroutine rttov_iniedd_tl (&
- & nwp_levels,&
- & nchannels ,&
- & nprofiles ,&
- & lprofiles ,&
- & angles ,&
- & coef_scatt,&
- & scatt_aux,&
- & scatt_aux_tl)
- Use rttov_types, Only :&
- & geometry_Type ,&
- & rttov_scatt_coef ,&
- & profile_scatt_aux
- Use parkind1, Only : jpim ,jprb
- Integer (Kind=jpim), Intent (in) :: nwp_levels
- Integer (Kind=jpim), Intent (in) :: nprofiles
- Integer (Kind=jpim), Intent (in) :: nchannels
- Integer (Kind=jpim), Intent (in) :: lprofiles (nchannels)
- Type (geometry_Type), Intent (in) :: angles (nprofiles)
- Type (rttov_scatt_coef), Intent (in) :: coef_scatt
- Type (profile_scatt_aux), Intent (inout) :: scatt_aux
- Type (profile_scatt_aux), Intent (inout) :: scatt_aux_tl
-End subroutine rttov_iniedd_tl
-END INTERFACE
diff --git a/src/LIB/RTTOV/src/rttov_iniscatt.F90 b/src/LIB/RTTOV/src/rttov_iniscatt.F90
deleted file mode 100644
index f97f9561932dffd4709fe933e3b9ca7546dd0ad4..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_iniscatt.F90
+++ /dev/null
@@ -1,354 +0,0 @@
-!
-Subroutine rttov_iniscatt (&
- & errorstatus, &! out
- & nwp_levels, &! in
- & nrt_levels, &! in
- & nfrequencies, &! in
- & nchannels, &! in
- & nprofiles, &! in
- & polarisations, &! in
- & channels, &! in
- & frequencies, &! in
- & lprofiles, &! in
- & lsprofiles, &! in
- & profiles, &! in
- & cld_profiles, &! in
- & coef_rttov, &! in
- & coef_scatt, &! in
- & transmission, &! in
- & calcemiss, &! in
- & angles, &! out
- & scatt_aux) ! inout
-
- !
- ! Description:
- ! Calculates some variables related to the input precipitation profile
- !
- ! Copyright:
- ! This software was developed within the context of
- ! the EUMETSAT Satellite Application Facility on
- ! Numerical Weather Prediction (NWP SAF), under the
- ! Cooperation Agreement dated 25 November 1998, between
- ! EUMETSAT and the Met Office, UK, by one or more painiscattrtners
- ! within the NWP SAF. The partners in the NWP SAF are
- ! the Met Office, ECMWF, KNMI and MeteoFrance.
- !
- ! Copyright 2002, EUMETSAT, All Rights Reserved.
- !
- ! Method:
- !
- ! Current Code Owner: SAF NWP
- !
- ! History:
- ! Version Date Comment
- ! ------- ---- -------
- ! 1.0 09/2002 Initial version (F. Chevallier)
- ! 1.1 05/2003 RTTOV7.3 compatible (F. Chevallier)
- ! 1.2 03/2004 Added polarimetry (R. Saunders)
- ! 1.3 08/2004 Polarimetry fixes (U. O'Keeffe)
- ! 1.4 11/2004 Clean-up (P. Bauer)
- ! 1.5 10/2005 Fixes for rttov8 indexing (U. O'Keeffe)
- ! 1.6 11/2005 Add errorstatus to arguments (J. Cameron)
- !
- ! Code Description:
- ! Language: Fortran 90.
- ! Software Standards: "European Standards for Writing and
- ! Documenting Exchangeable Fortran 90 Code".
- !
- ! Declarations:
- ! Modules used:
- ! Imported Type Definitions:
-
- Use rttov_types, Only : &
- & rttov_coef ,&
- & rttov_scatt_coef ,&
- & transmission_type ,&
- & geometry_Type ,&
- & profile_scatt_aux ,&
- & profile_Type ,&
- & profile_cloud_Type
-
- Use rttov_const, Only: &
- & errorstatus_success, &
- & errorstatus_fatal, &
- & gravity, &
- & pressure_top, &
- & rgp, &
- & rm, &
- & rho_rain, &
- & rho_snow, &
- & ccthres
-
- Use parkind1, Only : jpim ,jprb
-
- Implicit None
-
-#include "rttov_mieproc.interface"
-#include "rttov_iniedd.interface"
-#include "rttov_calcemis_mw.interface"
-#include "rttov_setgeometry.interface"
-#include "rttov_errorreport.interface"
-#include "rttov_intex.interface"
-
-!* Subroutine arguments:
- Integer (Kind=jpim), Intent (in) :: nwp_levels ! Number of levels
- Integer (Kind=jpim), Intent (in) :: nrt_levels ! Number of levels
- Integer (Kind=jpim), Intent (in) :: nprofiles ! Number of profiles
- Integer (Kind=jpim), Intent (in) :: nfrequencies ! Number of frequencies
- Integer (Kind=jpim), Intent (in) :: nchannels ! Number of channels*profiles=radiances
- Integer (Kind=jpim), Intent(out) :: errorstatus(nprofiles) ! Error return code
- Integer (Kind=jpim), Intent (in) :: frequencies (nchannels) ! Frequency indices
- Integer (Kind=jpim), Intent (in) :: channels (nfrequencies) ! Channels indices
- Integer (Kind=jpim), Intent (in) :: polarisations (nchannels,3) ! Polarisation indices
- Integer (Kind=jpim), Intent (in) :: lprofiles (nfrequencies) ! Profile indices
- Integer (Kind=jpim), Intent (in) :: lsprofiles (nchannels) ! Profile indices
- Logical , Intent (in) :: calcemiss (nchannels) ! Emissivity flags
-
- Type (profile_Type), Intent (in) :: profiles (nprofiles) ! Atmospheric profiles
- Type (rttov_coef), Intent (in) :: coef_rttov ! RTTOV Coefficients
- Type (rttov_scatt_coef), Intent (in) :: coef_scatt ! RTTOV_SCATT Coefficients
- Type (profile_cloud_Type), Intent (in) :: cld_profiles (nprofiles) ! Cloud profiles with NWP levels
- Type (transmission_Type), Intent (in) :: transmission ! Transmittances and optical depths
- Type (geometry_Type), Intent (out) :: angles (nprofiles) ! Zenith angles
- Type (profile_scatt_aux), Intent (inout) :: scatt_aux ! Auxiliary profile variables
-
-!* Local variables
- Integer (Kind=jpim) :: ilayer, iprof, ichan, iccmax
- Real (Kind=jprb) :: p1, p2, pm, dp2dz, de2mr, zccmax
-
- Real (Kind=jprb), Dimension (nprofiles,nwp_levels) :: presf ! Pressure levels [hPa]
- Real (Kind=jprb), Dimension (nprofiles,nwp_levels+1) :: presfh ! Half-level NWP pressure levels [hPa]
- Real (Kind=jprb), Dimension (nrt_levels) :: presi ! Half-level RTTOV pressure levels [hPa]
- Real (Kind=jprb), Dimension (nchannels,nwp_levels) :: opd_nwp
- Real (Kind=jprb), Dimension (nchannels,nrt_levels) :: opdp_nrt
- Real (Kind=jprb), Dimension (nchannels) :: zod_up_cld ! Optical depth from top of the atmosphere
- Real (Kind=jprb), Dimension (nchannels) :: emissivity ! Surface emissivity
- Real (Kind=jprb), Dimension (nchannels) :: reflectivity ! Surface reflectivity
-
- Type (transmission_Type) :: transmissioncld ! Clear+cloud transmittances with cloud
-
- Character (len=80) :: errMessage
- Character (len=15) :: NameOfRoutine = 'rttov_iniscatt '
-
- !- End of header --------------------------------------------------------
-
- errorstatus(:) = errorstatus_success
-
- allocate (transmissioncld % tau_surf (nchannels))
-
- de2mr = 1.0E+05_JPRB * rm / rgp
- dp2dz = -1.0E-03_JPRB * rgp / gravity / rm
-
- scatt_aux % ext (:,:) = 0.0_JPRB
- scatt_aux % ssa (:,:) = 0.0_JPRB
- scatt_aux % asm (:,:) = 0.0_JPRB
-
-!* Security on user-defined pressures
- Do iprof = 1, nprofiles
- Do ilayer = 1, nwp_levels
- If (cld_profiles (iprof) % p (ilayer) >= pressure_top) Then
- presf (iprof,ilayer) = cld_profiles (iprof) % p (ilayer)
- else
- presf (iprof,ilayer) = pressure_top
- endif
- Enddo
- Do ilayer = 1, nwp_levels + 1
- If (cld_profiles (iprof) % ph (ilayer) >= pressure_top) Then
- presfh (iprof,ilayer) = cld_profiles (iprof) % ph (ilayer)
- else
- presfh (iprof,ilayer) = pressure_top
- endif
- Enddo
- Enddo
-
-!* Geometric variables
- Do iprof = 1, nprofiles
- Call rttov_setgeometry (profiles (iprof), coef_rttov, angles (iprof))
- End Do
-
-!* Temperature at layer boundaries (K)
- Do iprof = 1, nprofiles
- scatt_aux % tbd (iprof,nwp_levels+1) = profiles (iprof) % s2m % t
- scatt_aux % tbd (iprof,1) = cld_profiles (iprof) % t (1)
- Enddo
-
- Do ilayer = 1, nwp_levels-1
- Do iprof = 1, nprofiles
- p1 = presf (iprof,ilayer+1)
- p2 = presf (iprof,ilayer )
- pm = presfh (iprof,ilayer+1)
-
- scatt_aux % tbd (iprof,ilayer+1) = cld_profiles (iprof) % t (ilayer+1) &
- & + (cld_profiles (iprof) % t (ilayer) &
- & - cld_profiles (iprof) % t (ilayer+1)) &
- & / log(p2/p1) * log(pm/p1)
- Enddo
- Enddo
-
-!* Horizontal clear-sky fraction
- scatt_aux % clw (:,:) = 0.0_JPRB
- scatt_aux % ciw (:,:) = 0.0_JPRB
- scatt_aux % rain (:,:) = 0.0_JPRB
- scatt_aux % sp (:,:) = 0.0_JPRB
- scatt_aux % ccmax (:) = 0.0_JPRB
-
- Do iprof = 1, nprofiles
- zccmax = 0.0_JPRB
- iccmax = 0
-
- Do ilayer = 1, nwp_levels
- if (cld_profiles (iprof) % cc (ilayer) > zccmax) then
- zccmax = cld_profiles (iprof) % cc (ilayer)
- iccmax = ilayer
- end if
- end do
- scatt_aux % ccmax (iprof) = zccmax
-
- If (scatt_aux % ccmax (iprof) > ccthres) Then
- scatt_aux % clw (iprof,:) = cld_profiles (iprof) % clw (:) / scatt_aux % ccmax (iprof)
- scatt_aux % ciw (iprof,:) = cld_profiles (iprof) % ciw (:) / scatt_aux % ccmax (iprof)
- scatt_aux % rain (iprof,:) = cld_profiles (iprof) % rain (:) / scatt_aux % ccmax (iprof)
- scatt_aux % sp (iprof,:) = cld_profiles (iprof) % sp (:) / scatt_aux % ccmax (iprof)
- else
- scatt_aux % clw (iprof,:) = 0.0_JPRB
- scatt_aux % ciw (iprof,:) = 0.0_JPRB
- scatt_aux % rain (iprof,:) = 0.0_JPRB
- scatt_aux % sp (iprof,:) = 0.0_JPRB
- Endif
- Enddo
-
-!* Nadir heights (km)
- Do ilayer = nwp_levels, 1, -1
- Do iprof = 1, nprofiles
- p1 = presfh (iprof,ilayer+1)
- p2 = presfh (iprof,ilayer )
-
- If (p1 <= p2) then
- errorstatus (:) = errorstatus_fatal
- Write( errMessage, '( "iniscatt : problem with user-defined pressure layering")' )
- Call Rttov_ErrorReport (errorstatus(iprof), errMessage, NameOfRoutine)
- Return
- End If
-
- scatt_aux % dz (iprof,ilayer) = dp2dz * Log(p2/p1) * cld_profiles (iprof) % t (ilayer)
- Enddo
- Enddo
-
-!* Interpolate optical depths (at nadir and in hPa-1) to model levels
- Do ichan = 1, nchannels
- iprof = lsprofiles (ichan)
-
- opdp_nrt (ichan,1) = transmission % od_singlelayer (1,ichan) / (profiles (iprof) % p (1) - pressure_top)
- presi (1) = (profiles (iprof) % p (1) + pressure_top) / 2.0_JPRB
-
- Do ilayer = 2, nrt_levels
- opdp_nrt (ichan,ilayer) = transmission % od_singlelayer (ilayer,ichan) &
- & / (profiles (iprof) % p (ilayer) - profiles (iprof) % p (ilayer-1))
- presi (ilayer) = (profiles (iprof) % p (ilayer) + profiles (iprof) % p (ilayer-1)) / 2.0_JPRB
- Enddo
-
- Call rttov_intex (nrt_levels, nwp_levels, presi, presf (iprof,:), opdp_nrt (ichan,:), opd_nwp (ichan,:))
- Enddo
-
-!* Change units
- Do ilayer = 1, nwp_levels
-
-!* Optical depths in km-1 and at nadir
- Do ichan = 1, nchannels
- iprof = lsprofiles (ichan)
-
- scatt_aux % ext (ichan,ilayer) = opd_nwp (ichan,ilayer) * (presfh (iprof,ilayer+1) - presfh (iprof,ilayer)) &
- & / scatt_aux % dz (iprof,ilayer) * angles (iprof) % coszen
-
- if (scatt_aux % ext (ichan,ilayer) < 1.0E-10_JPRB) scatt_aux % ext (ichan,ilayer) = 1.0E-10_JPRB
- Enddo
-
-!* Condensate from g/g to g/m^3
- Do iprof = 1, nprofiles
- scatt_aux % clw (iprof,ilayer) = scatt_aux % clw (iprof,ilayer) * presf (iprof,ilayer) &
- & * de2mr / cld_profiles (iprof) % t (ilayer)
- scatt_aux % ciw (iprof,ilayer) = scatt_aux % ciw (iprof,ilayer) * presf (iprof,ilayer) &
- & * de2mr / cld_profiles (iprof) % t (ilayer)
-
-!* Rates from kg/m^2/s to g/m^3
-!*JPC*(J.-P. CHABOUREAU - 4 Jan 2006)
- scatt_aux % rain (iprof,ilayer) = scatt_aux % rain (iprof,ilayer) * presf (iprof,ilayer) &
- & * de2mr / cld_profiles (iprof) % t (ilayer)
- scatt_aux % sp (iprof,ilayer) = scatt_aux % sp (iprof,ilayer) * presf (iprof,ilayer) &
- & * de2mr / cld_profiles (iprof) % t (ilayer)
-! scatt_aux % rain (iprof,ilayer) = scatt_aux % rain (iprof,ilayer) / rho_rain
-! scatt_aux % sp (iprof,ilayer) = scatt_aux % sp (iprof,ilayer) / rho_snow
-!
-! scatt_aux % rain (iprof,ilayer) = scatt_aux % rain (iprof,ilayer) * 3600.0_JPRB
-! scatt_aux % sp (iprof,ilayer) = scatt_aux % sp (iprof,ilayer) * 3600.0_JPRB
-!
-! if (scatt_aux % rain (iprof,ilayer) > 0.0_JPRB) &
-! & scatt_aux % rain (iprof,ilayer) = (scatt_aux % rain (iprof,ilayer) * &
-! & coef_scatt % conv_rain (1))**(coef_scatt % conv_rain (2))
-! if (scatt_aux % sp (iprof,ilayer) > 0.0_JPRB) &
-! & scatt_aux % sp (iprof,ilayer) = (scatt_aux % sp (iprof,ilayer) * &
-! & coef_scatt % conv_sp (1))**(coef_scatt % conv_sp (2))
-!*JPC*(J.-P. CHABOUREAU - 4 Jan 2006)
- enddo
- Enddo
-
-!* Cloud/rain absorption/scattering parameters
- Call rttov_mieproc ( &
- & nwp_levels, &! in
- & nchannels, &! in
- & nprofiles, &! in
- & frequencies, &! in
- & lsprofiles, &! in
- & cld_profiles, &! in
- & coef_rttov, &! in
- & coef_scatt, &! in
- & scatt_aux) ! inout
-
-!* Scattering parameters for Eddington RT
- Call rttov_iniedd ( &
- & nwp_levels, &! in
- & nchannels , &! in
- & nprofiles , &! in
- & lsprofiles , &! in
- & angles , &! in
- & coef_scatt, &! in
- & scatt_aux) ! inout
-
-!* Surface emissivities
- zod_up_cld (:) = 0.0_JPRB
-
- Do ichan = 1, nchannels
- iprof = lsprofiles (ichan)
-
- Do ilayer = 1, nwp_levels
- zod_up_cld (ichan) = zod_up_cld (ichan) + scatt_aux % ext (ichan,ilayer) * scatt_aux % dz (iprof,ilayer)
- Enddo
-
- if (zod_up_cld (ichan) >= 30.0_JPRB) zod_up_cld (ichan) = 30.0_JPRB
- transmissioncld % tau_surf (ichan) = Exp(-1.0_JPRB * zod_up_cld (ichan) / angles (iprof) % coszen)
- Enddo
-
- Call rttov_calcemis_mw ( &
- & profiles, &! in
- & angles, &! in
- & coef_rttov, &! in
- & nfrequencies, &! in
- & nchannels, &! in
- & nprofiles, &! in
- & channels, &! in
- & polarisations, &! in
- & lprofiles, &! in
- & transmissioncld, &! in
- & calcemiss, &! in
- & scatt_aux % ems_cld, &! inout
- & scatt_aux % ref_cld, &! out
- & errorstatus ) ! inout
-
-!* Hemispheric emissivity (= Fastem's effective emissivity)
- scatt_aux % ems_bnd (:) = scatt_aux % ems_cld (:)
- scatt_aux % ref_bnd (:) = scatt_aux % ref_cld (:)
-
-!* Deallocate
- deallocate (transmissioncld % tau_surf)
-
-End Subroutine rttov_iniscatt
diff --git a/src/LIB/RTTOV/src/rttov_iniscatt.F90_orig b/src/LIB/RTTOV/src/rttov_iniscatt.F90_orig
deleted file mode 100644
index 8914413006be7993c011fcb86b74856eeed39e7b..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_iniscatt.F90_orig
+++ /dev/null
@@ -1,348 +0,0 @@
-!
-Subroutine rttov_iniscatt (&
- & errorstatus, &! out
- & nwp_levels, &! in
- & nrt_levels, &! in
- & nfrequencies, &! in
- & nchannels, &! in
- & nprofiles, &! in
- & polarisations, &! in
- & channels, &! in
- & frequencies, &! in
- & lprofiles, &! in
- & lsprofiles, &! in
- & profiles, &! in
- & cld_profiles, &! in
- & coef_rttov, &! in
- & coef_scatt, &! in
- & transmission, &! in
- & calcemiss, &! in
- & angles, &! out
- & scatt_aux) ! inout
-
- !
- ! Description:
- ! Calculates some variables related to the input precipitation profile
- !
- ! Copyright:
- ! This software was developed within the context of
- ! the EUMETSAT Satellite Application Facility on
- ! Numerical Weather Prediction (NWP SAF), under the
- ! Cooperation Agreement dated 25 November 1998, between
- ! EUMETSAT and the Met Office, UK, by one or more painiscattrtners
- ! within the NWP SAF. The partners in the NWP SAF are
- ! the Met Office, ECMWF, KNMI and MeteoFrance.
- !
- ! Copyright 2002, EUMETSAT, All Rights Reserved.
- !
- ! Method:
- !
- ! Current Code Owner: SAF NWP
- !
- ! History:
- ! Version Date Comment
- ! ------- ---- -------
- ! 1.0 09/2002 Initial version (F. Chevallier)
- ! 1.1 05/2003 RTTOV7.3 compatible (F. Chevallier)
- ! 1.2 03/2004 Added polarimetry (R. Saunders)
- ! 1.3 08/2004 Polarimetry fixes (U. O'Keeffe)
- ! 1.4 11/2004 Clean-up (P. Bauer)
- ! 1.5 10/2005 Fixes for rttov8 indexing (U. O'Keeffe)
- ! 1.6 11/2005 Add errorstatus to arguments (J. Cameron)
- !
- ! Code Description:
- ! Language: Fortran 90.
- ! Software Standards: "European Standards for Writing and
- ! Documenting Exchangeable Fortran 90 Code".
- !
- ! Declarations:
- ! Modules used:
- ! Imported Type Definitions:
-
- Use rttov_types, Only : &
- & rttov_coef ,&
- & rttov_scatt_coef ,&
- & transmission_type ,&
- & geometry_Type ,&
- & profile_scatt_aux ,&
- & profile_Type ,&
- & profile_cloud_Type
-
- Use rttov_const, Only: &
- & errorstatus_success, &
- & errorstatus_fatal, &
- & gravity, &
- & pressure_top, &
- & rgp, &
- & rm, &
- & rho_rain, &
- & rho_snow, &
- & ccthres
-
- Use parkind1, Only : jpim ,jprb
-
- Implicit None
-
-#include "rttov_mieproc.interface"
-#include "rttov_iniedd.interface"
-#include "rttov_calcemis_mw.interface"
-#include "rttov_setgeometry.interface"
-#include "rttov_errorreport.interface"
-#include "rttov_intex.interface"
-
-!* Subroutine arguments:
- Integer (Kind=jpim), Intent (in) :: nwp_levels ! Number of levels
- Integer (Kind=jpim), Intent (in) :: nrt_levels ! Number of levels
- Integer (Kind=jpim), Intent (in) :: nprofiles ! Number of profiles
- Integer (Kind=jpim), Intent (in) :: nfrequencies ! Number of frequencies
- Integer (Kind=jpim), Intent (in) :: nchannels ! Number of channels*profiles=radiances
- Integer (Kind=jpim), Intent(out) :: errorstatus(nprofiles) ! Error return code
- Integer (Kind=jpim), Intent (in) :: frequencies (nchannels) ! Frequency indices
- Integer (Kind=jpim), Intent (in) :: channels (nfrequencies) ! Channels indices
- Integer (Kind=jpim), Intent (in) :: polarisations (nchannels,3) ! Polarisation indices
- Integer (Kind=jpim), Intent (in) :: lprofiles (nfrequencies) ! Profile indices
- Integer (Kind=jpim), Intent (in) :: lsprofiles (nchannels) ! Profile indices
- Logical , Intent (in) :: calcemiss (nchannels) ! Emissivity flags
-
- Type (profile_Type), Intent (in) :: profiles (nprofiles) ! Atmospheric profiles
- Type (rttov_coef), Intent (in) :: coef_rttov ! RTTOV Coefficients
- Type (rttov_scatt_coef), Intent (in) :: coef_scatt ! RTTOV_SCATT Coefficients
- Type (profile_cloud_Type), Intent (in) :: cld_profiles (nprofiles) ! Cloud profiles with NWP levels
- Type (transmission_Type), Intent (in) :: transmission ! Transmittances and optical depths
- Type (geometry_Type), Intent (out) :: angles (nprofiles) ! Zenith angles
- Type (profile_scatt_aux), Intent (inout) :: scatt_aux ! Auxiliary profile variables
-
-!* Local variables
- Integer (Kind=jpim) :: ilayer, iprof, ichan, iccmax
- Real (Kind=jprb) :: p1, p2, pm, dp2dz, de2mr, zccmax
-
- Real (Kind=jprb), Dimension (nprofiles,nwp_levels) :: presf ! Pressure levels [hPa]
- Real (Kind=jprb), Dimension (nprofiles,nwp_levels+1) :: presfh ! Half-level NWP pressure levels [hPa]
- Real (Kind=jprb), Dimension (nrt_levels) :: presi ! Half-level RTTOV pressure levels [hPa]
- Real (Kind=jprb), Dimension (nchannels,nwp_levels) :: opd_nwp
- Real (Kind=jprb), Dimension (nchannels,nrt_levels) :: opdp_nrt
- Real (Kind=jprb), Dimension (nchannels) :: zod_up_cld ! Optical depth from top of the atmosphere
- Real (Kind=jprb), Dimension (nchannels) :: emissivity ! Surface emissivity
- Real (Kind=jprb), Dimension (nchannels) :: reflectivity ! Surface reflectivity
-
- Type (transmission_Type) :: transmissioncld ! Clear+cloud transmittances with cloud
-
- Character (len=80) :: errMessage
- Character (len=15) :: NameOfRoutine = 'rttov_iniscatt '
-
- !- End of header --------------------------------------------------------
-
- errorstatus(:) = errorstatus_success
-
- allocate (transmissioncld % tau_surf (nchannels))
-
- de2mr = 1.0E+05_JPRB * rm / rgp
- dp2dz = -1.0E-03_JPRB * rgp / gravity / rm
-
- scatt_aux % ext (:,:) = 0.0_JPRB
- scatt_aux % ssa (:,:) = 0.0_JPRB
- scatt_aux % asm (:,:) = 0.0_JPRB
-
-!* Security on user-defined pressures
- Do iprof = 1, nprofiles
- Do ilayer = 1, nwp_levels
- If (cld_profiles (iprof) % p (ilayer) >= pressure_top) Then
- presf (iprof,ilayer) = cld_profiles (iprof) % p (ilayer)
- else
- presf (iprof,ilayer) = pressure_top
- endif
- Enddo
- Do ilayer = 1, nwp_levels + 1
- If (cld_profiles (iprof) % ph (ilayer) >= pressure_top) Then
- presfh (iprof,ilayer) = cld_profiles (iprof) % ph (ilayer)
- else
- presfh (iprof,ilayer) = pressure_top
- endif
- Enddo
- Enddo
-
-!* Geometric variables
- Do iprof = 1, nprofiles
- Call rttov_setgeometry (profiles (iprof), coef_rttov, angles (iprof))
- End Do
-
-!* Temperature at layer boundaries (K)
- Do iprof = 1, nprofiles
- scatt_aux % tbd (iprof,nwp_levels+1) = profiles (iprof) % s2m % t
- scatt_aux % tbd (iprof,1) = cld_profiles (iprof) % t (1)
- Enddo
-
- Do ilayer = 1, nwp_levels-1
- Do iprof = 1, nprofiles
- p1 = presf (iprof,ilayer+1)
- p2 = presf (iprof,ilayer )
- pm = presfh (iprof,ilayer+1)
-
- scatt_aux % tbd (iprof,ilayer+1) = cld_profiles (iprof) % t (ilayer+1) &
- & + (cld_profiles (iprof) % t (ilayer) &
- & - cld_profiles (iprof) % t (ilayer+1)) &
- & / log(p2/p1) * log(pm/p1)
- Enddo
- Enddo
-
-!* Horizontal clear-sky fraction
- scatt_aux % clw (:,:) = 0.0_JPRB
- scatt_aux % ciw (:,:) = 0.0_JPRB
- scatt_aux % rain (:,:) = 0.0_JPRB
- scatt_aux % sp (:,:) = 0.0_JPRB
- scatt_aux % ccmax (:) = 0.0_JPRB
-
- Do iprof = 1, nprofiles
- zccmax = 0.0_JPRB
- iccmax = 0
-
- Do ilayer = 1, nwp_levels
- if (cld_profiles (iprof) % cc (ilayer) > zccmax) then
- zccmax = cld_profiles (iprof) % cc (ilayer)
- iccmax = ilayer
- end if
- end do
- scatt_aux % ccmax (iprof) = zccmax
-
- If (scatt_aux % ccmax (iprof) > ccthres) Then
- scatt_aux % clw (iprof,:) = cld_profiles (iprof) % clw (:) / scatt_aux % ccmax (iprof)
- scatt_aux % ciw (iprof,:) = cld_profiles (iprof) % ciw (:) / scatt_aux % ccmax (iprof)
- scatt_aux % rain (iprof,:) = cld_profiles (iprof) % rain (:) / scatt_aux % ccmax (iprof)
- scatt_aux % sp (iprof,:) = cld_profiles (iprof) % sp (:) / scatt_aux % ccmax (iprof)
- else
- scatt_aux % clw (iprof,:) = 0.0_JPRB
- scatt_aux % ciw (iprof,:) = 0.0_JPRB
- scatt_aux % rain (iprof,:) = 0.0_JPRB
- scatt_aux % sp (iprof,:) = 0.0_JPRB
- Endif
- Enddo
-
-!* Nadir heights (km)
- Do ilayer = nwp_levels, 1, -1
- Do iprof = 1, nprofiles
- p1 = presfh (iprof,ilayer+1)
- p2 = presfh (iprof,ilayer )
-
- If (p1 <= p2) then
- errorstatus (:) = errorstatus_fatal
- Write( errMessage, '( "iniscatt : problem with user-defined pressure layering")' )
- Call Rttov_ErrorReport (errorstatus(iprof), errMessage, NameOfRoutine)
- Return
- End If
-
- scatt_aux % dz (iprof,ilayer) = dp2dz * Log(p2/p1) * cld_profiles (iprof) % t (ilayer)
- Enddo
- Enddo
-
-!* Interpolate optical depths (at nadir and in hPa-1) to model levels
- Do ichan = 1, nchannels
- iprof = lsprofiles (ichan)
-
- opdp_nrt (ichan,1) = transmission % od_singlelayer (1,ichan) / (profiles (iprof) % p (1) - pressure_top)
- presi (1) = (profiles (iprof) % p (1) + pressure_top) / 2.0_JPRB
-
- Do ilayer = 2, nrt_levels
- opdp_nrt (ichan,ilayer) = transmission % od_singlelayer (ilayer,ichan) &
- & / (profiles (iprof) % p (ilayer) - profiles (iprof) % p (ilayer-1))
- presi (ilayer) = (profiles (iprof) % p (ilayer) + profiles (iprof) % p (ilayer-1)) / 2.0_JPRB
- Enddo
-
- Call rttov_intex (nrt_levels, nwp_levels, presi, presf (iprof,:), opdp_nrt (ichan,:), opd_nwp (ichan,:))
- Enddo
-
-!* Change units
- Do ilayer = 1, nwp_levels
-
-!* Optical depths in km-1 and at nadir
- Do ichan = 1, nchannels
- iprof = lsprofiles (ichan)
-
- scatt_aux % ext (ichan,ilayer) = opd_nwp (ichan,ilayer) * (presfh (iprof,ilayer+1) - presfh (iprof,ilayer)) &
- & / scatt_aux % dz (iprof,ilayer) * angles (iprof) % coszen
-
- if (scatt_aux % ext (ichan,ilayer) < 1.0E-10_JPRB) scatt_aux % ext (ichan,ilayer) = 1.0E-10_JPRB
- Enddo
-
-!* Condensate from g/g to g/m^3
- Do iprof = 1, nprofiles
- scatt_aux % clw (iprof,ilayer) = scatt_aux % clw (iprof,ilayer) * presf (iprof,ilayer) &
- & * de2mr / cld_profiles (iprof) % t (ilayer)
- scatt_aux % ciw (iprof,ilayer) = scatt_aux % ciw (iprof,ilayer) * presf (iprof,ilayer) &
- & * de2mr / cld_profiles (iprof) % t (ilayer)
-
-!* Rates from kg/m^2/s to g/m^3
- scatt_aux % rain (iprof,ilayer) = scatt_aux % rain (iprof,ilayer) / rho_rain
- scatt_aux % sp (iprof,ilayer) = scatt_aux % sp (iprof,ilayer) / rho_snow
-
- scatt_aux % rain (iprof,ilayer) = scatt_aux % rain (iprof,ilayer) * 3600.0_JPRB
- scatt_aux % sp (iprof,ilayer) = scatt_aux % sp (iprof,ilayer) * 3600.0_JPRB
-
- if (scatt_aux % rain (iprof,ilayer) > 0.0_JPRB) &
- & scatt_aux % rain (iprof,ilayer) = (scatt_aux % rain (iprof,ilayer) * &
- & coef_scatt % conv_rain (1))**(coef_scatt % conv_rain (2))
- if (scatt_aux % sp (iprof,ilayer) > 0.0_JPRB) &
- & scatt_aux % sp (iprof,ilayer) = (scatt_aux % sp (iprof,ilayer) * &
- & coef_scatt % conv_sp (1))**(coef_scatt % conv_sp (2))
- enddo
- Enddo
-
-!* Cloud/rain absorption/scattering parameters
- Call rttov_mieproc ( &
- & nwp_levels, &! in
- & nchannels, &! in
- & nprofiles, &! in
- & frequencies, &! in
- & lsprofiles, &! in
- & cld_profiles, &! in
- & coef_rttov, &! in
- & coef_scatt, &! in
- & scatt_aux) ! inout
-
-!* Scattering parameters for Eddington RT
- Call rttov_iniedd ( &
- & nwp_levels, &! in
- & nchannels , &! in
- & nprofiles , &! in
- & lsprofiles , &! in
- & angles , &! in
- & coef_scatt, &! in
- & scatt_aux) ! inout
-
-!* Surface emissivities
- zod_up_cld (:) = 0.0_JPRB
-
- Do ichan = 1, nchannels
- iprof = lsprofiles (ichan)
-
- Do ilayer = 1, nwp_levels
- zod_up_cld (ichan) = zod_up_cld (ichan) + scatt_aux % ext (ichan,ilayer) * scatt_aux % dz (iprof,ilayer)
- Enddo
-
- if (zod_up_cld (ichan) >= 30.0_JPRB) zod_up_cld (ichan) = 30.0_JPRB
- transmissioncld % tau_surf (ichan) = Exp(-1.0_JPRB * zod_up_cld (ichan) / angles (iprof) % coszen)
- Enddo
-
- Call rttov_calcemis_mw ( &
- & profiles, &! in
- & angles, &! in
- & coef_rttov, &! in
- & nfrequencies, &! in
- & nchannels, &! in
- & nprofiles, &! in
- & channels, &! in
- & polarisations, &! in
- & lprofiles, &! in
- & transmissioncld, &! in
- & calcemiss, &! in
- & scatt_aux % ems_cld, &! inout
- & scatt_aux % ref_cld, &! out
- & errorstatus ) ! inout
-
-!* Hemispheric emissivity (= Fastem's effective emissivity)
- scatt_aux % ems_bnd (:) = scatt_aux % ems_cld (:)
- scatt_aux % ref_bnd (:) = scatt_aux % ref_cld (:)
-
-!* Deallocate
- deallocate (transmissioncld % tau_surf)
-
-End Subroutine rttov_iniscatt
diff --git a/src/LIB/RTTOV/src/rttov_iniscatt.interface b/src/LIB/RTTOV/src/rttov_iniscatt.interface
deleted file mode 100644
index 2aea7aed2895a83b8108a7df9d113334d7b8a1c3..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_iniscatt.interface
+++ /dev/null
@@ -1,51 +0,0 @@
-INTERFACE
-Subroutine rttov_iniscatt (&
- & errorstatus,&
- & nwp_levels,&
- & nrt_levels,&
- & nfrequencies,&
- & nchannels,&
- & nprofiles,&
- & polarisations,&
- & channels,&
- & frequencies,&
- & lprofiles,&
- & lsprofiles,&
- & profiles,&
- & cld_profiles,&
- & coef_rttov,&
- & coef_scatt,&
- & transmission,&
- & calcemiss,&
- & angles,&
- & scatt_aux)
- Use rttov_types, Only :&
- & rttov_coef ,&
- & rttov_scatt_coef ,&
- & transmission_type ,&
- & geometry_Type ,&
- & profile_scatt_aux ,&
- & profile_Type ,&
- & profile_cloud_Type
- Use parkind1, Only : jpim ,jprb
- Integer (Kind=jpim), Intent (in) :: nwp_levels
- Integer (Kind=jpim), Intent (in) :: nrt_levels
- Integer (Kind=jpim), Intent (in) :: nprofiles
- Integer (Kind=jpim), Intent (in) :: nfrequencies
- Integer (Kind=jpim), Intent (in) :: nchannels
- Integer (Kind=jpim), Intent(out) :: errorstatus(nprofiles)
- Integer (Kind=jpim), Intent (in) :: frequencies (nchannels)
- Integer (Kind=jpim), Intent (in) :: channels (nfrequencies)
- Integer (Kind=jpim), Intent (in) :: polarisations (nchannels,3)
- Integer (Kind=jpim), Intent (in) :: lprofiles (nfrequencies)
- Integer (Kind=jpim), Intent (in) :: lsprofiles (nchannels)
- Logical , Intent (in) :: calcemiss (nchannels)
- Type (profile_Type), Intent (in) :: profiles (nprofiles)
- Type (rttov_coef), Intent (in) :: coef_rttov
- Type (rttov_scatt_coef), Intent (in) :: coef_scatt
- Type (profile_cloud_Type), Intent (in) :: cld_profiles (nprofiles)
- Type (transmission_Type), Intent (in) :: transmission
- Type (geometry_Type), Intent (out) :: angles (nprofiles)
- Type (profile_scatt_aux), Intent (inout) :: scatt_aux
-End Subroutine rttov_iniscatt
-END INTERFACE
diff --git a/src/LIB/RTTOV/src/rttov_iniscatt_ad.F90 b/src/LIB/RTTOV/src/rttov_iniscatt_ad.F90
deleted file mode 100644
index a08719b3c73d7d87c20c87e461d193a4419b3a3c..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_iniscatt_ad.F90
+++ /dev/null
@@ -1,687 +0,0 @@
-!
-Subroutine rttov_iniscatt_ad (&
- & errorstatus, &! out
- & nwp_levels, &! in
- & nrt_levels, &! in
- & nfrequencies, &! in
- & nchannels, &! in
- & nprofiles, &! in
- & polarisations, &! in
- & channels, &! in
- & frequencies, &! in
- & lprofiles, &! in
- & lsprofiles, &! in
- & profiles, &! in
- & profiles_ad, &! inout
- & cld_profiles, &! in
- & cld_profiles_ad, &! inout
- & coef_rttov, &! in
- & coef_scatt, &! in
- & transmission, &! in
- & transmission_ad, &! inout
- & calcemiss, &! in
- & angles, &! out
- & scatt_aux, &! inout
- & scatt_aux_ad) ! inout
-
- !
- ! Description:
- ! AD of routine to
- ! Calculate some variables related to the input precipitation profile
- !
- ! Copyright:
- ! This software was developed within the context of
- ! the EUMETSAT Satellite Application Facility on
- ! Numerical Weather Prediction (NWP SAF), under the
- ! Cooperation Agreement dated 25 November 1998, between
- ! EUMETSAT and the Met Office, UK, by one or more partners
- ! within the NWP SAF. The partners in the NWP SAF are
- ! the Met Office, ECMWF, KNMI and MeteoFrance.
- !
- ! Copyright 2002, EUMETSAT, All Rights Reserved.
- !
- ! Method:
- !
- ! Current Code Owner: SAF NWP
- !
- ! History:
- ! Version Date Comment
- ! ------- ---- -------
- ! 1.0 09/2002 Initial version (F. Chevallier)
- ! 1.1 05/2003 RTTOV7.3 compatible (F. Chevallier)
- ! 1.2 03/2004 Added polarimetry (R. Saunders)
- ! 1.3 08/2004 Polarimetry fixes (U. O'Keefe)
- ! 1.4 11/2004 Clean-up (P. Bauer)
- ! 1.5 10/2005 Fixes for rttov8 indexing (U. O'Keeffe)
- ! 1.6 11/2005 Limit lines to 132 characters
- ! add errorstatus to arguments
- ! change stop to return (J Cameron)
- ! 1.7 09/2006 Add if loop to stop use of iccmax index
- ! if = 0 (A. Doherty)
- !
- ! Code Description:
- ! Language: Fortran 90.
- ! Software Standards: "European Standards for Writing and
- ! Documenting Exchangeable Fortran 90 Code".
- !
- ! Declarations:
- ! Modules used:
- ! Imported Type Definitions:
-
- Use rttov_types, Only : &
- & rttov_coef ,&
- & rttov_scatt_coef ,&
- & transmission_type ,&
- & geometry_Type ,&
- & profile_scatt_aux ,&
- & profile_Type ,&
- & profile_cloud_Type
-
- Use rttov_const, Only: &
- & errorstatus_success, &
- & errorstatus_fatal, &
- & gravity, &
- & pressure_top, &
- & rgp, &
- & rm, &
- & rho_rain, &
- & rho_snow, &
- & ccthres
-
- Use parkind1, Only : jpim ,jprb
-
- Implicit None
-
-#include "rttov_mieproc.interface"
-#include "rttov_iniedd.interface"
-#include "rttov_calcemis_mw.interface"
-#include "rttov_mieproc_ad.interface"
-#include "rttov_iniedd_ad.interface"
-#include "rttov_calcemis_mw_ad.interface"
-#include "rttov_setgeometry.interface"
-#include "rttov_errorreport.interface"
-#include "rttov_intex.interface"
-#include "rttov_intex_ad.interface"
-
-!* Subroutine arguments:
- Integer (Kind=jpim), Intent (in) :: nwp_levels ! Number of levels
- Integer (Kind=jpim), Intent (in) :: nrt_levels ! Number of levels
- Integer (Kind=jpim), Intent (in) :: nprofiles ! Number of profiles
- Integer (Kind=jpim), Intent (in) :: nfrequencies ! Number of frequencies
- Integer (Kind=jpim), Intent (in) :: nchannels ! Number of channels*profiles=radiances
- Integer (Kind=jpim), Intent(out) :: errorstatus(nprofiles) ! Error return code
- Integer (Kind=jpim), Intent (in) :: channels (nfrequencies) ! Channel indices
- Integer (Kind=jpim), Intent (in) :: frequencies (nchannels) ! Frequency indices
- Integer (Kind=jpim), Intent (in) :: polarisations (nchannels,3) ! Polarisation indices
- Integer (Kind=jpim), Intent (in) :: lprofiles (nfrequencies) ! Profile indices
- Integer (Kind=jpim), Intent (in) :: lsprofiles (nchannels) ! Profile indices
- Logical , Intent (in) :: calcemiss (nchannels) ! Emissivity flags
-
- Type (profile_Type), Intent (in) :: profiles (nprofiles) ! Atmospheric profiles
- Type (profile_Type), Intent (inout) :: profiles_ad (nprofiles) ! Atmospheric profiles
- Type (rttov_coef), Intent (in) :: coef_rttov ! RTTOV Coefficients
- Type (rttov_scatt_coef), Intent (in) :: coef_scatt ! RTTOV_SCATT Coefficients
- Type (profile_cloud_Type), Intent (in) :: cld_profiles (nprofiles) ! Cloud profiles with NWP levels
- Type (profile_cloud_Type), Intent (inout) :: cld_profiles_ad (nprofiles) ! Cloud profiles on NWP levels
- Type (transmission_Type), Intent (in) :: transmission ! Transmittances and optical depths
- Type (transmission_Type), Intent (inout) :: transmission_ad ! Transmittances and optical depths
- Type (geometry_Type), Intent (out) :: angles (nprofiles) ! Zenith angles
- Type (profile_scatt_aux), Intent (inout) :: scatt_aux ! Auxiliary profile variables
- Type (profile_scatt_aux), Intent (inout) :: scatt_aux_ad ! Auxiliary profile variables
-
-!* Local variables
- Integer (Kind=jpim) :: ilayer, iprof, ichan, iccmax (nprofiles)
- Real (Kind=jprb) :: p1, p2, pm, p1_ad, p2_ad, pm_ad, dp2dz, de2mr, zccmax
-
- Real (Kind=jprb), Dimension (nprofiles,nwp_levels) :: presf ! Pressure levels [hPa]
- Real (Kind=jprb), Dimension (nprofiles,nwp_levels+1) :: presfh ! Half-level NWP pressure levels [hPa]
- Real (Kind=jprb), Dimension (nprofiles,nrt_levels) :: presi ! Half-level RTTOV pressure levels [hPa]
- Real (Kind=jprb), Dimension (nchannels,nwp_levels) :: opd_nwp
- Real (Kind=jprb), Dimension (nchannels,nrt_levels) :: opd_nrt
- Real (Kind=jprb), Dimension (nchannels) :: zod_up_cld ! Optical depth from top of the atmosphere
- Real (Kind=jprb), Dimension (nchannels) :: emissivity ! Surface emissivity
- Real (Kind=jprb), Dimension (nchannels) :: reflectivity ! Surface reflectivity
- Real (Kind=jprb), Dimension (nprofiles,nwp_levels) :: presf_ad ! Pressure levels [hPa]
- Real (Kind=jprb), Dimension (nprofiles,nwp_levels+1) :: presfh_ad ! Half-level NWP pressure levels [hPa]
- Real (Kind=jprb), Dimension (nprofiles,nrt_levels) :: presi_ad ! Half-level RTTOV pressure levels [hPa]
- Real (Kind=jprb), Dimension (nchannels,nwp_levels) :: opd_nwp_ad
- Real (Kind=jprb), Dimension (nchannels,nrt_levels) :: opd_nrt_ad
- Real (Kind=jprb), Dimension (nchannels) :: zod_up_cld_ad ! Optical depth from top of the atmosphere
- Real (Kind=jprb), Dimension (nchannels) :: emissivity_ad ! Surface emissivity
- Real (Kind=jprb), Dimension (nchannels) :: reflectivity_ad ! Surface reflectivity
-
- Real (Kind=jprb), Dimension (nchannels,nwp_levels) :: ext_0
- Real (Kind=jprb), Dimension (nchannels,nwp_levels) :: ext_1, ssa_1, asm_1
- Real (Kind=jprb), Dimension (nchannels,nwp_levels) :: ext_2, ssa_2, asm_2
- Real (Kind=jprb), Dimension (nchannels,nwp_levels) :: ext_3, ssa_3, asm_3
- Real (Kind=jprb), Dimension (nprofiles,nwp_levels) :: clw_scale, ciw_scale, rain_scale, sp_scale
-
- Type (transmission_Type) :: transmissioncld ! Clear+cloud transmittances with cloud
- Type (transmission_Type) :: transmissioncld_ad ! Clear+cloud transmittances with cloud
-
- Character (len=80) :: errMessage
- Character (len=18) :: NameOfRoutine = 'rttov_iniscatt_ad '
-
- REAL(KIND=JPRB) :: ZHOOK_HANDLE
-
- !- End of header --------------------------------------------------------
-
- errorstatus(:) = errorstatus_success
-
- allocate (transmissioncld % tau_surf (nchannels))
- allocate (transmissioncld_ad % tau_surf (nchannels))
-
- de2mr = 1.0E+05_JPRB * rm / rgp
- dp2dz = -1.0E-03_JPRB * rgp / gravity / rm
-
- scatt_aux % ext (:,:) = 0.0_JPRB
- scatt_aux % ssa (:,:) = 0.0_JPRB
- scatt_aux % asm (:,:) = 0.0_JPRB
-
-!* Security on user-defined pressures
- Do iprof = 1, nprofiles
- Do ilayer = 1, nwp_levels
- If (cld_profiles (iprof) % p (ilayer) >= pressure_top) Then
- presf (iprof,ilayer) = cld_profiles (iprof) % p (ilayer)
- else
- presf (iprof,ilayer) = pressure_top
- Endif
- Enddo
- Do ilayer = 1, nwp_levels + 1
- If (cld_profiles (iprof) % ph (ilayer) >= pressure_top ) Then
- presfh (iprof,ilayer) = cld_profiles (iprof) % ph (ilayer)
- else
- presfh (iprof,ilayer) = pressure_top
- Endif
- Enddo
- Enddo
-
-!* Set up geometric variables
- Do iprof = 1, nprofiles
- Call rttov_setgeometry (profiles (iprof), coef_rttov, angles (iprof))
- End Do
-
-!* Compute temperature at layer boundaries (K)
- Do iprof = 1, nprofiles
- scatt_aux % tbd (iprof,nwp_levels+1) = profiles (iprof) % s2m % t
- scatt_aux % tbd (iprof,1) = cld_profiles (iprof) % t(1)
- Enddo
-
- Do ilayer = 1, nwp_levels-1
- Do iprof = 1, nprofiles
- p1 = presf (iprof,ilayer+1)
- p2 = presf (iprof,ilayer )
- pm = presfh (iprof,ilayer+1)
-
- scatt_aux % tbd (iprof,ilayer+1) = cld_profiles (iprof) % t (ilayer+1) &
- & + (cld_profiles (iprof) % t (ilayer) &
- & - cld_profiles (iprof) % t (ilayer+1)) &
- & / log(p2/p1) * log(pm/p1)
- Enddo
- Enddo
-
-!* Horizontal clear-sky fraction
- scatt_aux % clw (:,:) = 0.0_JPRB
- scatt_aux % ciw (:,:) = 0.0_JPRB
- scatt_aux % rain (:,:) = 0.0_JPRB
- scatt_aux % sp (:,:) = 0.0_JPRB
- scatt_aux % ccmax (:) = 0.0_JPRB
-
- iccmax (:) = 0
-
- Do iprof = 1, nprofiles
- zccmax = 0.0_JPRB
- Do ilayer = 1, nwp_levels
- if (cld_profiles (iprof) % cc (ilayer) > zccmax) then
- zccmax = cld_profiles (iprof) % cc (ilayer)
- iccmax (iprof) = ilayer
- end if
- end do
- scatt_aux % ccmax (iprof) = zccmax
-
- If (scatt_aux % ccmax (iprof) > ccthres) Then
- clw_scale (iprof,:) = cld_profiles (iprof) % clw (:) / scatt_aux % ccmax (iprof)
- ciw_scale (iprof,:) = cld_profiles (iprof) % ciw (:) / scatt_aux % ccmax (iprof)
- rain_scale (iprof,:) = cld_profiles (iprof) % rain (:) / scatt_aux % ccmax (iprof)
- sp_scale (iprof,:) = cld_profiles (iprof) % sp (:) / scatt_aux % ccmax (iprof)
- else
- clw_scale (iprof,:) = 0.0_JPRB
- ciw_scale (iprof,:) = 0.0_JPRB
- rain_scale (iprof,:) = 0.0_JPRB
- sp_scale (iprof,:) = 0.0_JPRB
- Endif
- Enddo
-
-!* Nadir heights (km)
- Do ilayer = nwp_levels, 1, -1
- Do iprof = 1, nprofiles
- p1 = presfh (iprof,ilayer+1)
- p2 = presfh (iprof,ilayer )
-
- If (p1 <= p2) then
- errorstatus (:) = errorstatus_fatal
- Write( errMessage, '( "iniscatt : problem with user-defined pressure layering")' )
- Call Rttov_ErrorReport (errorstatus(iprof), errMessage, NameOfRoutine)
- Return
- End If
-
- scatt_aux % dz (iprof,ilayer) = dp2dz * Log(p2/p1) * cld_profiles (iprof) % t (ilayer)
- Enddo
- Enddo
-
-!* Interpolate optical depths (at nadir and in hPa-1) to model levels
- Do ichan = 1, nchannels
- iprof = lsprofiles (ichan)
-
- opd_nrt (ichan,1) = transmission % od_singlelayer (1,ichan) / (profiles (iprof) % p (1) - pressure_top)
- presi (iprof,1) = (profiles (iprof) % p (1) + pressure_top) / 2.0_JPRB
-
- Do ilayer = 2, nrt_levels
- opd_nrt (ichan,ilayer) = transmission % od_singlelayer (ilayer,ichan) &
- & / (profiles (iprof) % p (ilayer) - profiles (iprof) % p (ilayer-1))
- presi (iprof,ilayer) = (profiles (iprof) % p (ilayer) + profiles (iprof) % p (ilayer-1)) / 2.0_JPRB
- Enddo
-
- Call rttov_intex (nrt_levels, nwp_levels, presi (iprof,:), presf (iprof,:), opd_nrt (ichan,:), opd_nwp (ichan,:))
- Enddo
-
-!* Change units
- Do ilayer = 1, nwp_levels
-
-!* Optical depths in km-1 and at nadir
- Do ichan = 1, nchannels
- iprof = lsprofiles (ichan)
-
- scatt_aux % ext (ichan,ilayer) = opd_nwp (ichan,ilayer) * (presfh (iprof,ilayer+1) - presfh (iprof,ilayer)) &
- & / scatt_aux % dz (iprof,ilayer) * angles (iprof) % coszen
-
- ext_0 (ichan,ilayer) = scatt_aux % ext (ichan,ilayer)
-
- if (scatt_aux % ext (ichan,ilayer) < 1.0E-10_JPRB) scatt_aux % ext (ichan,ilayer) = 1.0E-10_JPRB
- Enddo
-
-!* Condensate from g/g to g/m^3
- Do iprof = 1, nprofiles
- scatt_aux % clw (iprof,ilayer) = clw_scale (iprof,ilayer) * presf (iprof,ilayer) * de2mr / cld_profiles (iprof) % t (ilayer)
- scatt_aux % ciw (iprof,ilayer) = ciw_scale (iprof,ilayer) * presf (iprof,ilayer) * de2mr / cld_profiles (iprof) % t (ilayer)
-
-!* Rates from kg/m^2/s to g/m^3
- rain_scale (iprof,ilayer) = rain_scale (iprof,ilayer) / rho_rain
- sp_scale (iprof,ilayer) = sp_scale (iprof,ilayer) / rho_snow
-
- rain_scale (iprof,ilayer) = rain_scale (iprof,ilayer) * 3600.0_JPRB
- sp_scale (iprof,ilayer) = sp_scale (iprof,ilayer) * 3600.0_JPRB
-
- if (rain_scale (iprof,ilayer) > 0.0_JPRB) scatt_aux % rain (iprof,ilayer) = &
- & (rain_scale (iprof,ilayer) * coef_scatt % conv_rain (1))**(coef_scatt % conv_rain (2))
- if (sp_scale (iprof,ilayer) > 0.0_JPRB) scatt_aux % sp (iprof,ilayer) = &
- & (sp_scale (iprof,ilayer) * coef_scatt % conv_sp (1))**(coef_scatt % conv_sp (2))
- Enddo
- Enddo
-
-!* Store clear-sky absorption/scattering parameters
- ext_1 (:,:) = scatt_aux % ext (:,:)
- ssa_1 (:,:) = scatt_aux % ssa (:,:)
- asm_1 (:,:) = scatt_aux % asm (:,:)
-
-!* Cloud/rain absorption/scattering parameters
- Call rttov_mieproc ( &
- & nwp_levels, &! in
- & nchannels, &! in
- & nprofiles, &! in
- & frequencies, &! in
- & lsprofiles, &! in
- & cld_profiles, &! in
- & coef_rttov, &! in
- & coef_scatt, &! in
- & scatt_aux) ! inout
-
-!* Store clear+cloud+rain absorption/scattering parameters
- ext_2 (:,:) = scatt_aux % ext (:,:)
- ssa_2 (:,:) = scatt_aux % ssa (:,:)
- asm_2 (:,:) = scatt_aux % asm (:,:)
-
-!* Scattering parameters for Eddington RT
- Call rttov_iniedd( &
- & nwp_levels, &! in
- & nchannels , &! in
- & nprofiles , &! in
- & lsprofiles , &! in
- & angles , &! in
- & coef_scatt, &! in
- & scatt_aux) ! inout
-
-!* Store delta-scaled clear+cloud+rain absorption/scattering parameters
- ext_3 (:,:) = scatt_aux % ext (:,:)
- ssa_3 (:,:) = scatt_aux % ssa (:,:)
- asm_3 (:,:) = scatt_aux % asm (:,:)
-
-!* Surface emissivities
- zod_up_cld (:) = 0.0_JPRB
-
- Do ichan = 1, nchannels
- iprof = lsprofiles (ichan)
-
- Do ilayer = 1, nwp_levels
- zod_up_cld (ichan) = zod_up_cld (ichan) + scatt_aux % ext (ichan,ilayer) * scatt_aux % dz (iprof,ilayer)
- Enddo
- if (zod_up_cld (ichan) >= 30.0_JPRB) zod_up_cld (ichan) = 30.0_JPRB
- transmissioncld % tau_surf (ichan) = Exp(-1.0_JPRB * zod_up_cld (ichan) / angles (iprof) % coszen)
- Enddo
-
- Call rttov_calcemis_mw( &
- & profiles, &! in
- & angles, &! in
- & coef_rttov, &! in
- & nfrequencies, &! in
- & nchannels, &! in
- & nprofiles, &! in
- & channels, &! in
- & polarisations, &! in
- & lprofiles, &! in
- & transmissioncld, &! in
- & calcemiss, &! in
- & scatt_aux % ems_cld, &! inout
- & scatt_aux % ref_cld, &! out
- & errorstatus ) ! inout
-
-!* Hemispheric emissivity (= Fastem's effective emissivity)
- scatt_aux % ems_bnd (:) = scatt_aux % ems_cld (:)
- scatt_aux % ref_bnd (:) = scatt_aux % ref_cld (:)
-
-!* ADJOINT PART
-!* Hemispheric emissivity (= Fastem's effective emissivity)
- scatt_aux_ad % ems_cld (:) = scatt_aux_ad % ems_cld (:) + scatt_aux_ad % ems_bnd (:)
- scatt_aux_ad % ems_bnd (:) = 0.0_JPRB
-
- scatt_aux_ad % ref_cld (:) = scatt_aux_ad % ref_cld (:) + scatt_aux_ad % ref_bnd (:)
- scatt_aux_ad % ref_bnd (:) = 0.0_JPRB
-
- transmissioncld_ad % tau_surf (:) = 0.0_JPRB
-
-
- Call rttov_calcemis_mw_ad( &
- & profiles, &! in
- & profiles_ad, &! inout
- & angles, &! in
- & coef_rttov, &! in
- & nfrequencies, &! in
- & nchannels, &! in
- & nprofiles, &! in
- & channels, &! in
- & polarisations, &! in
- & lprofiles, &! in
- & transmissioncld , &! in
- & transmissioncld_ad, &! in
- & calcemiss, &! in
- & scatt_aux_ad % ems_cld, &! inout
- & scatt_aux_ad % ref_cld) ! inout
-
- scatt_aux_ad % ems_cld (:) = 0.0_JPRB
- scatt_aux_ad % ref_cld (:) = 0.0_JPRB
-
- zod_up_cld_ad (:) = 0.0_JPRB
-
- Do ichan = 1, nchannels
- iprof = lsprofiles (ichan)
-
- zod_up_cld_ad (ichan) = zod_up_cld_ad (ichan) - transmissioncld_ad % tau_surf (ichan) &
- & * transmissioncld % tau_surf (ichan) / angles (iprof) % coszen
- transmissioncld_ad % tau_surf (ichan) = 0.0_JPRB
-
- if (zod_up_cld (ichan) == 30.0_JPRB) zod_up_cld_ad (ichan) = 0.0_JPRB
-
- Do ilayer = 1, nwp_levels
- iprof = lsprofiles (ichan)
-
- scatt_aux_ad % ext (ichan,ilayer) = scatt_aux_ad % ext (ichan,ilayer) &
- & + scatt_aux % dz (iprof,ilayer) * zod_up_cld_ad (ichan)
- scatt_aux_ad % dz (iprof,ilayer) = scatt_aux_ad % dz (iprof,ilayer) &
- & + scatt_aux % ext (ichan,ilayer) * zod_up_cld_ad (ichan)
- Enddo
- Enddo
- zod_up_cld_ad (:) = 0.0_JPRB
-
- scatt_aux % ext (:,:) = ext_2 (:,:)
- scatt_aux % ssa (:,:) = ssa_2 (:,:)
- scatt_aux % asm (:,:) = asm_2 (:,:)
-
-!* Scattering parameters for Eddington RT
- Call rttov_iniedd_ad( &
- & nwp_levels, &! in
- & nchannels , &! in
- & nprofiles , &! in
- & lsprofiles , &! in
- & angles , &! in
- & coef_scatt, &! in
- & scatt_aux , &! inout
- & scatt_aux_ad) ! inout
-
-!* Cloud/rain absorption/scattering parameters
- scatt_aux % ext (:,:) = ext_1 (:,:)
- scatt_aux % ssa (:,:) = ssa_1 (:,:)
- scatt_aux % asm (:,:) = asm_1 (:,:)
-
- Call rttov_mieproc_ad (&
- & nwp_levels, &! in
- & nchannels, &! in
- & nprofiles, &! in
- & frequencies, &! in
- & lsprofiles, &! in
- & cld_profiles, &! in
- & cld_profiles_ad, &! in
- & coef_rttov, &! in
- & coef_scatt, &! in
- & scatt_aux, &! inout
- & scatt_aux_ad) ! inout
-
-
-!* Change units
- presfh_ad (:,:) = 0.0_JPRB
- presf_ad (:,:) = 0.0_JPRB
-
- Do ilayer = 1,nwp_levels
- Do iprof = 1, nprofiles
-
-!* Rates from kg/m^2/s to g/m^3
- if (sp_scale (iprof,ilayer) > 0.0_JPRB) then
- scatt_aux_ad % sp (iprof,ilayer) = scatt_aux_ad % sp (iprof,ilayer) &
- & * (coef_scatt % conv_sp (2)) * (sp_scale (iprof,ilayer)**(coef_scatt % conv_sp (2) - 1.0_JPRB)) &
- & * (coef_scatt % conv_sp (1))**(coef_scatt % conv_sp (2))
- else
- scatt_aux_ad % sp (iprof,ilayer) = 0.0_JPRB
- endif
-
- if (rain_scale (iprof,ilayer) > 0.0_JPRB) then
- scatt_aux_ad % rain (iprof,ilayer) = scatt_aux_ad % rain (iprof,ilayer) &
- & * (coef_scatt % conv_rain (2)) * (rain_scale (iprof,ilayer)**(coef_scatt % conv_rain (2) - 1.0_JPRB)) &
- & * (coef_scatt % conv_rain (1))**(coef_scatt % conv_rain (2))
- else
- scatt_aux_ad % rain (iprof,ilayer) = 0.0_JPRB
- endif
-
- scatt_aux_ad % sp (iprof,ilayer) = scatt_aux_ad % sp (iprof,ilayer) * 3600.0_JPRB
- scatt_aux_ad % rain (iprof,ilayer) = scatt_aux_ad % rain (iprof,ilayer) * 3600.0_JPRB
-
- scatt_aux_ad % sp (iprof,ilayer) = scatt_aux_ad % sp (iprof,ilayer) / rho_snow
- scatt_aux_ad % rain (iprof,ilayer) = scatt_aux_ad % rain (iprof,ilayer) / rho_rain
-
-!* Condensate from g/g to g/m^3
- presf_ad (iprof,ilayer) = presf_ad (iprof,ilayer) + ciw_scale (iprof,ilayer) &
- & * de2mr / cld_profiles (iprof) % t (ilayer) * scatt_aux_ad % ciw (iprof,ilayer)
- cld_profiles_ad (iprof) % t (ilayer) = cld_profiles_ad (iprof) % t (ilayer) &
- & - ciw_scale (iprof,ilayer) * presf (iprof,ilayer) * de2mr &
- & / (cld_profiles (iprof) % t (ilayer) &
- & * cld_profiles (iprof) % t (ilayer)) * scatt_aux_ad % ciw (iprof,ilayer)
- scatt_aux_ad % ciw (iprof,ilayer) = presf(iprof,ilayer) * de2mr / cld_profiles (iprof) % t (ilayer) &
- & * scatt_aux_ad % ciw (iprof,ilayer)
-
- presf_ad (iprof,ilayer) = presf_ad (iprof,ilayer) + clw_scale (iprof,ilayer) &
- & * de2mr / cld_profiles (iprof) % t (ilayer) * scatt_aux_ad % clw (iprof,ilayer)
- cld_profiles_ad (iprof) % t (ilayer) = cld_profiles_ad (iprof) % t (ilayer) &
- & - clw_scale (iprof,ilayer) * presf (iprof,ilayer) * de2mr &
- & / (cld_profiles (iprof) % t (ilayer) &
- & * cld_profiles (iprof) % t (ilayer)) * scatt_aux_ad % clw (iprof,ilayer)
- scatt_aux_ad % clw (iprof,ilayer) = presf (iprof,ilayer) * de2mr / cld_profiles(iprof) % t (ilayer) &
- & * scatt_aux_ad % clw (iprof,ilayer)
-
- Enddo
-
-!* Optical depths in km-1 and at nadir
- Do ichan = 1, nchannels
- iprof = lsprofiles (ichan)
-
-! scatt_aux % ext (ichan,ilayer) = opd_nwp (ichan,ilayer) * (presfh (iprof,ilayer+1) - presfh (iprof,ilayer)) &
-! & / scatt_aux % dz (iprof,ilayer) * angles (iprof) % coszen
- If (ext_0 (ichan,ilayer) < 1.0E-10_JPRB) scatt_aux_ad % ext (ichan,ilayer) = 0.0_JPRB
-
- opd_nwp_ad (ichan,ilayer ) = (presfh (iprof,ilayer+1) - presfh (iprof,ilayer)) / scatt_aux % dz (iprof,ilayer) &
- & * angles (iprof) % coszen * scatt_aux_ad % ext (ichan,ilayer)
- presfh_ad (iprof,ilayer+1) = presfh_ad (iprof,ilayer+1) + opd_nwp (ichan,ilayer) / scatt_aux % dz (iprof,ilayer) &
- & * angles (iprof) % coszen * scatt_aux_ad % ext (ichan,ilayer)
- presfh_ad (iprof,ilayer ) = presfh_ad (iprof,ilayer ) - opd_nwp (ichan,ilayer) / scatt_aux % dz (iprof,ilayer) &
- & * angles (iprof) % coszen * scatt_aux_ad % ext (ichan,ilayer)
- scatt_aux_ad % dz (iprof,ilayer) = scatt_aux_ad % dz (iprof,ilayer) - opd_nwp (ichan,ilayer) &
- & * (presfh (iprof,ilayer+1) - presfh (iprof,ilayer)) &
- & * angles (iprof) % coszen / (scatt_aux % dz (iprof,ilayer) * scatt_aux % dz (iprof,ilayer)) &
- & * scatt_aux_ad % ext (ichan,ilayer)
- scatt_aux_ad % ext (ichan,ilayer) = 0.0_JPRB
- Enddo
- Enddo
-
-
-!* Interpolate optical depths (at nadir and in hPa-1) to model levels
- opd_nrt_ad (:,:) = 0.0_JPRB
- presi_ad (:,:) = 0.0_JPRB
-
- Do ichan = 1, nchannels
- iprof = lsprofiles (ichan)
-
- Call rttov_intex_ad (nrt_levels, nwp_levels, &
- & presi_ad (iprof,:), presf_ad (iprof,:), opd_nrt_ad (ichan,:), opd_nwp_ad (ichan,:), &
- & presi (iprof,:), presf (iprof,:), opd_nrt (ichan,:), opd_nwp (ichan,:))
-
- Do ilayer = nrt_levels, 2, -1
- transmission_ad % od_singlelayer (ilayer,ichan) = transmission_ad % od_singlelayer (ilayer,ichan) &
- & + opd_nrt_ad (ichan,ilayer) / (profiles (iprof) % p (ilayer) - profiles (iprof) % p (ilayer-1))
- opd_nrt_ad (ichan,ilayer) = 0.0_JPRB
- Enddo
- transmission_ad % od_singlelayer (1,ichan) = transmission_ad % od_singlelayer (1,ichan) &
- & + opd_nrt_ad (ichan,1) / (profiles (iprof) % p (1) - pressure_top)
- opd_nrt_ad (ichan,1) = 0.0_JPRB
- Enddo
-
-!* Nadir heights (km)
- Do ilayer = 1, nwp_levels
- Do iprof = 1, nprofiles
- p1 = presfh (iprof,ilayer+1)
- p2 = presfh (iprof,ilayer )
-
- p2_ad = dp2dz / p2 * cld_profiles (iprof) % t (ilayer) * scatt_aux_ad % dz (iprof,ilayer)
- p1_ad = -1.0_JPRB * dp2dz / p1 * cld_profiles (iprof) % t (ilayer) * scatt_aux_ad % dz (iprof,ilayer)
- cld_profiles_ad (iprof) % t (ilayer) = cld_profiles_ad (iprof) % t (ilayer) &
- & + dp2dz * Log(p2/p1) * scatt_aux_ad % dz (iprof,ilayer)
- scatt_aux_ad % dz (iprof,ilayer) = 0.0_JPRB
-
- presfh_ad (iprof,ilayer) = presfh_ad (iprof,ilayer) + p2_ad
- presfh_ad (iprof,ilayer+1) = presfh_ad (iprof,ilayer+1) + p1_ad
- Enddo
- Enddo
-
-!* Horizontal clear-sky fraction
- Do iprof = 1, nprofiles
- If (scatt_aux % ccmax (iprof) > ccthres) Then
- cld_profiles_ad (iprof) % clw (:) = cld_profiles_ad (iprof) % clw (:) &
- & + scatt_aux_ad % clw (iprof,:) / scatt_aux % ccmax (iprof)
- cld_profiles_ad (iprof) % ciw (:) = cld_profiles_ad (iprof) % ciw (:) &
- & + scatt_aux_ad % ciw (iprof,:) / scatt_aux % ccmax (iprof)
- cld_profiles_ad (iprof) % rain (:) = cld_profiles_ad (iprof) % rain (:) &
- & + scatt_aux_ad % rain (iprof,:) / scatt_aux % ccmax (iprof)
- cld_profiles_ad (iprof) % sp (:) = cld_profiles_ad (iprof) % sp (:) &
- & + scatt_aux_ad % sp (iprof,:) / scatt_aux % ccmax (iprof)
-
- Do ilayer = 1, nwp_levels
- scatt_aux_ad % ccmax (iprof) = scatt_aux_ad % ccmax (iprof) &
- & - (cld_profiles (iprof) % clw (ilayer) * scatt_aux_ad % clw (iprof,ilayer) &
- & + cld_profiles (iprof) % ciw (ilayer) * scatt_aux_ad % ciw (iprof,ilayer) &
- & + cld_profiles (iprof) % rain (ilayer) * scatt_aux_ad % rain (iprof,ilayer) &
- & + cld_profiles (iprof) % sp (ilayer) * scatt_aux_ad % sp (iprof,ilayer)) &
- & / (scatt_aux % ccmax (iprof) * scatt_aux % ccmax (iprof))
- Enddo
- else
- scatt_aux_ad % clw (iprof,:) = 0.0_JPRB
- scatt_aux_ad % ciw (iprof,:) = 0.0_JPRB
- scatt_aux_ad % rain (iprof,:) = 0.0_JPRB
- scatt_aux_ad % sp (iprof,:) = 0.0_JPRB
- Endif
-
- if (iccmax(iprof) >0) then
- cld_profiles_ad (iprof) % cc (iccmax (iprof)) = cld_profiles_ad (iprof) % cc (iccmax (iprof)) + scatt_aux_ad % ccmax (iprof)
- endif
- scatt_aux_ad % ccmax (iprof) = 0.0_JPRB
- Enddo
-
- scatt_aux_ad % clw (:,:) = 0.0_JPRB
- scatt_aux_ad % ciw (:,:) = 0.0_JPRB
- scatt_aux_ad % rain (:,:) = 0.0_JPRB
- scatt_aux_ad % sp (:,:) = 0.0_JPRB
-
-
-!* Temperature at layer boundaries (K)
- Do ilayer = nwp_levels - 1, 1, -1
- Do iprof = 1, nprofiles
- p1 = presf (iprof,ilayer+1)
- p2 = presf (iprof,ilayer )
- pm = presfh (iprof,ilayer+1)
-
- cld_profiles_ad (iprof) % t (ilayer+1) = cld_profiles_ad (iprof) % t (ilayer+1) + scatt_aux_ad % tbd (iprof,ilayer+1) &
- & - 1.0_JPRB / Log(p2/p1) * Log(pm/p1) * scatt_aux_ad % tbd (iprof,ilayer+1)
- cld_profiles_ad (iprof) % t (ilayer) = cld_profiles_ad (iprof) % t (ilayer) &
- & + 1.0_JPRB / Log(p2/p1) * Log(pm/p1) * scatt_aux_ad % tbd (iprof,ilayer+1)
-
- p1_ad = (cld_profiles (iprof) % t (ilayer) - cld_profiles (iprof) % t (ilayer+1)) &
- & / (Log(p2/p1) * Log(p2/p1)) / p1 * Log(pm/p1) * scatt_aux_ad % tbd (iprof,ilayer+1) &
- & - (cld_profiles (iprof) % t (ilayer) - cld_profiles (iprof) % t (ilayer+1)) &
- & / Log(p2/p1) / p1 * scatt_aux_ad % tbd (iprof,ilayer+1)
- p2_ad = -1.0_JPRB &
- & * (cld_profiles (iprof) % t (ilayer) - cld_profiles (iprof) % t (ilayer+1)) &
- & * Log(pm/p1) / (Log(p2/p1) * Log(p2/p1)) / p2 * scatt_aux_ad % tbd (iprof,ilayer+1)
- pm_ad = (cld_profiles (iprof) % t (ilayer) - cld_profiles (iprof) % t (ilayer+1)) &
- & / Log(p2/p1) / pm * scatt_aux_ad % tbd (iprof,ilayer+1)
- scatt_aux_ad % tbd (iprof,ilayer+1) = 0.0_JPRB
-
- presf_ad (iprof,ilayer+1) = presf_ad (iprof,ilayer+1) + p1_ad
- presf_ad (iprof,ilayer ) = presf_ad (iprof,ilayer ) + p2_ad
- presfh_ad (iprof,ilayer+1) = presfh_ad (iprof,ilayer+1) + pm_ad
- Enddo
- Enddo
-
- Do iprof = 1, nprofiles
- profiles_ad (iprof) % s2m % t = profiles_ad (iprof) % s2m % t + scatt_aux_ad % tbd (iprof,nwp_levels+1)
- cld_profiles_ad (iprof) % t (1) = cld_profiles_ad (iprof) % t (1) + scatt_aux_ad % tbd (iprof,1)
- Enddo
- scatt_aux_ad % tbd (:,:) = 0.0_JPRB
-
-!* Security on user-defined pressures
- Do iprof = 1, nprofiles
- Do ilayer = 1, nwp_levels
- If (cld_profiles (iprof) % p (ilayer) >= pressure_top) &
- & cld_profiles_ad (iprof) % p (ilayer) = cld_profiles_ad (iprof) % p (ilayer) + presf_ad (iprof,ilayer)
- presf_ad (iprof,ilayer) = 0.0_JPRB
- Enddo
- Do ilayer = 1, nwp_levels + 1
- If (cld_profiles (iprof) % ph (ilayer) >= pressure_top) &
- & cld_profiles_ad (iprof) % ph (ilayer) = cld_profiles_ad (iprof) % ph (ilayer) + presfh_ad (iprof,ilayer)
- presfh_ad (iprof,ilayer) = 0.0_JPRB
- Enddo
- Enddo
-
- scatt_aux % ext (:,:) = ext_3 (:,:)
- scatt_aux % ssa (:,:) = ssa_3 (:,:)
- scatt_aux % asm (:,:) = asm_3 (:,:)
-
-!* Deallocate
- deallocate (transmissioncld % tau_surf)
- deallocate (transmissioncld_ad % tau_surf)
-
-End Subroutine rttov_iniscatt_ad
diff --git a/src/LIB/RTTOV/src/rttov_iniscatt_ad.interface b/src/LIB/RTTOV/src/rttov_iniscatt_ad.interface
deleted file mode 100644
index 665ad7432a65952b9fa19cf7d4f778d434727109..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_iniscatt_ad.interface
+++ /dev/null
@@ -1,59 +0,0 @@
-INTERFACE
-Subroutine rttov_iniscatt_ad (&
- & errorstatus,&
- & nwp_levels,&
- & nrt_levels,&
- & nfrequencies,&
- & nchannels,&
- & nprofiles,&
- & polarisations,&
- & channels,&
- & frequencies,&
- & lprofiles,&
- & lsprofiles,&
- & profiles,&
- & profiles_ad,&
- & cld_profiles,&
- & cld_profiles_ad,&
- & coef_rttov,&
- & coef_scatt,&
- & transmission,&
- & transmission_ad,&
- & calcemiss,&
- & angles,&
- & scatt_aux,&
- & scatt_aux_ad)
- Use rttov_types, Only :&
- & rttov_coef ,&
- & rttov_scatt_coef ,&
- & transmission_type ,&
- & geometry_Type ,&
- & profile_scatt_aux ,&
- & profile_Type ,&
- & profile_cloud_Type
- Use parkind1, Only : jpim ,jprb
- Integer (Kind=jpim), Intent (in) :: nwp_levels
- Integer (Kind=jpim), Intent (in) :: nrt_levels
- Integer (Kind=jpim), Intent (in) :: nprofiles
- Integer (Kind=jpim), Intent (in) :: nfrequencies
- Integer (Kind=jpim), Intent (in) :: nchannels
- Integer (Kind=jpim), Intent(out) :: errorstatus(nprofiles)
- Integer (Kind=jpim), Intent (in) :: channels (nfrequencies)
- Integer (Kind=jpim), Intent (in) :: frequencies (nchannels)
- Integer (Kind=jpim), Intent (in) :: polarisations (nchannels,3)
- Integer (Kind=jpim), Intent (in) :: lprofiles (nfrequencies)
- Integer (Kind=jpim), Intent (in) :: lsprofiles (nchannels)
- Logical , Intent (in) :: calcemiss (nchannels)
- Type (profile_Type), Intent (in) :: profiles (nprofiles)
- Type (profile_Type), Intent (inout) :: profiles_ad (nprofiles)
- Type (rttov_coef), Intent (in) :: coef_rttov
- Type (rttov_scatt_coef), Intent (in) :: coef_scatt
- Type (profile_cloud_Type), Intent (in) :: cld_profiles (nprofiles)
- Type (profile_cloud_Type), Intent (inout) :: cld_profiles_ad (nprofiles)
- Type (transmission_Type), Intent (in) :: transmission
- Type (transmission_Type), Intent (inout) :: transmission_ad
- Type (geometry_Type), Intent (out) :: angles (nprofiles)
- Type (profile_scatt_aux), Intent (inout) :: scatt_aux
- Type (profile_scatt_aux), Intent (inout) :: scatt_aux_ad
-End Subroutine rttov_iniscatt_ad
-END INTERFACE
diff --git a/src/LIB/RTTOV/src/rttov_iniscatt_k.F90 b/src/LIB/RTTOV/src/rttov_iniscatt_k.F90
deleted file mode 100644
index 693028b99c4247ea20b8d51c76d42708a230dbb3..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_iniscatt_k.F90
+++ /dev/null
@@ -1,698 +0,0 @@
-!
-Subroutine rttov_iniscatt_k (&
- & errorstatus, &! out
- & nwp_levels, &! in
- & nrt_levels, &! in
- & nfrequencies, &! in
- & nchannels, &! in
- & nprofiles, &! in
- & polarisations, &! in
- & channels, &! in
- & frequencies, &! in
- & lprofiles, &! in
- & lsprofiles, &! in
- & profiles, &! in
- & profiles_k, &! inout
- & cld_profiles, &! in
- & cld_profiles_k, &! inout
- & coef_rttov, &! in
- & coef_scatt, &! in
- & transmission, &! in
- & transmission_k, &! inout
- & calcemiss, &! in
- & angles, &! out
- & scatt_aux, &! inout
- & scatt_aux_k) ! inout
-
- !
- ! Description:
- ! AD of routine to
- ! Calculate some variables related to the input precipitation profile
- !
- ! Copyright:
- ! This software was developed within the context of
- ! the EUMETSAT Satellite Application Facility on
- ! Numerical Weather Prediction (NWP SAF), under the
- ! Cooperation Agreement dated 25 November 1998, between
- ! EUMETSAT and the Met Office, UK, by one or more partners
- ! within the NWP SAF. The partners in the NWP SAF are
- ! the Met Office, ECMWF, KNMI and MeteoFrance.
- !
- ! Copyright 2002, EUMETSAT, All Rights Reserved.
- !
- ! Method:
- !
- ! Current Code Owner: SAF NWP
- !
- ! History:
- ! Version Date Comment
- ! ------- ---- -------
- ! 1.0 09/2002 Initial version (F. Chevallier)
- ! 1.1 05/2003 RTTOV7.3 compatible (F. Chevallier)
- ! 1.2 03/2004 Added polarimetry (R. Saunders)
- ! 1.3 08/2004 Polarimetry fixes (U. O'Keeffe)
- ! 1.4 11/2004 Clean-up (P. Bauer)
- ! 1.5 02/2005 K-code (A. Collard)
- ! 1.6 10/2005 Fixes for rttov8 indexing (U. O'Keeffe)
- ! 1.7 11/2005 Limit lines to 132 characters,
- ! add errorstatus to arguments,
- ! change stop to return. (J. Cameron)
- ! 1.8 09/2006 Add if loop to stop use of iccmax index
- ! if = 0 (A. Doherty)
- !
- ! Code Description:
- ! Language: Fortran 90.
- ! Software Standards: "European Standards for Writing and
- ! Documenting Exchangeable Fortran 90 Code".
- !
- ! Declarations:
- ! Modules used:
- ! Imported Type Definitions:
-
- Use rttov_types, Only : &
- & rttov_coef ,&
- & rttov_scatt_coef ,&
- & transmission_type ,&
- & geometry_Type ,&
- & profile_scatt_aux ,&
- & profile_Type ,&
- & profile_cloud_Type
-
- Use rttov_const, Only: &
- & errorstatus_success, &
- & errorstatus_fatal, &
- & gravity, &
- & pressure_top, &
- & rgp, &
- & rm, &
- & rho_rain, &
- & rho_snow, &
- & ccthres
-
- Use parkind1, Only : jpim ,jprb
-
- Implicit None
-
-#include "rttov_mieproc.interface"
-#include "rttov_iniedd.interface"
-#include "rttov_calcemis_mw.interface"
-#include "rttov_mieproc_k.interface"
-#include "rttov_iniedd_k.interface"
-#include "rttov_calcemis_mw_k.interface"
-#include "rttov_setgeometry.interface"
-#include "rttov_errorreport.interface"
-#include "rttov_intex.interface"
-#include "rttov_intex_ad.interface"
-
-!* Subroutine arguments:
-
- Integer (Kind=jpim), Intent (in) :: nwp_levels ! Number of levels
- Integer (Kind=jpim), Intent (in) :: nrt_levels ! Number of levels
- Integer (Kind=jpim), Intent (in) :: nprofiles ! Number of profiles
- Integer (Kind=jpim), Intent (in) :: nfrequencies ! Number of frequencies
- Integer (Kind=jpim), Intent (in) :: nchannels ! Number of channels*profiles=radiances
- Integer (Kind=jpim), Intent(out) :: errorstatus(nprofiles) ! Error return code
- Integer (Kind=jpim), Intent (in) :: channels (nfrequencies) ! Channel indices
- Integer (Kind=jpim), Intent (in) :: frequencies (nchannels) ! Frequency indices
- Integer (Kind=jpim), Intent (in) :: polarisations (nchannels,3) ! Polarisation indices
- Integer (Kind=jpim), Intent (in) :: lprofiles (nfrequencies) ! Profile indices
- Integer (Kind=jpim), Intent (in) :: lsprofiles (nchannels) ! Profile indices
- Logical , Intent (in) :: calcemiss (nchannels) ! Emissivity flags
-
- Type (profile_Type), Intent (in) :: profiles (nprofiles) ! Atmospheric profiles
- Type (profile_Type), Intent (inout) :: profiles_k (nchannels) ! Atmospheric profiles
- Type (rttov_coef), Intent (in) :: coef_rttov ! RTTOV Coefficients
- Type (rttov_scatt_coef), Intent (in) :: coef_scatt ! RTTOV_SCATT Coefficients
- Type (profile_cloud_Type), Intent (in) :: cld_profiles (nprofiles) ! Cloud profiles with NWP levels
- Type (profile_cloud_Type), Intent (inout) :: cld_profiles_k (nchannels) ! Cloud profiles on NWP levels
- Type (transmission_Type), Intent (in) :: transmission ! Transmittances and optical depths
- Type (transmission_Type), Intent (inout) :: transmission_k ! Transmittances and optical depths
- Type (geometry_Type), Intent (out) :: angles (nprofiles) ! Zenith angles
- Type (profile_scatt_aux), Intent (inout) :: scatt_aux ! Auxiliary profile variables
- Type (profile_scatt_aux), Intent (inout) :: scatt_aux_k ! Auxiliary profile variables
-
-!* Local variables
- Integer(Kind=jpim) :: freq
- Integer (Kind=jpim) :: ilayer, iprof, ichan, iccmax (nprofiles)
- Real (Kind=jprb) :: p1, p2, pm, p1_k, p2_k, pm_k, dp2dz, de2mr, zccmax
-
- Real (Kind=jprb), Dimension (nprofiles,nwp_levels) :: presf ! Pressure levels [hPa]
- Real (Kind=jprb), Dimension (nprofiles,nwp_levels+1) :: presfh ! Half-level NWP pressure levels [hPa]
- Real (Kind=jprb), Dimension (nprofiles,nrt_levels) :: presi ! Half-level RTTOV pressure levels [hPa]
- Real (Kind=jprb), Dimension (nchannels,nwp_levels) :: opd_nwp
- Real (Kind=jprb), Dimension (nchannels,nrt_levels) :: opd_nrt
- Real (Kind=jprb), Dimension (nchannels) :: zod_up_cld ! Optical depth from top of the atmosphere
- Real (Kind=jprb), Dimension (nchannels) :: emissivity ! Surface emissivity
- Real (Kind=jprb), Dimension (nchannels) :: reflectivity ! Surface reflectivity
- Real (Kind=jprb), Dimension (nchannels,nwp_levels) :: presf_k ! Pressure levels [hPa]
- Real (Kind=jprb), Dimension (nchannels,nwp_levels+1) :: presfh_k ! Half-level NWP pressure levels [hPa]
- Real (Kind=jprb), Dimension (nchannels,nrt_levels) :: presi_k ! Half-level RTTOV pressure levels [hPa]
- Real (Kind=jprb), Dimension (nchannels,nwp_levels) :: opd_nwp_k
- Real (Kind=jprb), Dimension (nchannels,nrt_levels) :: opd_nrt_k
- Real (Kind=jprb), Dimension (nchannels) :: zod_up_cld_k ! Optical depth from top of the atmosphere
- Real (Kind=jprb), Dimension (nchannels) :: emissivity_k ! Surface emissivity
- Real (Kind=jprb), Dimension (nchannels) :: reflectivity_k ! Surface reflectivity
-
- Real (Kind=jprb), Dimension (nchannels,nwp_levels) :: ext_0
- Real (Kind=jprb), Dimension (nchannels,nwp_levels) :: ext_1, ssa_1, asm_1
- Real (Kind=jprb), Dimension (nchannels,nwp_levels) :: ext_2, ssa_2, asm_2
- Real (Kind=jprb), Dimension (nchannels,nwp_levels) :: ext_3, ssa_3, asm_3
- Real (Kind=jprb), Dimension (nprofiles,nwp_levels) :: clw_scale, ciw_scale, rain_scale, sp_scale
-
- Type (transmission_Type) :: transmissioncld ! Clear+cloud transmittances with cloud
- Type (transmission_Type) :: transmissioncld_k ! Clear+cloud transmittances with cloud
-
- Character (len=80) :: errMessage
- Character (len=18) :: NameOfRoutine = 'rttov_iniscatt_k '
-
- REAL(KIND=JPRB) :: ZHOOK_HANDLE
-
- !- End of header --------------------------------------------------------
-
- errorstatus(:) = errorstatus_success
-
- allocate (transmissioncld % tau_surf (nchannels))
- allocate (transmissioncld_k % tau_surf (nchannels))
-
- de2mr = 1.0E+05_JPRB * rm / rgp
- dp2dz = -1.0E-03_JPRB * rgp / gravity / rm
-
- scatt_aux % ext (:,:) = 0.0_JPRB
- scatt_aux % ssa (:,:) = 0.0_JPRB
- scatt_aux % asm (:,:) = 0.0_JPRB
-
-!* Security on user-defined pressures
- Do iprof = 1, nprofiles
- Do ilayer = 1, nwp_levels
- If (cld_profiles (iprof) % p (ilayer) >= pressure_top) Then
- presf (iprof,ilayer) = cld_profiles (iprof) % p (ilayer)
- else
- presf (iprof,ilayer) = pressure_top
- Endif
- Enddo
- Do ilayer = 1, nwp_levels + 1
- If (cld_profiles (iprof) % ph (ilayer) >= pressure_top ) Then
- presfh (iprof,ilayer) = cld_profiles (iprof) % ph (ilayer)
- else
- presfh (iprof,ilayer) = pressure_top
- Endif
- Enddo
- Enddo
-
-!* Set up geometric variables
- Do iprof = 1, nprofiles
- Call rttov_setgeometry (profiles (iprof), coef_rttov, angles (iprof))
- End Do
-
-!* Compute temperature at layer boundaries (K)
- Do iprof = 1, nprofiles
- scatt_aux % tbd (iprof,nwp_levels+1) = profiles (iprof) % s2m % t
- scatt_aux % tbd (iprof,1) = cld_profiles (iprof) % t(1)
- Enddo
-
- Do ilayer = 1, nwp_levels-1
- Do iprof = 1, nprofiles
- p1 = presf (iprof,ilayer+1)
- p2 = presf (iprof,ilayer )
- pm = presfh (iprof,ilayer+1)
-
- scatt_aux % tbd (iprof,ilayer+1) = cld_profiles (iprof) % t (ilayer+1) &
- & + (cld_profiles (iprof) % t (ilayer) &
- & - cld_profiles (iprof) % t (ilayer+1)) &
- & / log(p2/p1) * log(pm/p1)
- Enddo
- Enddo
-
-!* Horizontal clear-sky fraction
- scatt_aux % clw (:,:) = 0.0_JPRB
- scatt_aux % ciw (:,:) = 0.0_JPRB
- scatt_aux % rain (:,:) = 0.0_JPRB
- scatt_aux % sp (:,:) = 0.0_JPRB
- scatt_aux % ccmax (:) = 0.0_JPRB
-
- iccmax (:) = 0
-
- Do iprof = 1, nprofiles
- zccmax = 0.0_JPRB
- Do ilayer = 1, nwp_levels
- if (cld_profiles (iprof) % cc (ilayer) > zccmax) then
- zccmax = cld_profiles (iprof) % cc (ilayer)
- iccmax (iprof) = ilayer
- end if
- end do
- scatt_aux % ccmax (iprof) = zccmax
-
- If (scatt_aux % ccmax (iprof) > ccthres) Then
- clw_scale (iprof,:) = cld_profiles (iprof) % clw (:) / scatt_aux % ccmax (iprof)
- ciw_scale (iprof,:) = cld_profiles (iprof) % ciw (:) / scatt_aux % ccmax (iprof)
- rain_scale (iprof,:) = cld_profiles (iprof) % rain (:) / scatt_aux % ccmax (iprof)
- sp_scale (iprof,:) = cld_profiles (iprof) % sp (:) / scatt_aux % ccmax (iprof)
- else
- clw_scale (iprof,:) = 0.0_JPRB
- ciw_scale (iprof,:) = 0.0_JPRB
- rain_scale (iprof,:) = 0.0_JPRB
- sp_scale (iprof,:) = 0.0_JPRB
- Endif
- Enddo
-
-!* Nadir heights (km)
- Do ilayer = nwp_levels, 1, -1
- Do iprof = 1, nprofiles
- p1 = presfh (iprof,ilayer+1)
- p2 = presfh (iprof,ilayer )
-
- If (p1 <= p2) then
- errorstatus (:) = errorstatus_fatal
- Write( errMessage, '( "iniscatt : problem with user-defined pressure layering")' )
- Call Rttov_ErrorReport (errorstatus(iprof), errMessage, NameOfRoutine)
- Return
- End If
-
- scatt_aux % dz (iprof,ilayer) = dp2dz * Log(p2/p1) * cld_profiles (iprof) % t (ilayer)
- Enddo
- Enddo
-
-!* Interpolate optical depths (at nadir and in hPa-1) to model levels
- Do ichan = 1, nchannels
- iprof = lsprofiles (ichan)
-
- opd_nrt (ichan,1) = transmission % od_singlelayer (1,ichan) / (profiles (iprof) % p (1) - pressure_top)
- presi (iprof,1) = (profiles (iprof) % p (1) + pressure_top) / 2.0_JPRB
-
- Do ilayer = 2, nrt_levels
- opd_nrt (ichan,ilayer) = transmission % od_singlelayer (ilayer,ichan) &
- & / (profiles (iprof) % p (ilayer) - profiles (iprof) % p (ilayer-1))
- presi (iprof,ilayer) = (profiles (iprof) % p (ilayer) + profiles (iprof) % p (ilayer-1)) / 2.0_JPRB
- Enddo
-
- Call rttov_intex (nrt_levels, nwp_levels, presi (iprof,:), presf (iprof,:), opd_nrt (ichan,:), opd_nwp (ichan,:))
- Enddo
-
-!* Change units
- Do ilayer = 1, nwp_levels
-
-!* Optical depths in km-1 and at nadir
- Do ichan = 1, nchannels
- iprof = lsprofiles (ichan)
-
- scatt_aux % ext (ichan,ilayer) = opd_nwp (ichan,ilayer) * (presfh (iprof,ilayer+1) - presfh (iprof,ilayer)) &
- & / scatt_aux % dz (iprof,ilayer) * angles (iprof) % coszen
-
- ext_0 (ichan,ilayer) = scatt_aux % ext (ichan,ilayer)
-
- if (scatt_aux % ext (ichan,ilayer) < 1.0E-10_JPRB) scatt_aux % ext (ichan,ilayer) = 1.0E-10_JPRB
- Enddo
-
-!* Condensate from g/g to g/m^3
- Do iprof = 1, nprofiles
- scatt_aux % clw (iprof,ilayer) = clw_scale (iprof,ilayer) * presf (iprof,ilayer) * de2mr / cld_profiles (iprof) % t (ilayer)
- scatt_aux % ciw (iprof,ilayer) = ciw_scale (iprof,ilayer) * presf (iprof,ilayer) * de2mr / cld_profiles (iprof) % t (ilayer)
-
-!* Rates from kg/m^2/s to g/m^3
- rain_scale (iprof,ilayer) = rain_scale (iprof,ilayer) / rho_rain
- sp_scale (iprof,ilayer) = sp_scale (iprof,ilayer) / rho_snow
-
- rain_scale (iprof,ilayer) = rain_scale (iprof,ilayer) * 3600.0_JPRB
- sp_scale (iprof,ilayer) = sp_scale (iprof,ilayer) * 3600.0_JPRB
-
- if (rain_scale (iprof,ilayer) > 0.0_JPRB) scatt_aux % rain (iprof,ilayer) = &
- & (rain_scale (iprof,ilayer) * coef_scatt % conv_rain (1))**(coef_scatt % conv_rain (2))
- if (sp_scale (iprof,ilayer) > 0.0_JPRB) scatt_aux % sp (iprof,ilayer) = &
- & (sp_scale (iprof,ilayer) * coef_scatt % conv_sp (1))**(coef_scatt % conv_sp (2))
- Enddo
- Enddo
-
-!* Store clear-sky absorption/scattering parameters
- ext_1 (:,:) = scatt_aux % ext (:,:)
- ssa_1 (:,:) = scatt_aux % ssa (:,:)
- asm_1 (:,:) = scatt_aux % asm (:,:)
-
-!* Cloud/rain absorption/scattering parameters
- Call rttov_mieproc ( &
- & nwp_levels, &! in
- & nchannels, &! in
- & nprofiles, &! in
- & frequencies, &! in
- & lsprofiles, &! in
- & cld_profiles, &! in
- & coef_rttov, &! in
- & coef_scatt, &! in
- & scatt_aux) ! inout
-
-!* Store clear+cloud+rain absorption/scattering parameters
- ext_2 (:,:) = scatt_aux % ext (:,:)
- ssa_2 (:,:) = scatt_aux % ssa (:,:)
- asm_2 (:,:) = scatt_aux % asm (:,:)
-
-!* Scattering parameters for Eddington RT
- Call rttov_iniedd( &
- & nwp_levels, &! in
- & nchannels , &! in
- & nprofiles , &! in
- & lsprofiles , &! in
- & angles , &! in
- & coef_scatt, &! in
- & scatt_aux) ! inout
-
-!* Store delta-scaled clear+cloud+rain absorption/scattering parameters
- ext_3 (:,:) = scatt_aux % ext (:,:)
- ssa_3 (:,:) = scatt_aux % ssa (:,:)
- asm_3 (:,:) = scatt_aux % asm (:,:)
-
-!* Surface emissivities
- zod_up_cld (:) = 0.0_JPRB
-
- Do ichan = 1, nchannels
- iprof = lsprofiles (ichan)
-
- Do ilayer = 1, nwp_levels
- zod_up_cld (ichan) = zod_up_cld (ichan) + scatt_aux % ext (ichan,ilayer) * scatt_aux % dz (iprof,ilayer)
- Enddo
- if (zod_up_cld (ichan) >= 30.0_JPRB) zod_up_cld (ichan) = 30.0_JPRB
- transmissioncld % tau_surf (ichan) = Exp(-1.0_JPRB * zod_up_cld (ichan) / angles (iprof) % coszen)
- Enddo
-
- Call rttov_calcemis_mw( &
- & profiles, &! in
- & angles, &! in
- & coef_rttov, &! in
- & nfrequencies, &! in
- & nchannels, &! in
- & nprofiles, &! in
- & channels, &! in
- & polarisations, &! in
- & lprofiles, &! in
- & transmissioncld, &! in
- & calcemiss, &! in
- & scatt_aux % ems_cld, &! inout
- & scatt_aux % ref_cld, &! out
- & errorstatus ) ! inout
-
-!* Hemispheric emissivity (= Fastem's effective emissivity)
- scatt_aux % ems_bnd (:) = scatt_aux % ems_cld (:)
- scatt_aux % ref_bnd (:) = scatt_aux % ref_cld (:)
-
-!* ADJOINT PART
-!* Hemispheric emissivity (= Fastem's effective emissivity)
- scatt_aux_k % ems_cld (:) = scatt_aux_k % ems_cld (:) + scatt_aux_k % ems_bnd (:)
- scatt_aux_k % ems_bnd (:) = 0.0_JPRB
-
- scatt_aux_k % ref_cld (:) = scatt_aux_k % ref_cld (:) + scatt_aux_k % ref_bnd (:)
- scatt_aux_k % ref_bnd (:) = 0.0_JPRB
-
- transmissioncld_k % tau_surf (:) = 0.0_JPRB
-
- Call rttov_calcemis_mw_k( &
- & profiles, &! in
- & profiles_k, &! inout
- & angles, &! in
- & coef_rttov, &! in
- & nfrequencies, &! in
- & nchannels, &! in
- & nprofiles, &! in
- & channels, &! in
- & polarisations, &! in
- & lprofiles, &! in
- & transmissioncld , &! in
- & transmissioncld_k, &! in
- & calcemiss, &! in
- & scatt_aux_k % ems_cld, &! inout
- & scatt_aux_k % ref_cld) ! inout
-
- scatt_aux_k % ems_cld (:) = 0.0_JPRB
- scatt_aux_k % ref_cld (:) = 0.0_JPRB
-
- zod_up_cld_k (:) = 0.0_JPRB
-
- Do ichan = 1, nchannels
- iprof = lsprofiles (ichan)
-
- zod_up_cld_k (ichan) = zod_up_cld_k (ichan) - transmissioncld_k % tau_surf (ichan) &
- & * transmissioncld % tau_surf (ichan) / angles (iprof) % coszen
- transmissioncld_k % tau_surf (ichan) = 0.0_JPRB
-
- if (zod_up_cld (ichan) == 30.0_JPRB) zod_up_cld_k (ichan) = 0.0_JPRB
-
- Do ilayer = 1, nwp_levels
- iprof = lsprofiles (ichan)
-
- scatt_aux_k % ext (ichan,ilayer) = scatt_aux_k % ext (ichan,ilayer) + scatt_aux % dz (iprof,ilayer) * zod_up_cld_k (ichan)
- scatt_aux_k % dz (ichan,ilayer) = scatt_aux_k % dz (ichan,ilayer) + scatt_aux % ext (ichan,ilayer) * zod_up_cld_k (ichan)
- Enddo
- Enddo
- zod_up_cld_k (:) = 0.0_JPRB
-
- scatt_aux % ext (:,:) = ext_2 (:,:)
- scatt_aux % ssa (:,:) = ssa_2 (:,:)
- scatt_aux % asm (:,:) = asm_2 (:,:)
-
-!* Scattering parameters for Eddington RT
- Call rttov_iniedd_k( &
- & nwp_levels, &! in
- & nchannels , &! in
- & nprofiles , &! in
- & lsprofiles , &! in
- & angles , &! in
- & coef_scatt, &! in
- & scatt_aux , &! inout
- & scatt_aux_k) ! inout
-
-!* Cloud/rain absorption/scattering parameters
- scatt_aux % ext (:,:) = ext_1 (:,:)
- scatt_aux % ssa (:,:) = ssa_1 (:,:)
- scatt_aux % asm (:,:) = asm_1 (:,:)
-
- Call rttov_mieproc_k (&
- & nwp_levels, &! in
- & nchannels, &! in
- & nprofiles, &! in
- & frequencies, &! in
- & lsprofiles, &! in
- & cld_profiles, &! in
- & cld_profiles_k, &! in
- & coef_rttov, &! in
- & coef_scatt, &! in
- & scatt_aux, &! inout
- & scatt_aux_k) ! inout
-
-
-!* Change units
- presfh_k (:,:) = 0.0_JPRB
- presf_k (:,:) = 0.0_JPRB
-
- Do ilayer = 1,nwp_levels
- Do ichan = 1, nchannels
- freq=polarisations(ichan, 2)
- iprof = lsprofiles(ichan)
-
-!* Rates from kg/m^2/s to g/m^3
- if (sp_scale (iprof,ilayer) > 0.0_JPRB) then
- scatt_aux_k % sp (ichan,ilayer) = scatt_aux_k % sp (ichan,ilayer) &
- & * (coef_scatt % conv_sp (2)) * (sp_scale (iprof,ilayer)**(coef_scatt % conv_sp (2) - 1.0_JPRB)) &
- & * (coef_scatt % conv_sp (1))**(coef_scatt % conv_sp (2))
- else
- scatt_aux_k % sp (ichan,ilayer) = 0.0_JPRB
- endif
-
- if (rain_scale (iprof,ilayer) > 0.0_JPRB) then
- scatt_aux_k % rain (ichan,ilayer) = scatt_aux_k % rain (ichan,ilayer) &
- & * (coef_scatt % conv_rain (2)) * (rain_scale (iprof,ilayer)**(coef_scatt % conv_rain (2) - 1.0_JPRB)) &
- & * (coef_scatt % conv_rain (1))**(coef_scatt % conv_rain (2))
- else
- scatt_aux_k % rain (ichan,ilayer) = 0.0_JPRB
- endif
-
- scatt_aux_k % sp (ichan,ilayer) = scatt_aux_k % sp (ichan,ilayer) * 3600.0_JPRB
- scatt_aux_k % rain (ichan,ilayer) = scatt_aux_k % rain (ichan,ilayer) * 3600.0_JPRB
-
- scatt_aux_k % sp (ichan,ilayer) = scatt_aux_k % sp (ichan,ilayer) / rho_snow
- scatt_aux_k % rain (ichan,ilayer) = scatt_aux_k % rain (ichan,ilayer) / rho_rain
-
-!* Condensate from g/g to g/m^3
- presf_k (ichan,ilayer) = presf_k (ichan,ilayer) + ciw_scale (iprof,ilayer) * de2mr &
- & / cld_profiles (iprof) % t (ilayer) * scatt_aux_k % ciw (ichan,ilayer)
- cld_profiles_k (ichan) % t (ilayer) = cld_profiles_k (ichan) % t (ilayer) &
- & - ciw_scale (iprof,ilayer) * presf (iprof,ilayer) * de2mr &
- & / (cld_profiles (iprof) % t (ilayer) * cld_profiles (iprof) % t (ilayer)) &
- & * scatt_aux_k % ciw (ichan,ilayer)
- scatt_aux_k % ciw (ichan,ilayer) = presf(iprof,ilayer) * de2mr &
- & / cld_profiles (iprof) % t (ilayer) * scatt_aux_k % ciw (ichan,ilayer)
-
- presf_k (ichan,ilayer) = presf_k (ichan,ilayer) + clw_scale (iprof,ilayer) * de2mr &
- & / cld_profiles (iprof) % t (ilayer) * scatt_aux_k % clw (ichan,ilayer)
- cld_profiles_k (ichan) % t (ilayer) = cld_profiles_k (ichan) % t (ilayer) &
- & - clw_scale (iprof,ilayer) * presf (iprof,ilayer) * de2mr &
- & / (cld_profiles (iprof) % t (ilayer) * cld_profiles (iprof) % t (ilayer)) &
- & * scatt_aux_k % clw (ichan,ilayer)
- scatt_aux_k % clw (ichan,ilayer) = presf (iprof,ilayer) * de2mr &
- & / cld_profiles(iprof) % t (ilayer) * scatt_aux_k % clw (ichan,ilayer)
-
- Enddo
-
-!* Optical depths in km-1 and at nadir
- Do ichan = 1, nchannels
- iprof = lsprofiles (ichan)
-
-! scatt_aux % ext (ichan,ilayer) = opd_nwp (ichan,ilayer) * (presfh (iprof,ilayer+1) - presfh (iprof,ilayer)) &
-! & / scatt_aux % dz (iprof,ilayer) * angles (iprof) % coszen
- If (ext_0 (ichan,ilayer) < 1.0E-10_JPRB) scatt_aux_k % ext (ichan,ilayer) = 0.0_JPRB
-
- opd_nwp_k (ichan,ilayer ) = (presfh (iprof,ilayer+1) - presfh (iprof,ilayer)) / scatt_aux % dz (iprof,ilayer) &
- & * angles (iprof) % coszen * scatt_aux_k % ext (ichan,ilayer)
- presfh_k (ichan,ilayer+1) = presfh_k (ichan,ilayer+1) + opd_nwp (ichan,ilayer) / scatt_aux % dz (iprof,ilayer) &
- & * angles (iprof) % coszen * scatt_aux_k % ext (ichan,ilayer)
- presfh_k (ichan,ilayer ) = presfh_k (ichan,ilayer ) - opd_nwp (ichan,ilayer) / scatt_aux % dz (iprof,ilayer) &
- & * angles (iprof) % coszen * scatt_aux_k % ext (ichan,ilayer)
- scatt_aux_k % dz (ichan,ilayer) = scatt_aux_k % dz (ichan,ilayer) - opd_nwp (ichan,ilayer) &
- & * (presfh (iprof,ilayer+1) - presfh (iprof,ilayer)) &
- & * angles (iprof) % coszen / (scatt_aux % dz (iprof,ilayer) * scatt_aux % dz (iprof,ilayer)) &
- & * scatt_aux_k % ext (ichan,ilayer)
- scatt_aux_k % ext (ichan,ilayer) = 0.0_JPRB
- Enddo
- Enddo
-
-
-!* Interpolate optical depths (at nadir and in hPa-1) to model levels
- opd_nrt_k (:,:) = 0.0_JPRB
- presi_k (:,:) = 0.0_JPRB
-
- Do ichan = 1, nchannels
- iprof = lsprofiles (ichan)
-
- Call rttov_intex_ad (nrt_levels, nwp_levels, &
- & presi_k (ichan,:), presf_k (ichan,:), opd_nrt_k (ichan,:), opd_nwp_k (ichan,:), &
- & presi (iprof,:), presf (iprof,:), opd_nrt (ichan,:), opd_nwp (ichan,:))
-
- Do ilayer = nrt_levels, 2, -1
- transmission_k % od_singlelayer (ilayer,ichan) = transmission_k % od_singlelayer (ilayer,ichan) &
- & + opd_nrt_k (ichan,ilayer) / (profiles (iprof) % p (ilayer) - profiles (iprof) % p (ilayer-1))
- opd_nrt_k (ichan,ilayer) = 0.0_JPRB
- Enddo
- transmission_k % od_singlelayer (1,ichan) = transmission_k % od_singlelayer (1,ichan) &
- & + opd_nrt_k (ichan,1) / (profiles (iprof) % p (1) - pressure_top)
- opd_nrt_k (ichan,1) = 0.0_JPRB
- Enddo
-
-!* Nadir heights (km)
- Do ilayer = 1, nwp_levels
- Do ichan = 1, nchannels
- freq=polarisations(ichan, 2)
- iprof = lsprofiles(ichan)
- p1 = presfh (iprof,ilayer+1)
- p2 = presfh (iprof,ilayer )
-
- p2_k = dp2dz / p2 * cld_profiles (iprof) % t (ilayer) * scatt_aux_k % dz (ichan,ilayer)
- p1_k = -1.0_JPRB * dp2dz / p1 * cld_profiles (iprof) % t (ilayer) * scatt_aux_k % dz (ichan,ilayer)
- cld_profiles_k (ichan) % t (ilayer) = cld_profiles_k (ichan) % t (ilayer) &
- & + dp2dz * Log(p2/p1) * scatt_aux_k % dz (ichan,ilayer)
- scatt_aux_k % dz (ichan,ilayer) = 0.0_JPRB
-
- presfh_k (ichan,ilayer) = presfh_k (ichan,ilayer) + p2_k
- presfh_k (ichan,ilayer+1) = presfh_k (ichan,ilayer+1) + p1_k
- Enddo
- Enddo
-
-!* Horizontal clear-sky fraction
- Do ichan = 1, nchannels
- freq=polarisations(ichan, 2)
- iprof = lsprofiles(ichan)
- If (scatt_aux % ccmax (iprof) > ccthres) Then
- cld_profiles_k (ichan) % clw (:) = cld_profiles_k (ichan) % clw (:) &
- & + scatt_aux_k % clw (ichan,:) / scatt_aux % ccmax (iprof)
- cld_profiles_k (ichan) % ciw (:) = cld_profiles_k (ichan) % ciw (:) &
- & + scatt_aux_k % ciw (ichan,:) / scatt_aux % ccmax (iprof)
- cld_profiles_k (ichan) % rain (:) = cld_profiles_k (ichan) % rain (:) &
- & + scatt_aux_k % rain (ichan,:) / scatt_aux % ccmax (iprof)
- cld_profiles_k (ichan) % sp (:) = cld_profiles_k (ichan) % sp (:) &
- & + scatt_aux_k % sp (ichan,:) / scatt_aux % ccmax (iprof)
-
- Do ilayer = 1, nwp_levels
- scatt_aux_k % ccmax (ichan) = scatt_aux_k % ccmax (ichan) &
- & - (cld_profiles (iprof) % clw (ilayer) * scatt_aux_k % clw (ichan,ilayer) &
- & + cld_profiles (iprof) % ciw (ilayer) * scatt_aux_k % ciw (ichan,ilayer) &
- & + cld_profiles (iprof) % rain (ilayer) * scatt_aux_k % rain (ichan,ilayer) &
- & + cld_profiles (iprof) % sp (ilayer) * scatt_aux_k % sp (ichan,ilayer)) &
- & / (scatt_aux % ccmax (iprof) * scatt_aux % ccmax (iprof))
- Enddo
- else
- scatt_aux_k % clw (ichan,:) = 0.0_JPRB
- scatt_aux_k % ciw (ichan,:) = 0.0_JPRB
- scatt_aux_k % rain (ichan,:) = 0.0_JPRB
- scatt_aux_k % sp (ichan,:) = 0.0_JPRB
- Endif
-
- if (iccmax(iprof) > 0) then
- cld_profiles_k (ichan) % cc (iccmax (iprof)) = cld_profiles_k (ichan) % cc (iccmax (iprof)) + scatt_aux_k % ccmax (ichan)
- endif
- scatt_aux_k % ccmax (ichan) = 0.0_JPRB
- Enddo
-
- scatt_aux_k % clw (:,:) = 0.0_JPRB
- scatt_aux_k % ciw (:,:) = 0.0_JPRB
- scatt_aux_k % rain (:,:) = 0.0_JPRB
- scatt_aux_k % sp (:,:) = 0.0_JPRB
-
-!* Temperature at layer boundaries (K)
- Do ilayer = nwp_levels - 1, 1, -1
- Do ichan = 1, nchannels
- freq=polarisations(ichan, 2)
- iprof = lsprofiles(ichan)
- p1 = presf (iprof,ilayer+1)
- p2 = presf (iprof,ilayer )
- pm = presfh (iprof,ilayer+1)
-
- cld_profiles_k (ichan) % t (ilayer+1) = cld_profiles_k (ichan) % t (ilayer+1) + scatt_aux_k % tbd (ichan,ilayer+1) &
- & - 1.0_JPRB / Log(p2/p1) * Log(pm/p1) * scatt_aux_k % tbd (ichan,ilayer+1)
- cld_profiles_k (ichan) % t (ilayer) = cld_profiles_k (ichan) % t (ilayer) &
- & + 1.0_JPRB / Log(p2/p1) * Log(pm/p1) * scatt_aux_k % tbd (ichan,ilayer+1)
-
- p1_k = (cld_profiles (iprof) % t (ilayer) - cld_profiles (iprof) % t (ilayer+1)) &
- & / (Log(p2/p1) * Log(p2/p1)) / p1 * Log(pm/p1) * scatt_aux_k % tbd (ichan,ilayer+1) &
- & - (cld_profiles (iprof) % t (ilayer) - cld_profiles (iprof) % t (ilayer+1)) &
- & / Log(p2/p1) / p1 * scatt_aux_k % tbd (ichan,ilayer+1)
- p2_k = -1.0_JPRB &
- & * (cld_profiles (iprof) % t (ilayer) - cld_profiles (iprof) % t (ilayer+1)) &
- & * Log(pm/p1) / (Log(p2/p1) * Log(p2/p1)) / p2 * scatt_aux_k % tbd (ichan,ilayer+1)
- pm_k = (cld_profiles (iprof) % t (ilayer) - cld_profiles (iprof) % t (ilayer+1)) &
- & / Log(p2/p1) / pm * scatt_aux_k % tbd (ichan,ilayer+1)
- scatt_aux_k % tbd (ichan,ilayer+1) = 0.0_JPRB
-
- presf_k (ichan,ilayer+1) = presf_k (ichan,ilayer+1) + p1_k
- presf_k (ichan,ilayer ) = presf_k (ichan,ilayer ) + p2_k
- presfh_k (ichan,ilayer+1) = presfh_k (ichan,ilayer+1) + pm_k
- Enddo
- Enddo
-
- Do ichan = 1, nchannels
- freq=polarisations(ichan, 2)
- iprof = lsprofiles(ichan)
- profiles_k (ichan) % s2m % t = profiles_k (ichan) % s2m % t + scatt_aux_k % tbd (ichan,nwp_levels+1)
- cld_profiles_k (ichan) % t (1) = cld_profiles_k (ichan) % t (1) + scatt_aux_k % tbd (ichan,1)
- Enddo
- scatt_aux_k % tbd (:,:) = 0.0_JPRB
-
-!* Security on user-defined pressures
- Do ichan = 1, nchannels
- freq=polarisations(ichan, 2)
- iprof = lsprofiles(ichan)
- Do ilayer = 1, nwp_levels
- If (cld_profiles (iprof) % p (ilayer) >= pressure_top) &
- & cld_profiles_k (ichan) % p (ilayer) = cld_profiles_k (ichan) % p (ilayer) + presf_k (ichan,ilayer)
- presf_k (ichan,ilayer) = 0.0_JPRB
- Enddo
- Do ilayer = 1, nwp_levels + 1
- If (cld_profiles (iprof) % ph (ilayer) >= pressure_top) &
- & cld_profiles_k (ichan) % ph (ilayer) = cld_profiles_k (ichan) % ph (ilayer) + presfh_k (ichan,ilayer)
- presfh_k (ichan,ilayer) = 0.0_JPRB
- Enddo
- Enddo
-
- scatt_aux % ext (:,:) = ext_3 (:,:)
- scatt_aux % ssa (:,:) = ssa_3 (:,:)
- scatt_aux % asm (:,:) = asm_3 (:,:)
-
-!* Deallocate
- deallocate (transmissioncld % tau_surf)
- deallocate (transmissioncld_k % tau_surf)
-
-End Subroutine rttov_iniscatt_k
diff --git a/src/LIB/RTTOV/src/rttov_iniscatt_k.interface b/src/LIB/RTTOV/src/rttov_iniscatt_k.interface
deleted file mode 100644
index 044072d055eff29346c245bd8c2467cf37289b26..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_iniscatt_k.interface
+++ /dev/null
@@ -1,59 +0,0 @@
-INTERFACE
-Subroutine rttov_iniscatt_k (&
- & errorstatus,&
- & nwp_levels,&
- & nrt_levels,&
- & nfrequencies,&
- & nchannels,&
- & nprofiles,&
- & polarisations,&
- & channels,&
- & frequencies,&
- & lprofiles,&
- & lsprofiles,&
- & profiles,&
- & profiles_k,&
- & cld_profiles,&
- & cld_profiles_k,&
- & coef_rttov,&
- & coef_scatt,&
- & transmission,&
- & transmission_k,&
- & calcemiss,&
- & angles,&
- & scatt_aux,&
- & scatt_aux_k)
- Use rttov_types, Only :&
- & rttov_coef ,&
- & rttov_scatt_coef ,&
- & transmission_type ,&
- & geometry_Type ,&
- & profile_scatt_aux ,&
- & profile_Type ,&
- & profile_cloud_Type
- Use parkind1, Only : jpim ,jprb
- Integer (Kind=jpim), Intent (in) :: nwp_levels
- Integer (Kind=jpim), Intent (in) :: nrt_levels
- Integer (Kind=jpim), Intent (in) :: nprofiles
- Integer (Kind=jpim), Intent (in) :: nfrequencies
- Integer (Kind=jpim), Intent (in) :: nchannels
- Integer (Kind=jpim), Intent(out) :: errorstatus(nprofiles)
- Integer (Kind=jpim), Intent (in) :: channels (nfrequencies)
- Integer (Kind=jpim), Intent (in) :: frequencies (nchannels)
- Integer (Kind=jpim), Intent (in) :: polarisations (nchannels,3)
- Integer (Kind=jpim), Intent (in) :: lprofiles (nfrequencies)
- Integer (Kind=jpim), Intent (in) :: lsprofiles (nchannels)
- Logical , Intent (in) :: calcemiss (nchannels)
- Type (profile_Type), Intent (in) :: profiles (nprofiles)
- Type (profile_Type), Intent (inout) :: profiles_k (nchannels)
- Type (rttov_coef), Intent (in) :: coef_rttov
- Type (rttov_scatt_coef), Intent (in) :: coef_scatt
- Type (profile_cloud_Type), Intent (in) :: cld_profiles (nprofiles)
- Type (profile_cloud_Type), Intent (inout) :: cld_profiles_k (nchannels)
- Type (transmission_Type), Intent (in) :: transmission
- Type (transmission_Type), Intent (inout) :: transmission_k
- Type (geometry_Type), Intent (out) :: angles (nprofiles)
- Type (profile_scatt_aux), Intent (inout) :: scatt_aux
- Type (profile_scatt_aux), Intent (inout) :: scatt_aux_k
-End Subroutine rttov_iniscatt_k
-END INTERFACE
diff --git a/src/LIB/RTTOV/src/rttov_iniscatt_tl.F90 b/src/LIB/RTTOV/src/rttov_iniscatt_tl.F90
deleted file mode 100644
index 655835e181df0c4917c9c300a59f386e747975a9..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_iniscatt_tl.F90
+++ /dev/null
@@ -1,512 +0,0 @@
-!
-Subroutine rttov_iniscatt_tl (&
- & errorstatus, &! out
- & nwp_levels, &! in
- & nrt_levels, &! in
- & nfrequencies, &! in
- & nchannels, &! in
- & nprofiles, &! in
- & polarisations, &! in
- & channels, &! in
- & frequencies, &! in
- & lprofiles, &! in
- & lsprofiles, &! in
- & profiles, &! in
- & profiles_tl, &! in
- & cld_profiles, &! in
- & cld_profiles_tl, &! in
- & coef_rttov, &! in
- & coef_scatt, &! in
- & transmission, &! in
- & transmission_tl, &! in
- & calcemiss, &! in
- & angles, &! out
- & scatt_aux, &! inout
- & scatt_aux_tl) ! inout
-
- !
- ! Description:
- ! Calculates some variables related to the input precipitation profile
- !
- ! Copyright:
- ! This software was developed within the context of
- ! the EUMETSAT Satellite Application Facility on
- ! Numerical Weather Prediction (NWP SAF), under the
- ! Cooperation Agreement dated 25 November 1998, between
- ! EUMETSAT and the Met Office, UK, by one or more partners
- ! within the NWP SAF. The partners in the NWP SAF are
- ! the Met Office, ECMWF, KNMI and MeteoFrance.
- !
- ! Copyright 2002, EUMETSAT, All Rights Reserved.
- !
- ! Method:
- !
- ! Current Code Owner: SAF NWP
- !
- ! History:
- ! Version Date Comment
- ! ------- ---- -------
- ! 1.0 09/2002 Initial version (F. Chevallier)
- ! 1.1 05/2003 RTTOV7.3 compatible (F. Chevallier)
- ! 1.2 03/2004 Added polarimetry (R. Saunders)
- ! 1.3 08/2004 Polarimetry fixes (U. O'Keeffe)
- ! 1.4 11/2004 Clean-up (P. Bauer)
- ! 1.5 10/2005 Fixes for rttov8 indexing (U. O'Keeffe)
- ! 1.6 11/2005 Add errorstatus to arguments (J. Cameron)
- ! 1.7 09/2006 Use zccmax_tl instead of iccmax index (A. Doherty)
- !
- ! Code Description:
- ! Language: Fortran 90.
- ! Software Standards: "European Standards for Writing and
- ! Documenting Exchangeable Fortran 90 Code".
- !
- ! Declaratiochannelsns:
- ! Modules used:
- ! Imported Type Definitions:
-
- Use rttov_types, Only : &
- & rttov_coef ,&
- & rttov_scatt_coef ,&
- & transmission_type ,&
- & geometry_Type ,&
- & profile_scatt_aux ,&
- & profile_Type ,&
- & profile_cloud_Type
-
- Use rttov_const, Only: &
- & errorstatus_success, &
- & errorstatus_fatal, &
- & gravity, &
- & pressure_top, &
- & rgp, &
- & rm, &
- & rho_rain, &
- & rho_snow, &
- & ccthres
-
- Use parkind1, Only : jpim ,jprb
-
- Implicit None
-
-#include "rttov_mieproc_tl.interface"
-#include "rttov_iniedd_tl.interface"
-#include "rttov_calcemis_mw.interface"
-#include "rttov_calcemis_mw_tl.interface"
-#include "rttov_setgeometry.interface"
-#include "rttov_errorreport.interface"
-#include "rttov_intex_tl.interface"
-
-!* Subroutine arguments:
-
- Integer (Kind=jpim), Intent (in) :: nwp_levels ! Number of levels
- Integer (Kind=jpim), Intent (in) :: nrt_levels ! Number of levels
- Integer (Kind=jpim), Intent (in) :: nprofiles ! Number of profiles
- Integer (Kind=jpim), Intent (in) :: nfrequencies ! Number of frequencies
- Integer (Kind=jpim), Intent (in) :: nchannels ! Number of channels*profiles=radiances
- Integer (Kind=jpim), Intent(out) :: errorstatus(nprofiles) ! Error return code
- Integer (Kind=jpim), Intent (in) :: frequencies (nchannels) ! Frequency indices
- Integer (Kind=jpim), Intent (in) :: channels (nfrequencies) ! Channel indices
- Integer (Kind=jpim), Intent (in) :: polarisations (nchannels,3) ! Polarisation indices
- Integer (Kind=jpim), Intent (in) :: lprofiles (nfrequencies) ! Profile indices
- Integer (Kind=jpim), Intent (in) :: lsprofiles (nchannels) ! Profile indices
- Logical , Intent (in) :: calcemiss (nchannels) ! Emissivity flags
-
- Type (profile_Type), Intent (in) :: profiles (nprofiles) ! Atmospheric profiles
- Type (profile_Type), Intent (in) :: profiles_tl (nprofiles) ! Atmospheric profiles
- Type (rttov_coef), Intent (in) :: coef_rttov ! RTTOV Coefficients
- Type (rttov_scatt_coef), Intent (in) :: coef_scatt ! RTTOV_SCATT Coefficients
- Type (profile_cloud_Type), Intent (in) :: cld_profiles (nprofiles) ! Cloud profiles with NWP levels
- Type (profile_cloud_Type), Intent (in) :: cld_profiles_tl (nprofiles) ! Cloud profiles on NWP levels
- Type (transmission_Type), Intent (in) :: transmission ! Transmittances and optical depths
- Type (transmission_Type), Intent (in) :: transmission_tl ! Transmittances and optical depths
- Type (geometry_Type), Intent (out) :: angles (nprofiles) ! Zenith angles
- Type (profile_scatt_aux), Intent (inout) :: scatt_aux ! Auxiliary profile variables
- Type (profile_scatt_aux), Intent (inout) :: scatt_aux_tl ! Auxiliary profile variables
-
-!* Local variables
- Integer (Kind=jpim) :: ilayer, iprof, ichan, iccmax
- Real (Kind=jprb) :: p1, p2, pm, p1_tl, p2_tl, pm_tl, dp2dz, de2mr, zccmax, zccmax_tl
-
- Real (Kind=jprb), Dimension (nprofiles,nwp_levels) :: presf ! Pressure levels [hPa]
- Real (Kind=jprb), Dimension (nprofiles,nwp_levels+1) :: presfh ! Half-level NWP pressure levels [hPa]
- Real (Kind=jprb), Dimension (nrt_levels) :: presi ! Half-level RTTOV pressure levels [hPa]
- Real (Kind=jprb), Dimension (nchannels,nwp_levels) :: opd_nwp
- Real (Kind=jprb), Dimension (nchannels,nrt_levels) :: opd_nrt
- Real (Kind=jprb), Dimension (nchannels) :: zod_up_cld ! Optical depth from top of the atmosphere
- Real (Kind=jprb), Dimension (nchannels) :: emissivity ! Surface emissivity
- Real (Kind=jprb), Dimension (nchannels) :: reflectivity ! Surface reflectivity
- Real (Kind=jprb), Dimension (nprofiles,nwp_levels) :: presf_tl ! Pressure levels [hPa]
- Real (Kind=jprb), Dimension (nprofiles,nwp_levels+1) :: presfh_tl ! Half-level NWP pressure levels [hPa]
- Real (Kind=jprb), Dimension (nrt_levels) :: presi_tl ! Half-level RTTOV pressure levels [hPa]
- Real (Kind=jprb), Dimension (nchannels,nwp_levels) :: opd_nwp_tl
- Real (Kind=jprb), Dimension (nchannels,nrt_levels) :: opd_nrt_tl
- Real (Kind=jprb), Dimension (nchannels) :: zod_up_cld_tl ! Optical depth from top of the atmosphere
- Real (Kind=jprb), Dimension (nchannels) :: emissivity_tl ! Surface emissivity
- Real (Kind=jprb), Dimension (nchannels) :: reflectivity_tl ! Surface reflectivity
-
- Type (transmission_Type) :: transmissioncld, transmissioncld_tl ! Clear+cloud transmittances with cloud
-
- Character (len=80) :: errMessage
- Character (len=18) :: NameOfRoutine = 'rttov_iniscatt_tl '
-
- !- End of header --------------------------------------------------------
-
- errorstatus(:) = errorstatus_success
-
- allocate (transmissioncld % tau_surf (nchannels))
- allocate (transmissioncld_tl % tau_surf (nchannels))
-
- de2mr = 1.0E+05_JPRB * rm / rgp
- dp2dz = -1.0E-03_JPRB * rgp / gravity / rm
-
- scatt_aux % ext (:,:) = 0.0_JPRB
- scatt_aux % ssa (:,:) = 0.0_JPRB
- scatt_aux % asm (:,:) = 0.0_JPRB
- scatt_aux_tl % ext (:,:) = 0.0_JPRB
- scatt_aux_tl % ssa (:,:) = 0.0_JPRB
- scatt_aux_tl % asm (:,:) = 0.0_JPRB
-
-!* Security on user-defined pressures
- Do iprof = 1, nprofiles
- Do ilayer = 1, nwp_levels
- If (cld_profiles (iprof) % p (ilayer) >= pressure_top) Then
- presf_tl (iprof,ilayer) = cld_profiles_tl (iprof) % p (ilayer)
- presf (iprof,ilayer) = cld_profiles (iprof) % p (ilayer)
- else
- presf_tl (iprof,ilayer) = 0.0_JPRB
- presf (iprof,ilayer) = pressure_top
- Endif
- Enddo
- Do ilayer = 1, nwp_levels + 1
- If (cld_profiles(iprof) % ph (ilayer) >= pressure_top) Then
- presfh_tl (iprof,ilayer) = cld_profiles_tl (iprof) % ph (ilayer)
- presfh (iprof,ilayer) = cld_profiles (iprof) % ph (ilayer)
- else
- presfh_tl (iprof,ilayer) = 0.0_JPRB
- presfh (iprof,ilayer) = pressure_top
- Endif
- Enddo
- Enddo
-
-!* Geometric variables
- Do iprof = 1, nprofiles
- Call rttov_setgeometry (profiles (iprof), coef_rttov, angles (iprof))
- End Do
-
-!* Temperature at layer boundaries (K)
- Do iprof = 1, nprofiles
- scatt_aux_tl % tbd (iprof,nwp_levels+1) = profiles_tl (iprof) % s2m % t
- scatt_aux % tbd (iprof,nwp_levels+1) = profiles (iprof) % s2m % t
- scatt_aux_tl % tbd (iprof,1) = cld_profiles_tl (iprof) % t (1)
- scatt_aux % tbd (iprof,1) = cld_profiles (iprof) % t (1)
- Enddo
-
- Do ilayer = 1, nwp_levels-1
- Do iprof = 1, nprofiles
- p1_tl = presf_tl (iprof,ilayer+1)
- p1 = presf (iprof,ilayer+1)
- p2_tl = presf_tl (iprof,ilayer )
- p2 = presf (iprof,ilayer )
- pm_tl = presfh_tl (iprof,ilayer+1)
- pm = presfh (iprof,ilayer+1)
-
- scatt_aux_tl % tbd (iprof,ilayer+1) = cld_profiles_tl (iprof) % t (ilayer+1) &
- & + (cld_profiles_tl (iprof) % t (ilayer) &
- & - cld_profiles_tl (iprof) % t (ilayer+1)) &
- & / log(p2/p1) * log(pm/p1) &
- & + (cld_profiles (iprof) % t (ilayer) &
- & - cld_profiles (iprof) % t (ilayer+1)) &
- & / (-1.0_JPRB * log(p2/p1) * log(p2/p1) ) &
- & * (p2_tl / p2 - p1_tl / p1) * log(pm/p1) &
- & + (cld_profiles (iprof) % t (ilayer) &
- & - cld_profiles (iprof) % t (ilayer+1)) &
- & / log(p2/p1) * (pm_tl / pm - p1_tl / p1)
- scatt_aux % tbd (iprof,ilayer+1) = cld_profiles (iprof) % t (ilayer+1) &
- & + (cld_profiles (iprof) % t (ilayer) &
- & - cld_profiles (iprof) % t (ilayer+1)) &
- & / log(p2/p1) * log(pm/p1)
- Enddo
- Enddo
-
-!* Horizontal clear-sky fraction
- scatt_aux_tl % clw (:,:) = 0.0_JPRB
- scatt_aux_tl % ciw (:,:) = 0.0_JPRB
- scatt_aux_tl % rain (:,:) = 0.0_JPRB
- scatt_aux_tl % sp (:,:) = 0.0_JPRB
- scatt_aux % clw (:,:) = 0.0_JPRB
- scatt_aux % ciw (:,:) = 0.0_JPRB
- scatt_aux % rain (:,:) = 0.0_JPRB
- scatt_aux % sp (:,:) = 0.0_JPRB
-
- scatt_aux_tl % ccmax (:) = 0.0_JPRB
- scatt_aux % ccmax (:) = 0.0_JPRB
-
- Do iprof = 1, nprofiles
- zccmax = 0.0_JPRB
- zccmax_tl = 0.0_JPRB
-
- Do ilayer = 1, nwp_levels
- if (cld_profiles (iprof) % cc (ilayer) > zccmax) then
- zccmax = cld_profiles (iprof) % cc (ilayer)
- zccmax_tl = cld_profiles_tl (iprof) % cc (ilayer)
- endif
- end do
- scatt_aux % ccmax (iprof) = zccmax
- scatt_aux_tl % ccmax (iprof) = zccmax_tl
-
- If (scatt_aux % ccmax (iprof) > ccthres) Then
- scatt_aux_tl % clw (iprof,:) = (cld_profiles_tl (iprof) % clw (:) &
- & * scatt_aux % ccmax (iprof) - scatt_aux_tl % ccmax (iprof) &
- & * cld_profiles (iprof) % clw (:)) &
- & / (scatt_aux % ccmax (iprof) * scatt_aux % ccmax (iprof))
- scatt_aux % clw (iprof,:) = cld_profiles (iprof) % clw (:) &
- & / scatt_aux % ccmax (iprof)
- scatt_aux_tl % ciw (iprof,:) = (cld_profiles_tl (iprof) % ciw (:) &
- & * scatt_aux % ccmax (iprof) - scatt_aux_tl % ccmax (iprof) &
- & * cld_profiles (iprof) % ciw (:)) &
- & / (scatt_aux % ccmax (iprof) * scatt_aux % ccmax (iprof))
- scatt_aux % ciw (iprof,:) = cld_profiles (iprof) % ciw (:) &
- & / scatt_aux % ccmax (iprof)
- scatt_aux_tl % rain (iprof,:) = (cld_profiles_tl (iprof) % rain (:) &
- & * scatt_aux % ccmax (iprof) - scatt_aux_tl % ccmax (iprof) &
- & * cld_profiles (iprof) % rain (:)) &
- & / (scatt_aux % ccmax (iprof) * scatt_aux % ccmax (iprof))
- scatt_aux % rain (iprof,:) = cld_profiles (iprof) % rain (:) &
- & / scatt_aux % ccmax (iprof)
- scatt_aux_tl % sp (iprof,:) = (cld_profiles_tl (iprof) % sp (:) &
- & * scatt_aux % ccmax (iprof) - scatt_aux_tl % ccmax (iprof) &
- & * cld_profiles (iprof) % sp (:)) &
- & / (scatt_aux % ccmax (iprof) * scatt_aux % ccmax (iprof))
- scatt_aux % sp (iprof,:) = cld_profiles (iprof) % sp (:) &
- & / scatt_aux % ccmax (iprof)
- else
- scatt_aux_tl % clw (iprof,:) = 0.0_JPRB
- scatt_aux % clw (iprof,:) = 0.0_JPRB
- scatt_aux_tl % ciw (iprof,:) = 0.0_JPRB
- scatt_aux % ciw (iprof,:) = 0.0_JPRB
- scatt_aux_tl % rain (iprof,:) = 0.0_JPRB
- scatt_aux % rain (iprof,:) = 0.0_JPRB
- scatt_aux_tl % sp (iprof,:) = 0.0_JPRB
- scatt_aux % sp (iprof,:) = 0.0_JPRB
- Endif
- Enddo
-
-!* Nadir heights (km)
- Do ilayer = nwp_levels, 1, -1
- Do iprof = 1, nprofiles
- p1_tl = presfh_tl (iprof,ilayer+1)
- p1 = presfh (iprof,ilayer+1)
- p2_tl = presfh_tl (iprof,ilayer )
- p2 = presfh (iprof,ilayer )
-
- If (p1 <= p2) then
- errorstatus (:) = errorstatus_fatal
- Write( errMessage, '( "iniscatt : problem with user-defined pressure layering")' )
- Call Rttov_ErrorReport (errorstatus(iprof), errMessage, NameOfRoutine)
- Return
- End If
-
- scatt_aux_tl % dz (iprof,ilayer) = dp2dz * (Log(p2/p1) * cld_profiles_tl (iprof) % t (ilayer) &
- & + (p2_tl / p2 - p1_tl / p1) * cld_profiles (iprof) % t (ilayer))
- scatt_aux % dz (iprof,ilayer) = dp2dz * Log(p2/p1) * cld_profiles (iprof) % t (ilayer)
- Enddo
- Enddo
-
-!* Interpolate optical depths (at nadir and in hPa-1) to model levels
- Do ichan = 1, nchannels
- iprof = lsprofiles (ichan)
-
- presi_tl (:) = 0.0_JPRB
-
- opd_nrt_tl (ichan,1) = transmission_tl % od_singlelayer (1,ichan) / (profiles (iprof) % p (1) - pressure_top)
- opd_nrt (ichan,1) = transmission % od_singlelayer (1,ichan) / (profiles (iprof) % p (1) - pressure_top)
-
- presi (1) = (profiles (iprof) % p (1) + pressure_top) / 2.0_JPRB
-
- Do ilayer = 2, nrt_levels
- opd_nrt_tl (ichan,ilayer) = transmission_tl % od_singlelayer (ilayer,ichan) &
- & / (profiles (iprof) % p (ilayer) - profiles (iprof) % p (ilayer-1))
- opd_nrt (ichan,ilayer) = transmission % od_singlelayer (ilayer,ichan) &
- & / (profiles (iprof) % p (ilayer) - profiles (iprof) % p (ilayer-1))
- presi (ilayer) = (profiles (iprof) % p (ilayer) + profiles (iprof) % p (ilayer-1)) / 2.0_JPRB
-
- Enddo
- Call rttov_intex_tl (nrt_levels, nwp_levels, &
- & presi_tl, presf_tl (iprof,:), opd_nrt_tl (ichan,:), opd_nwp_tl (ichan,:), &
- & presi , presf (iprof,:), opd_nrt (ichan,:), opd_nwp (ichan,:))
- Enddo
-
-!* Change units
- Do ilayer = 1,nwp_levels
-
-!* Optical depths in km-1 and at nadir
- Do ichan = 1, nchannels
- iprof = lsprofiles (ichan)
-
- scatt_aux_tl % ext (ichan,ilayer) = opd_nwp_tl (ichan,ilayer) * (presfh (iprof,ilayer+1) - presfh (iprof,ilayer)) &
- & / scatt_aux % dz (iprof,ilayer) * angles (iprof) % coszen &
- & + opd_nwp (ichan,ilayer) * (presfh_tl (iprof,ilayer+1) - presfh_tl (iprof,ilayer)) &
- & / scatt_aux % dz (iprof,ilayer) * angles (iprof) % coszen &
- & - opd_nwp (ichan,ilayer) * (presfh (iprof,ilayer+1) - presfh (iprof,ilayer)) &
- & * scatt_aux_tl % dz(iprof,ilayer) / (scatt_aux % dz (iprof,ilayer) &
- & * scatt_aux % dz (iprof,ilayer)) &
- & * angles (iprof) % coszen
- scatt_aux % ext (ichan,ilayer) = opd_nwp (ichan,ilayer) * (presfh (iprof,ilayer+1) - presfh (iprof,ilayer)) &
- & / scatt_aux % dz (iprof,ilayer) * angles (iprof) % coszen
-
- If (scatt_aux % ext (ichan,ilayer) < 1.0e-10_JPRB) Then
- scatt_aux_tl % ext (ichan,ilayer) = 0.0_JPRB
- scatt_aux % ext (ichan,ilayer) = 1.0e-10_JPRB
- Endif
- Enddo
-
-!* Condensate from g/g to g/m^3
- Do iprof = 1, nprofiles
- scatt_aux_tl % clw (iprof,ilayer) = (scatt_aux_tl % clw (iprof,ilayer) * presf (iprof,ilayer) &
- & / cld_profiles (iprof) % t (ilayer) &
- & + scatt_aux % clw (iprof,ilayer) * presf_tl (iprof,ilayer) &
- & / cld_profiles (iprof) % t (ilayer) &
- & - scatt_aux % clw (iprof,ilayer) * presf (iprof,ilayer) &
- & * cld_profiles_tl (iprof) % t (ilayer) &
- & / (cld_profiles (iprof) % t (ilayer) * cld_profiles (iprof) % t (ilayer))) * de2mr
-
- scatt_aux % clw (iprof,ilayer) = scatt_aux % clw (iprof,ilayer) * presf (iprof,ilayer) * de2mr &
- & / cld_profiles (iprof) % t (ilayer)
-
- scatt_aux_tl % ciw (iprof,ilayer) = (scatt_aux_tl % ciw (iprof,ilayer) * presf (iprof,ilayer) &
- & / cld_profiles (iprof) % t (ilayer) &
- & + scatt_aux % ciw (iprof,ilayer) * presf_tl (iprof,ilayer) &
- & / cld_profiles (iprof) % t (ilayer) &
- & - scatt_aux % ciw (iprof,ilayer) * presf (iprof,ilayer) &
- & * cld_profiles_tl (iprof) % t (ilayer) &
- & / (cld_profiles (iprof) % t (ilayer) * cld_profiles (iprof) % t (ilayer))) * de2mr
-
- scatt_aux % ciw (iprof,ilayer) = scatt_aux % ciw (iprof,ilayer) * presf (iprof,ilayer) * de2mr &
- & / cld_profiles (iprof) % t (ilayer)
-
-!* Rates from kg/m^2/s to g/m^3
- scatt_aux_tl % rain (iprof,ilayer) = scatt_aux_tl % rain (iprof,ilayer) / rho_rain
- scatt_aux % rain (iprof,ilayer) = scatt_aux % rain (iprof,ilayer) / rho_rain
- scatt_aux_tl % sp (iprof,ilayer) = scatt_aux_tl % sp (iprof,ilayer) / rho_snow
- scatt_aux % sp (iprof,ilayer) = scatt_aux % sp (iprof,ilayer) / rho_snow
-
- scatt_aux_tl % rain (iprof,ilayer) = scatt_aux_tl % rain (iprof,ilayer) * 3600.0_JPRB
- scatt_aux % rain (iprof,ilayer) = scatt_aux % rain (iprof,ilayer) * 3600.0_JPRB
- scatt_aux_tl % sp (iprof,ilayer) = scatt_aux_tl % sp (iprof,ilayer) * 3600.0_JPRB
- scatt_aux % sp (iprof,ilayer) = scatt_aux % sp (iprof,ilayer) * 3600.0_JPRB
-
- if (scatt_aux % rain (iprof,ilayer) > 0.0_JPRB) then
- scatt_aux_tl % rain (iprof,ilayer) = scatt_aux_tl % rain (iprof,ilayer) &
- & * (coef_scatt % conv_rain (2)) * (scatt_aux % rain (iprof,ilayer)**(coef_scatt % conv_rain (2) - 1.0_JPRB)) &
- & * (coef_scatt % conv_rain (1))**(coef_scatt % conv_rain (2))
- scatt_aux % rain (iprof,ilayer) = (scatt_aux % rain (iprof,ilayer) &
- & * coef_scatt % conv_rain (1))**(coef_scatt % conv_rain (2))
- else
- scatt_aux_tl % rain (iprof,ilayer) = 0.0_JPRB
- endif
- if (scatt_aux % sp (iprof,ilayer) > 0.0_JPRB) then
- scatt_aux_tl % sp (iprof,ilayer) = scatt_aux_tl % sp (iprof,ilayer) &
- & * (coef_scatt % conv_sp (2)) * (scatt_aux % sp (iprof,ilayer)**(coef_scatt % conv_sp (2) - 1.0_JPRB)) &
- & * (coef_scatt % conv_sp (1))**(coef_scatt % conv_sp (2))
- scatt_aux % sp (iprof,ilayer) = (scatt_aux % sp (iprof,ilayer) &
- & * coef_scatt % conv_sp (1))**(coef_scatt%conv_sp (2))
- else
- scatt_aux_tl % sp (iprof,ilayer) = 0.0_JPRB
- endif
- end do
- Enddo
-
-
-!* Cloud/rain absorption/scattering parameters
- Call rttov_mieproc_tl ( &
- & nwp_levels, &! in
- & nchannels, &! in
- & nprofiles, &! in
- & frequencies, &! in
- & lsprofiles, &! in
- & cld_profiles, &! in
- & cld_profiles_tl, &! in
- & coef_rttov, &! in
- & coef_scatt, &! in
- & scatt_aux, &! inout
- & scatt_aux_tl) ! inout
-
-!* Scattering parameters for Eddington RT
- Call rttov_iniedd_tl( &
- & nwp_levels, &! in
- & nchannels , &! in
- & nprofiles , &! in
- & lsprofiles , &! in
- & angles , &! in
- & coef_scatt, &! in
- & scatt_aux , &! inout
- & scatt_aux_tl) ! inout
-
-!* Surface emissivities
- zod_up_cld_tl (:) = 0.0_JPRB
- zod_up_cld (:) = 0.0_JPRB
-
- Do ichan = 1, nchannels
- iprof = lsprofiles (ichan)
-
- Do ilayer = 1, nwp_levels
- zod_up_cld_tl (ichan) = zod_up_cld_tl (ichan) &
- & + scatt_aux_tl % ext (ichan,ilayer) * scatt_aux % dz (iprof,ilayer) &
- & + scatt_aux % ext (ichan,ilayer) * scatt_aux_tl % dz (iprof,ilayer)
- zod_up_cld (ichan) = zod_up_cld (ichan) &
- & + scatt_aux % ext (ichan,ilayer) * scatt_aux % dz (iprof,ilayer)
- Enddo
- if (zod_up_cld (ichan) >= 30.0_JPRB) then
- zod_up_cld (ichan) = 30.0_JPRB
- zod_up_cld_tl (ichan) = 0.0_JPRB
- endif
-
- transmissioncld % tau_surf (ichan) = Exp(-1.0_JPRB * zod_up_cld (ichan) / angles (iprof) % coszen)
- transmissioncld_tl % tau_surf (ichan) = -1.0_JPRB * zod_up_cld_tl (ichan) / angles (iprof) % coszen &
- & * transmissioncld % tau_surf (ichan)
- Enddo
-
- Call rttov_calcemis_mw( &
- & profiles, &! in
- & angles, &! in
- & coef_rttov, &! in
- & nfrequencies, &! in
- & nchannels, &! in
- & nprofiles, &! in
- & channels, &! in
- & polarisations, &! in
- & lprofiles, &! in
- & transmissioncld, &! in
- & calcemiss, &! in
- & scatt_aux % ems_cld, &! inout
- & scatt_aux % ref_cld, &! out
- & errorstatus ) ! inout
-
- Call rttov_calcemis_mw_tl( &
- & profiles, &! in
- & profiles_tl, &! in
- & angles, &! in
- & coef_rttov, &! in
- & nfrequencies, &! in
- & nchannels, &! in
- & nprofiles, &! in
- & channels, &! in
- & polarisations, &! in
- & lprofiles, &! in
- & transmissioncld, &! in
- & transmissioncld_tl, &! in
- & calcemiss, &! in
- & scatt_aux_tl % ems_cld, &! inout
- & scatt_aux_tl % ref_cld) ! out
-
-!* Hemispheric emissivity (= Fastem's effective emissivity)
- scatt_aux_tl % ems_bnd (:) = scatt_aux_tl % ems_cld (:)
- scatt_aux % ems_bnd (:) = scatt_aux % ems_cld (:)
- scatt_aux_tl % ref_bnd (:) = scatt_aux_tl % ref_cld (:)
- scatt_aux % ref_bnd (:) = scatt_aux % ref_cld (:)
-
-!* Deallocate
- Deallocate (transmissioncld % tau_surf)
- Deallocate (transmissioncld_tl % tau_surf)
-
-End Subroutine rttov_iniscatt_tl
diff --git a/src/LIB/RTTOV/src/rttov_iniscatt_tl.interface b/src/LIB/RTTOV/src/rttov_iniscatt_tl.interface
deleted file mode 100644
index 9fd56f19e681e08bbeeb2f45dee11cd3411fd8d5..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_iniscatt_tl.interface
+++ /dev/null
@@ -1,59 +0,0 @@
-INTERFACE
-Subroutine rttov_iniscatt_tl (&
- & errorstatus,&
- & nwp_levels,&
- & nrt_levels,&
- & nfrequencies,&
- & nchannels,&
- & nprofiles,&
- & polarisations,&
- & channels,&
- & frequencies,&
- & lprofiles,&
- & lsprofiles,&
- & profiles,&
- & profiles_tl,&
- & cld_profiles,&
- & cld_profiles_tl,&
- & coef_rttov,&
- & coef_scatt,&
- & transmission,&
- & transmission_tl,&
- & calcemiss,&
- & angles,&
- & scatt_aux,&
- & scatt_aux_tl)
- Use rttov_types, Only :&
- & rttov_coef ,&
- & rttov_scatt_coef ,&
- & transmission_type ,&
- & geometry_Type ,&
- & profile_scatt_aux ,&
- & profile_Type ,&
- & profile_cloud_Type
- Use parkind1, Only : jpim ,jprb
- Integer (Kind=jpim), Intent (in) :: nwp_levels
- Integer (Kind=jpim), Intent (in) :: nrt_levels
- Integer (Kind=jpim), Intent (in) :: nprofiles
- Integer (Kind=jpim), Intent (in) :: nfrequencies
- Integer (Kind=jpim), Intent (in) :: nchannels
- Integer (Kind=jpim), Intent(out) :: errorstatus(nprofiles)
- Integer (Kind=jpim), Intent (in) :: frequencies (nchannels)
- Integer (Kind=jpim), Intent (in) :: channels (nfrequencies)
- Integer (Kind=jpim), Intent (in) :: polarisations (nchannels,3)
- Integer (Kind=jpim), Intent (in) :: lprofiles (nfrequencies)
- Integer (Kind=jpim), Intent (in) :: lsprofiles (nchannels)
- Logical , Intent (in) :: calcemiss (nchannels)
- Type (profile_Type), Intent (in) :: profiles (nprofiles)
- Type (profile_Type), Intent (in) :: profiles_tl (nprofiles)
- Type (rttov_coef), Intent (in) :: coef_rttov
- Type (rttov_scatt_coef), Intent (in) :: coef_scatt
- Type (profile_cloud_Type), Intent (in) :: cld_profiles (nprofiles)
- Type (profile_cloud_Type), Intent (in) :: cld_profiles_tl (nprofiles)
- Type (transmission_Type), Intent (in) :: transmission
- Type (transmission_Type), Intent (in) :: transmission_tl
- Type (geometry_Type), Intent (out) :: angles (nprofiles)
- Type (profile_scatt_aux), Intent (inout) :: scatt_aux
- Type (profile_scatt_aux), Intent (inout) :: scatt_aux_tl
-End Subroutine rttov_iniscatt_tl
-END INTERFACE
diff --git a/src/LIB/RTTOV/src/rttov_initcoeffs.F90 b/src/LIB/RTTOV/src/rttov_initcoeffs.F90
deleted file mode 100644
index a69196659fe551f25256a798279398a20e2cfa17..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_initcoeffs.F90
+++ /dev/null
@@ -1,335 +0,0 @@
-!
-Subroutine rttov_initcoeffs (&
- & errorstatus, &! out
- & coef, &! inout
- & knproc, &! in Optional
- & kmyproc, &! in Optional
- & kioproc )! in Optional
- ! Description:
- !
- ! coef arrays initialisation for all pes
- !
- ! Copyright:
- ! This software was developed within the context of
- ! the EUMETSAT Satellite Application Facility on
- ! Numerical Weather Prediction (NWP SAF), under the
- ! Cooperation Agreement dated 25 November 1998, between
- ! EUMETSAT and the Met Office, UK, by one or more partners
- ! within the NWP SAF. The partners in the NWP SAF are
- ! the Met Office, ECMWF, KNMI and MeteoFrance.
- !
- ! Copyright 2002, EUMETSAT, All Rights Reserved.
- !
- ! Method:
- !
- ! Current Code Owner: SAF NWP
- !
- ! History:
- ! Version Date Comment
- ! ------- ---- -------
- ! 1.0 17/05/2004 Original (based on rttov_readcoeffs)
- !
- ! Code Description:
- ! Language: Fortran 90.
- ! Software Standards: "European Standards for Writing and
- ! Documenting Exchangeable Fortran 90 Code".
- !
- ! Declarations:
- ! Modules used:
- ! Imported Parameters:
- Use rttov_const, Only : &
- & sensor_id_mw ,&
- & errorstatus_success ,&
- & errorstatus_fatal ,&
- & gas_id_mixed ,&
- & gas_id_watervapour ,&
- & gas_id_ozone ,&
- & gas_id_wvcont ,&
- & gas_id_co2 ,&
- & gas_id_n2o ,&
- & gas_id_co ,&
- & gas_id_ch4 ,&
- & gas_unit_specconc ,&
- & gas_unit_ppmv ,&
- & earthradius ,&
- & pressure_top
-
-
- ! Imported Type Definitions:
- Use rttov_types, Only : &
- & rttov_coef
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
-#include "rttov_errorreport.interface"
-#include "rttov_distribcoeffs.interface"
-#include "rttov_q2v.interface"
-
- ! subroutine arguments
- ! scalar arguments with intent(in):
- Integer(Kind=jpim), Optional, Intent(in) :: knproc ! number of procs
- Integer(Kind=jpim), Optional, Intent(in) :: kmyproc ! logical processor id
- Integer(Kind=jpim), Optional, Intent(in) :: kioproc ! procs dedicated for io
-
- ! scalar arguments with intent(out):
- Integer(Kind=jpim), Intent (out) :: errorstatus ! return code
- Type( rttov_coef ), Intent (inout) :: coef ! coefficients
-
- ! Local Scalars:
- Integer(Kind=jpim) :: inproc,imyproc,iioproc
- Integer(Kind=jpim) :: alloc_status(10)
- Integer(Kind=jpim) :: i,n,h
-
- Character (len=80) :: errMessage
- Character (len=16) :: NameOfRoutine = 'rttov_initcoeffs'
-
-
- !- End of header --------------------------------------------------------
-
- ! 0 Initialise variables
- !---------------------------------------------
- errorstatus = errorstatus_success
- alloc_status(:) = 0
-
- If ( .Not. Present (knproc) ) Then
- inproc = 1
- Else
- inproc = knproc
- Endif
-
- If ( .Not. Present (kmyproc) ) Then
- imyproc = 1
- Else
- imyproc = kmyproc
- Endif
-
- If ( .Not. Present (kioproc) ) Then
- iioproc = 1
- Else
- iioproc = kioproc
- Endif
-
- If ( inproc > 1 ) then
- Call rttov_distribcoeffs (&
- & imyproc, &! logical processor id
- & iioproc, &! processor dedicated for reading
- & coef) ! inout
- Endif
-
- ! 5 Now compute auxillary variables and change unit for mixing ratios
- !--------------------------------------------------------------------
-
- ! ratio satellite altitude to earth radius
- coef % ratoe = ( earthradius + coef % fc_sat_height ) / earthradius
-
- ! planck variables
- Allocate ( coef % planck1 ( coef % fmv_chn ), stat= alloc_status(1))
- Allocate ( coef % planck2 ( coef % fmv_chn ), stat= alloc_status(2))
- If( Any(alloc_status /= 0) ) Then
- errorstatus = errorstatus_fatal
- Write( errMessage, '( "allocation of Planck arrays")' )
- Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine)
- Return
- End If
- coef % planck1(:) = coef % fc_planck_c1 * coef % ff_cwn(:) **3
- coef % planck2(:) = coef % fc_planck_c2 * coef % ff_cwn(:)
-
- ! frequency in GHz for MicroWaves
- If( coef % id_sensor == sensor_id_mw ) Then
- Allocate ( coef % frequency_ghz ( coef % fmv_chn ), stat= alloc_status(1))
- If( Any(alloc_status /= 0) ) Then
- errorstatus = errorstatus_fatal
- Write( errMessage, '( "allocation of frequency array")' )
- Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine)
- Return
- End If
- coef % frequency_ghz(:) = coef % fc_speedl * 1.0e-09_JPRB * coef % ff_cwn(:)
- Endif
-
-
- ! Conversion of gas mixing ratio units, if needed
- ! The correct unit for RTTOV calculations is ppmv
- ! Take care this conversion is only valid
- ! if all gases have the same unit
- h = coef % fmv_gas_pos(gas_id_watervapour)
- Do n = 1, coef % fmv_gas
- If( coef % gaz_units( n ) == gas_unit_specconc ) Then
- ! Unit of gaz n is specific concentration
- Do i = 1, coef % nlevels
- ! Convert reference profile mixing ratio
- call rttov_q2v( &
- & coef % gaz_units( h ) ,&
- & coef % ref_prfl_mr ( i, h ) ,&
- & coef % fmv_gas_id( n ) ,&
- & coef % ref_prfl_mr ( i, n ) ,&
- & coef % ref_prfl_mr ( i, n ) )
- ! Now unit of gaz n is ppmv for the reference
- ! in particular for H2O
- coef % gaz_units( n ) = gas_unit_ppmv
- ! Convert profile minimum limit mixing ratio
- call rttov_q2v( &
- & coef % gaz_units( h ) ,&
- & coef % ref_prfl_mr ( i, h ) ,&
- & coef % fmv_gas_id( n ) ,&
- & coef % lim_prfl_gmin ( i, n ) ,&
- & coef % lim_prfl_gmin ( i, n ) )
- ! Convert profile maximum limit mixing ratio
- call rttov_q2v( &
- & coef % gaz_units( h ) ,&
- & coef % ref_prfl_mr ( i, h ) ,&
- & coef % fmv_gas_id( n ) ,&
- & coef % lim_prfl_gmax ( i, n ) ,&
- & coef % lim_prfl_gmax ( i, n ) )
- End Do
- End If
- End Do
-
-
- ! 6 Compute specific variables for RTTOV7
- ! ---------------------------------------
- ! Test on model and coeff versions
- If( coef % fmv_model_ver == 7 ) Then
- Allocate ( coef % dp ( coef % nlevels ), stat= alloc_status(1))
- Allocate ( coef % dpp ( coef % nlevels ), stat= alloc_status(2))
- Allocate ( coef % tstar ( coef % nlevels ), stat= alloc_status(3))
- Allocate ( coef % to3star ( coef % nlevels ), stat= alloc_status(4))
- Allocate ( coef % wstar ( coef % nlevels ), stat= alloc_status(5))
- Allocate ( coef % ostar ( coef % nlevels ), stat= alloc_status(6))
- If( Any(alloc_status /= 0) ) Then
- errorstatus = errorstatus_fatal
- Write( errMessage, '( "allocation of specific RTTOV7 arrays")' )
- Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine)
- Return
- End If
-
- ! pressure intervals between levels
- coef % dp(1) = coef % ref_prfl_p(1)
- coef % dp(2:coef % nlevels) = coef % ref_prfl_p(2:coef % nlevels) -&
- & coef % ref_prfl_p(1:coef % nlevels-1)
-
- ! pressure quantity
- coef % dpp(1) = ( coef % ref_prfl_p(1)-0.004985_JPRB ) * pressure_top
- coef % dpp(2) = ( coef % ref_prfl_p(1)-0.004985_JPRB ) * coef % ref_prfl_p(1)
- Do i = 3, coef % nlevels
- coef % dpp(i) = ( coef % ref_prfl_p(i-1)-coef % ref_prfl_p(i-2) ) * &
- & coef % ref_prfl_p(i-1)
- Enddo
-
- ! reference layer quantities
- ! temperature
- n = coef % fmv_gas_pos(gas_id_mixed)
- coef % tstar(1) = coef % ref_prfl_t(1 , n)
- coef % tstar(2:coef % nlevels) = &
- & ( coef % ref_prfl_t(1:coef % nlevels-1 , n) + &
- & coef % ref_prfl_t(2:coef % nlevels , n) ) / 2
-
- ! temperature for O3 profiles
- If ( coef % nozone > 0 ) Then
- n = coef % fmv_gas_pos(gas_id_ozone)
- coef % to3star(1) = coef % ref_prfl_t(1 , n)
- coef % to3star(2:coef % nlevels) = &
- & ( coef % ref_prfl_t(1:coef % nlevels-1 , n) + &
- & coef % ref_prfl_t(2:coef % nlevels , n) ) / 2
- n = coef % fmv_gas_pos(gas_id_ozone)
- Endif
-
- ! water vapour
- n = coef % fmv_gas_pos(gas_id_watervapour)
- coef % wstar(1) = coef % ref_prfl_mr(1 , n)
- coef % wstar(2:coef % nlevels) = &
- & ( coef % ref_prfl_mr(1:coef % nlevels-1 , n) + &
- & coef % ref_prfl_mr(2:coef % nlevels , n) ) / 2
-
- ! ozone
- If ( coef % nozone > 0 ) Then
- n = coef % fmv_gas_pos(gas_id_ozone)
- coef % ostar(1) = coef % ref_prfl_mr(1 , n)
- coef % ostar(2:coef % nlevels) = &
- & ( coef % ref_prfl_mr(1:coef % nlevels-1 , n) + &
- & coef % ref_prfl_mr(2:coef % nlevels , n) ) / 2
- Endif
-
- End If
-
- ! 7 Compute specific variables for RTTOV8
- ! AT PRESENT SAME VARIABLES AS RTTOV7
- ! ---------------------------------------
- ! Test on model and coeff versions
- If( coef % fmv_model_ver == 8 ) Then
- Allocate ( coef % dp ( coef % nlevels ), stat= alloc_status(1))
- Allocate ( coef % dpp ( coef % nlevels ), stat= alloc_status(2))
- Allocate ( coef % tstar ( coef % nlevels ), stat= alloc_status(3))
- Allocate ( coef % to3star ( coef % nlevels ), stat= alloc_status(4))
- Allocate ( coef % wstar ( coef % nlevels ), stat= alloc_status(5))
- Allocate ( coef % ostar ( coef % nlevels ), stat= alloc_status(6))
- Allocate ( coef % co2star ( coef % nlevels ), stat= alloc_status(7))
- If( Any(alloc_status /= 0) ) Then
- errorstatus = errorstatus_fatal
- Write( errMessage, '( "allocation of specific RTTOV8 arrays")' )
- Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine)
- Return
- End If
-
- ! pressure intervals between levels
- coef % dp(1) = coef % ref_prfl_p(1)
- coef % dp(2:coef % nlevels) = coef % ref_prfl_p(2:coef % nlevels) -&
- & coef % ref_prfl_p(1:coef % nlevels-1)
-
- ! pressure quantity
- coef % dpp(1) = ( coef % ref_prfl_p(1)-0.004985_JPRB ) * pressure_top
- coef % dpp(2) = ( coef % ref_prfl_p(1)-0.004985_JPRB ) * coef % ref_prfl_p(1)
- Do i = 3, coef % nlevels
- coef % dpp(i) = ( coef % ref_prfl_p(i-1)-coef % ref_prfl_p(i-2) ) * &
- & coef % ref_prfl_p(i-1)
- Enddo
-
- ! reference layer quantities
- ! temperature
- n = coef % fmv_gas_pos(gas_id_mixed)
- coef % tstar(1) = coef % ref_prfl_t(1 , n)
- coef % tstar(2:coef % nlevels) = &
- & ( coef % ref_prfl_t(1:coef % nlevels-1 , n) + &
- & coef % ref_prfl_t(2:coef % nlevels , n) ) / 2
-
- ! temperature for O3 profiles
- If ( coef % nozone > 0 ) Then
- n = coef % fmv_gas_pos(gas_id_ozone)
- coef % to3star(1) = coef % ref_prfl_t(1 , n)
- coef % to3star(2:coef % nlevels) = &
- & ( coef % ref_prfl_t(1:coef % nlevels-1 , n) + &
- & coef % ref_prfl_t(2:coef % nlevels , n) ) / 2
- Endif
-
- ! water vapour
- n = coef % fmv_gas_pos(gas_id_watervapour)
- coef % wstar(1) = coef % ref_prfl_mr(1 , n)
- coef % wstar(2:coef % nlevels) = &
- & ( coef % ref_prfl_mr(1:coef % nlevels-1 , n) + &
- & coef % ref_prfl_mr(2:coef % nlevels , n) ) / 2
-
- ! ozone
- If ( coef % nozone > 0 ) Then
- n = coef % fmv_gas_pos(gas_id_ozone)
- coef % ostar(1) = coef % ref_prfl_mr(1 , n)
- coef % ostar(2:coef % nlevels) = &
- & ( coef % ref_prfl_mr(1:coef % nlevels-1 , n) + &
- & coef % ref_prfl_mr(2:coef % nlevels , n) ) / 2
- Endif
-
- ! CO2
- If ( coef % nco2 > 0 ) Then
- n = coef % fmv_gas_pos(gas_id_co2)
- coef % co2star(1) = coef % ref_prfl_mr(1 , n)
- coef % co2star(2:coef % nlevels) = &
- & ( coef % ref_prfl_mr(1:coef % nlevels-1 , n) + &
- & coef % ref_prfl_mr(2:coef % nlevels , n) ) / 2
- Endif
-
- End If
-
- ! Here add specific statements for a later release of the model or
- ! of the coefficients
-
-
-End Subroutine rttov_initcoeffs
diff --git a/src/LIB/RTTOV/src/rttov_initcoeffs.interface b/src/LIB/RTTOV/src/rttov_initcoeffs.interface
deleted file mode 100644
index 6541a60f3f35daa2fb465954343cb8414fd096f0..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_initcoeffs.interface
+++ /dev/null
@@ -1,44 +0,0 @@
-Interface
-!
-Subroutine rttov_initcoeffs (&
- & errorstatus, &! out
- & coef, &! out
- & knproc, &! in Optional
- & kmyproc, &! in Optional
- & kioproc )! in Optional
- Use rttov_const, Only : &
- & sensor_id_mw ,&
- & errorstatus_info ,&
- & errorstatus_success ,&
- & errorstatus_fatal ,&
- & gas_id_mixed ,&
- & gas_id_watervapour ,&
- & gas_id_ozone ,&
- & gas_id_wvcont ,&
- & gas_id_co2 ,&
- & gas_id_n2o ,&
- & gas_id_co ,&
- & gas_id_ch4 ,&
- & gas_unit_specconc ,&
- & gas_unit_ppmv ,&
- & earthradius ,&
- & gas_name ,&
- & pressure_top
-
- ! Imported Type Definitions:
- Use rttov_types, Only : &
- & rttov_coef
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
- Integer(Kind=jpim), Optional, Intent(in) :: knproc ! number of procs
- Integer(Kind=jpim), Optional, Intent(in) :: kmyproc ! logical processor id
- Integer(Kind=jpim), Optional, Intent(in) :: kioproc ! procs dedicated for io
-
- ! scalar arguments with intent(out):
- Integer(Kind=jpim), Intent (out) :: errorstatus ! return code
- Type( rttov_coef ), Intent (out) :: coef ! coefficients
-
-End Subroutine rttov_initcoeffs
-End Interface
diff --git a/src/LIB/RTTOV/src/rttov_integrate.F90 b/src/LIB/RTTOV/src/rttov_integrate.F90
deleted file mode 100644
index b8bff2261a5b52e37174172622373f062cbe8377..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_integrate.F90
+++ /dev/null
@@ -1,398 +0,0 @@
-!
-Subroutine rttov_integrate( &
- & addcloud, &! in
- & addcosmic, &! in
- & nfrequencies, &! in
- & nchannels, &! in
- & nbtout, &! in
- & nprofiles, &! in
- & angles, &! in
- & channels, &! in
- & polarisations, &! in
- & lprofiles, &! in
- & emissivity, &! in
- & reflectivity, &! in
- & transmission, &! in
- & profiles, &! in
- & aux_prof, &! in
- & coef, &! in
- & rad, &! inout
- & auxrad ) ! inout
- ! Description:
- ! To perform integration of radiative transfer equation
- ! in rttov suite, calculating radiances and brightness temperature.
- !
- ! Copyright:
- ! This software was developed within the context of
- ! the EUMETSAT Satellite Application Facility on
- ! Numerical Weather Prediction (NWP SAF), under the
- ! Cooperation Agreement dated 25 November 1998, between
- ! EUMETSAT and the Met Office, UK, by one or more partners
- ! within the NWP SAF. The partners in the NWP SAF are
- ! the Met Office, ECMWF, KNMI and MeteoFrance.
- !
- ! Copyright 2002, EUMETSAT, All Rights Reserved.
- !
- ! Method:
- ! Eyre J.R. 1991 A fast radiative transfer model for satellite sounding
- ! systems. ECMWF Research Dept. Tech. Memo. 176 (available from the
- ! librarian at ECMWF).
- !
- ! Saunders R.W., M. Matricardi and P. Brunel 1999 An Improved Fast Radiative
- ! Transfer Model for Assimilation of Satellite Radiance Observations.
- ! QJRMS, 125, 1407-1425.
- !
- ! Current Code Owner: SAF NWP
- !
- ! History:
- ! Version Date Comment
- ! ------- ---- -------
- ! 25/06/91. Original code. J.R.EYRE *ECMWF*
- ! 21/08/00. Emissivity and reflectivity handled separately. Steve English
- ! 31/01/01. More cloud computations. F. Chevallier
- ! 23/03/01 New coef. format, new channel numbers (P. Brunel)
- ! 31/01/01. More cloud computations. F. Chevallier
- ! 28/09/01 Cosmic background temp added G.Deblonde
- ! 18/01/2002 Thread safe (D.Salmond)
- ! 1.0 01/12/2002 New F90 code with structures (P Brunel A Smith)
- ! 1.1 02/01/2003 Added comments (R Saunders)
- ! 1.2 06/05/2003 Init rad%downcld to 0 in section 1 (P Brunel)
- ! 1.3 26/09/2003 Modified to allow for multiple polarisations (S English)
- ! 03/09/2004 Mods. for Vectorisation (D Salmond ECMWF & BCarruthers, Cray)
- ! 28/02/2005 Further mods to vectorisation (D Dent)
- !
- ! Code Description:
- ! Language: Fortran 90.
- ! Software Standards: "European Standards for Writing and
- ! Documenting Exchangeable Fortran 90 Code".
- !
- ! Declarations:
- ! Modules used:
- ! Imported Type Definitions:
- Use rttov_const, only : &
- & sensor_id_mw
-
- Use rttov_types, Only : &
- & rttov_coef ,&
- & geometry_Type ,&
- & profile_Type ,&
- & profile_aux ,&
- & transmission_Type ,&
- & radiance_Type ,&
- & radiance_aux
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
-#include "rttov_calcbt.interface"
-#include "rttov_calcrad.interface"
-#include "rttov_calcpolarisation.interface"
-
- !subroutine arguments:
- Logical, Intent(in) :: addcloud ! switch for cloud computations
- Logical, Intent(in) :: addcosmic ! switch for adding cosmic background
- Integer(Kind=jpim), Intent(in) :: nbtout ! Number of BTs returned
- Integer(Kind=jpim), Intent(in) :: nfrequencies ! Number of frequencies
- Integer(Kind=jpim), Intent(in) :: nchannels ! Number of output radiances
- Integer(Kind=jpim), Intent(in) :: nprofiles ! Number of profiles
- Integer(Kind=jpim), Intent(in) :: channels(nfrequencies) ! Channel indices
- Integer(Kind=jpim), Intent(in) :: polarisations(nchannels,3) ! Channel indices
- Integer(Kind=jpim), Intent(in) :: lprofiles(nfrequencies) ! Profiles indices
- Real(Kind=jprb), Intent(in) :: emissivity(nchannels) ! surface emmissivity
- Real(Kind=jprb), Intent(in) :: reflectivity(nchannels) ! surface reflectivity
- Type(geometry_Type), Intent(in) :: angles(nprofiles) ! geometry angles
- Type(rttov_coef), Intent(in) :: coef ! Coefficients
- Type(profile_Type), Intent(in) ,Target :: profiles(nprofiles) ! Profiles
- Type(profile_aux) , Intent(in) ,Target :: aux_prof(nprofiles) ! auxillary profiles info.
- Type(transmission_Type), Intent(in):: transmission ! transmittances and single-layer od
- Type(radiance_Type), Intent(inout) :: rad ! radiances (mw/cm-1/ster/sq.m) and BTs
- Type(radiance_aux), Intent(inout) :: auxrad ! auxillary radiances
- !
-
- !local constants:
- Real(Kind=jprb), Parameter :: min_tau = 1.0e-8_JPRB
-
- !local variables:
- Real(Kind=jprb) :: rad_tmp(nchannels, coef % nlevels)
- Real(Kind=jprb) :: meanrad_up
- Real(Kind=jprb) :: meanrad_down
- Integer(Kind=jpim) :: i,j,lev,freq,kpol
-
- Real(Kind=jprb) :: cfraction(nchannels) ! cloud fraction
- Real(Kind=jprb) :: pfraction(nchannels) !
- Real(Kind=jprb) :: rad_down_cloud(coef % nlevels, nchannels) ! layer downwelling radiance
-
- Type(profile_aux), Pointer :: aux ! pointer on auxillary radiances
-
-integer(Kind=jpim) :: iv1(nchannels), iv2(nchannels), iv3(nchannels)
-
-
- !- End of header ------------------------------------------------------
- ! initialise radiance structure cloud flag
-
- rad % lcloud = addcloud
-
- !----------------------------
- !1. calculate layer radiances
- !----------------------------
-
- Call rttov_calcrad( &
- & addcosmic, &!in
- & nchannels, &!in
- & nfrequencies, &!in
- & nprofiles, &!in
- & channels, &!in
- & polarisations,&!in
- & lprofiles, &!in
- & profiles, &!in
- & coef, &!in
- & auxrad%cosmic, &!out
- & auxrad%skin, &!out
- & auxrad%surfair, &!out
- & auxrad%layer ) !out
-
-
- If ( addcloud ) Then
- rad_down_cloud(:,:) = 0._JPRB
- rad % downcld(:,:) = 0._JPRB
- Endif
-
- !2.1 layer above top pressure level
- !----------------------------------
- auxrad%up(1,:) = auxrad%layer(1,:) * ( 1.0_JPRB-transmission % tau_layer(1,:) )
- auxrad%down(1,:) = auxrad%up(1,:) / transmission % tau_layer(1,:)
-
- !-------------------------------------
- !2. calculate atmospheric contribution
- !-------------------------------------
-
- !2.2 layers between standard pressure levels
- !-------------------------------------------
-
-!dir$ concurrent
- Do lev = 2, coef % nlevels
-
-!dir$ concurrent
- Do i = 1, nchannels
-
- meanrad_up = 0.5_JPRB * ( auxrad%layer(lev,i)+auxrad%layer(lev-1,i) ) * &
- & ( transmission % tau_layer(lev-1,i) - transmission % tau_layer(lev,i) )
- auxrad%up(lev,i) = auxrad%up(lev-1,i) + meanrad_up
-
- If ( transmission % tau_layer(lev,i) > min_tau ) Then
- rad_tmp(i, lev) = meanrad_up / ( transmission % tau_layer(lev,i) * transmission % tau_layer(lev-1,i) )
- Else
- rad_tmp(i, lev) = 0.0_JPRB
- End If
- auxrad%down(lev,i) = auxrad%down(lev-1,i) + rad_tmp(i, lev)
-
- end do
-
- end do
-
-
-!dir$ concurrent
- Do i = 1, nchannels
-
- freq=polarisations(i,2)
- aux => aux_prof( lprofiles(freq) )
- cfraction(i) = aux%cfraction
- pfraction(i) = aux%pfraction_surf
- iv3(i) = aux % nearestlev_surf - 1
- iv2(i) = aux % nearestlev_surf
- iv1(i) = min( coef % nlevels, iv3(i) )
- If ( pfraction(i) < 0.0_JPRB ) iv3(i) = iv3(i) + 1
- End Do
-
- if( addcloud )then
- Do i = 1, nchannels
- Do lev = 2, iv1(i)
-
- Do j = 1, lev-1
- rad_down_cloud(j,i) = rad_down_cloud(j,i) + rad_tmp(i,lev)
- End Do
- End Do
- End Do
- end if
-
-
-!dir$ concurrent
- Do i = 1, nchannels
-
- freq=polarisations(i,2)
- kpol= 1 + i - polarisations(freq,1) ! Polarisation index
-
- !2.3 near-surface layer
- !----------------------
- ! add upward and downward parts
-
- lev = iv3(i)
-
- meanrad_up = 0.5_JPRB * ( auxrad%surfair(i) + auxrad%layer(lev,i) ) * &
- & ( transmission % tau_layer(lev,i) - transmission % tau_surf(i) )
- If ( transmission % tau_surf(i) > min_tau ) Then
- rad_tmp(i, lev) = meanrad_up / ( transmission % tau_layer(lev,i) * transmission % tau_surf(i) )
- Else
- rad_tmp(i, lev) = 0.0_JPRB
- End If
- meanrad_down = auxrad%down(lev,i) + rad_tmp(i, lev)
- meanrad_up = auxrad%up(lev,i) + meanrad_up
- ! assume that there is no atmospheric source term for 3rd or 4th Stokes vector elements
- if (kpol >= 3) meanrad_up = 0.0
- rad % clear(i) = meanrad_up + &
- & meanrad_down * reflectivity(i) * transmission % tau_surf(i) * transmission % tau_surf(i)
-
- ! clear sky radiance without reflection term
- ! without surface contribution at this line
- rad % upclear(i) = meanrad_up
-
- ! clear sky downwelling radiance
- rad % dnclear(i) = &
- & meanrad_down * transmission % tau_surf(i)
-
- ! reflected clear sky downwelling radiance
- rad % reflclear(i) = &
- & rad % dnclear(i) * ( reflectivity(i) ) * transmission % tau_surf(i)
-
- auxrad%up(iv2(i),i) = meanrad_up
-
- End Do
-
- If ( addcloud ) Then
-
- Do i = 1, nchannels
-
- lev = iv3(i)
-
- Do j = 1, lev
- rad_down_cloud(j,i) = (rad_down_cloud(j,i) + rad_tmp(i, lev)) * transmission % tau_surf(i)
- End Do
-
- End Do
-
- End If
-
-
- !-----------------------
- !3. surface contribution
- !-----------------------
-
- rad % clear(:) = rad % clear(:) +&
- & emissivity(:) * transmission % tau_surf(:) * auxrad%skin(:)
-
- ! clear sky radiance without reflection term
- rad % upclear(:) = rad % upclear(:) +&
- & emissivity(:) * transmission % tau_surf(:) * auxrad%skin(:)
-
- !--------------------------------
- !4. cosmic temperature correction
- !--------------------------------
-
- !calculate planck function corresponding to tcosmic=2.7k
- !deblonde tcosmic for microwave sensors only
-
- If ( addcosmic ) Then
- rad % clear(:) = rad % clear(:) + &
- & reflectivity(:) * auxrad%cosmic(:) * transmission % tau_surf(:) * transmission % tau_surf(:)
- Endif
-
-
- !----------------------------------------
- !5. calculate cloudy (overcast) radiances
- !----------------------------------------
-
- !---------------
- !5.1 Upward part
- !---------------
- ! (levels, channels)
- ! overcast radiance at given cloud top
-!dir$ concurrent
- rad % overcast(:,:) = auxrad%up(:,:) + auxrad%layer(:,:) * transmission % tau_layer(:,:)
-
-!dir$ concurrent
- Do i = 1, nchannels
-
- freq=polarisations(i,2)
- aux => aux_prof( lprofiles(freq) )
-
- lev = aux % nearestlev_surf
- rad % overcast(lev,i) = auxrad%up(lev,i) + transmission % tau_surf(i) * auxrad%skin(i)
-
- !-----------------
- !5.2 Downward part
- !-----------------
-
- !(takes reflection and upward clear-sky transmission into account)
-
- If ( addcloud ) Then
-!dir$ concurrent
- Do j = 1,lev-1
- If ( transmission % tau_layer(j,i) > min_tau ) &
- !contribution to radiance of downward
- ! cloud emission at given cloud top
- & rad % downcld(j,i) = &
- & ( rad_down_cloud(j,i) + &
- & auxrad%layer(j,i) * transmission % tau_surf(i)/transmission % tau_layer(j,i) ) &
- & * transmission % tau_surf(i) * (reflectivity(i))
- End Do
- ! No specific action for transmission % tau_layer(j,i) <= min_tau or
- ! levels between aux % nearestlev_surf and nlevels
- ! because the array rad % downcld has already
- ! been init. to 0 in section 1
- End If
-
- !--------------------------------------------
- !5.3 Interpolate to given cloud-top pressures
- !--------------------------------------------
-
- lev = aux % nearestlev_ctp
- rad%cloudy(i) = rad % overcast(lev,i) * (1.0_JPRB-aux % pfraction_ctp) + &
- & rad % overcast(lev-1,i) * (aux % pfraction_ctp)
-
- End Do
-
- !---------------------------
- !6. calculate total radiance
- !---------------------------
-
-!dir$ concurrent
- rad % total(:) = rad%clear(:) + cfraction(:) * ( rad%cloudy(:) - rad%clear(:) )
- If ( addcloud ) Then
- auxrad%down_cloud(:,:) = rad_down_cloud(:,:)
- End If
-
- !-----------------------------------------------
- !7. convert radiances to brightness temperatures
- !-----------------------------------------------
-
- Call rttov_calcbt( &
- & nfrequencies, &! in
- & nchannels, &! in
- & channels, &! in
- & polarisations, &! in
- & coef, &! in
- & rad ) ! inout
-
- !-----------------------------------------------------------
- !8. convert brightness temperatures to required polarisation
- !-----------------------------------------------------------
-
- If (coef % id_sensor == sensor_id_mw) Then
- Call rttov_calcpolarisation( &
- & nfrequencies, &! in
- & nchannels, &! in
- & nprofiles, &! in
- & angles, &! in
- & channels, &! in
- & polarisations, &! in
- & lprofiles, &! in
- & coef, &! in
- & rad ) ! inout
- Else
- rad%out = rad%bt
- rad%out_clear = rad%bt_clear
- rad%total_out = rad%total
- rad%clear_out = rad%clear
- End If
-
-End Subroutine rttov_integrate
diff --git a/src/LIB/RTTOV/src/rttov_integrate.interface b/src/LIB/RTTOV/src/rttov_integrate.interface
deleted file mode 100644
index 349a9003c77184c2f06d9d0403a7d05ccb915b61..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_integrate.interface
+++ /dev/null
@@ -1,57 +0,0 @@
-Interface
-!
-Subroutine rttov_integrate( &
- addcloud, & ! in
- addcosmic, & ! in
- nfrequencies, & ! in
- nchannels, & ! in
- nbtout, & ! in
- nprofiles, & ! in
- geometry, & ! in
- channels, & ! in
- polarisations,& ! in
- lprofiles, & ! in
- emissivity, & ! in
- reflectivity, & ! in
- transmission, & ! in
- profiles, & ! in
- aux_prof, & ! in
- coef, & ! in
- rad, & ! inout
- auxrad ) ! inout
- Use rttov_types, Only : &
- rttov_coef ,&
- profile_Type ,&
- profile_aux ,&
- transmission_Type ,&
- radiance_Type ,&
- radiance_aux ,&
- geometry_Type
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
-
- Logical, Intent(in) :: addcloud ! switch for cloud computations
- Logical, Intent(in) :: addcosmic ! switch for adding cosmic background
- Integer(Kind=jpim), Intent(in) :: nfrequencies
- Integer(Kind=jpim), Intent(in) :: nchannels
- Integer(Kind=jpim), Intent(in) :: nbtout
- Integer(Kind=jpim), Intent(in) :: nprofiles
- Integer(Kind=jpim), Intent(in) :: channels(nfrequencies)
- Integer(Kind=jpim), Intent(in) :: polarisations(nchannels,3)
- Integer(Kind=jpim), Intent(in) :: lprofiles(nfrequencies)
- Real(Kind=jprb), Intent(in) :: emissivity(nchannels)
- Real(Kind=jprb), Intent(in) :: reflectivity(nchannels)
- Type(geometry_Type), Intent(in) ,Target :: geometry(nprofiles)
- Type(rttov_coef), Intent(in) :: coef ! Coefficients
- Type(profile_Type), Intent(in) ,Target :: profiles(nprofiles) ! Profiles
- Type(profile_aux) , Intent(in) ,Target :: aux_prof(nprofiles) ! auxillary profiles info.
- Type(transmission_Type), Intent(in):: transmission ! transmittances and single-layer od
- Type(radiance_Type), Intent(inout) :: rad ! radiances (mw/cm-1/ster/sq.m) and BTs
- Type(radiance_aux), Intent(inout) :: auxrad ! auxillary radiances
-
-
-
-End Subroutine rttov_integrate
-End Interface
diff --git a/src/LIB/RTTOV/src/rttov_integrate_ad.F90 b/src/LIB/RTTOV/src/rttov_integrate_ad.F90
deleted file mode 100644
index 9942c2398404a46066f3294786a8c51afaa29f03..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_integrate_ad.F90
+++ /dev/null
@@ -1,614 +0,0 @@
-Subroutine rttov_integrate_ad( &
- & addcloud, &! in
- & addcosmic, &! in
- & switchrad, &! in
- & nfrequencies, &! in
- & nchannels, &! in
- & nbtout, &! in
- & nprofiles, &! in
- & angles, &! in
- & channels, &! in
- & polarisations, &! in
- & lprofiles, &! in
- & emissivity, &! in
- & emissivity_ad, &! inout
- & reflectivity, &! in
- & reflectivity_ad, &! inout
- & transmission, &! in
- & transmission_ad, &! inout
- & profiles, &! in
- & profiles_ad, &! inout
- & aux_prof, &! in
- & aux_prof_ad, &! inout
- & coef, &! in
- & rad , &! in
- & auxrad , &! in
- & rad_ad ) ! inout
- !
- ! Description:
- ! To perform AD of integration of radiative transfer equation
- ! in rttov suite, calculating radiances and brightness temperature.
- !
- ! Copyright:
- ! This software was developed within the context of
- ! the EUMETSAT Satellite Application Facility on
- ! Numerical Weather Prediction (NWP SAF), under the
- ! Cooperation Agreement dated 25 November 1998, between
- ! EUMETSAT and the Met Office, UK, by one or more partners
- ! within the NWP SAF. The partners in the NWP SAF are
- ! the Met Office, ECMWF, KNMI and MeteoFrance.
- !
- ! Copyright 2002, EUMETSAT, All Rights Reserved.
- !
- ! Method:
- ! Eyre J.R. 1991 A fast radiative transfer model for satellite sounding
- ! systems. ECMWF Research Dept. Tech. Memo. 176 (available from the
- ! librarian at ECMWF).
- !
- ! Saunders R.W., M. Matricardi and P. Brunel 1999 An Improved Fast Radiative
- ! Transfer Model for Assimilation of Satellite Radiance Observations.
- ! QJRMS, 125, 1407-1425.
- !
- ! Current Code Owner: SAF NWP
- !
- ! History:
- ! Version Date Comment
- ! ------- ---- -------
- ! 25/06/91. Original code. J.R.EYRE *ECMWF*
- ! 21/08/00. Emissivity and reflectivity handled separately. Steve English
- ! 31/01/01. More cloud computations. F. Chevallier
- ! 23/03/01 New coef. format, new channel numbers (P. Brunel)
- ! 31/01/01. More cloud computations. F. Chevallier
- ! 28/09/01 Cosmic background temp added G.Deblonde
- ! 18/01/2002 Thread safe (D.Salmond)
- ! 1.0 01/12/2002 New F90 code with structures (P Brunel A Smith)
- ! 1.1 02/01/2003 Added comments (R Saunders)
- ! 1.2 06/05/2003 Init rad%downcld to 0 in section 1 (P Brunel)
- ! 1.3 26/09/2003 Modified to allow for multiple polarisations (S English)
- ! 10/05/2004 Fixed bug in call to rttov_calcpolarisation (D.Salmond)
- ! 06/09/2004 Mods. for Vectorisation (D Salmond ECMWF & B Carruthers, Cray)
- ! 28/02/2005 More improvements to vectorisation (D Dent)
- ! 29/03/2005 Add end of header comment (J. Cameron)
- !
- ! Code Description:
- ! Language: Fortran 90.
- ! Software Standards: "European Standards for Writing and
- ! Documenting Exchangeable Fortran 90 Code".
- !
- ! Declarations:
- ! Modules used:
- ! Imported Type Definitions:
-
-! Adjoint Variables
-! transmission_ad % tau_surf |
-! transmission_ad % tau_layer |
-! emissivity_ad |
-! reflectivity_ad | initialised before calling
-! profiles_ad |
-! aux_prof_ad |
-
- Use rttov_const, only : &
- & sensor_id_mw
-
- Use rttov_types, Only : &
- & geometry_Type ,&
- & rttov_coef ,&
- & profile_Type ,&
- & profile_aux ,&
- & transmission_type, &
- & radiance_Type ,&
- & radiance_aux
-
-
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
-#include "rttov_calcbt_ad.interface"
-#include "rttov_calcrad_ad.interface"
-#include "rttov_calcpolarisation_ad.interface"
-
- !subroutine arguments:
- Logical, Intent(in) :: addcloud
- Logical, Intent(in) :: addcosmic
- Logical, Intent(in) :: switchrad ! true if input is BT
- Integer(Kind=jpim), Intent(in) :: nbtout ! Number of BTs returned
- Integer(Kind=jpim), Intent(in) :: nfrequencies
- Integer(Kind=jpim), Intent(in) :: nchannels
- Integer(Kind=jpim), Intent(in) :: nprofiles
- Integer(Kind=jpim), Intent(in) :: channels(nfrequencies)
- Integer(Kind=jpim), Intent(in) :: polarisations(nchannels,3)
- Integer(Kind=jpim), Intent(in) :: lprofiles(nfrequencies)
- Real(Kind=jprb), Intent(in) :: emissivity(nchannels)
- Real(Kind=jprb), Intent(in) :: reflectivity(nchannels)
- Type(geometry_Type), Intent(in) :: angles(nprofiles) ! geometry angles
- Type(rttov_coef), Intent(in) :: coef
- Type(profile_Type), Intent(in) ,Target :: profiles(nprofiles)
- Type(profile_aux) , Intent(in) ,Target :: aux_prof(nprofiles)
- Type(transmission_Type), Intent(in):: transmission
- Type(radiance_Type), Intent(in) :: rad
- Type(radiance_aux), Intent(in) :: auxrad
-
- Real(Kind=jprb), Intent(inout) :: emissivity_ad(nchannels)
- Real(Kind=jprb), Intent(inout) :: reflectivity_ad(nchannels)
- Type(profile_Type), Intent(inout) ,Target :: profiles_ad(nprofiles)
- Type(profile_aux) , Intent(inout) ,Target :: aux_prof_ad(nprofiles)
- Type(transmission_Type), Intent(inout) :: transmission_ad
- Type(radiance_Type), Intent(inout) :: rad_ad
-
- !local constants:
- Real(Kind=jprb), Parameter :: min_tau = 1.0e-8_JPRB
-
- !local variables:
- Real(Kind=jprb) :: cfraction(nchannels)
- Real(Kind=jprb) :: cfraction_ad(nchannels)
-
- Real(Kind=jprb) :: rad_tmp(nchannels)
- Real(Kind=jprb) :: meanrad_up(nchannels)
- Real(Kind=jprb) :: meanrad_up_2d(nchannels, coef % nlevels)
- Real(Kind=jprb) :: meanrad_down(nchannels)
-
- Real(Kind=jprb) :: rad_layer_ad(coef % nlevels,nchannels)
- Real(Kind=jprb) :: rad_surfair_ad(nchannels)
- Real(Kind=jprb) :: rad_skin_ad(nchannels)
- Real(Kind=jprb) :: rad_up_ad(coef % nlevels, nchannels)
- Real(Kind=jprb) :: rad_down_ad(coef % nlevels, nchannels)
- Real(Kind=jprb) :: rad_down_cloud_ad(coef % nlevels, nchannels)
- Real(Kind=jprb) :: rad_tmp_ad(nchannels)
- Real(Kind=jprb) :: rad_tmp_ad_2d(nchannels, coef % nlevels)
- Real(Kind=jprb) :: meanrad_up_ad(nchannels)
- Real(Kind=jprb) :: meanrad_up_ad_2d(nchannels, coef % nlevels)
- Real(Kind=jprb) :: meanrad_down_ad(nchannels)
- Real(Kind=jprb) :: tau_prod
-
-
- Integer(Kind=jpim) :: i,j,lev,lev2,freq,kpol
- Integer(Kind=jpim) :: aux_levels(nchannels)
- Integer(Kind=jpim) :: aux_nearestlev_surf(nchannels)
- Real(Kind=jprb) :: aux_pfraction(nchannels)
- Real(Kind=jprb) :: aj
-
- Type(profile_aux), Pointer :: aux
- Type(profile_aux), Pointer :: aux_ad
-
- !- End of header --------------------------------------------------------
-
- !----------------------------------------------------------------------------
- ! initialise radiance structure cloud flag
-
- rad_ad % lcloud = addcloud
-
-
- !----------------------------
- !1. calculate layer radiances
- !----------------------------
- If (coef % id_sensor == sensor_id_mw) Then
- Call rttov_calcpolarisation_ad( &
- & nfrequencies, &! in
- & nchannels, &! in
- & nbtout, &! in
- & profiles, &! in
- & nprofiles, &! in
- & angles, &! in
- & channels, &! in
- & polarisations, &! in
- & lprofiles, &! in
- & coef, &! in
- & rad_ad ) ! inout
- Else
- rad_ad%bt = rad_ad%out
- rad_ad%bt_clear = rad_ad%out_clear
- rad_ad%total = rad_ad%total_out
- rad_ad%clear = rad_ad%clear_out
- End If
-
-! if input AD unit is temperature, convert it in radiance
- if ( switchrad ) then
- Call rttov_calcbt_ad( &
- & nfrequencies, &! in
- & nchannels, &! in
- & channels, &! in
- & polarisations, &! in
- & coef, &! in
- & rad, &! in
- & rad_ad ) ! inout output is only rad_ad%total
- endif
-
- ! initialisation of local variables
- rad_layer_ad(:,:) = 0._JPRB
- rad_surfair_ad(:) = 0._JPRB
- rad_skin_ad(:) = 0._JPRB
- rad_up_ad(:,:) = 0._JPRB
- rad_down_ad(:,:) = 0._JPRB
- rad_down_cloud_ad(:,:) = 0._JPRB
-
- Do i = 1, nchannels
- freq=polarisations(i,2)
- cfraction(i) = aux_prof( lprofiles(freq) )%cfraction
- End Do
-
-
- !--------------------------- !6. calculate total radiance
- !---------------------------
-
-
- rad_ad%clear(:) = (1 - cfraction(:)) * rad_ad%total(:)
- rad_ad%cloudy(:) = cfraction(:) * rad_ad%total(:)
- cfraction_ad(:) = ( rad%cloudy(:) - rad%clear(:) ) * rad_ad%total(:)
-
- Do i = 1, nchannels
- freq=polarisations(i,2)
- aux_prof_ad( lprofiles(freq) )%cfraction =&
- & aux_prof_ad( lprofiles(freq) )%cfraction + cfraction_ad(i)
- End Do
-
-!dir$ concurrent
- Do i = 1, nchannels
- freq=polarisations(i,2)
- aux => aux_prof( lprofiles(freq) )
- aux_ad => aux_prof_ad( lprofiles(freq) )
-
- !--------------------------------------------
- !5.3 Interpolate to given cloud-top pressures
- !--------------------------------------------
-
- lev = aux % nearestlev_ctp
-
- rad_ad%overcast(lev,i) = rad_ad%overcast(lev,i) +&
- & (1 - aux % pfraction_ctp) * rad_ad%cloudy(i)
-
- rad_ad%overcast(lev-1,i) = rad_ad%overcast(lev-1,i) +&
- & aux % pfraction_ctp * rad_ad%cloudy(i)
-
- aux_ad % pfraction_ctp = aux_ad % pfraction_ctp +&
- & (rad%overcast(lev-1,i) - rad%overcast(lev,i)) * rad_ad%cloudy(i)
-
- !rad_ad%cloudy(i) is no later used rad_tl % cloudy was an output only
- rad_ad%cloudy(i) = 0._JPRB
-
- !(takes reflection and upward clear-sky transmission into account)
- ! surface level
- lev = aux % nearestlev_surf
- aux_nearestlev_surf(i) = lev
- aux_pfraction(i) = aux % pfraction_surf
- lev2 = lev - 1
-! If ( aux % pfraction_surf < 0.0_JPRB ) lev = lev + 1
- If ( aux_pfraction(i) < 0.0_JPRB ) lev2 = lev2 + 1
- aux_levels(i) = lev2
- End Do
-
-!dir$ concurrent
- Do i = 1, nchannels
-
- !----------------------------------------
- !5. calculate cloudy (overcast) radiances
- !----------------------------------------
- !-----------------
- !5.2 Downward part
- !-----------------
-
- lev = aux_nearestlev_surf(i)
- rad_up_ad(lev,i) = rad_up_ad(lev,i) + rad_ad % overcast(lev,i)
- transmission_ad % tau_surf(i) = transmission_ad % tau_surf(i) + rad_ad % overcast(lev,i) * auxrad%skin(i)
- rad_skin_ad(i) = rad_skin_ad(i) + rad_ad % overcast(lev,i) * transmission % tau_surf(i)
- rad_ad % overcast(lev,i) = 0._JPRB
-
- End Do
-
- If ( addcloud ) Then
- Do i = 1, nchannels
-
- !(takes reflection and upward clear-sky transmission into account)
- ! surface level
- lev = aux_nearestlev_surf(i)
-
-!dir$ concurrent
- Do j = lev-1, 1 ,-1
- If ( transmission % tau_layer(j,i) > min_tau ) Then
-
- transmission_ad % tau_surf(i) = transmission_ad % tau_surf(i) + rad_ad % downcld(j,i) * &
- & ( auxrad%down_cloud(j,i) * reflectivity(i) + &
- & 2 * auxrad%layer(j,i) * transmission % tau_surf(i) * &
- & reflectivity(i) / transmission % tau_layer(j,i) )
-
- reflectivity_ad(i) = reflectivity_ad(i) + rad_ad % downcld(j,i) *&
- & ( auxrad%down_cloud(j,i) * transmission % tau_surf(i) +&
- & auxrad%layer(j,i) * transmission % tau_surf(i) *&
- & transmission % tau_surf(i) / transmission % tau_layer(j,i) )
-
- Endif
- End Do
-!
-!dir$ concurrent
- Do j = lev-1, 1 ,-1
- If ( transmission % tau_layer(j,i) > min_tau ) Then
- rad_down_cloud_ad(j,i) = rad_down_cloud_ad(j,i) + rad_ad % downcld(j,i) *&
- & transmission % tau_surf(i) * reflectivity(i)
-
- rad_layer_ad(j,i) = rad_layer_ad(j,i) + rad_ad % downcld(j,i) *&
- & reflectivity(i) * transmission % tau_surf(i) * &
- & transmission % tau_surf(i) / transmission % tau_layer(j,i)
-
- transmission_ad % tau_layer(j,i) = transmission_ad % tau_layer(j,i) - rad_ad % downcld(j,i) *&
- & auxrad%layer(j,i) * transmission % tau_surf(i) * &
- & transmission % tau_surf(i) * reflectivity(i) /&
- & (transmission % tau_layer(j,i) * transmission % tau_layer(j,i))
-
- rad_ad % downcld(j,i) = 0._JPRB
- Endif
- End Do
-
- End Do
- End If
-!dir$ concurrent
- Do i = 1, nchannels
- lev = aux_nearestlev_surf(i)
-! Do j = lev-1, 1 ,-1
- aj = lev-1
- rad_up_ad(lev,i) = rad_up_ad(lev,i) + aj * rad_ad % overcast(lev,i)
- transmission_ad % tau_surf(i) = transmission_ad % tau_surf(i) + aj * rad_ad % overcast(lev,i) * auxrad%skin(i)
- rad_skin_ad(i) = rad_skin_ad(i) + aj * rad_ad % overcast(lev,i) * transmission % tau_surf(i)
- rad_ad % overcast(lev,i) = 0._JPRB
-! End Do
- End Do
-
- !---------------
- !5.1 Upward part
- !---------------
- rad_up_ad(:,:) = rad_up_ad(:,:) + rad_ad % overcast(:,:)
- rad_layer_ad(:,:) = rad_layer_ad(:,:) + rad_ad % overcast(:,:) * transmission % tau_layer(:,:)
- transmission_ad % tau_layer(:,:) = transmission_ad % tau_layer(:,:) + rad_ad % overcast(:,:) * auxrad%layer(:,:)
- rad_ad % overcast(:,:) = 0._JPRB
-
- !--------------------------------
- !4. cosmic temperature correction
- !--------------------------------
-
- !calculate planck function corresponding to tcosmic=2.7k
- !deblonde tcosmic for microwave sensors only
-
- If ( addcosmic ) Then
- reflectivity_ad(:) = reflectivity_ad(:) + rad_ad % clear(:) *&
- & auxrad%cosmic(:) * transmission % tau_surf(:) * transmission % tau_surf(:)
- transmission_ad % tau_surf(:) = transmission_ad % tau_surf(:) + rad_ad % clear(:) *&
- & 2 * reflectivity(:) * auxrad%cosmic(:) * transmission % tau_surf(:)
- Endif
-
- !-----------------------
- !3. surface contribution
- !-----------------------
- !rad_ad % clear(:) = rad_ad % clear(:)
- emissivity_ad(:) = emissivity_ad(:) + rad_ad % clear(:) *&
- & auxrad%skin(:) * transmission % tau_surf(:)
- transmission_ad % tau_surf(:) = transmission_ad % tau_surf(:) + rad_ad % clear(:) *&
- & auxrad%skin(:) * emissivity(:)
- rad_skin_ad(:) = rad_skin_ad(:) + rad_ad % clear(:) *&
- & emissivity(:) * transmission % tau_surf(:)
-
- emissivity_ad(:) = emissivity_ad(:) + rad_ad % upclear(:) *&
- & auxrad%skin(:) * transmission % tau_surf(:)
- transmission_ad % tau_surf(:) = transmission_ad % tau_surf(:) + rad_ad % upclear(:) *&
- & auxrad%skin(:) * emissivity(:)
- rad_skin_ad(:) = rad_skin_ad(:) + rad_ad % upclear(:) *&
- & emissivity(:) * transmission % tau_surf(:)
-
-!dir$ concurrent
-!cdir nodep
- Do i = 1, nchannels
- rad_tmp_ad(i) = 0._JPRB
-
- !2.3 near-surface layer
- !----------------------
- ! add upward and downward parts
- lev = aux_levels(i)
-
- ! repeat direct code
- meanrad_up(i) = 0.5_JPRB * ( auxrad%surfair(i) + auxrad%layer(lev,i) ) * &
- & ( transmission % tau_layer(lev,i) - transmission % tau_surf(i) )
-
- If ( transmission % tau_surf(i) > min_tau ) Then
- rad_tmp(i) = meanrad_up(i) / ( transmission % tau_layer(lev,i) * transmission % tau_surf(i) )
- Else
- rad_tmp(i) = 0.0_JPRB
- End If
- meanrad_down(i) = auxrad%down(lev,i) + rad_tmp(i)
- end do
-
- If ( addcloud ) Then
- Do i = 1, nchannels
-
- !2.3 near-surface layer
- !----------------------
- ! add upward and downward parts
-
- lev = aux_levels(i)
-
- ! Adjoint
-!dir$ concurrent
- Do j =lev, 1, -1
- ! in the direct model the value of auxrad%down_cloud(j) is later
- ! modified by
- ! auxrad%down_cloud(j) = (auxrad%down_cloud(j) + rad_tmp(i)) * transmission % tau_surf(i)
- ! So to get the right trajectory one need to divide by transmission % tau_surf(i)
- transmission_ad % tau_surf(i) = transmission_ad % tau_surf(i) + rad_down_cloud_ad(j,i) *&
- & auxrad%down_cloud(j,i) / transmission % tau_surf(i)
- rad_tmp_ad(i) = rad_tmp_ad(i) + rad_down_cloud_ad(j,i) * transmission % tau_surf(i)
-
- rad_down_cloud_ad(j,i) = rad_down_cloud_ad(j,i) * transmission % tau_surf(i)
- End Do
- end do
- End If
-
-!dir$ concurrent
- Do i = 1, nchannels
-
- !2.3 near-surface layer
- !----------------------
- ! add upward and downward parts
- freq=polarisations(i,2)
- kpol= 1 + i - polarisations(freq,1) ! Polarisation index
- lev = aux_levels(i)
-
- meanrad_up_ad(i) = 0._JPRB
- meanrad_down_ad(i) = 0._JPRB
-
- meanrad_up_ad(i) = rad_up_ad(aux_nearestlev_surf(i),i)
- rad_up_ad(aux_nearestlev_surf(i),i) = 0._JPRB
-
- meanrad_down_ad(i) = rad_ad % reflclear(i) *&
- & transmission % tau_surf(i) * transmission % tau_surf(i) * reflectivity(i)
- transmission_ad % tau_surf(i) = transmission_ad % tau_surf(i) + rad_ad % reflclear(i) *&
- & 2._JPRB * transmission % tau_surf(i) * reflectivity(i) * meanrad_down(i)
- reflectivity_ad(i) = reflectivity_ad(i) + rad_ad % reflclear(i) *&
- & transmission % tau_surf(i) * transmission % tau_surf(i) * meanrad_down(i)
- rad_ad % reflclear(i) = 0
-
-
- meanrad_up_ad(i) = meanrad_up_ad(i) + rad_ad % upclear(i)
- rad_ad % upclear(i) = 0._JPRB
-
- meanrad_up_ad(i) = meanrad_up_ad(i) + rad_ad % clear(i)
- meanrad_down_ad(i) = meanrad_down_ad(i) + rad_ad % clear(i) *&
- & transmission % tau_surf(i) * transmission % tau_surf(i) * reflectivity(i)
- transmission_ad % tau_surf(i) = transmission_ad % tau_surf(i) + rad_ad % clear(i) *&
- & 2._JPRB * transmission % tau_surf(i) * reflectivity(i) * meanrad_down(i)
- reflectivity_ad(i) = reflectivity_ad(i) + rad_ad % clear(i) *&
- & transmission % tau_surf(i) * transmission % tau_surf(i) * meanrad_down(i)
- rad_ad % clear(i) = 0._JPRB
-
- ! assume that there is no atmospheric source term for 3rd or 4th Stokes vector elements
- if (kpol >= 3) meanrad_up_ad(i) = 0.0
-
- !meanrad_up_ad = meanrad_up_ad
- rad_up_ad(lev,i) = rad_up_ad(lev,i) + meanrad_up_ad(i)
-
-
- rad_down_ad(lev,i) = meanrad_down_ad(i)
- rad_tmp_ad(i) = rad_tmp_ad(i) + meanrad_down_ad(i) ! cor 28/11
- meanrad_down_ad(i) = 0._JPRB
-
- ! on peut creer une variable intermediaire pour gagner
- ! du temps rad_tmp_ad * meanrad_up / (tau_prod*tau_prod)
- If ( transmission % tau_surf(i) > min_tau ) Then
- tau_prod = transmission % tau_layer(lev,i) * transmission % tau_surf(i)
- meanrad_up_ad(i) = meanrad_up_ad(i) + rad_tmp_ad(i) /&
- & tau_prod
- transmission_ad % tau_layer(lev,i) = transmission_ad % tau_layer(lev,i) - rad_tmp_ad(i) *&
- & meanrad_up(i) * transmission % tau_surf(i) / (tau_prod*tau_prod)
- transmission_ad % tau_surf(i) = transmission_ad % tau_surf(i) - rad_tmp_ad(i) *&
- & meanrad_up(i) * transmission % tau_layer(lev,i) / (tau_prod*tau_prod)
- rad_tmp_ad(i) = 0.0_JPRB
- Else
- rad_tmp_ad(i) = 0.0_JPRB
- End If
-
- ! on peut creer une variable intermediaire pour gagner
- ! du temps 0.5 * meanrad_up_ad * ( auxrad%surfair(i) + auxrad%layer(lev,i)
- ! rad_surfair_ad(i) est certainement inutile car plus utilise
- rad_surfair_ad(i) = rad_surfair_ad(i) + 0.5_JPRB * meanrad_up_ad(i) *&
- & ( transmission % tau_layer(lev,i) - transmission % tau_surf(i) )
- rad_layer_ad(lev,i) = rad_layer_ad(lev,i) + 0.5_JPRB * meanrad_up_ad(i) *&
- & ( transmission % tau_layer(lev,i) - transmission % tau_surf(i) )
- transmission_ad % tau_layer(lev,i) = transmission_ad % tau_layer(lev,i) + 0.5_JPRB * meanrad_up_ad(i) *&
- & ( auxrad%surfair(i) + auxrad%layer(lev,i) )
- transmission_ad % tau_surf(i) = transmission_ad % tau_surf(i) - 0.5_JPRB * meanrad_up_ad(i) * &
- & ( auxrad%surfair(i) + auxrad%layer(lev,i) )
- meanrad_up_ad(i) = 0._JPRB
- end do
-
- rad_tmp_ad_2d(:,:) = 0._JPRB
- meanrad_up_ad_2d(:,:) = 0._JPRB
- Do i = 1, nchannels
-
- !2.2 layers between standard pressure levels
- !-------------------------------------------
- Do lev = coef % nlevels, 2, -1
-
- ! adjoint
- If ( addcloud .And. lev < aux_nearestlev_surf(i)) Then
-!dir$ concurrent
- Do j = lev-1, 1, -1
- rad_tmp_ad_2d(i,lev) = rad_tmp_ad_2d(i,lev) + rad_down_cloud_ad(j,i)
- End Do
- End If
- end do
- end do
-
-!dir$ concurrent
-!cdir nodep
- Do i = 1, nchannels
-
- !2.2 layers between standard pressure levels
- !-------------------------------------------
- Do lev = coef % nlevels, 2, -1
-
- ! direct code
- meanrad_up_2d(i,lev) = 0.5_JPRB * ( auxrad%layer(lev,i) + auxrad%layer(lev-1,i) ) * &
- & ( transmission % tau_layer(lev-1,i) - transmission % tau_layer(lev,i) )
-
- rad_tmp_ad_2d(i,lev) = rad_tmp_ad_2d(i,lev) + rad_down_ad(lev,i)
- rad_down_ad(lev-1,i) = rad_down_ad(lev-1,i) + rad_down_ad(lev,i)
-
- If ( transmission % tau_layer(lev,i) > min_tau ) Then
- ! on peut creer une variable intermediaire pour gagner
- ! du temps rad_tmp_ad * meanrad_up / (tau_prod*tau_prod)
- tau_prod = transmission % tau_layer(lev,i) * transmission % tau_layer(lev-1,i)
- meanrad_up_ad_2d(i,lev) = meanrad_up_ad_2d(i,lev) + rad_tmp_ad_2d(i,lev) /&
- & tau_prod
- transmission_ad % tau_layer(lev,i) = transmission_ad % tau_layer(lev,i) - rad_tmp_ad_2d(i,lev) *&
- & transmission % tau_layer(lev-1,i) * meanrad_up_2d(i,lev) / (tau_prod*tau_prod)
- transmission_ad % tau_layer(lev-1,i) = transmission_ad % tau_layer(lev-1,i) - rad_tmp_ad_2d(i,lev) *&
- & transmission % tau_layer(lev,i) * meanrad_up_2d(i,lev) / (tau_prod*tau_prod)
- rad_tmp_ad_2d(i,lev) = 0._JPRB
- Else
- rad_tmp_ad_2d(i,lev) = 0._JPRB
- End If
-
- meanrad_up_ad_2d(i,lev) = meanrad_up_ad_2d(i,lev) + rad_up_ad(lev,i)
- rad_up_ad(lev-1,i) = rad_up_ad(lev-1,i) + rad_up_ad(lev,i)
-
- rad_layer_ad(lev,i) = rad_layer_ad(lev,i) + meanrad_up_ad_2d(i,lev) *&
- & 0.5_JPRB * ( transmission % tau_layer(lev-1,i) - transmission % tau_layer(lev,i) )
- rad_layer_ad(lev-1,i) = rad_layer_ad(lev-1,i) + meanrad_up_ad_2d(i,lev) *&
- & 0.5_JPRB * ( transmission % tau_layer(lev-1,i) - transmission % tau_layer(lev,i) )
- transmission_ad % tau_layer(lev-1,i) = transmission_ad % tau_layer(lev-1,i) + meanrad_up_ad_2d(i,lev) *&
- & 0.5_JPRB * ( auxrad%layer(lev,i) + auxrad%layer(lev-1,i) )
- transmission_ad % tau_layer(lev,i) = transmission_ad % tau_layer(lev,i) - meanrad_up_ad_2d(i,lev) *&
- & 0.5_JPRB * ( auxrad%layer(lev,i) + auxrad%layer(lev-1,i) )
- End Do
-
- End Do
-
- !2.1 layer above top pressure level
- !----------------------------------
- !
- rad_up_ad(1,:) = rad_up_ad(1,:) + rad_down_ad(1,:) /&
- & transmission % tau_layer(1,:)
- transmission_ad % tau_layer(1,:) = transmission_ad % tau_layer(1,:) - rad_down_ad(1,:) *&
- & auxrad%down(1,:) / transmission % tau_layer(1,:)
- rad_down_ad(1,:) = 0._JPRB
-
- rad_layer_ad(1,:) = rad_layer_ad(1,:) + rad_up_ad(1,:) *&
- & ( 1.0_JPRB-transmission % tau_layer(1,:) )
- transmission_ad % tau_layer(1,:) = transmission_ad % tau_layer(1,:) - rad_up_ad(1,:) *&
- & auxrad%layer(1,:)
- rad_up_ad(1,:) = 0._JPRB
-
- Call rttov_calcrad_ad( &
- & nfrequencies, &! in
- & nchannels, &! in
- & nprofiles, &! in
- & channels, &! in
- & polarisations, &! in
- & lprofiles, &! in
- & profiles, &! in
- & profiles_ad, &! inout
- & coef, &! in
- & auxrad%skin, &! in
- & auxrad%surfair, &! in
- & auxrad%layer, &! in
- & rad_skin_ad, &! in
- & rad_surfair_ad, &! in
- & rad_layer_ad ) ! in
-
-End Subroutine rttov_integrate_ad
diff --git a/src/LIB/RTTOV/src/rttov_integrate_ad.interface b/src/LIB/RTTOV/src/rttov_integrate_ad.interface
deleted file mode 100644
index 95b1bcc21d41409885dcd8567e349372a3bc295f..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_integrate_ad.interface
+++ /dev/null
@@ -1,83 +0,0 @@
-Interface
-Subroutine rttov_integrate_ad( &
- addcloud, & ! in
- addcosmic, & ! in
- switchrad, & ! in
- nfrequencies, & ! in
- nchannels, & ! in
- nbtout, & ! in
- nprofiles, & ! in
- geometry, & ! in
- channels, & ! in
- polarisations,& ! in
- lprofiles, & ! in
- emissivity, & ! in
- emissivity_ad, & ! inout
- reflectivity, & ! in
- reflectivity_ad, & ! inout
- transmission, & ! in
- transmission_ad, & ! inout
- profiles, & ! in
- profiles_ad, & ! inout
- aux_prof, & ! in
- aux_prof_ad, & ! inout
- coef, & ! in
- rad , & ! in
- auxrad , & ! in
- rad_ad ) ! inout
-
-! Adjoint Variables
-! transmission_ad % tau_surf |
-! transmission_ad % tau_layer |
-! emissivity_ad |
-! reflectivity_ad | initialised before calling
-! profiles_ad |
-! aux_prof_ad |
-
-
- Use rttov_types, Only : &
- rttov_coef ,&
- profile_Type ,&
- profile_aux ,&
- transmission_type, &
- radiance_Type ,&
- radiance_aux ,&
- geometry_Type
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
-
- Logical, Intent(in) :: addcloud
- Logical, Intent(in) :: addcosmic
- Logical, Intent(in) :: switchrad ! true if input is BT
- Integer(Kind=jpim), Intent(in) :: nchannels
- Integer(Kind=jpim), Intent(in) :: nbtout
- Integer(Kind=jpim), Intent(in) :: nfrequencies
- Integer(Kind=jpim), Intent(in) :: nprofiles
- Integer(Kind=jpim), Intent(in) :: channels(nfrequencies)
- Integer(Kind=jpim), Intent(in) :: polarisations(nchannels,3)
- Integer(Kind=jpim), Intent(in) :: lprofiles(nfrequencies)
- Real(Kind=jprb), Intent(in) :: emissivity(nchannels)
- Real(Kind=jprb), Intent(in) :: reflectivity(nchannels)
- Type(rttov_coef), Intent(in) :: coef
- Type(profile_Type), Intent(in) ,Target :: profiles(nprofiles)
- Type(profile_aux) , Intent(in) ,Target :: aux_prof(nprofiles)
- Type(transmission_Type), Intent(in):: transmission
- Type(radiance_Type), Intent(in) :: rad
- Type(radiance_aux), Intent(in) :: auxrad
-
- Real(Kind=jprb), Intent(inout) :: emissivity_ad(nchannels)
- Real(Kind=jprb), Intent(inout) :: reflectivity_ad(nchannels)
- Type(geometry_Type), Intent(in) ,Target :: geometry(nprofiles)
- Type(profile_Type), Intent(inout) ,Target :: profiles_ad(nprofiles)
- Type(profile_aux) , Intent(inout) ,Target :: aux_prof_ad(nprofiles)
- Type(transmission_Type), Intent(inout) :: transmission_ad
- Type(radiance_Type), Intent(inout) :: rad_ad
-
-
-
-
-
-End Subroutine rttov_integrate_ad
-End Interface
diff --git a/src/LIB/RTTOV/src/rttov_integrate_k.F90 b/src/LIB/RTTOV/src/rttov_integrate_k.F90
deleted file mode 100644
index b64b6fe929764aafe44f166b572614126e2f5194..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_integrate_k.F90
+++ /dev/null
@@ -1,592 +0,0 @@
-Subroutine rttov_integrate_k( &
- & addcloud, &! in
- & addcosmic, &! in
- & switchrad, &! in
- & nfrequencies, &! in
- & nchannels, &! in
- & nbtout, &! in
- & nprofiles, &! in
- & angles, &! in
- & channels, &! in
- & polarisations, &! in
- & lprofiles, &! in
- & emissivity, &! in
- & emissivity_k, &! inout
- & reflectivity, &! in
- & reflectivity_k, &! inout
- & transmission, &! in
- & transmission_k, &! inout
- & profiles, &! in
- & profiles_k, &! inout
- & aux_prof, &! in
- & aux_prof_k, &! inout
- & coef, &! in
- & rad , &! in
- & auxrad , &! in
- & rad_k ) ! inout
- !
- ! Description:
- ! To perform K integration of radiative transfer equation
- ! in rttov suite, calculating radiances and brightness temperature.
- !
- ! Copyright:
- ! This software was developed within the context of
- ! the EUMETSAT Satellite Application Facility on
- ! Numerical Weather Prediction (NWP SAF), under the
- ! Cooperation Agreement dated 25 November 1998, between
- ! EUMETSAT and the Met Office, UK, by one or more partners
- ! within the NWP SAF. The partners in the NWP SAF are
- ! the Met Office, ECMWF, KNMI and MeteoFrance.
- !
- ! Copyright 2002, EUMETSAT, All Rights Reserved.
- !
- ! Method:
- ! Eyre J.R. 1991 A fast radiative transfer model for satellite sounding
- ! systems. ECMWF Research Dept. Tech. Memo. 176 (available from the
- ! librarian at ECMWF).
- !
- ! Saunders R.W., M. Matricardi and P. Brunel 1999 An Improved Fast Radiative
- ! Transfer Model for Assimilation of Satellite Radiance Observations.
- ! QJRMS, 125, 1407-1425.
- !
- ! Current Code Owner: SAF NWP
- !
- ! History:
- ! Version Date Comment
- ! ------- ---- -------
- ! 25/06/91. Original code. J.R.EYRE *ECMWF*
- ! 21/08/00. Emissivity and reflectivity handled separately. Steve English
- ! 31/01/01. More cloud computations. F. Chevallier
- ! 23/03/01 New coef. format, new channel numbers (P. Brunel)
- ! 31/01/01. More cloud computations. F. Chevallier
- ! 28/09/01 Cosmic background temp added G.Deblonde
- ! 18/01/2002 Thread safe (D.Salmond)
- ! 1.0 01/12/2002 New F90 code with structures (P Brunel A Smith)
- ! 1.1 02/01/2003 Added comments (R Saunders)
- ! 1.2 06/05/2003 Init rad%downcld to 0 in section 1 (P Brunel)
- ! 1.3 26/09/2003 Modified to allow for multiple polarisations(S English)
- ! 1.4 06/09/2004 Mods. for Vectorisation (D Salmond ECMWF & B Carruthers, Cray)
- ! 1.5 29/03/2005 Add end of header comment (J. Cameron)
- !
- ! Code Description:
- ! Language: Fortran 90.
- ! Software Standards: "European Standards for Writing and
- ! Documenting Exchangeable Fortran 90 Code".
- !
- ! Declarations:
- ! Modules used:
- ! Imported Type Definitions:
-
- ! Adjoint Variables
- ! transmission_k % tau_surf |
- ! transmission_k % tau_layer |
- ! emissivity_k |
- ! reflectivity_k | initialised before calling
- ! profiles_k |
- ! aux_prof_k |
-
- Use rttov_const, only : &
- & sensor_id_mw
-
- Use rttov_types, Only : &
- & geometry_Type ,&
- & rttov_coef ,&
- & profile_Type ,&
- & profile_aux ,&
- & transmission_Type ,&
- & radiance_Type ,&
- & radiance_aux
-
-
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
-#include "rttov_calcbt_ad.interface"
-#include "rttov_calcrad_k.interface"
-#include "rttov_calcpolarisation_ad.interface"
-
- !subroutine arguments:
- Logical, Intent(in) :: addcloud
- Logical, Intent(in) :: addcosmic
- Logical, Intent(in) :: switchrad ! true if input is BT
- Integer(Kind=jpim), Intent(in) :: nbtout ! Number of BTs returned
- Integer(Kind=jpim), Intent(in) :: nfrequencies
- Integer(Kind=jpim), Intent(in) :: nchannels
- Integer(Kind=jpim), Intent(in) :: nprofiles
- Integer(Kind=jpim), Intent(in) :: channels(nfrequencies)
- Integer(Kind=jpim), Intent(in) :: polarisations(nchannels,3)
- Integer(Kind=jpim), Intent(in) :: lprofiles(nfrequencies)
- Real(Kind=jprb), Intent(in) :: emissivity(nchannels)
- Real(Kind=jprb), Intent(in) :: reflectivity(nchannels)
- Type(geometry_Type), Intent(in) :: angles(nprofiles) ! geometry angles
- Type(rttov_coef), Intent(in) :: coef
- Type(profile_Type), Intent(in) ,Target :: profiles(nprofiles)
- Type(profile_aux) , Intent(in) ,Target :: aux_prof(nprofiles)
- Type(transmission_Type), Intent(in):: transmission
- Type(radiance_Type), Intent(in) :: rad
- Type(radiance_aux), Intent(in) :: auxrad
- Real(Kind=jprb), Intent(inout) :: emissivity_k(nchannels)
- Real(Kind=jprb), Intent(inout) :: reflectivity_k(nchannels)
- Type(profile_Type), Intent(inout) ,Target :: profiles_k(nchannels)
- Type(profile_aux) , Intent(inout) ,Target :: aux_prof_k(nchannels)
- Type(transmission_Type), Intent(inout) :: transmission_k
- Type(radiance_Type), Intent(inout) :: rad_k
-
- !local constants:
- Real(Kind=jprb), Parameter :: min_tau = 1.0e-8_JPRB
-
- !local variables:
- Real(Kind=jprb) :: cfraction(nchannels)
- Real(Kind=jprb) :: cfraction_k(nchannels)
-
- Real(Kind=jprb) :: rad_tmp
- Real(Kind=jprb) :: meanrad_up(nchannels)
- Real(Kind=jprb) :: meanrad_up_2d(nchannels, coef % nlevels)
- Real(Kind=jprb) :: meanrad_down(nchannels)
-
- Real(Kind=jprb) :: rad_layer_k(coef % nlevels,nchannels)
- Real(Kind=jprb) :: rad_surfair_k(nchannels)
- Real(Kind=jprb) :: rad_skin_k(nchannels)
- Real(Kind=jprb) :: rad_up_k(coef % nlevels, nchannels)
- Real(Kind=jprb) :: rad_down_k(coef % nlevels, nchannels)
- Real(Kind=jprb) :: rad_down_cloud_k(coef % nlevels, nchannels)
- Real(Kind=jprb) :: rad_tmp_k(nchannels)
- Real(Kind=jprb) :: rad_tmp_k_2d(nchannels, coef % nlevels)
- Real(Kind=jprb) :: meanrad_up_k(nchannels)
- Real(Kind=jprb) :: meanrad_up_k_2d(nchannels, coef % nlevels)
- Real(Kind=jprb) :: meanrad_down_k(nchannels)
- Real(Kind=jprb) :: tau_prod
-
- Integer(Kind=jpim) :: i,j,lev,freq,kpol
-
- Type(profile_aux), Pointer :: aux
- Type(profile_aux), Pointer :: aux_k
-
- !- End of header --------------------------------------------------------
-
- !----------------------------------------------------------------------------
- ! initialise radiance structure cloud flag
- rad_k % lcloud = addcloud
-
-
- !----------------------------
- !1. calculate layer radiances
- !----------------------------
- If (coef % id_sensor == sensor_id_mw) Then
- Call rttov_calcpolarisation_ad( &
- & nfrequencies, &! in
- & nchannels, &! in
- & nbtout, &! in
- & profiles, &! in
- & nprofiles, &! in
- & angles, &! in
- & channels, &! in
- & polarisations, &! in
- & lprofiles, &! in
- & coef, &! in
- & rad_k ) ! inout
- Else
- rad_k%bt = rad_k%out
- rad_k%bt_clear = rad_k%out_clear
- rad_k%total = rad_k%total_out
- rad_k%clear = rad_k%clear_out
- End If
-
-! if input K unit is temperature, convert it in radiance
-! call AD routine because all arguments size are nchannels
- if ( switchrad ) then
- Call rttov_calcbt_ad( &
- & nfrequencies, &! in
- & nchannels, &! in
- & channels, &! in
- & polarisations, &! in
- & coef, &! in
- & rad, &! in
- & rad_k ) ! inout output is only rad_k%total
- endif
-
-
-
- ! initialisation of local variables
- rad_layer_k(:,:) = 0._JPRB
- rad_surfair_k(:) = 0._JPRB
- rad_skin_k(:) = 0._JPRB
- rad_up_k(:,:) = 0._JPRB
- rad_down_k(:,:) = 0._JPRB
- rad_down_cloud_k(:,:) = 0._JPRB
-
- Do i = 1, nchannels
- freq=polarisations(i,2)
- cfraction(i) = aux_prof( lprofiles(freq) )%cfraction
- End Do
-
-
-
-
- !---------------------------
- !6. calculate total radiance
- !---------------------------
-
-
- rad_k%clear(:) = (1 - cfraction(:)) * rad_k%total(:)
- rad_k%cloudy(:) = cfraction(:) * rad_k%total(:)
- cfraction_k(:) = ( rad%cloudy(:) - rad%clear(:) ) * rad_k%total(:)
-
- Do i = 1, nchannels
- aux_prof_k( i )%cfraction =&
- & aux_prof_k( i )%cfraction + cfraction_k(i)
- End Do
-
- Do i = 1, nchannels
- freq=polarisations(i,2)
- aux => aux_prof( lprofiles(freq) )
- aux_k => aux_prof_k( i )
-
- !--------------------------------------------
- !5.3 Interpolate to given cloud-top pressures
- !--------------------------------------------
-
- lev = aux % nearestlev_ctp
- rad_k%overcast(lev,i) = rad_k%overcast(lev,i) +&
- & (1 - aux % pfraction_ctp) * rad_k%cloudy(i)
-
- rad_k%overcast(lev-1,i) = rad_k%overcast(lev-1,i) +&
- & aux % pfraction_ctp * rad_k%cloudy(i)
-
- aux_k % pfraction_ctp = aux_k % pfraction_ctp +&
- & (rad%overcast(lev-1,i) - rad%overcast(lev,i)) * rad_k%cloudy(i)
-
- !rad_k%cloudy(i) is no later used rad_tl % cloudy was an output only
- rad_k%cloudy(i) = 0._JPRB
-
- !----------------------------------------
- !5. calculate cloudy (overcast) radiances
- !----------------------------------------
- !-----------------
- !5.2 Downward part
- !-----------------
-
- !(takes reflection and upward clear-sky transmission into account)
- ! surface level
- lev = aux % nearestlev_surf ! cor 28/11
- rad_up_k(lev,i) = rad_up_k(lev,i) + rad_k % overcast(lev,i)
- transmission_k % tau_surf(i)=transmission_k % tau_surf(i)+rad_k % overcast(lev,i)*auxrad%skin(i)
- rad_skin_k(i) = rad_skin_k(i) + rad_k % overcast(lev,i) * transmission % tau_surf(i)
- rad_k % overcast(lev,i) = 0._JPRB
- End Do
-
- If ( addcloud ) Then
- Do i = 1, nchannels
- freq=polarisations(i,2)
- aux => aux_prof( lprofiles(freq) )
-
- !(takes reflection and upward clear-sky transmission into account)
- ! surface level
- lev = aux % nearestlev_surf
-
- Do j = lev-1, 1 ,-1
- If ( transmission % tau_layer(j,i) > min_tau ) Then
- transmission_k% tau_surf(i) = transmission_k% tau_surf(i) + rad_k % downcld(j,i) * &
- & ( auxrad%down_cloud(j,i) * reflectivity(i) + &
- & 2 * auxrad%layer(j,i) * transmission % tau_surf(i) *&
- & reflectivity(i) / transmission % tau_layer(j,i) )
-
- reflectivity_k(i) = reflectivity_k(i) + rad_k % downcld(j,i) *&
- & ( auxrad%down_cloud(j,i) * transmission % tau_surf(i) +&
- & auxrad%layer(j,i) * transmission % tau_surf(i) *&
- & transmission % tau_surf(i) / transmission % tau_layer(j,i) )
- Endif
- End Do
-!
-!dir$ concurrent
- Do j = lev-1, 1 ,-1
- If ( transmission % tau_layer(j,i) > min_tau ) Then
- rad_down_cloud_k(j,i) = rad_down_cloud_k(j,i) + rad_k % downcld(j,i) *&
- & transmission % tau_surf(i) * reflectivity(i)
-
- rad_layer_k(j,i) = rad_layer_k(j,i) + rad_k % downcld(j,i) *&
- & reflectivity(i) * transmission % tau_surf(i) * &
- & transmission % tau_surf(i) / transmission % tau_layer(j,i)
-
- transmission_k% tau_layer(j,i) = transmission_k% tau_layer(j,i) - rad_k % downcld(j,i) *&
- & auxrad%layer(j,i) * transmission % tau_surf(i) * transmission % tau_surf(i) * reflectivity(i) /&
- & (transmission % tau_layer(j,i) * transmission % tau_layer(j,i))
-
- rad_k % downcld(j,i) = 0._JPRB
- Endif
- End Do
- End Do
- End If
- Do i = 1, nchannels
- freq=polarisations(i,2)
- aux => aux_prof( lprofiles(freq) )
- lev = aux % nearestlev_surf
- rad_up_k(lev,i) = rad_up_k(lev,i) + rad_k % overcast(lev,i)
- transmission_k % tau_surf(i) = transmission_k % tau_surf(i) + rad_k % overcast(lev,i) * auxrad%skin(i)
- rad_skin_k(i) = rad_skin_k(i) + rad_k % overcast(lev,i) * transmission % tau_surf(i)
- rad_k % overcast(lev,i) = 0._JPRB
- End Do
-
- !---------------
- !5.1 Upward part
- !---------------
- rad_up_k(:,:) = rad_up_k(:,:) + rad_k % overcast(:,:)
- rad_layer_k(:,:) = rad_layer_k(:,:) + rad_k % overcast(:,:) * transmission % tau_layer(:,:)
- transmission_k% tau_layer(:,:) = transmission_k% tau_layer(:,:) + rad_k % overcast(:,:) * auxrad%layer(:,:)
- rad_k % overcast(:,:) = 0._JPRB
-
- !--------------------------------
- !4. cosmic temperature correction
- !--------------------------------
-
- !calculate planck function corresponding to tcosmic=2.7k
- !deblonde tcosmic for microwave sensors only
-
- If ( addcosmic ) Then
- reflectivity_k(:) = reflectivity_k(:) + rad_k % clear(:) *&
- & auxrad%cosmic(:) * transmission % tau_surf(:) * transmission % tau_surf(:)
- transmission_k% tau_surf(:) = transmission_k% tau_surf(:) + rad_k % clear(:) *&
- & 2 * reflectivity(:) * auxrad%cosmic(:) * transmission % tau_surf(:)
- Endif
-
- !-----------------------
- !3. surface contribution
- !-----------------------
- emissivity_k(:) = emissivity_k(:) + rad_k % clear(:) *&
- & auxrad%skin(:) * transmission % tau_surf(:)
- transmission_k% tau_surf(:) = transmission_k% tau_surf(:) + rad_k % clear(:) *&
- & auxrad%skin(:) * emissivity(:)
- rad_skin_k(:) = rad_skin_k(:) + rad_k % clear(:) *&
- & emissivity(:) * transmission % tau_surf(:)
-
- emissivity_k(:) = emissivity_k(:) + rad_k % upclear(:) *&
- & auxrad%skin(:) * transmission % tau_surf(:)
- transmission_k% tau_surf(:) = transmission_k% tau_surf(:) + rad_k % upclear(:) *&
- & auxrad%skin(:) * emissivity(:)
- rad_skin_k(:) = rad_skin_k(:) + rad_k % upclear(:) *&
- & emissivity(:) * transmission % tau_surf(:)
-
-
- Do i = 1, nchannels
- freq=polarisations(i,2)
- aux => aux_prof( lprofiles(freq) )
- aux_k => aux_prof_k( i )
- rad_tmp_k(i) = 0._JPRB
-
- !2.3 near-surface layer
- !----------------------
- ! add upward and downward parts
- lev = aux % nearestlev_surf - 1
- If ( aux % pfraction_surf < 0.0_JPRB ) lev = lev + 1
-
- ! repeat direct code
- meanrad_up(i) = 0.5_JPRB * ( auxrad%surfair(i) + auxrad%layer(lev,i) ) * &
- & ( transmission % tau_layer(lev,i) - transmission % tau_surf(i) )
-
- If ( transmission % tau_surf(i) > min_tau ) Then
- rad_tmp = meanrad_up(i) / ( transmission % tau_layer(lev,i) * transmission % tau_surf(i) )
- Else
- rad_tmp = 0.0_JPRB
- End If
- meanrad_down(i) = auxrad%down(lev,i) + rad_tmp
- end do
-
- If ( addcloud ) Then
- Do i = 1, nchannels
- freq=polarisations(i,2)
- aux => aux_prof( lprofiles(freq) )
-
- !2.3 near-surface layer
- !----------------------
- ! add upward and downward parts
- lev = aux % nearestlev_surf - 1
- If ( aux % pfraction_surf < 0.0_JPRB ) lev = lev + 1
-
- ! K
- Do j =lev, 1, -1
- ! in the direct model the value of auxrad%down_cloud(j) is later
- ! modified by
- ! auxrad%down_cloud(j) = (auxrad%down_cloud(j) + rad_tmp) * transmission % tau_surf(i)
- ! So to get the right trajectory one need to divide by transmission % tau_surf(i)
- transmission_k% tau_surf(i) = transmission_k% tau_surf(i) + rad_down_cloud_k(j,i) *&
- & auxrad%down_cloud(j,i) / transmission % tau_surf(i)
- rad_tmp_k(i) = rad_tmp_k(i) + rad_down_cloud_k(j,i) * transmission % tau_surf(i)
-
- rad_down_cloud_k(j,i) = rad_down_cloud_k(j,i) * transmission % tau_surf(i)
- End Do
- End Do
- End If
-
- Do i = 1, nchannels
- freq=polarisations(i,2)
- kpol= 1 + i - polarisations(freq,1) ! Polarisation index
- aux => aux_prof( lprofiles(freq) )
-
- !2.3 near-surface layer
- !----------------------
- ! add upward and downward parts
- lev = aux % nearestlev_surf - 1
- If ( aux % pfraction_surf < 0.0_JPRB ) lev = lev + 1
-
- meanrad_up_k(i) = 0._JPRB
- meanrad_down_k(i) = 0._JPRB
- meanrad_up_k(i) = rad_up_k(aux % nearestlev_surf,i)
- rad_up_k(aux % nearestlev_surf,i) = 0._JPRB
- meanrad_down_k(i) = rad_k % reflclear(i) *&
- & transmission % tau_surf(i) * transmission % tau_surf(i) * reflectivity(i)
- transmission_k% tau_surf(i) = transmission_k% tau_surf(i) + rad_k % reflclear(i) *&
- & 2._JPRB * transmission % tau_surf(i) * reflectivity(i) * meanrad_down(i)
- reflectivity_k(i) = reflectivity_k(i) + rad_k % reflclear(i) *&
- & transmission % tau_surf(i) * transmission % tau_surf(i) * meanrad_down(i)
- rad_k % reflclear(i) = 0._JPRB
-
- meanrad_up_k(i) = meanrad_up_k(i) + rad_k % upclear(i)
- rad_k % upclear(i) = 0._JPRB
-
- meanrad_up_k(i) = meanrad_up_k(i) + rad_k % clear(i)
- meanrad_down_k(i) = meanrad_down_k(i) + rad_k % clear(i) *&
- & transmission % tau_surf(i) * transmission % tau_surf(i) * reflectivity(i)
- transmission_k% tau_surf(i) = transmission_k% tau_surf(i) + rad_k % clear(i) *&
- & 2._JPRB * transmission % tau_surf(i) * reflectivity(i) * meanrad_down(i)
- reflectivity_k(i) = reflectivity_k(i) + rad_k % clear(i) *&
- & transmission % tau_surf(i) * transmission % tau_surf(i) * meanrad_down(i)
- rad_k % clear(i) = 0._JPRB
-
- ! assume that there is no atmospheric source term for 3rd or 4th Stokes vector elements
- if (kpol >= 3) meanrad_up_k(i) = 0.0
-
- !meanrad_up_k(i) = meanrad_up_k(i)
- rad_up_k(lev,i) = rad_up_k(lev,i) + meanrad_up_k(i)
-
- rad_down_k(lev,i) = meanrad_down_k(i)
- rad_tmp_k(i) = rad_tmp_k(i) + meanrad_down_k(i)
- meanrad_down_k(i) = 0._JPRB
-
- ! on peut creer une variable intermediaire pour gagner
- ! du temps rad_tmp_k * meanrad_up / (tau_prod*tau_prod)
- If ( transmission % tau_surf(i) > min_tau ) Then
- tau_prod = transmission % tau_layer(lev,i) * transmission % tau_surf(i)
- meanrad_up_k(i) = meanrad_up_k(i) + rad_tmp_k(i) /&
- & tau_prod
- transmission_k% tau_layer(lev,i) = transmission_k% tau_layer(lev,i) - rad_tmp_k(i) *&
- & meanrad_up(i) * transmission % tau_surf(i) / (tau_prod*tau_prod)
- transmission_k% tau_surf(i) = transmission_k% tau_surf(i) - rad_tmp_k(i) *&
- & meanrad_up(i) * transmission % tau_layer(lev,i) / (tau_prod*tau_prod)
- rad_tmp_k(i) = 0.0_JPRB
- Else
- rad_tmp_k(i) = 0.0_JPRB
- End If
-
- ! on peut creer une variable intermediaire pour gagner
- ! du temps 0.5 * meanrad_up_k * ( auxrad%surfair(i) + auxrad%layer(lev,i)
- ! rad_surfair_k(i) est certainement inutile car plus utilise
- rad_surfair_k(i) = rad_surfair_k(i) + 0.5_JPRB * meanrad_up_k(i) *&
- & ( transmission % tau_layer(lev,i) - transmission % tau_surf(i) )
- rad_layer_k(lev,i) = rad_layer_k(lev,i) + 0.5_JPRB * meanrad_up_k(i) *&
- & ( transmission % tau_layer(lev,i) - transmission % tau_surf(i) )
- transmission_k% tau_layer(lev,i) = transmission_k% tau_layer(lev,i) + 0.5_JPRB * meanrad_up_k(i) *&
- & ( auxrad%surfair(i) + auxrad%layer(lev,i) )
- transmission_k% tau_surf(i) = transmission_k% tau_surf(i) - 0.5_JPRB * meanrad_up_k(i) * &
- & ( auxrad%surfair(i) + auxrad%layer(lev,i) )
- meanrad_up_k(i) = 0._JPRB
- End Do
-
- rad_tmp_k_2d(:,:) = 0._JPRB
- meanrad_up_k_2d(:,:) = 0._JPRB
- Do i = 1, nchannels
- freq=polarisations(i,2)
- aux => aux_prof( lprofiles(freq) )
-
- !2.2 layers between standard pressure levels
- !-------------------------------------------
- Do lev = coef % nlevels, 2, -1
-
- ! adjoint
- If ( addcloud .And. lev < aux % nearestlev_surf) Then
- Do j = lev-1, 1, -1
- rad_tmp_k_2d(i,lev) = rad_tmp_k_2d(i,lev) + rad_down_cloud_k(j,i)
- End Do
- End If
- End do
- End do
-
- Do i = 1, nchannels
- freq=polarisations(i,2)
- aux => aux_prof( lprofiles(freq) )
-
- !2.2 layers between standard pressure levels
- !-------------------------------------------
- Do lev = coef % nlevels, 2, -1
-
- ! direct code
- meanrad_up_2d(i,lev) = 0.5_JPRB * ( auxrad%layer(lev,i) + auxrad%layer(lev-1,i) ) * &
- & ( transmission % tau_layer(lev-1,i) - transmission % tau_layer(lev,i) )
-
- rad_tmp_k_2d(i,lev) = rad_tmp_k_2d(i,lev) + rad_down_k(lev,i)
- rad_down_k(lev-1,i) = rad_down_k(lev-1,i) + rad_down_k(lev,i)
-
- If ( transmission % tau_layer(lev,i) > min_tau ) Then
- ! on peut creer une variable intermediaire pour gagner
- ! du temps rad_tmp_k * meanrad_up / (tau_prod*tau_prod)
- tau_prod = transmission % tau_layer(lev,i) * transmission % tau_layer(lev-1,i)
- meanrad_up_k_2d(i,lev) = meanrad_up_k_2d(i,lev) + rad_tmp_k_2d(i,lev) /&
- & tau_prod
- transmission_k % tau_layer(lev,i) = transmission_k % tau_layer(lev,i) - rad_tmp_k_2d(i,lev) *&
- & transmission % tau_layer(lev-1,i) * meanrad_up_2d(i,lev) / (tau_prod*tau_prod)
- transmission_k % tau_layer(lev-1,i) = transmission_k % tau_layer(lev-1,i) - rad_tmp_k_2d(i,lev) *&
- & transmission % tau_layer(lev,i) * meanrad_up_2d(i,lev) / (tau_prod*tau_prod)
- rad_tmp_k_2d(i,lev) = 0._JPRB
- Else
- rad_tmp_k_2d(i,lev) = 0._JPRB
- End If
-
- meanrad_up_k_2d(i,lev) = meanrad_up_k_2d(i,lev) + rad_up_k(lev,i)
- rad_up_k(lev-1,i) = rad_up_k(lev-1,i) + rad_up_k(lev,i)
- rad_layer_k(lev,i) = rad_layer_k(lev,i) + meanrad_up_k_2d(i,lev) *&
- & 0.5_JPRB * ( transmission % tau_layer(lev-1,i) - transmission % tau_layer(lev,i) )
- rad_layer_k(lev-1,i) = rad_layer_k(lev-1,i) + meanrad_up_k_2d(i,lev) *&
- & 0.5_JPRB * ( transmission % tau_layer(lev-1,i) - transmission % tau_layer(lev,i) )
- transmission_k % tau_layer(lev-1,i) = transmission_k % tau_layer(lev-1,i) + meanrad_up_k_2d(i,lev) *&
- & 0.5_JPRB * ( auxrad%layer(lev,i) + auxrad%layer(lev-1,i) )
- transmission_k % tau_layer(lev,i) = transmission_k % tau_layer(lev,i) - meanrad_up_k_2d(i,lev) *&
- & 0.5_JPRB * ( auxrad%layer(lev,i) + auxrad%layer(lev-1,i) )
-
- End Do
-
- End Do
-
- !2.1 layer above top pressure level
- !----------------------------------
- !
- rad_up_k(1,:) = rad_up_k(1,:) + rad_down_k(1,:) /&
- & transmission % tau_layer(1,:)
- transmission_k% tau_layer(1,:) = transmission_k% tau_layer(1,:) - rad_down_k(1,:) *&
- & auxrad%down(1,:) / transmission % tau_layer(1,:)
- rad_down_k(1,:) = 0._JPRB
-
- rad_layer_k(1,:) = rad_layer_k(1,:) + rad_up_k(1,:) *&
- & ( 1.0_JPRB-transmission % tau_layer(1,:) )
- transmission_k% tau_layer(1,:) = transmission_k% tau_layer(1,:) - rad_up_k(1,:) *&
- & auxrad%layer(1,:)
- rad_up_k(1,:) = 0._JPRB
-
- Call rttov_calcrad_k( &
- & nfrequencies, &! in
- & nchannels, &! in
- & nprofiles, &! in
- & channels, &! in
- & polarisations, &! in
- & lprofiles, &! in
- & profiles, &! in
- & profiles_k, &! inout
- & coef, &! in
- & auxrad%skin, &! in
- & auxrad%surfair, &! in
- & auxrad%layer, &! in
- & rad_skin_k, &! in
- & rad_surfair_k, &! in
- & rad_layer_k ) ! in
-
-
-End Subroutine rttov_integrate_k
diff --git a/src/LIB/RTTOV/src/rttov_integrate_k.interface b/src/LIB/RTTOV/src/rttov_integrate_k.interface
deleted file mode 100644
index f73ca68b86c98d9ca60e1f3ebdbdc82ea9941e65..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_integrate_k.interface
+++ /dev/null
@@ -1,85 +0,0 @@
-Interface
-Subroutine rttov_integrate_k( &
- addcloud, & ! in
- addcosmic, & ! in
- switchrad, & ! in
- nfrequencies, & ! in
- nchannels, & ! in
- nbtout, & ! in
- nprofiles, & ! in
- angles, & ! in
- channels, & ! in
- polarisations,& ! in
- lprofiles, & ! in
- emissivity, & ! in
- emissivity_k, & ! inout
- reflectivity, & ! in
- reflectivity_k, & ! inout
- transmission, & ! in
- transmission_k, & ! inout
- profiles, & ! in
- profiles_k, & ! inout
- aux_prof, & ! in
- aux_prof_k, & ! inout
- coef, & ! in
- rad , & ! in
- auxrad , & ! in
- rad_k ) ! inout
-
-! Adjoint Variables
-! transmission_k % tau_surf |
-! transmission_k % tau_layer |
-! emissivity_k |
-! reflectivity_k | initialised before calling
-! profiles_k |
-! aux_prof_k |
-
-
- Use rttov_types, Only : &
- geometry_Type ,&
- rttov_coef ,&
- profile_Type ,&
- profile_aux ,&
- transmission_Type ,&
- radiance_Type ,&
- radiance_aux
-
-
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
-
- Logical, Intent(in) :: addcloud
- Logical, Intent(in) :: addcosmic
- Logical, Intent(in) :: switchrad ! true if input is BT
- Integer(Kind=jpim), Intent(in) :: nchannels
- Integer(Kind=jpim), Intent(in) :: nfrequencies
- Integer(Kind=jpim), Intent(in) :: nbtout
- Integer(Kind=jpim), Intent(in) :: nprofiles
- Integer(Kind=jpim), Intent(in) :: channels(nfrequencies)
- Integer(Kind=jpim), Intent(in) :: polarisations(nchannels,3)
- Integer(Kind=jpim), Intent(in) :: lprofiles(nfrequencies)
- Real(Kind=jprb), Intent(in) :: emissivity(nchannels)
- Real(Kind=jprb), Intent(in) :: reflectivity(nchannels)
- Type(geometry_Type), Intent(in) :: angles(nprofiles) ! geometry angles
- Type(rttov_coef), Intent(in) :: coef
- Type(profile_Type), Intent(in) ,Target :: profiles(nprofiles)
- Type(profile_aux) , Intent(in) ,Target :: aux_prof(nprofiles)
- Type(transmission_Type), Intent(in):: transmission
- Type(radiance_Type), Intent(in) :: rad
- Type(radiance_aux), Intent(in) :: auxrad
-
- Real(Kind=jprb), Intent(inout) :: emissivity_k(nchannels)
- Real(Kind=jprb), Intent(inout) :: reflectivity_k(nchannels)
- Type(profile_Type), Intent(inout) ,Target :: profiles_k(nchannels)
- Type(profile_aux) , Intent(inout) ,Target :: aux_prof_k(nchannels)
- Type(transmission_Type), Intent(inout):: transmission_k
- Type(radiance_Type), Intent(inout) :: rad_k
-
-
-
-
-
-End Subroutine rttov_integrate_k
-End Interface
diff --git a/src/LIB/RTTOV/src/rttov_integrate_tl.F90 b/src/LIB/RTTOV/src/rttov_integrate_tl.F90
deleted file mode 100644
index 0f1b40858be06ee0413090a6393d286f98ea886e..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_integrate_tl.F90
+++ /dev/null
@@ -1,503 +0,0 @@
-Subroutine rttov_integrate_tl( &
- & addcloud, &! in
- & addcosmic, &! in
- & nfrequencies, &! in
- & nchannels, &! in
- & nbtout, &! in
- & nprofiles, &! in
- & angles, &! in
- & channels, &! in
- & polarisations, &! in
- & lprofiles, &! in
- & emissivity, &! in
- & emissivity_tl, &! in
- & reflectivity, &! in
- & reflectivity_tl, &! in
- & transmission, &! in
- & transmission_tl, &! in
- & profiles, &! in
- & profiles_tl, &! in
- & aux_prof, &! in
- & aux_prof_tl, &! in
- & coef, &! in
- & rad , &! in
- & auxrad , &! in
- & rad_tl ) ! inout
- !
- ! Description:
- ! To perform TL of integration of radiative transfer equation
- ! in rttov suite, calculating radiances and brightness temperature.
- !
- ! Copyright:
- ! This software was developed within the context of
- ! the EUMETSAT Satellite Application Facility on
- ! Numerical Weather Prediction (NWP SAF), under the
- ! Cooperation Agreement dated 25 November 1998, between
- ! EUMETSAT and the Met Office, UK, by one or more partners
- ! within the NWP SAF. The partners in the NWP SAF are
- ! the Met Office, ECMWF, KNMI and MeteoFrance.
- !
- ! Copyright 2002, EUMETSAT, All Rights Reserved.
- !
- ! Method:
- ! Eyre J.R. 1991 A fast radiative transfer model for satellite sounding
- ! systems. ECMWF Research Dept. Tech. Memo. 176 (available from the
- ! librarian at ECMWF).
- !
- ! Saunders R.W., M. Matricardi and P. Brunel 1999 An Improved Fast Radiative
- ! Transfer Model for Assimilation of Satellite Radiance Observations.
- ! QJRMS, 125, 1407-1425.
- !
- ! Current Code Owner: SAF NWP
- !
- ! History:
- ! Version Date Comment
- ! ------- ---- -------
- ! 25/06/91. Original code. J.R.EYRE *ECMWF*
- ! 21/08/00. Emissivity and reflectivity handled separately. Steve English
- ! 31/01/01. More cloud computations. F. Chevallier
- ! 23/03/01 New coef. format, new channel numbers (P. Brunel)
- ! 31/01/01. More cloud computations. F. Chevallier
- ! 28/09/01 Cosmic background temp added G.Deblonde
- ! 18/01/2002 Thread safe (D.Salmond)
- ! 1.0 01/12/2002 New F90 code with structures (P Brunel A Smith)
- ! 1.1 02/01/2003 Added comments (R Saunders)
- ! 1.2 06/05/2003 Init rad%downcld to 0 in section 1 (P Brunel)
- ! 1.3 26/09/2003 Modified to allow for multiple polarisations (S English)
- ! 28/02/2005 Improved vectorisation (D Dent)
- ! 29/03/2005 Add end of header comment (J. Cameron)
- !
- ! Code Description:
- ! Language: Fortran 90.
- ! Software Standards: "European Standards for Writing and
- ! Documenting Exchangeable Fortran 90 Code".
- !
- ! Declarations:
- ! Modules used:
- ! Imported Type Definitions:
-
- Use rttov_const, only : &
- & sensor_id_mw
-
- Use rttov_types, Only : &
- & geometry_Type ,&
- & rttov_coef ,&
- & profile_Type ,&
- & profile_aux ,&
- & transmission_Type ,&
- & radiance_Type ,&
- & radiance_aux
-
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
-#include "rttov_calcbt_tl.interface"
-#include "rttov_calcrad_tl.interface"
-#include "rttov_calcpolarisation_tl.interface"
-
- !subroutine arguments:
- Logical, Intent(in) :: addcloud
- Logical, Intent(in) :: addcosmic
- Integer(Kind=jpim), Intent(in) :: nfrequencies
- Integer(Kind=jpim), Intent(in) :: nchannels
- Integer(Kind=jpim), Intent(in) :: nbtout ! Number of BTs returned
- Integer(Kind=jpim), Intent(in) :: nprofiles
- Integer(Kind=jpim), Intent(in) :: channels(nfrequencies)
- Integer(Kind=jpim), Intent(in) :: polarisations(nchannels,3)
- Integer(Kind=jpim), Intent(in) :: lprofiles(nfrequencies)
- Real(Kind=jprb), Intent(in) :: emissivity(nchannels)
- Real(Kind=jprb), Intent(in) :: reflectivity(nchannels)
- Type(geometry_Type), Intent(in) :: angles(nprofiles) ! geometry angles
- Type(rttov_coef), Intent(in) :: coef
- Type(profile_Type), Intent(in) ,Target :: profiles(nprofiles)
- Type(profile_aux) , Intent(in) ,Target :: aux_prof(nprofiles)
- Type(transmission_Type), Intent(in):: transmission
- Type(radiance_Type), Intent(in) :: rad
- Type(radiance_aux), Intent(in) :: auxrad
-
- Real(Kind=jprb), Intent(in) :: emissivity_tl(nchannels)
- Real(Kind=jprb), Intent(in) :: reflectivity_tl(nchannels)
- Type(profile_Type), Intent(in) ,Target :: profiles_tl(nprofiles)
- Type(profile_aux) , Intent(in) ,Target :: aux_prof_tl(nprofiles)
- Type(transmission_Type), Intent(in):: transmission_tl
- Type(radiance_Type), Intent(inout) :: rad_tl ! in because of mem allocation
-
-
-
-
-
- !local constants:
- Real(Kind=jprb), Parameter :: min_tau = 1.0e-8_JPRB
-
-
-
- !local variables:
- Real(Kind=jprb) :: rad_tmp
- Real(Kind=jprb) :: meanrad_up
- Real(Kind=jprb) :: meanrad_down
-
- Real(Kind=jprb) :: rad_tmp_tl
- Real(Kind=jprb) :: meanrad_up_tl
- Real(Kind=jprb) :: meanrad_down_tl
- Real(Kind=jprb) :: tau_prod
-
- Real(Kind=jprb) :: cfraction(nchannels)
- Real(Kind=jprb) :: cfraction_tl(nchannels)
-
- ! rad_down_cloud overwrite auxrad % down_cloud
- ! because it is in input/output of several code lines
- Real(Kind=jprb) :: rad_down_cloud(coef % nlevels, nchannels)
-
- Real(Kind=jprb) :: rad_layer_tl(coef % nlevels, nchannels)
- Real(Kind=jprb) :: rad_surfair_tl(nchannels)
- Real(Kind=jprb) :: rad_skin_tl(nchannels)
- Real(Kind=jprb) :: rad_up_tl(coef % nlevels, nchannels)
- Real(Kind=jprb) :: rad_down_tl(coef % nlevels, nchannels)
- Real(Kind=jprb) :: rad_down_cloud_tl(coef % nlevels, nchannels)
-
- Integer(Kind=jpim) :: i,j,lev,freq,kpol
-
- Type(profile_aux), Pointer :: aux
- Type(profile_aux), Pointer :: aux_tl
-
- real(Kind=jprb) :: v1(nchannels,coef%nlevels,2), v2(nchannels), p1, p2
- real(Kind=jprb) :: pfraction(nchannels)
- integer(Kind=jpim) :: iv1(nchannels), iv2(nchannels), iv3(nchannels)
-
- !- End of header --------------------------------------------------------
-
-!cdir nooverlap(aux,aux_tl)
-
- !-------------------------------------------------------------------------------
- ! initialise radiance structure cloud flag
- rad_tl % lcloud = addcloud
-
-
- !----------------------------
- !1. calculate layer radiances
- !----------------------------
-
- Call rttov_calcrad_tl( &
- & nfrequencies, &! in
- & nchannels, &! in
- & nprofiles, &! in
- & channels, &! in
- & polarisations, &! in
- & lprofiles, &! in
- & profiles, &! in
- & profiles_tl, &! in
- & coef, &! in
- & auxrad%skin, &! in
- & auxrad%surfair, &! in
- & auxrad%layer, &! in
- & rad_skin_tl, &! out
- & rad_surfair_tl, &! out
- & rad_layer_tl ) ! out
-
- If ( addcloud ) Then
- rad_down_cloud(:,:) =0._JPRB
- rad_down_cloud_tl(:,:) = 0._JPRB
- rad_tl % downcld(:,:) = 0._JPRB
- Endif
-
- !2.1 layer above top pressure level
- !----------------------------------
- !
-
- rad_up_tl(1,:) = rad_layer_tl(1,:) * ( 1.0_JPRB-transmission % tau_layer(1,:) ) -&
- & auxrad%layer(1,:) * transmission_tl % tau_layer(1,:)
- rad_down_tl(1,:) = (rad_up_tl(1,:) - auxrad%down(1,:) * transmission_tl % tau_layer(1,:)) /&
- & transmission % tau_layer(1,:)
-
- !-------------------------------------
- !2. calculate atmospheric contribution
- !-------------------------------------
-!cdir nodep
- Do i = 1, nchannels
- freq=polarisations(i,2)
- j = lprofiles(freq)
- aux => aux_prof( j )
- aux_tl => aux_prof_tl( j )
- cfraction(i) = aux%cfraction
- cfraction_tl(i) = aux_tl%cfraction
- pfraction(i) = aux%pfraction_surf
- iv2(i) = aux%nearestlev_surf
- iv1(i) = min( coef % nlevels, iv2(i) - 1 )
- iv3(i) = iv2(i) - 1
- If ( pfraction(i) < 0.0_JPRB ) iv3(i) = iv3(i) + 1
- End Do
-
- !2.2 layers between standard pressure levels
- !-------------------------------------------
-
- Do i = 1, nchannels
- Do lev = 2, coef % nlevels
- meanrad_up = 0.5_JPRB * ( auxrad%layer(lev,i) + auxrad%layer(lev-1,i) ) * &
- & ( transmission % tau_layer(lev-1,i) - transmission % tau_layer(lev,i) )
-
- meanrad_up_tl = 0.5_JPRB *((( auxrad%layer(lev,i) + auxrad%layer(lev-1,i) ) * &
- & ( transmission_tl % tau_layer(lev-1,i) - transmission_tl % tau_layer(lev,i) )) + &
- & (( rad_layer_tl(lev,i) + rad_layer_tl(lev-1,i)) * &
- & ( transmission % tau_layer(lev-1,i) - transmission % tau_layer(lev,i) )))
- rad_up_tl(lev,i) = rad_up_tl(lev-1,i) + meanrad_up_tl
-
- If ( transmission % tau_layer(lev,i) > min_tau ) Then
- tau_prod = transmission % tau_layer(lev,i) * transmission % tau_layer(lev-1,i)
- v1(i,lev,1) = meanrad_up / tau_prod
- v1(i,lev,2) = ( meanrad_up_tl - &
- & meanrad_up * ( transmission_tl % tau_layer(lev,i) * transmission % tau_layer(lev-1,i) + &
- & transmission % tau_layer(lev,i) * transmission_tl % tau_layer(lev-1,i)) / &
- & tau_prod ) / tau_prod
- Else
- v1(i,lev,1) = 0.0_JPRB
- v1(i,lev,2) = 0.0_JPRB
- End If
- rad_down_tl(lev,i) = rad_down_tl(lev-1,i) + v1(i,lev,2)
-
- End Do
- End Do
-
-
- Do i = 1, nchannels
- Do lev = 2, coef % nlevels
- If ( addcloud .And. lev < iv2(i) ) Then
- Do j = 1, lev-1
- rad_down_cloud(j,i) = rad_down_cloud(j,i) + v1(i,lev,1)
- rad_down_cloud_tl(j,i) = rad_down_cloud_tl(j,i) + v1(i,lev,2)
- End Do
- End If
- End Do
- End Do
-
-
- !2.3 near-surface layer
- !----------------------
- ! add upward and downward parts
-
-!dir$ concurrent
- Do i = 1, nchannels
-
- lev = iv3(i)
- freq = polarisations(i,2) ! Frequency index
- kpol= 1 + i - polarisations(freq,1) ! Polarisation index
-
- meanrad_up = 0.5_JPRB * ( auxrad%surfair(i) + auxrad%layer(lev,i) ) * &
- & ( transmission % tau_layer(lev,i) - transmission % tau_surf(i) )
- meanrad_up_tl = 0.5_JPRB *((( rad_surfair_tl(i) + rad_layer_tl(lev,i) ) * &
- & ( transmission % tau_layer(lev,i) - transmission % tau_surf(i) )) + &
- & (( auxrad%surfair(i) + auxrad%layer(lev,i) ) * &
- & ( transmission_tl % tau_layer(lev,i)- transmission_tl % tau_surf(i) )))
-
- If ( transmission % tau_surf(i) > min_tau ) Then
- tau_prod = transmission % tau_layer(lev,i) * transmission % tau_surf(i)
- v1(i,lev,1) = meanrad_up / ( transmission % tau_layer(lev,i) * transmission % tau_surf(i) )
- v1(i,lev,2) = ( meanrad_up_tl - &
- & meanrad_up * ( transmission_tl % tau_layer(lev,i) * transmission % tau_surf(i) + &
- & transmission % tau_layer(lev,i) * transmission_tl % tau_surf(i)) / &
- & tau_prod ) / tau_prod
- Else
- v1(i,lev,1) = 0.0_JPRB
- v1(i,lev,2) = 0.0_JPRB
- End If
-
- meanrad_down = auxrad%down(lev,i) + v1(i,lev,1)
- meanrad_down_tl = rad_down_tl(lev,i) + v1(i,lev,2)
-
- meanrad_up_tl = rad_up_tl(lev,i) + meanrad_up_tl
-
- ! assume that there is no atmospheric source term for 3rd or 4th Stokes vector elements
- if (kpol >= 3) meanrad_up_tl = 0.0_JPRB
-
- rad_tl % clear(i) =&
- & meanrad_up_tl + &
- & transmission % tau_surf(i) * ( reflectivity(i) * &
- & ( meanrad_down_tl * transmission % tau_surf(i) + &
- & 2._JPRB * transmission_tl % tau_surf(i) * meanrad_down ) + &
- & reflectivity_tl(i) * meanrad_down * transmission % tau_surf(i))
-
- rad_tl % upclear(i) = meanrad_up_tl
-
- rad_tl % reflclear(i) = transmission % tau_surf(i) * &
- & ( reflectivity(i) * ( meanrad_down_tl * transmission % tau_surf(i) +&
- & 2.0_JPRB * transmission_tl % tau_surf(i) * meanrad_down ) +&
- & reflectivity_tl(i) * meanrad_down * transmission % tau_surf(i))
-
-
- rad_up_tl(iv2(i),i) = meanrad_up_tl
- End Do
-
- If ( addcloud ) Then
- Do i = 1, nchannels
- lev = iv3(i)
- Do j = 1, lev
- rad_down_cloud_tl(j,i) =&
- & (rad_down_cloud_tl(j,i) + v1(i,lev,2)) * transmission % tau_surf(i) +&
- & (rad_down_cloud(j,i) + v1(i,lev,1)) * transmission_tl % tau_surf(i)
- rad_down_cloud(j,i) = (rad_down_cloud(j,i) + v1(i,lev,1)) * transmission % tau_surf(i)
- End Do
- End Do
- End If
-
- !-----------------------
- !3. surface contribution
- !-----------------------
-
- rad_tl % clear(:) = &
- & rad_tl % clear(:) +&
- & auxrad%skin(:) * (emissivity_tl(:) * transmission % tau_surf(:) +&
- & emissivity(:) * transmission_tl % tau_surf(:)) +&
- & rad_skin_tl(:) * emissivity(:) * transmission % tau_surf(:)
-
-
- rad_tl % upclear(:) =&
- & rad_tl % upclear(:) + &
- & auxrad%skin(:) * (emissivity_tl(:) * transmission % tau_surf(:) +&
- & emissivity(:) * transmission_tl % tau_surf(:)) +&
- & rad_skin_tl(:) * emissivity(:) * transmission % tau_surf(:)
-
-
- !--------------------------------
- !4. cosmic temperature correction
- !--------------------------------
-
- !calculate planck function corresponding to tcosmic=2.7k
- !deblonde tcosmic for microwave sensors only
-
- If ( addcosmic ) Then
- rad_tl % clear(:) =&
- & rad_tl % clear(:) + &
- & reflectivity_tl(:) * auxrad%cosmic(:) * transmission % tau_surf(:) * transmission % tau_surf(:) + &
- & 2 * reflectivity(:) * auxrad%cosmic(:) * transmission_tl % tau_surf(:) * transmission % tau_surf(:)
- Endif
-
-
- !----------------------------------------
- !5. calculate cloudy (overcast) radiances
- !----------------------------------------
-
- !---------------
- !5.1 Upward part
- !---------------
-
-!dir$ concurrent
- rad_tl % overcast(:,:) = &
- & rad_up_tl(:,:) +&
- & rad_layer_tl(:,:) * transmission % tau_layer(:,:) +&
- & auxrad%layer(:,:) * transmission_tl % tau_layer(:,:)
-
-!dir$ concurrent
- Do i = 1, nchannels
-
- lev = iv2(i)
- rad_tl % overcast(lev,i) = &
- & rad_up_tl(lev,i) +&
- & transmission_tl % tau_surf(i) * auxrad%skin(i) +&
- & transmission % tau_surf(i) * rad_skin_tl(i)
-
- End Do
-
- !-----------------
- !5.2 Downward part
- !-----------------
-
- !(takes reflection and upward clear-sky transmission into account)
-
- If ( addcloud ) Then
-!dir$ concurrent
- Do i = 1, nchannels
-
- lev = iv2(i)
-!dir$ concurrent
- Do j = 1,lev-1
- If ( transmission % tau_layer(j,i) > min_tau ) Then
- rad_tl % downcld(j,i) = &
- & rad_down_cloud_tl(j,i) * transmission % tau_surf(i) * reflectivity(i) +&
- & rad_down_cloud(j,i) * transmission_tl % tau_surf(i) * reflectivity(i) +&
- & rad_down_cloud(j,i) * transmission % tau_surf(i) * reflectivity_tl(i) +&
- & rad_layer_tl(j,i) * transmission % tau_surf(i) &
- & * transmission % tau_surf(i) * reflectivity(i) &
- & / transmission % tau_layer(j,i) +&
- & auxrad%layer(j,i) * transmission_tl % tau_surf(i) &
- & * transmission % tau_surf(i) * reflectivity(i) &
- & / transmission % tau_layer(j,i) +&
- & auxrad%layer(j,i) * transmission % tau_surf(i) &
- & * transmission % tau_surf(i) * reflectivity_tl(i) &
- & / transmission % tau_layer(j,i) +&
- & auxrad%layer(j,i) *&
- & ( transmission_tl % tau_surf(i) * transmission % tau_layer(j,i) &
- & - transmission % tau_surf(i) * transmission_tl % tau_layer(j,i)) &
- & / (transmission % tau_layer(j,i) * transmission % tau_layer(j,i)) *&
- & transmission % tau_surf(i) * reflectivity(i)
- Endif
- End Do
- ! No specific action for transmission % tau_layer(j,i) <= min_tau or
- ! levels between aux % nearestlev_surf and nlevels
- ! because the array rad_tl % downcld has already
- ! been init. to 0 in section 1
- End Do
- End If
-
- !--------------------------------------------
- !5.3 Interpolate to given cloud-top pressures
- !--------------------------------------------
-
-!dir$ concurrent
- Do i = 1, nchannels
- freq = polarisations(i,2) ! Frequency index
- lev = aux_prof( lprofiles(freq) )% nearestlev_ctp
- p1 = aux_prof( lprofiles(freq) )% pfraction_ctp
- p2 = aux_prof_tl( lprofiles(freq) )% pfraction_ctp
-
- rad_tl % cloudy(i) =&
- & rad_tl%overcast(lev,i) +&
- & (rad_tl%overcast(lev-1,i) - rad_tl%overcast(lev,i)) * p1 +&
- & (rad%overcast(lev-1,i) - rad%overcast(lev,i)) * p2
-
- End Do
-
-
- !---------------------------
- !6. calculate total radiance
- !---------------------------
-
-!dir$ concurrent
- rad_tl % total(:) = &
- & rad_tl % clear(:) +&
- & cfraction(:) * ( rad_tl%cloudy(:) - rad_tl%clear(:) ) +&
- & cfraction_tl(:) * ( rad%cloudy(:) - rad%clear(:) )
-
-
-
- !-----------------------------------------------
- !7. convert radiances to brightness temperatures
- !-----------------------------------------------
-
- Call rttov_calcbt_tl( &
- & nfrequencies, &! in
- & nchannels, &! in
- & channels, &! in
- & polarisations, &! in
- & coef, &! in
- & rad, &! in
- & rad_tl ) ! inout
-
- If (coef % id_sensor == sensor_id_mw) Then
- Call rttov_calcpolarisation_tl( &
- & nfrequencies, &! in
- & nchannels, &! in
- & nprofiles, &! in
- & angles, &! in
- & channels, &! in
- & polarisations, &! in
- & lprofiles, &! in
- & coef, &! in
- & rad_tl ) ! inout
- Else
- rad_tl%out = rad_tl%bt
- rad_tl%out_clear = rad_tl%bt_clear
- rad_tl%total_out = rad_tl%total
- rad_tl%clear_out = rad_tl%clear
- End If
-
-End Subroutine rttov_integrate_tl
diff --git a/src/LIB/RTTOV/src/rttov_integrate_tl.interface b/src/LIB/RTTOV/src/rttov_integrate_tl.interface
deleted file mode 100644
index 1a8ef5c81088beee6e4825902077f1a2617b8759..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_integrate_tl.interface
+++ /dev/null
@@ -1,73 +0,0 @@
-Interface
-Subroutine rttov_integrate_tl( &
- addcloud, & ! in
- addcosmic, & ! in
- nfrequencies, & ! in
- nchannels, & ! in
- nbtout, & ! in
- nprofiles, & ! in
- geometry, & ! in
- channels, & ! in
- polarisations,& ! in
- lprofiles, & ! in
- emissivity, & ! in
- emissivity_tl, & ! in
- reflectivity, & ! in
- reflectivity_tl, & ! in
- transmission, & ! in
- transmission_tl, & ! in
- profiles, & ! in
- profiles_tl, & ! in
- aux_prof, & ! in
- aux_prof_tl, & ! in
- coef, & ! in
- rad , & ! in
- auxrad , & ! in
- rad_tl ) ! inout
-
- Use rttov_types, Only : &
- rttov_coef ,&
- profile_Type ,&
- profile_aux ,&
- transmission_Type ,&
- radiance_Type ,&
- radiance_aux ,&
- geometry_Type
-
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
-
- Logical, Intent(in) :: addcloud
- Logical, Intent(in) :: addcosmic
- Integer(Kind=jpim), Intent(in) :: nchannels
- Integer(Kind=jpim), Intent(in) :: nfrequencies
- Integer(Kind=jpim), Intent(in) :: nbtout
- Integer(Kind=jpim), Intent(in) :: nprofiles
- Integer(Kind=jpim), Intent(in) :: channels(nfrequencies)
- Integer(Kind=jpim), Intent(in) :: polarisations(nchannels,3)
- Integer(Kind=jpim), Intent(in) :: lprofiles(nfrequencies)
- Real(Kind=jprb), Intent(in) :: emissivity(nchannels)
- Real(Kind=jprb), Intent(in) :: reflectivity(nchannels)
- Type(geometry_Type), Intent(in) ,Target :: geometry(nprofiles)
- Type(rttov_coef), Intent(in) :: coef
- Type(profile_Type), Intent(in) ,Target :: profiles(nprofiles)
- Type(profile_aux) , Intent(in) ,Target :: aux_prof(nprofiles)
- Type(transmission_Type), Intent(in):: transmission
- Type(radiance_Type), Intent(in) :: rad
- Type(radiance_aux), Intent(in) :: auxrad
-
- Real(Kind=jprb), Intent(in) :: emissivity_tl(nchannels)
- Real(Kind=jprb), Intent(in) :: reflectivity_tl(nchannels)
- Type(profile_Type), Intent(in) ,Target :: profiles_tl(nprofiles)
- Type(profile_aux) , Intent(in) ,Target :: aux_prof_tl(nprofiles)
- Type(transmission_Type), Intent(in):: transmission_tl
- Type(radiance_Type), Intent(inout) :: rad_tl ! in because of mem allocation
-
-
-
-
-
-End Subroutine rttov_integrate_tl
-End Interface
diff --git a/src/LIB/RTTOV/src/rttov_integratesource.F90 b/src/LIB/RTTOV/src/rttov_integratesource.F90
deleted file mode 100644
index e7afdbc049a2c059ba350aa62e0149fd3e16d287..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_integratesource.F90
+++ /dev/null
@@ -1,140 +0,0 @@
-!
-Subroutine rttov_integratesource (&
- & nwp_levels, &! in
- & nchannels, &! in
- & nprofiles, &! in
- & lprofiles, &! in
- & angles, &! in
- & scatt_aux, &! in
- & dp, &! in
- & dm, &! in
- & j_do, &! inout
- & j_up) ! inout
-
- ! Description:
- ! integrate source in Eddington
- !
- ! Copyright:
- ! This software was developed within the context of
- ! the EUMETSAT Satellite Application Facility on
- ! Numerical Weather Prediction (NWP SAF), under the
- ! Cooperation Agreement dated 25 November 1998, between
- ! EUMETSAT and the Met Office, UK, by one or more partners
- ! within the NWP SAF. The partners in the NWP SAF are
- ! the Met Office, ECMWF, KNMI and MeteoFrance.
- !
- ! Copyright 2002, EUMETSAT, All Rights Reserved.
- !
- ! Method:
- ! - Bauer, P., 2002: Microwave radiative transfer modeling in clouds and precipitation.
- ! Part I: Model description.
- ! NWP SAF Report No. NWPSAF-EC-TR-005, 27 pp.
- ! - Chevallier, F., and P. Bauer, 2003:
- ! Model rain and clouds over oceans: comparison with SSM/I observations.
- ! Mon. Wea. Rev., 131, 1240-1255.
- ! - Moreau, E., P. Bauer and F. Chevallier, 2002: Microwave radiative transfer modeling in clouds and precipitation.
- ! Part II: Model evaluation.
- ! NWP SAF Report No. NWPSAF-EC-TR-006, 27 pp.
- !
- ! Current Code Owner: SAF NWP
- !
- ! History:
- ! Version Date Comment
- ! ------- ---- -------
- ! 1.0 09/2002 Initial version (P. Bauer, E. Moreau)
- ! 1.1 05/2003 RTTOV7.3 compatible (F. Chevallier)
- ! 1.2 03/2004 Added polarimetry (R. Saunders)
- ! 1.3 08/2004 Polarimetry fixes (U. O'Keefe)
- ! 1.4 11/2004 Clean-up (P. Bauer)
- !
- ! Code Description:
- ! Language: Fortran 90.
- ! Software Standards: "European Standards for Writing and
- ! Documenting Exchangeable Fortran 90 Code".
- !
- ! Declarations:
- ! Modules used:
- ! Imported Type Definitions:
-
- Use rttov_types, Only : &
- & profile_scatt_aux ,&
- & geometry_Type
-
- Use parkind1, Only : jpim ,jprb
-
- Implicit None
-
-!* Subroutine arguments:
- Integer (Kind=jpim), Intent (in) :: nwp_levels ! Number of levels
- Integer (Kind=jpim), Intent (in) :: nprofiles ! Number of profiles
- Integer (Kind=jpim), Intent (in) :: nchannels ! Number of channels*profiles=radiances
- Integer (Kind=jpim), Intent (in) :: lprofiles (nchannels) ! Profile indices
-
- Type (profile_scatt_aux), Intent (in) :: scatt_aux ! Auxiliary profile variables for RTTOV_SCATT
- Type (geometry_Type), Intent (in) :: angles (nprofiles) ! Zenith angles
-
- Real (Kind=jprb), Intent (in) , dimension (nchannels,nwp_levels) :: dp ! D+ for boundary conditions
- Real (Kind=jprb), Intent (in) , dimension (nchannels,nwp_levels) :: dm ! D- for boundary conditions
- Real (Kind=jprb), Intent (inout), dimension (nchannels,nwp_levels) :: j_do ! Downward source terms
- Real (Kind=jprb), Intent (inout), dimension (nchannels,nwp_levels) :: j_up ! Upward source terms
-
-!* Local variables
- Real (Kind=jprb), dimension (nwp_levels) :: ja, jb, jc, jd, aa, bb, cp, cm, ztmp
- Integer (Kind=jpim) :: iprof, ichan
-
- !- End of header --------------------------------------------------------
-
-!* Channels * Profiles
- do ichan = 1, nchannels
- iprof = lprofiles (ichan)
-
-!* Reset
- ja (:) = 0.0_JPRB
- jb (:) = 0.0_JPRB
- jc (:) = 0.0_JPRB
- jd (:) = 0.0_JPRB
-
-!* Coefficients
- aa (:) = scatt_aux % b0 (iprof,:) - 1.5_JPRB * scatt_aux % asm (ichan,:) * scatt_aux % ssa (ichan,:) &
- & * angles (iprof) % coszen * scatt_aux % b1 (iprof,:) / scatt_aux % h (ichan,:)
- bb (:) = scatt_aux % b1 (iprof,:)
- cp (:) = dp (ichan,:) * scatt_aux % ssa (ichan,:) * (1.0_JPRB - 1.5_JPRB * scatt_aux % asm (ichan,:) &
- & * angles (iprof) % coszen * scatt_aux % lambda (ichan,:) / scatt_aux % h (ichan,:))
- cm (:) = dm (ichan,:) * scatt_aux % ssa (ichan,:) * (1.0_JPRB + 1.5_JPRB * scatt_aux % asm (ichan,:) &
- & * angles (iprof) % coszen * scatt_aux % lambda (ichan,:) / scatt_aux % h (ichan,:))
-
-!* Downward radiance source terms
- where (scatt_aux % ssa (ichan,:) > 1.0E-08_JPRB) ! limit depends on mie tables
- ja (:) = 1.0_JPRB - scatt_aux % tau (ichan,:)
- jb (:) = angles (iprof) % coszen / scatt_aux % ext (ichan,:) * (1.0_JPRB - scatt_aux % tau (ichan,:)) &
- & - scatt_aux % tau (ichan,:) * scatt_aux % dz (iprof,:)
-
- ztmp (:) = exp (scatt_aux % dz (iprof,:) * (scatt_aux % lambda (ichan,:) &
- & - scatt_aux % ext (ichan,:) / angles (iprof) % coszen))
- jc (:) = scatt_aux % ext (ichan,:) &
- & / (scatt_aux % lambda (ichan,:) * angles (iprof) % coszen - scatt_aux % ext (ichan,:)) * (ztmp(:) - 1.0_JPRB)
-
- ztmp (:) = exp (scatt_aux % dz (iprof,:) * (scatt_aux % lambda (ichan,:) &
- & + scatt_aux % ext (ichan,:) / angles (iprof) % coszen))
- jd (:) = scatt_aux % ext (ichan,:) &
- & / (scatt_aux % lambda (ichan,:) * angles (iprof) % coszen &
- & + scatt_aux % ext (ichan,:)) * (1.0_JPRB - 1.0_JPRB / ztmp(:))
-
- j_do (ichan,:) = ja (:) * aa (:) + jb (:) * bb (:) + jc (:) * cp (:) + jd (:) * cm (:)
-
-!* Upward radiance source terms
- ja (:) = 1.0_JPRB - scatt_aux % tau (ichan,:)
- jb (:) = scatt_aux % dz (iprof,:) - angles (iprof) % coszen / scatt_aux % ext (ichan,:) &
- & * (1.0_JPRB - scatt_aux % tau (ichan,:))
-
- ztmp (:) = exp (scatt_aux % dz (iprof,:) * scatt_aux % lambda (ichan,:))
- jc (:) = scatt_aux % ext (ichan,:) / (scatt_aux % ext (ichan,:) + scatt_aux % lambda (ichan,:) &
- & * angles (iprof) % coszen) * (ztmp (:) - scatt_aux % tau (ichan,:))
- jd (:) = scatt_aux % ext (ichan,:) / (scatt_aux % ext (ichan,:) - scatt_aux % lambda (ichan,:) &
- & * angles (iprof) % coszen) * (1.0_JPRB / ztmp (:) - scatt_aux % tau (ichan,:))
-
- j_up (ichan,:) = ja (:) * aa (:) + jb (:) * bb (:) + jc (:) * cp (:) + jd (:) * cm (:)
- end where
- end do
-
-End subroutine rttov_integratesource
diff --git a/src/LIB/RTTOV/src/rttov_integratesource.interface b/src/LIB/RTTOV/src/rttov_integratesource.interface
deleted file mode 100644
index dee3f9ca0d48b25e7451982a3d88486ff1297f9c..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_integratesource.interface
+++ /dev/null
@@ -1,28 +0,0 @@
-INTERFACE
-Subroutine rttov_integratesource (&
- & nwp_levels,&
- & nchannels,&
- & nprofiles,&
- & lprofiles,&
- & angles,&
- & scatt_aux,&
- & dp,&
- & dm,&
- & j_do,&
- & j_up)
- Use rttov_types, Only :&
- & profile_scatt_aux ,&
- & geometry_Type
- Use parkind1, Only : jpim ,jprb
- Integer (Kind=jpim), Intent (in) :: nwp_levels
- Integer (Kind=jpim), Intent (in) :: nprofiles
- Integer (Kind=jpim), Intent (in) :: nchannels
- Integer (Kind=jpim), Intent (in) :: lprofiles (nchannels)
- Type (profile_scatt_aux), Intent (in) :: scatt_aux
- Type (geometry_Type), Intent (in) :: angles (nprofiles)
- Real (Kind=jprb), Intent (in) , dimension (nchannels,nwp_levels) :: dp
- Real (Kind=jprb), Intent (in) , dimension (nchannels,nwp_levels) :: dm
- Real (Kind=jprb), Intent (inout), dimension (nchannels,nwp_levels) :: j_do
- Real (Kind=jprb), Intent (inout), dimension (nchannels,nwp_levels) :: j_up
-End subroutine rttov_integratesource
-END INTERFACE
diff --git a/src/LIB/RTTOV/src/rttov_integratesource_ad.F90 b/src/LIB/RTTOV/src/rttov_integratesource_ad.F90
deleted file mode 100644
index 1780a2ecbc566e515b9b75da34ef64aedbfefdbf..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_integratesource_ad.F90
+++ /dev/null
@@ -1,367 +0,0 @@
-!
-Subroutine rttov_integratesource_ad (&
- & nwp_levels, &! in
- & nchannels, &! in
- & nprofiles, &! in
- & lprofiles, &! in
- & angles, &! in
- & scatt_aux, &! in
- & scatt_aux_ad, &! inout
- & dp, &! in
- & dp_ad, &! inout
- & dm, &! in
- & dm_ad, &! inout
- & j_do, &! inout
- & j_do_ad, &! inout
- & j_up, &! inout
- & j_up_ad) ! inout
-
- ! Description:
- ! integrate source in Eddington
- !
- ! Copyright:
- ! This software was developed within the context of
- ! the EUMETSAT Satellite Application Facility on
- ! Numerical Weather Prediction (NWP SAF), under the
- ! Cooperation Agreement dated 25 November 1998, between
- ! EUMETSAT and the Met Office, UK, by one or more partners
- ! within the NWP SAF. The partners in the NWP SAF are
- ! the Met Office, ECMWF, KNMI and MeteoFrance.
- !
- ! Copyright 2002, EUMETSAT, All Rights Reserved.
- !
- ! Method:
- ! - Bauer, P., 2002: Microwave radiative transfer modeling in clouds and precipitation.
- ! Part I: Model description.
- ! NWP SAF Report No. NWPSAF-EC-TR-005, 27 pp.
- ! - Chevallier, F., and P. Bauer, 2003:
- ! Model rain and clouds over oceans: comparison with SSM/I observations.
- ! Mon. Wea. Rev., 131, 1240-1255.
- ! - Moreau, E., P. Bauer and F. Chevallier, 2002: Microwave radiative transfer modeling in clouds and precipitation.
- ! Part II: Model evaluation.
- ! NWP SAF Report No. NWPSAF-EC-TR-006, 27 pp.
- !
- ! Current Code Owner: SAF NWP
- !
- ! History:
- ! Version Date Comment
- ! ------- ---- -------
- ! 1.0 09/2002 Initial version (E. Moreau)
- ! 1.1 05/2003 RTTOV7.3 compatible (F. Chevallier)
- ! 1.2 03/2004 Added polarimetry (R. Saunders)
- ! 1.3 08/2004 Polarimetry fixes (U. O'Keefe)
- ! 1.4 11/2004 Clean-up (P. Bauer)
- !
- ! Code Description:
- ! Language: Fortran 90.
- ! Software Standards: "European Standards for Writing and
- ! Documenting Exchangeable Fortran 90 Code".
- !
- ! Declarations:
- ! Modules used:
- ! Imported Type Definitions:
-
- Use rttov_types, Only : &
- & profile_scatt_aux ,&
- & geometry_Type
-
- Use parkind1, Only : jpim ,jprb
-
- Implicit None
-
-!* Subroutine arguments:
- Integer (Kind=jpim), Intent (in) :: nwp_levels ! Number of levels
- Integer (Kind=jpim), Intent (in) :: nprofiles ! Number of profiles
- Integer (Kind=jpim), Intent (in) :: nchannels ! Number of channels*profiles=radiances
- Integer (Kind=jpim), Intent (in) :: lprofiles (nchannels) ! Profile indices
-
- Type (profile_scatt_aux), Intent (in) :: scatt_aux ! Auxiliary profile variables for RTTOV_SCATT
- Type (profile_scatt_aux), Intent (inout) :: scatt_aux_ad ! Auxiliary profile variables for RTTOV_SCATT
- Type (geometry_Type), Intent (in) :: angles (nprofiles) ! Zenith angles
-
- Real (Kind=jprb), Intent (in) , dimension (nchannels,nwp_levels) :: dp ! D+ for boundary conditions
- Real (Kind=jprb), Intent (in) , dimension (nchannels,nwp_levels) :: dm ! D- for boundary conditions
- Real (Kind=jprb), Intent (inout), dimension (nchannels,nwp_levels) :: j_do ! Downward source terms
- Real (Kind=jprb), Intent (inout), dimension (nchannels,nwp_levels) :: j_up ! Upward source terms
- Real (Kind=jprb), Intent (inout), dimension (nchannels,nwp_levels) :: dp_ad ! D+ for boundary conditions
- Real (Kind=jprb), Intent (inout), dimension (nchannels,nwp_levels) :: dm_ad ! D- for boundary conditions
- Real (Kind=jprb), Intent (inout), dimension (nchannels,nwp_levels) :: j_do_ad ! Downward source terms
- Real (Kind=jprb), Intent (inout), dimension (nchannels,nwp_levels) :: j_up_ad ! Upward source terms
-
-!* Local variables
- Real (Kind=jprb), dimension (nwp_levels) :: ja1, jb1, jc1, jd1, aa, bb, cp, cm, ztmp
- Real (Kind=jprb), dimension (nwp_levels) :: ja2, jb2, jc2, jd2
- Real (Kind=jprb), dimension (nwp_levels) :: ja_ad, jb_ad, jc_ad, jd_ad, aa_ad, bb_ad, cp_ad, cm_ad, ztmp_ad
- Integer (Kind=jpim) :: iprof, ichan
-
- !- End of header --------------------------------------------------------
-
-!* Channels * Profiles
- do ichan = 1, nchannels
- iprof = lprofiles (ichan)
-
-!* Reset
- aa_ad (:) = 0.0_JPRB
- bb_ad (:) = 0.0_JPRB
- cp_ad (:) = 0.0_JPRB
- cm_ad (:) = 0.0_JPRB
- ja_ad (:) = 0.0_JPRB
- jb_ad (:) = 0.0_JPRB
- jc_ad (:) = 0.0_JPRB
- jd_ad (:) = 0.0_JPRB
-
-!* Coefficients
- aa (:) = scatt_aux % b0 (iprof,:) - 1.5_JPRB * scatt_aux % asm (ichan,:) * scatt_aux % ssa (ichan,:) &
- & * angles (iprof) % coszen * scatt_aux % b1 (iprof,:) / scatt_aux % h (ichan,:)
- bb (:) = scatt_aux % b1 (iprof,:)
- cp (:) = dp (ichan,:) * scatt_aux % ssa (ichan,:) * (1.0_JPRB - 1.5_JPRB * scatt_aux % asm (ichan,:) &
- & * angles (iprof) % coszen * scatt_aux % lambda (ichan,:) / scatt_aux % h (ichan,:))
- cm (:) = dm (ichan,:) * scatt_aux % ssa (ichan,:) * (1.0_JPRB + 1.5_JPRB * scatt_aux % asm (ichan,:) &
- & * angles (iprof) % coszen * scatt_aux % lambda (ichan,:) / scatt_aux % h (ichan,:))
-
- ja1 (:) = 0.0_JPRB
- jb1 (:) = 0.0_JPRB
- jc1 (:) = 0.0_JPRB
- jd1 (:) = 0.0_JPRB
-
- ja2 (:) = 0.0_JPRB
- jb2 (:) = 0.0_JPRB
- jc2 (:) = 0.0_JPRB
- jd2 (:) = 0.0_JPRB
-
-!* Downward radiance source terms
- where (scatt_aux % ssa (ichan,:) > 1.0E-08_JPRB) ! limit depends on mie tables
-!* FORWARD PART
- ja1 (:) = 1.0_JPRB - scatt_aux % tau (ichan,:)
- jb1 (:) = angles (iprof) % coszen / scatt_aux % ext (ichan,:) * (1.0_JPRB - scatt_aux % tau (ichan,:)) &
- & - scatt_aux % tau (ichan,:) * scatt_aux % dz (iprof,:)
-
- ztmp (:) = exp (scatt_aux % dz (iprof,:) * (scatt_aux % lambda (ichan,:) - scatt_aux % ext (ichan,:) &
- & / angles (iprof) % coszen))
- jc1 (:) = scatt_aux % ext (ichan,:) &
- & / (scatt_aux % lambda (ichan,:) * angles (iprof) % coszen - scatt_aux % ext (ichan,:)) * (ztmp(:) - 1.0_JPRB)
-
- ztmp (:) = exp (scatt_aux % dz (iprof,:) * (scatt_aux % lambda (ichan,:) &
- & + scatt_aux % ext (ichan,:) / angles (iprof) % coszen))
- jd1 (:) = scatt_aux % ext (ichan,:) &
- & / (scatt_aux % lambda (ichan,:) * angles (iprof) % coszen + scatt_aux % ext (ichan,:)) &
- & * (1.0_JPRB - 1.0_JPRB / ztmp(:))
-
- j_do (ichan,:) = ja1 (:) * aa (:) + jb1 (:) * bb (:) + jc1 (:) * cp (:) + jd1 (:) * cm (:)
-
-!* Upward radiance source terms
- ja2 (:) = 1.0_JPRB - scatt_aux % tau (ichan,:)
- jb2 (:) = scatt_aux % dz (iprof,:) - angles (iprof) % coszen / scatt_aux % ext (ichan,:) &
- & * (1.0_JPRB - scatt_aux % tau (ichan,:))
-
- ztmp (:) = exp (scatt_aux % dz (iprof,:) * scatt_aux % lambda (ichan,:))
- jc2 (:) = scatt_aux % ext (ichan,:) / (scatt_aux % ext (ichan,:) + scatt_aux % lambda (ichan,:) &
- & * angles (iprof) % coszen) * (ztmp (:) - scatt_aux % tau (ichan,:))
- jd2 (:) = scatt_aux % ext (ichan,:) / (scatt_aux % ext (ichan,:) - scatt_aux % lambda (ichan,:) &
- & * angles (iprof) % coszen) * (1.0_JPRB / ztmp (:) - scatt_aux % tau (ichan,:))
-
- j_up (ichan,:) = ja2 (:) * aa (:) + jb2 (:) * bb (:) + jc2 (:) * cp (:) + jd2 (:) * cm (:)
-
-!* ADJOINT PART
-!* Upward radiance source terms
- ja_ad (:) = ja_ad (:) + j_up_ad (ichan,:) * aa (:)
- aa_ad (:) = aa_ad (:) + j_up_ad (ichan,:) * ja2 (:)
- jb_ad (:) = jb_ad (:) + j_up_ad (ichan,:) * bb (:)
- bb_ad (:) = bb_ad (:) + j_up_ad (ichan,:) * jb2 (:)
- jc_ad (:) = jc_ad (:) + j_up_ad (ichan,:) * cp (:)
- cp_ad (:) = cp_ad (:) + j_up_ad (ichan,:) * jc2 (:)
- jd_ad (:) = jd_ad (:) + j_up_ad (ichan,:) * cm (:)
- cm_ad (:) = cm_ad (:) + j_up_ad (ichan,:) * jd2 (:)
-
- j_up_ad (ichan,:) = 0.0_JPRB
-
- scatt_aux_ad % ext (ichan,:) = scatt_aux_ad % ext (ichan,:) &
- & + jd_ad (:) / (scatt_aux % ext (ichan,:) - scatt_aux % lambda (ichan,:) * angles (iprof) % coszen) &
- & * (1.0_JPRB/ ztmp (:) - scatt_aux % tau (ichan,:)) &
- & * (1.0_JPRB - scatt_aux % ext (ichan,:) / (scatt_aux % ext (ichan,:) &
- & - scatt_aux % lambda (ichan,:) * angles (iprof) % coszen))
- scatt_aux_ad % lambda (ichan,:) = scatt_aux_ad % lambda (ichan,:) &
- & + jd_ad (:) * angles (iprof) % coszen * scatt_aux % ext (ichan,:) &
- & / (scatt_aux % ext (ichan,:) - scatt_aux % lambda (ichan,:) * angles (iprof) % coszen) &
- & / (scatt_aux % ext (ichan,:) - scatt_aux % lambda (ichan,:) * angles (iprof) % coszen) &
- & * (1.0_JPRB / ztmp (:) - scatt_aux % tau (ichan,:))
- ztmp_ad (:) = -1.0_JPRB * jd_ad (:) / ztmp (:) / ztmp (:) * scatt_aux % ext (ichan,:) &
- & / (scatt_aux % ext (ichan,:) &
- & - scatt_aux % lambda (ichan,:) * angles (iprof) % coszen)
- scatt_aux_ad % tau (ichan,:) = scatt_aux_ad % tau (ichan,:) &
- & - jd_ad (:) * scatt_aux % ext (ichan,:) / (scatt_aux % ext (ichan,:) &
- & - scatt_aux % lambda (ichan,:) * angles (iprof) % coszen)
- jd_ad (:) = 0.0_JPRB
-
- scatt_aux_ad % ext (ichan,:) = scatt_aux_ad % ext (ichan,:) &
- & + jc_ad (:) / (scatt_aux % ext (ichan,:) + scatt_aux % lambda (ichan,:) * angles (iprof) % coszen) &
- & * (ztmp (:) - scatt_aux % tau (ichan,:)) &
- & * (1.0_JPRB - scatt_aux % ext (ichan,:) / (scatt_aux % ext (ichan,:) &
- & + scatt_aux % lambda (ichan,:) * angles (iprof) % coszen))
- scatt_aux_ad % lambda (ichan,:) = scatt_aux_ad % lambda (ichan,:) &
- & - jc_ad (:) * angles (iprof) % coszen * scatt_aux % ext (ichan,:) &
- & / (scatt_aux % ext (ichan,:) + scatt_aux % lambda (ichan,:) * angles (iprof) % coszen) &
- & / (scatt_aux % ext (ichan,:) + scatt_aux % lambda (ichan,:) * angles (iprof) % coszen) &
- & * (ztmp (:) - scatt_aux % tau (ichan,:))
- ztmp_ad (:) = ztmp_ad (:) + jc_ad (:) * scatt_aux % ext (ichan,:) / (scatt_aux % ext (ichan,:) &
- & + scatt_aux % lambda (ichan,:) &
- & * angles (iprof) % coszen)
- scatt_aux_ad % tau (ichan,:) = scatt_aux_ad % tau (ichan,:) &
- & - jc_ad (:) * scatt_aux % ext (ichan,:) / (scatt_aux % ext (ichan,:) &
- & + scatt_aux % lambda (ichan,:) * angles (iprof) % coszen)
- jc_ad (:) = 0.0_JPRB
-
- scatt_aux_ad % dz (iprof,:) = scatt_aux_ad % dz (iprof,:) &
- & + ztmp_ad (:) * scatt_aux % lambda (ichan,:) * ztmp (:)
- scatt_aux_ad % lambda (ichan,:) = scatt_aux_ad % lambda (ichan,:) &
- & + ztmp_ad (:) * scatt_aux % dz (iprof,:) * ztmp (:)
- ztmp_ad (:) = 0.0_JPRB
-
- scatt_aux_ad % dz (iprof,:) = scatt_aux_ad % dz (iprof,:) + jb_ad (:)
- scatt_aux_ad % ext (ichan,:) = scatt_aux_ad % ext (ichan,:) + jb_ad (:) &
- & / scatt_aux % ext (ichan,:) / scatt_aux % ext (ichan,:) &
- & * angles (iprof) % coszen * (1.0_JPRB - scatt_aux % tau (ichan,:))
- scatt_aux_ad % tau (ichan,:) = scatt_aux_ad % tau (ichan,:) + jb_ad (:) &
- & * angles (iprof) % coszen / scatt_aux % ext (ichan,:)
- jb_ad (:) = 0.0_JPRB
-
- scatt_aux_ad % tau (ichan,:) = scatt_aux_ad % tau (ichan,:) - ja_ad (:)
- ja_ad (:) = 0.0_JPRB
-
-!* Downward radiance source terms
- ja_ad (:) = ja_ad (:) + j_do_ad (ichan,:) * aa (:)
- aa_ad (:) = aa_ad (:) + j_do_ad (ichan,:) * ja1 (:)
- jb_ad (:) = jb_ad (:) + j_do_ad (ichan,:) * bb (:)
- bb_ad (:) = bb_ad (:) + j_do_ad (ichan,:) * jb1 (:)
- jc_ad (:) = jc_ad (:) + j_do_ad (ichan,:) * cp (:)
- cp_ad (:) = cp_ad (:) + j_do_ad (ichan,:) * jc1 (:)
- jd_ad (:) = jd_ad (:) + j_do_ad (ichan,:) * cm (:)
- cm_ad (:) = cm_ad (:) + j_do_ad (ichan,:) * jd1 (:)
- j_do_ad (ichan,:) = 0.0_JPRB
-
- ztmp (:) = exp (scatt_aux % dz (iprof,:) * (scatt_aux % lambda (ichan,:) &
- & + scatt_aux % ext (ichan,:) / angles (iprof) % coszen))
-
- scatt_aux_ad % ext (ichan,:) = scatt_aux_ad % ext (ichan,:) &
- & + jd_ad (:) / (scatt_aux % lambda (ichan,:) * angles (iprof) % coszen &
- & + scatt_aux % ext (ichan,:)) * (1.0_JPRB - 1.0_JPRB / ztmp (:)) &
- & * (1.0_JPRB - scatt_aux % ext (ichan,:) / (scatt_aux % lambda (ichan,:) &
- & * angles (iprof) % coszen + scatt_aux % ext (ichan,:)))
- scatt_aux_ad % lambda (ichan,:) = scatt_aux_ad % lambda (ichan,:) &
- & - jd_ad (:) * angles (iprof) % coszen * scatt_aux % ext (ichan,:) * (1.0_JPRB - 1.0_JPRB / ztmp (:)) &
- & / (scatt_aux % lambda (ichan,:) * angles (iprof) % coszen + scatt_aux % ext (ichan,:)) &
- & / (scatt_aux % lambda (ichan,:) * angles (iprof) % coszen + scatt_aux % ext (ichan,:))
- ztmp_ad (:) = jd_ad (:) * scatt_aux % ext (ichan,:) &
- & / (scatt_aux % lambda (ichan,:) * angles (iprof) % coszen + scatt_aux % ext (ichan,:)) / ztmp (:) / ztmp (:)
- jd_ad (:) = 0.0_JPRB
-
- scatt_aux_ad % dz (iprof,:) = scatt_aux_ad % dz (iprof,:) &
- & + ztmp_ad (:) * (scatt_aux % lambda (ichan,:) + scatt_aux % ext (ichan,:) / angles (iprof) % coszen) * ztmp (:)
- scatt_aux_ad % lambda (ichan,:) = scatt_aux_ad % lambda (ichan,:) &
- & + ztmp_ad (:) * scatt_aux % dz (iprof,:) * ztmp (:)
- scatt_aux_ad % ext (ichan,:) = scatt_aux_ad % ext (ichan,:) &
- & + ztmp_ad (:) * scatt_aux % dz (iprof,:) / angles (iprof) % coszen * ztmp (:)
- ztmp_ad (:) = 0.0_JPRB
-
- ztmp(:) = exp (scatt_aux % dz (iprof,:) * (scatt_aux % lambda (ichan,:) &
- & - scatt_aux % ext (ichan,:) / angles (iprof) % coszen))
-
- scatt_aux_ad % ext (ichan,:) = scatt_aux_ad % ext (ichan,:) &
- & + jc_ad (:) / (scatt_aux % lambda (ichan,:) * angles (iprof) % coszen &
- & - scatt_aux % ext (ichan,:)) * (ztmp (:) - 1.0_JPRB) &
- & * (1.0_JPRB + scatt_aux % ext (ichan,:) / (scatt_aux % lambda (ichan,:) &
- & * angles (iprof) % coszen - scatt_aux % ext (ichan,:)) )
- scatt_aux_ad % lambda (ichan,:) = scatt_aux_ad % lambda (ichan,:) &
- & - jc_ad (:) * angles (iprof) % coszen * scatt_aux % ext (ichan,:) * (ztmp(:) - 1.0_JPRB) &
- & / (scatt_aux % lambda (ichan,:) * angles (iprof) % coszen - scatt_aux % ext (ichan,:)) &
- & / (scatt_aux % lambda (ichan,:) * angles (iprof) % coszen - scatt_aux % ext (ichan,:))
- ztmp_ad (:) = jc_ad (:) * scatt_aux % ext (ichan,:) &
- & / (scatt_aux % lambda (ichan,:) * angles (iprof) % coszen - scatt_aux % ext (ichan,:))
- jc_ad (:) = 0.0_JPRB
-
- scatt_aux_ad % dz (iprof,:) = scatt_aux_ad % dz (iprof,:) &
- & + ztmp_ad (:) * (scatt_aux % lambda (ichan,:) - scatt_aux % ext (ichan,:) &
- & / angles (iprof) % coszen) * ztmp (:)
- scatt_aux_ad % lambda(ichan,:) = scatt_aux_ad % lambda( ichan,:) &
- & + ztmp_ad (:) * scatt_aux % dz (iprof,:) * ztmp (:)
- scatt_aux_ad % ext(ichan,:) = scatt_aux_ad % ext(ichan,:) &
- & - ztmp_ad (:) * scatt_aux % dz (iprof,:) / angles (iprof) % coszen * ztmp (:)
- ztmp_ad (:) = 0.0_JPRB
-
- scatt_aux_ad % ext (ichan,:) = scatt_aux_ad % ext (ichan,:) &
- & - jb_ad (:) / scatt_aux % ext (ichan,:) / scatt_aux % ext (ichan,:) &
- & * angles (iprof) % coszen * (1.0_JPRB - scatt_aux % tau (ichan,:))
- scatt_aux_ad % tau(ichan,:) = scatt_aux_ad % tau(ichan,:) &
- & - jb_ad (:) * (angles (iprof) % coszen / scatt_aux % ext (ichan,:) + scatt_aux % dz (iprof,:))
- scatt_aux_ad % dz (iprof,:) = scatt_aux_ad % dz (iprof,:) - jb_ad (:) * scatt_aux % tau (ichan,:)
- jb_ad (:) = 0.0_JPRB
-
- scatt_aux_ad % tau (ichan,:) = scatt_aux_ad % tau (ichan,:) - ja_ad (:)
- ja_ad (:) = 0.0_JPRB
- endwhere
-
- dm_ad (ichan,:) = dm_ad (ichan,:) + cm_ad (:) * scatt_aux % ssa (ichan,:) &
- & * (1.0_JPRB + 1.5_JPRB * scatt_aux % asm (ichan,:) &
- & * angles (iprof) % coszen * scatt_aux % lambda (ichan,:) / scatt_aux % h (ichan,:))
-
- scatt_aux_ad % ssa (ichan,:) = scatt_aux_ad % ssa (ichan,:) + cm_ad (:) * dm (ichan,:) &
- & * (1.0_JPRB + 1.5_JPRB * scatt_aux % asm (ichan,:) &
- & * angles (iprof) % coszen * scatt_aux % lambda (ichan,:) / scatt_aux % h (ichan,:))
- scatt_aux_ad % asm (ichan,:) = scatt_aux_ad % asm (ichan,:) + cm_ad (:) * dm (ichan,:) &
- & * scatt_aux % ssa (ichan,:) * 1.5_JPRB &
- & * angles (iprof) % coszen * scatt_aux % lambda (ichan,:) / scatt_aux % h (ichan,:)
- scatt_aux_ad % lambda (ichan,:) = scatt_aux_ad % lambda (ichan,:) + cm_ad (:) * dm (ichan,:) &
- & * scatt_aux % ssa (ichan,:) &
- & * 1.5_JPRB * scatt_aux % asm (ichan,:) * angles (iprof) % coszen &
- & / scatt_aux % h (ichan,:)
- scatt_aux_ad % h (ichan,:) = scatt_aux_ad % h (ichan,:) - cm_ad (:) * dm (ichan,:) &
- & * scatt_aux % ssa (ichan,:) &
- & * 1.5_JPRB * scatt_aux % asm (ichan,:) * angles (iprof) % coszen &
- & * scatt_aux % lambda (ichan,:) &
- & / scatt_aux % h (ichan,:) / scatt_aux % h (ichan,:)
- cm_ad (:) = 0.0_JPRB
-
- dp_ad (ichan,:) = dp_ad (ichan,:) + cp_ad (:) * scatt_aux % ssa (ichan,:) &
- & * (1.0_JPRB - 1.5_JPRB * scatt_aux % asm(ichan,:) &
- & * angles (iprof) % coszen * scatt_aux % lambda (ichan,:) / scatt_aux % h (ichan,:))
-
- scatt_aux_ad % ssa (ichan,:) = scatt_aux_ad % ssa (ichan,:) + cp_ad (:) * dp (ichan,:) &
- & * (1.0_JPRB - 1.5_JPRB * scatt_aux % asm (ichan,:) &
- & * angles (iprof) % coszen * scatt_aux % lambda (ichan,:) / scatt_aux % h (ichan,:))
- scatt_aux_ad % asm (ichan,:) = scatt_aux_ad % asm (ichan,:) - cp_ad (:) * dp (ichan,:) &
- & * scatt_aux % ssa (ichan,:) * 1.5_JPRB &
- & * angles (iprof) % coszen * scatt_aux % lambda (ichan,:) / scatt_aux % h (ichan,:)
- scatt_aux_ad % lambda (ichan,:) = scatt_aux_ad % lambda (ichan,:) - cp_ad (:) * dp (ichan,:) &
- & * scatt_aux % ssa (ichan,:) * 1.5_JPRB * scatt_aux % asm (ichan,:) &
- & * angles (iprof) % coszen / scatt_aux % h (ichan,:)
- scatt_aux_ad % h (ichan,:) = scatt_aux_ad % h (ichan,:) + cp_ad (:) * dp (ichan,:) &
- & * scatt_aux % ssa (ichan,:) * 1.5_JPRB * scatt_aux % asm (ichan,:) &
- & * angles (iprof) % coszen * scatt_aux % lambda (ichan,:) &
- & / scatt_aux % h (ichan,:) / scatt_aux % h (ichan,:)
- cp_ad (:) = 0.0_JPRB
-
- scatt_aux_ad % b1 (iprof,:) = scatt_aux_ad % b1 (iprof,:) + bb_ad (:)
- bb_ad (:) = 0.0_JPRB
-
- scatt_aux_ad % b0 (iprof,:) = scatt_aux_ad % b0 (iprof,:) + aa_ad (:)
- scatt_aux_ad % asm (ichan,:) = scatt_aux_ad % asm (ichan,:) - aa_ad (:) * 1.5_JPRB * scatt_aux % ssa (ichan,:) &
- & * angles (iprof) % coszen * scatt_aux % b1 (iprof,:) / scatt_aux % h (ichan,:)
- scatt_aux_ad % ssa (ichan,:) = scatt_aux_ad % ssa (ichan,:) - aa_ad (:) * 1.5_JPRB * scatt_aux % asm (ichan,:) &
- & * angles (iprof) % coszen * scatt_aux % b1 (iprof,:) / scatt_aux % h (ichan,:)
- scatt_aux_ad % b1 (iprof,:) = scatt_aux_ad % b1 (iprof,:) - aa_ad (:) * 1.5_JPRB * scatt_aux % asm (ichan,:) &
- & * scatt_aux % ssa (ichan,:) &
- & * angles (iprof) % coszen / scatt_aux % h (ichan,:)
- scatt_aux_ad % h (ichan,:) = scatt_aux_ad % h (ichan,:) + aa_ad (:) * 1.5_JPRB * scatt_aux % asm (ichan,:) &
- & * scatt_aux % ssa (ichan,:) &
- & * angles (iprof) % coszen * scatt_aux % b1 (iprof,:) / scatt_aux % h( ichan,:) &
- & / scatt_aux % h (ichan,:)
- aa_ad(:) = 0._JPRB
- end do
-
-!* Reset
- ja_ad (:) = 0.0_JPRB
- jb_ad (:) = 0.0_JPRB
- jc_ad (:) = 0.0_JPRB
- jd_ad (:) = 0.0_JPRB
-
-End subroutine rttov_integratesource_ad
diff --git a/src/LIB/RTTOV/src/rttov_integratesource_ad.interface b/src/LIB/RTTOV/src/rttov_integratesource_ad.interface
deleted file mode 100644
index abc0e51b1c87d3a6b0766c77affb71db43919fb8..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_integratesource_ad.interface
+++ /dev/null
@@ -1,38 +0,0 @@
-INTERFACE
-Subroutine rttov_integratesource_ad (&
- & nwp_levels,&
- & nchannels,&
- & nprofiles,&
- & lprofiles,&
- & angles,&
- & scatt_aux,&
- & scatt_aux_ad,&
- & dp,&
- & dp_ad,&
- & dm,&
- & dm_ad,&
- & j_do,&
- & j_do_ad,&
- & j_up,&
- & j_up_ad)
- Use rttov_types, Only :&
- & profile_scatt_aux ,&
- & geometry_Type
- Use parkind1, Only : jpim ,jprb
- Integer (Kind=jpim), Intent (in) :: nwp_levels
- Integer (Kind=jpim), Intent (in) :: nprofiles
- Integer (Kind=jpim), Intent (in) :: nchannels
- Integer (Kind=jpim), Intent (in) :: lprofiles (nchannels)
- Type (profile_scatt_aux), Intent (in) :: scatt_aux
- Type (profile_scatt_aux), Intent (inout) :: scatt_aux_ad
- Type (geometry_Type), Intent (in) :: angles (nprofiles)
- Real (Kind=jprb), Intent (in) , dimension (nchannels,nwp_levels) :: dp
- Real (Kind=jprb), Intent (in) , dimension (nchannels,nwp_levels) :: dm
- Real (Kind=jprb), Intent (inout), dimension (nchannels,nwp_levels) :: j_do
- Real (Kind=jprb), Intent (inout), dimension (nchannels,nwp_levels) :: j_up
- Real (Kind=jprb), Intent (inout), dimension (nchannels,nwp_levels) :: dp_ad
- Real (Kind=jprb), Intent (inout), dimension (nchannels,nwp_levels) :: dm_ad
- Real (Kind=jprb), Intent (inout), dimension (nchannels,nwp_levels) :: j_do_ad
- Real (Kind=jprb), Intent (inout), dimension (nchannels,nwp_levels) :: j_up_ad
-End subroutine rttov_integratesource_ad
-END INTERFACE
diff --git a/src/LIB/RTTOV/src/rttov_integratesource_k.F90 b/src/LIB/RTTOV/src/rttov_integratesource_k.F90
deleted file mode 100644
index 37f4969b03ad7362985923225b0242c6a46b0d59..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_integratesource_k.F90
+++ /dev/null
@@ -1,367 +0,0 @@
-!
-Subroutine rttov_integratesource_k (&
- & nwp_levels, &! in
- & nchannels, &! in
- & nprofiles, &! in
- & lprofiles, &! in
- & angles, &! in
- & scatt_aux, &! in
- & scatt_aux_k, &! inout
- & dp, &! in
- & dp_k, &! inout
- & dm, &! in
- & dm_k, &! inout
- & j_do, &! inout
- & j_do_k, &! inout
- & j_up, &! inout
- & j_up_k) ! inout
-
- ! Description:
- ! integrate source in Eddington
- !
- ! Copyright:
- ! This software was developed within the context of
- ! the EUMETSAT Satellite Application Facility on
- ! Numerical Weather Prediction (NWP SAF), under the
- ! Cooperation Agreement dated 25 November 1998, between
- ! EUMETSAT and the Met Office, UK, by one or more partners
- ! within the NWP SAF. The partners in the NWP SAF are
- ! the Met Office, ECMWF, KNMI and MeteoFrance.
- !
- ! Copyright 2002, EUMETSAT, All Rights Reserved.
- !
- ! Method:
- ! - Bauer, P., 2002: Microwave radiative transfer modeling in clouds and precipitation.
- ! Part I: Model description.
- ! NWP SAF Report No. NWPSAF-EC-TR-005, 27 pp.
- ! - Chevallier, F., and P. Bauer, 2003:
- ! Model rain and clouds over oceans: comparison with SSM/I observations.
- ! Mon. Wea. Rev., 131, 1240-1255.
- ! - Moreau, E., P. Bauer and F. Chevallier, 2002: Microwave radiative transfer modeling in clouds and precipitation.
- ! Part II: Model evaluation.
- ! NWP SAF Report No. NWPSAF-EC-TR-006, 27 pp.
- !
- ! Current Code Owner: SAF NWP
- !
- ! History:
- ! Version Date Comment
- ! ------- ---- -------
- ! 1.0 09/2002 Initial version (E. Moreau)
- ! 1.1 05/2003 RTTOV7.3 compatible (F. Chevallier)
- ! 1.2 03/2004 Added polarimetry (R. Saunders)
- ! 1.3 08/2004 Polarimetry fixes (U. O'Keefe)
- ! 1.4 11/2004 Clean-up (P. Bauer)
- ! 1.5 02/2005 K-code (A. Collard)
- !
- ! Code Description:
- ! Language: Fortran 90.
- ! Software Standards: "European Standards for Writing and
- ! Documenting Exchangeable Fortran 90 Code".
- !
- ! Declarations:
- ! Modules used:
- ! Imported Type Definitions:
-
- Use rttov_types, Only : &
- & profile_scatt_aux ,&
- & geometry_Type
-
- Use parkind1, Only : jpim ,jprb
-
- Implicit None
-
-!* Subroutine arguments:
- Integer (Kind=jpim), Intent (in) :: nwp_levels ! Number of levels
- Integer (Kind=jpim), Intent (in) :: nprofiles ! Number of profiles
- Integer (Kind=jpim), Intent (in) :: nchannels ! Number of channels*profiles=radiances
- Integer (Kind=jpim), Intent (in) :: lprofiles (nchannels) ! Profile indices
-
- Type (profile_scatt_aux), Intent (in) :: scatt_aux ! Auxiliary profile variables for RTTOV_SCATT
- Type (profile_scatt_aux), Intent (inout) :: scatt_aux_k ! Auxiliary profile variables for RTTOV_SCATT
- Type (geometry_Type), Intent (in) :: angles (nprofiles) ! Zenith angles
-
- Real (Kind=jprb), Intent (in) , dimension (nchannels,nwp_levels) :: dp ! D+ for boundary conditions
- Real (Kind=jprb), Intent (in) , dimension (nchannels,nwp_levels) :: dm ! D- for boundary conditions
- Real (Kind=jprb), Intent (inout), dimension (nchannels,nwp_levels) :: j_do ! Downward source terms
- Real (Kind=jprb), Intent (inout), dimension (nchannels,nwp_levels) :: j_up ! Upward source terms
- Real (Kind=jprb), Intent (inout), dimension (nchannels,nwp_levels) :: dp_k ! D+ for boundary conditions
- Real (Kind=jprb), Intent (inout), dimension (nchannels,nwp_levels) :: dm_k ! D- for boundary conditions
- Real (Kind=jprb), Intent (inout), dimension (nchannels,nwp_levels) :: j_do_k ! Downward source terms
- Real (Kind=jprb), Intent (inout), dimension (nchannels,nwp_levels) :: j_up_k ! Upward source terms
-
-!* Local variables
- Real (Kind=jprb), dimension (nwp_levels) :: ja1, jb1, jc1, jd1, aa, bb, cp, cm, ztmp
- Real (Kind=jprb), dimension (nwp_levels) :: ja2, jb2, jc2, jd2
- Real (Kind=jprb), dimension (nwp_levels) :: ja_k, jb_k, jc_k, jd_k, aa_k, bb_k, cp_k, cm_k, ztmp_k
- Integer (Kind=jpim) :: iprof, ichan
-
- !- End of header --------------------------------------------------------
-
-!* Channels * Profiles
- do ichan = 1, nchannels
- iprof = lprofiles (ichan)
-
-!* Reset
- aa_k (:) = 0.0_JPRB
- bb_k (:) = 0.0_JPRB
- cp_k (:) = 0.0_JPRB
- cm_k (:) = 0.0_JPRB
- ja_k (:) = 0.0_JPRB
- jb_k (:) = 0.0_JPRB
- jc_k (:) = 0.0_JPRB
- jd_k (:) = 0.0_JPRB
-
-!* Coefficients
- aa (:) = scatt_aux % b0 (iprof,:) - 1.5_JPRB * scatt_aux % asm (ichan,:) * scatt_aux % ssa (ichan,:) &
- & * angles (iprof) % coszen * scatt_aux % b1 (iprof,:) / scatt_aux % h (ichan,:)
- bb (:) = scatt_aux % b1 (iprof,:)
- cp (:) = dp (ichan,:) * scatt_aux % ssa (ichan,:) * (1.0_JPRB - 1.5_JPRB * scatt_aux % asm (ichan,:) &
- & * angles (iprof) % coszen * scatt_aux % lambda (ichan,:) / scatt_aux % h (ichan,:))
- cm (:) = dm (ichan,:) * scatt_aux % ssa (ichan,:) * (1.0_JPRB + 1.5_JPRB * scatt_aux % asm (ichan,:) &
- & * angles (iprof) % coszen * scatt_aux % lambda (ichan,:) / scatt_aux % h (ichan,:))
-
- ja1 (:) = 0.0_JPRB
- jb1 (:) = 0.0_JPRB
- jc1 (:) = 0.0_JPRB
- jd1 (:) = 0.0_JPRB
-
- ja2 (:) = 0.0_JPRB
- jb2 (:) = 0.0_JPRB
- jc2 (:) = 0.0_JPRB
- jd2 (:) = 0.0_JPRB
-
-!* Downward radiance source terms
- where (scatt_aux % ssa (ichan,:) > 1.0E-08_JPRB) ! limit depends on mie tables
-!* FORWARD PART
- ja1 (:) = 1.0_JPRB - scatt_aux % tau (ichan,:)
- jb1 (:) = angles (iprof) % coszen / scatt_aux % ext (ichan,:) * (1.0_JPRB - scatt_aux % tau (ichan,:)) &
- & - scatt_aux % tau (ichan,:) * scatt_aux % dz (iprof,:)
-
- ztmp (:) = exp (scatt_aux % dz (iprof,:) * (scatt_aux % lambda (ichan,:) &
- & - scatt_aux % ext (ichan,:) / angles (iprof) % coszen))
- jc1 (:) = scatt_aux % ext (ichan,:) &
- & / (scatt_aux % lambda (ichan,:) * angles (iprof) % coszen - scatt_aux % ext (ichan,:)) * (ztmp(:) - 1.0_JPRB)
-
- ztmp (:) = exp (scatt_aux % dz (iprof,:) * (scatt_aux % lambda (ichan,:) &
- & + scatt_aux % ext (ichan,:) / angles (iprof) % coszen))
- jd1 (:) = scatt_aux % ext (ichan,:) &
- & / (scatt_aux % lambda (ichan,:) * angles (iprof) % coszen &
- & + scatt_aux % ext (ichan,:)) * (1.0_JPRB - 1.0_JPRB / ztmp(:))
-
- j_do (ichan,:) = ja1 (:) * aa (:) + jb1 (:) * bb (:) + jc1 (:) * cp (:) + jd1 (:) * cm (:)
-
-!* Upward radiance source terms
- ja2 (:) = 1.0_JPRB - scatt_aux % tau (ichan,:)
- jb2 (:) = scatt_aux % dz (iprof,:) - angles (iprof) % coszen / scatt_aux % ext (ichan,:) &
- & * (1.0_JPRB - scatt_aux % tau (ichan,:))
-
- ztmp (:) = exp (scatt_aux % dz (iprof,:) * scatt_aux % lambda (ichan,:))
- jc2 (:) = scatt_aux % ext (ichan,:) / (scatt_aux % ext (ichan,:) + scatt_aux % lambda (ichan,:) &
- & * angles (iprof) % coszen) * (ztmp (:) - scatt_aux % tau (ichan,:))
- jd2 (:) = scatt_aux % ext (ichan,:) / (scatt_aux % ext (ichan,:) - scatt_aux % lambda (ichan,:) &
- & * angles (iprof) % coszen) * (1.0_JPRB / ztmp (:) - scatt_aux % tau (ichan,:))
-
- j_up (ichan,:) = ja2 (:) * aa (:) + jb2 (:) * bb (:) + jc2 (:) * cp (:) + jd2 (:) * cm (:)
-
-!* ADJOINT PART
-!* Upward radiance source terms
- ja_k (:) = ja_k (:) + j_up_k (ichan,:) * aa (:)
- aa_k (:) = aa_k (:) + j_up_k (ichan,:) * ja2 (:)
- jb_k (:) = jb_k (:) + j_up_k (ichan,:) * bb (:)
- bb_k (:) = bb_k (:) + j_up_k (ichan,:) * jb2 (:)
- jc_k (:) = jc_k (:) + j_up_k (ichan,:) * cp (:)
- cp_k (:) = cp_k (:) + j_up_k (ichan,:) * jc2 (:)
- jd_k (:) = jd_k (:) + j_up_k (ichan,:) * cm (:)
- cm_k (:) = cm_k (:) + j_up_k (ichan,:) * jd2 (:)
-
- j_up_k (ichan,:) = 0.0_JPRB
-
- scatt_aux_k % ext (ichan,:) = scatt_aux_k % ext (ichan,:) &
- & + jd_k (:) / (scatt_aux % ext (ichan,:) - scatt_aux % lambda (ichan,:) * angles (iprof) % coszen) &
- & * (1.0_JPRB/ ztmp (:) - scatt_aux % tau (ichan,:)) &
- & * (1.0_JPRB - scatt_aux % ext (ichan,:) / (scatt_aux % ext (ichan,:) &
- & - scatt_aux % lambda (ichan,:) * angles (iprof) % coszen))
- scatt_aux_k % lambda (ichan,:) = scatt_aux_k % lambda (ichan,:) &
- & + jd_k (:) * angles (iprof) % coszen * scatt_aux % ext (ichan,:) &
- & / (scatt_aux % ext (ichan,:) - scatt_aux % lambda (ichan,:) * angles (iprof) % coszen) &
- & / (scatt_aux % ext (ichan,:) - scatt_aux % lambda (ichan,:) * angles (iprof) % coszen) &
- & * (1.0_JPRB / ztmp (:) - scatt_aux % tau (ichan,:))
- ztmp_k (:) = -1.0_JPRB * jd_k (:) / ztmp (:) / ztmp (:) * scatt_aux % ext (ichan,:) / (scatt_aux % ext (ichan,:) &
- & - scatt_aux % lambda (ichan,:) * angles (iprof) % coszen)
- scatt_aux_k % tau (ichan,:) = scatt_aux_k % tau (ichan,:) &
- & - jd_k (:) * scatt_aux % ext (ichan,:) / (scatt_aux % ext (ichan,:) &
- & - scatt_aux % lambda (ichan,:) * angles (iprof) % coszen)
- jd_k (:) = 0.0_JPRB
-
- scatt_aux_k % ext (ichan,:) = scatt_aux_k % ext (ichan,:) &
- & + jc_k (:) / (scatt_aux % ext (ichan,:) + scatt_aux % lambda (ichan,:) * angles (iprof) % coszen) &
- & * (ztmp (:) - scatt_aux % tau (ichan,:)) &
- & * (1.0_JPRB - scatt_aux % ext (ichan,:) / (scatt_aux % ext (ichan,:) &
- & + scatt_aux % lambda (ichan,:) * angles (iprof) % coszen))
- scatt_aux_k % lambda (ichan,:) = scatt_aux_k % lambda (ichan,:) &
- & - jc_k (:) * angles (iprof) % coszen * scatt_aux % ext (ichan,:) &
- & / (scatt_aux % ext (ichan,:) + scatt_aux % lambda (ichan,:) * angles (iprof) % coszen) &
- & / (scatt_aux % ext (ichan,:) + scatt_aux % lambda (ichan,:) * angles (iprof) % coszen) &
- & * (ztmp (:) - scatt_aux % tau (ichan,:))
- ztmp_k (:) = ztmp_k (:) + jc_k (:) * scatt_aux % ext (ichan,:) / (scatt_aux % ext (ichan,:) &
- & + scatt_aux % lambda (ichan,:) &
- & * angles (iprof) % coszen)
- scatt_aux_k % tau (ichan,:) = scatt_aux_k % tau (ichan,:) &
- & - jc_k (:) * scatt_aux % ext (ichan,:) / (scatt_aux % ext (ichan,:) &
- & + scatt_aux % lambda (ichan,:) * angles (iprof) % coszen)
- jc_k (:) = 0.0_JPRB
-
- scatt_aux_k % dz (ichan,:) = scatt_aux_k % dz (ichan,:) + ztmp_k (:) * scatt_aux % lambda (ichan,:) * ztmp (:)
- scatt_aux_k % lambda (ichan,:) = scatt_aux_k % lambda (ichan,:) + ztmp_k (:) * scatt_aux % dz (iprof,:) * ztmp (:)
- ztmp_k (:) = 0.0_JPRB
-
- scatt_aux_k % dz (ichan,:) = scatt_aux_k % dz (ichan,:) + jb_k (:)
- scatt_aux_k % ext (ichan,:) = scatt_aux_k % ext (ichan,:) + jb_k (:) / scatt_aux % ext (ichan,:) &
- & / scatt_aux % ext (ichan,:) &
- & * angles (iprof) % coszen * (1.0_JPRB - scatt_aux % tau (ichan,:))
- scatt_aux_k % tau (ichan,:) = scatt_aux_k % tau (ichan,:) + jb_k (:) * angles (iprof) % coszen &
- & / scatt_aux % ext (ichan,:)
- jb_k (:) = 0.0_JPRB
-
- scatt_aux_k % tau (ichan,:) = scatt_aux_k % tau (ichan,:) - ja_k (:)
- ja_k (:) = 0.0_JPRB
-
-!* Downward radiance source terms
- ja_k (:) = ja_k (:) + j_do_k (ichan,:) * aa (:)
- aa_k (:) = aa_k (:) + j_do_k (ichan,:) * ja1 (:)
- jb_k (:) = jb_k (:) + j_do_k (ichan,:) * bb (:)
- bb_k (:) = bb_k (:) + j_do_k (ichan,:) * jb1 (:)
- jc_k (:) = jc_k (:) + j_do_k (ichan,:) * cp (:)
- cp_k (:) = cp_k (:) + j_do_k (ichan,:) * jc1 (:)
- jd_k (:) = jd_k (:) + j_do_k (ichan,:) * cm (:)
- cm_k (:) = cm_k (:) + j_do_k (ichan,:) * jd1 (:)
- j_do_k (ichan,:) = 0.0_JPRB
-
- ztmp (:) = exp (scatt_aux % dz (iprof,:) * (scatt_aux % lambda (ichan,:) &
- & + scatt_aux % ext (ichan,:) / angles (iprof) % coszen))
-
- scatt_aux_k % ext (ichan,:) = scatt_aux_k % ext (ichan,:) &
- & + jd_k (:) / (scatt_aux % lambda (ichan,:) * angles (iprof) % coszen &
- & + scatt_aux % ext (ichan,:)) * (1.0_JPRB - 1.0_JPRB / ztmp (:)) &
- & * (1.0_JPRB - scatt_aux % ext (ichan,:) / (scatt_aux % lambda (ichan,:) &
- & * angles (iprof) % coszen + scatt_aux % ext (ichan,:)))
- scatt_aux_k % lambda (ichan,:) = scatt_aux_k % lambda (ichan,:) &
- & - jd_k (:) * angles (iprof) % coszen * scatt_aux % ext (ichan,:) * (1.0_JPRB - 1.0_JPRB / ztmp (:)) &
- & / (scatt_aux % lambda (ichan,:) * angles (iprof) % coszen + scatt_aux % ext (ichan,:)) &
- & / (scatt_aux % lambda (ichan,:) * angles (iprof) % coszen + scatt_aux % ext (ichan,:))
- ztmp_k (:) = jd_k (:) * scatt_aux % ext (ichan,:) &
- & / (scatt_aux % lambda (ichan,:) * angles (iprof) % coszen + scatt_aux % ext (ichan,:)) / ztmp (:) / ztmp (:)
- jd_k (:) = 0.0_JPRB
-
- scatt_aux_k % dz (ichan,:) = scatt_aux_k % dz (ichan,:) &
- & + ztmp_k (:) * (scatt_aux % lambda (ichan,:) + scatt_aux % ext (ichan,:) / angles (iprof) % coszen) * ztmp (:)
- scatt_aux_k % lambda (ichan,:) = scatt_aux_k % lambda (ichan,:) &
- & + ztmp_k (:) * scatt_aux % dz (iprof,:) * ztmp (:)
- scatt_aux_k % ext (ichan,:) = scatt_aux_k % ext (ichan,:) &
- & + ztmp_k (:) * scatt_aux % dz (iprof,:) / angles (iprof) % coszen * ztmp (:)
- ztmp_k (:) = 0.0_JPRB
-
- ztmp(:) = exp (scatt_aux % dz (iprof,:) * (scatt_aux % lambda (ichan,:) &
- & - scatt_aux % ext (ichan,:) / angles (iprof) % coszen))
-
- scatt_aux_k % ext (ichan,:) = scatt_aux_k % ext (ichan,:) &
- & + jc_k (:) / (scatt_aux % lambda (ichan,:) * angles (iprof) % coszen &
- & - scatt_aux % ext (ichan,:)) * (ztmp (:) - 1.0_JPRB) &
- & * (1.0_JPRB + scatt_aux % ext (ichan,:) / (scatt_aux % lambda (ichan,:) &
- & * angles (iprof) % coszen - scatt_aux % ext (ichan,:)) )
- scatt_aux_k % lambda (ichan,:) = scatt_aux_k % lambda (ichan,:) &
- & - jc_k (:) * angles (iprof) % coszen * scatt_aux % ext (ichan,:) * (ztmp(:) - 1.0_JPRB) &
- & / (scatt_aux % lambda (ichan,:) * angles (iprof) % coszen - scatt_aux % ext (ichan,:)) &
- & / (scatt_aux % lambda (ichan,:) * angles (iprof) % coszen - scatt_aux % ext (ichan,:))
- ztmp_k (:) = jc_k (:) * scatt_aux % ext (ichan,:) &
- & / (scatt_aux % lambda (ichan,:) * angles (iprof) % coszen - scatt_aux % ext (ichan,:))
- jc_k (:) = 0.0_JPRB
-
- scatt_aux_k % dz (ichan,:) = scatt_aux_k % dz (ichan,:) &
- & + ztmp_k (:) * (scatt_aux % lambda (ichan,:) - scatt_aux % ext (ichan,:) &
- & / angles (iprof) % coszen) * ztmp (:)
- scatt_aux_k % lambda(ichan,:) = scatt_aux_k % lambda( ichan,:) &
- & + ztmp_k (:) * scatt_aux % dz (iprof,:) * ztmp (:)
- scatt_aux_k % ext(ichan,:) = scatt_aux_k % ext(ichan,:) &
- & - ztmp_k (:) * scatt_aux % dz (iprof,:) / angles (iprof) % coszen * ztmp (:)
- ztmp_k (:) = 0.0_JPRB
-
- scatt_aux_k % ext (ichan,:) = scatt_aux_k % ext (ichan,:) &
- & - jb_k (:) / scatt_aux % ext (ichan,:) / scatt_aux % ext (ichan,:) &
- & * angles (iprof) % coszen * (1.0_JPRB - scatt_aux % tau (ichan,:))
- scatt_aux_k % tau(ichan,:) = scatt_aux_k % tau(ichan,:) &
- & - jb_k (:) * (angles (iprof) % coszen / scatt_aux % ext (ichan,:) + scatt_aux % dz (iprof,:))
- scatt_aux_k % dz (ichan,:) = scatt_aux_k % dz (ichan,:) - jb_k (:) * scatt_aux % tau (ichan,:)
- jb_k (:) = 0.0_JPRB
-
- scatt_aux_k % tau (ichan,:) = scatt_aux_k % tau (ichan,:) - ja_k (:)
- ja_k (:) = 0.0_JPRB
- endwhere
-
- dm_k (ichan,:) = dm_k (ichan,:) + cm_k (:) * scatt_aux % ssa (ichan,:) * (1.0_JPRB + 1.5_JPRB * scatt_aux % asm (ichan,:) &
- & * angles (iprof) % coszen * scatt_aux % lambda (ichan,:) / scatt_aux % h (ichan,:))
-
- scatt_aux_k % ssa (ichan,:) = scatt_aux_k % ssa (ichan,:) + cm_k (:) * dm (ichan,:) &
- & * (1.0_JPRB + 1.5_JPRB * scatt_aux % asm (ichan,:) &
- & * angles (iprof) % coszen * scatt_aux % lambda (ichan,:) &
- & / scatt_aux % h (ichan,:))
- scatt_aux_k % asm (ichan,:) = scatt_aux_k % asm (ichan,:) + cm_k (:) * dm (ichan,:) &
- & * scatt_aux % ssa (ichan,:) * 1.5_JPRB &
- & * angles (iprof) % coszen * scatt_aux % lambda (ichan,:) &
- &/ scatt_aux % h (ichan,:)
- scatt_aux_k % lambda (ichan,:) = scatt_aux_k % lambda (ichan,:) + cm_k (:) * dm (ichan,:) &
- & * scatt_aux % ssa (ichan,:) &
- & * 1.5_JPRB * scatt_aux % asm (ichan,:) * angles (iprof) % coszen &
- &/ scatt_aux % h (ichan,:)
- scatt_aux_k % h (ichan,:) = scatt_aux_k % h (ichan,:) - cm_k (:) * dm (ichan,:) &
- & * scatt_aux % ssa (ichan,:) &
- & * 1.5_JPRB * scatt_aux % asm (ichan,:) * angles (iprof) % coszen &
- & * scatt_aux % lambda (ichan,:) &
- & / scatt_aux % h (ichan,:) / scatt_aux % h (ichan,:)
- cm_k (:) = 0.0_JPRB
-
- dp_k (ichan,:) = dp_k (ichan,:) + cp_k (:) * scatt_aux % ssa (ichan,:) * (1.0_JPRB - 1.5_JPRB * scatt_aux % asm(ichan,:) &
- & * angles (iprof) % coszen * scatt_aux % lambda (ichan,:) / scatt_aux % h (ichan,:))
-
- scatt_aux_k % ssa (ichan,:) = scatt_aux_k % ssa (ichan,:) + cp_k (:) * dp (ichan,:) &
- & * (1.0_JPRB - 1.5_JPRB * scatt_aux % asm (ichan,:) &
- & * angles (iprof) % coszen * scatt_aux % lambda (ichan,:) &
- & / scatt_aux % h (ichan,:))
- scatt_aux_k % asm (ichan,:) = scatt_aux_k % asm (ichan,:) - cp_k (:) * dp (ichan,:) &
- & * scatt_aux % ssa (ichan,:) * 1.5_JPRB &
- & * angles (iprof) % coszen * scatt_aux % lambda (ichan,:) &
- & / scatt_aux % h (ichan,:)
- scatt_aux_k % lambda (ichan,:) = scatt_aux_k % lambda (ichan,:) - cp_k (:) * dp (ichan,:) &
- & * scatt_aux % ssa (ichan,:) * 1.5_JPRB * scatt_aux % asm (ichan,:) &
- & * angles (iprof) % coszen / scatt_aux % h (ichan,:)
- scatt_aux_k % h (ichan,:) = scatt_aux_k % h (ichan,:) + cp_k (:) * dp (ichan,:) &
- & * scatt_aux % ssa (ichan,:) * 1.5_JPRB * scatt_aux % asm (ichan,:) &
- & * angles (iprof) % coszen * scatt_aux % lambda (ichan,:) &
- & / scatt_aux % h (ichan,:) / scatt_aux % h (ichan,:)
- cp_k (:) = 0.0_JPRB
-
- scatt_aux_k % b1 (ichan,:) = scatt_aux_k % b1 (ichan,:) + bb_k (:)
- bb_k (:) = 0.0_JPRB
-
- scatt_aux_k % b0 (ichan,:) = scatt_aux_k % b0 (ichan,:) + aa_k (:)
- scatt_aux_k % asm (ichan,:) = scatt_aux_k % asm (ichan,:) - aa_k (:) * 1.5_JPRB * scatt_aux % ssa (ichan,:) &
- & * angles (iprof) % coszen * scatt_aux % b1 (iprof,:) / scatt_aux % h (ichan,:)
- scatt_aux_k % ssa (ichan,:) = scatt_aux_k % ssa (ichan,:) - aa_k (:) * 1.5_JPRB * scatt_aux % asm (ichan,:) &
- & * angles (iprof) % coszen * scatt_aux % b1 (iprof,:) / scatt_aux % h (ichan,:)
- scatt_aux_k % b1 (ichan,:) = scatt_aux_k % b1 (ichan,:) - aa_k (:) * 1.5_JPRB * scatt_aux % asm (ichan,:) &
- & * scatt_aux % ssa (ichan,:) &
- & * angles (iprof) % coszen / scatt_aux % h (ichan,:)
- scatt_aux_k % h (ichan,:) = scatt_aux_k % h (ichan,:) + aa_k (:) * 1.5_JPRB * scatt_aux % asm (ichan,:) &
- & * scatt_aux % ssa (ichan,:) &
- & * angles (iprof) % coszen * scatt_aux % b1 (iprof,:) / scatt_aux % h( ichan,:) &
- & / scatt_aux % h (ichan,:)
- aa_k(:) = 0._JPRB
- end do
-
-!* Reset
- ja_k (:) = 0.0_JPRB
- jb_k (:) = 0.0_JPRB
- jc_k (:) = 0.0_JPRB
- jd_k (:) = 0.0_JPRB
-
-End subroutine rttov_integratesource_k
diff --git a/src/LIB/RTTOV/src/rttov_integratesource_k.interface b/src/LIB/RTTOV/src/rttov_integratesource_k.interface
deleted file mode 100644
index 19987a23e9c16daa2290d79a43f54cdbd095c615..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_integratesource_k.interface
+++ /dev/null
@@ -1,38 +0,0 @@
-INTERFACE
-Subroutine rttov_integratesource_k (&
- & nwp_levels,&
- & nchannels,&
- & nprofiles,&
- & lprofiles,&
- & angles,&
- & scatt_aux,&
- & scatt_aux_k,&
- & dp,&
- & dp_k,&
- & dm,&
- & dm_k,&
- & j_do,&
- & j_do_k,&
- & j_up,&
- & j_up_k)
- Use rttov_types, Only :&
- & profile_scatt_aux ,&
- & geometry_Type
- Use parkind1, Only : jpim ,jprb
- Integer (Kind=jpim), Intent (in) :: nwp_levels
- Integer (Kind=jpim), Intent (in) :: nprofiles
- Integer (Kind=jpim), Intent (in) :: nchannels
- Integer (Kind=jpim), Intent (in) :: lprofiles (nchannels)
- Type (profile_scatt_aux), Intent (in) :: scatt_aux
- Type (profile_scatt_aux), Intent (inout) :: scatt_aux_k
- Type (geometry_Type), Intent (in) :: angles (nprofiles)
- Real (Kind=jprb), Intent (in) , dimension (nchannels,nwp_levels) :: dp
- Real (Kind=jprb), Intent (in) , dimension (nchannels,nwp_levels) :: dm
- Real (Kind=jprb), Intent (inout), dimension (nchannels,nwp_levels) :: j_do
- Real (Kind=jprb), Intent (inout), dimension (nchannels,nwp_levels) :: j_up
- Real (Kind=jprb), Intent (inout), dimension (nchannels,nwp_levels) :: dp_k
- Real (Kind=jprb), Intent (inout), dimension (nchannels,nwp_levels) :: dm_k
- Real (Kind=jprb), Intent (inout), dimension (nchannels,nwp_levels) :: j_do_k
- Real (Kind=jprb), Intent (inout), dimension (nchannels,nwp_levels) :: j_up_k
-End subroutine rttov_integratesource_k
-END INTERFACE
diff --git a/src/LIB/RTTOV/src/rttov_integratesource_tl.F90 b/src/LIB/RTTOV/src/rttov_integratesource_tl.F90
deleted file mode 100644
index 86dfe5b11ebc691aeaade0995092f97d668acee0..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_integratesource_tl.F90
+++ /dev/null
@@ -1,269 +0,0 @@
-!
-Subroutine rttov_integratesource_tl (&
- & nwp_levels, &! in
- & nchannels, &! in
- & nprofiles, &! in
- & lprofiles, &! in
- & angles, &! in
- & scatt_aux, &! in
- & scatt_aux_tl, &! in
- & dp, &! in
- & dp_tl, &! in
- & dm, &! in
- & dm_tl, &! in
- & j_do, &! inout
- & j_do_tl, &! inout
- & j_up, &! inout
- & j_up_tl) ! inout
-
- ! Description:
- ! integrate source in Eddington
- !
- ! Copyright:
- ! This software was developed within the context of
- ! the EUMETSAT Satellite Application Facility on
- ! Numerical Weather Prediction (NWP SAF), under the
- ! Cooperation Agreement dated 25 November 1998, between
- ! EUMETSAT and the Met Office, UK, by one or more partners
- ! within the NWP SAF. The partners in the NWP SAF are
- ! the Met Office, ECMWF, KNMI and MeteoFrance.
- !
- ! Copyright 2002, EUMETSAT, All Rights Reserved.
- !
- ! Method:
- ! - Bauer, P., 2002: Microwave radiative transfer modeling in clouds and precipitation.
- ! Part I: Model description.
- ! NWP SAF Report No. NWPSAF-EC-TR-005, 27 pp.
- ! - Chevallier, F., and P. Bauer, 2003:
- ! Model rain and clouds over oceans: comparison with SSM/I observations.
- ! Mon. Wea. Rev., 131, 1240-1255.
- ! - Moreau, E., P. Bauer and F. Chevallier, 2002: Microwave radiative transfer modeling in clouds and precipitation.
- ! Part II: Model evaluation.
- ! NWP SAF Report No. NWPSAF-EC-TR-006, 27 pp.
- !
- ! Current Code Owner: SAF NWP
- !
- ! History:
- ! Version Date Comment
- ! ------- ---- -------
- ! 1.0 09/2002 Initial version (E. Moreau)
- ! 1.1 05/2003 RTTOV7.3 compatible (F. Chevallier)
- ! 1.2 03/2004 Added polarimetry (R. Saunders)
- ! 1.3 08/2004 Polarimetry fixes (U. O'Keefe)
- ! 1.4 11/2004 Clean-up (P. Bauer)
- !
- ! Code Description:
- ! Language: Fortran 90.
- ! Software Standards: "European Standards for Writing and
- ! Documenting Exchangeable Fortran 90 Code".
- !
- ! Declarations:
- ! Modules used:
- ! Imported Type Definitions:
-
- Use rttov_types, Only : &
- & profile_scatt_aux ,&
- & geometry_Type
-
- Use parkind1, Only : jpim ,jprb
-
- Implicit None
-
-!* Subroutine arguments:
- Integer (Kind=jpim), Intent (in) :: nwp_levels ! Number of levels
- Integer (Kind=jpim), Intent (in) :: nprofiles ! Number of profiles
- Integer (Kind=jpim), Intent (in) :: nchannels ! Number of channels*profiles=radiances
- Integer (Kind=jpim), Intent (in) :: lprofiles (nchannels) ! Profile indices
-
- Type (profile_scatt_aux), Intent(in) :: scatt_aux ! Auxiliary profile variables for RTTOV_SCATT
- Type (profile_scatt_aux), Intent(in) :: scatt_aux_tl ! Auxiliary profile variables for RTTOV_SCATT
- Type (geometry_Type), Intent(in) :: angles (nprofiles) ! Zenith angles
-
- Real (Kind=jprb), Intent (in) , dimension (nchannels,nwp_levels) :: dp ! D+ for boundary conditions
- Real (Kind=jprb), Intent (in) , dimension (nchannels,nwp_levels) :: dm ! D- for boundary conditions
- Real (Kind=jprb), Intent (inout), dimension (nchannels,nwp_levels) :: j_do ! Downward source terms
- Real (Kind=jprb), Intent (inout), dimension (nchannels,nwp_levels) :: j_up ! Upward source terms
- Real (Kind=jprb), Intent (in) , dimension (nchannels,nwp_levels) :: dp_tl ! D+ for boundary conditions
- Real (Kind=jprb), Intent (in) , dimension (nchannels,nwp_levels) :: dm_tl ! D- for boundary conditions
- Real (Kind=jprb), Intent (inout), dimension (nchannels,nwp_levels) :: j_do_tl ! Downward source terms
- Real (Kind=jprb), Intent (inout), dimension (nchannels,nwp_levels) :: j_up_tl ! Upward source terms
-
-!* Local variables
- Real (Kind=jprb), dimension (nwp_levels) :: ja , jb , jc , jd , aa , bb , cp , cm , ztmp
- Real (Kind=jprb), dimension (nwp_levels) :: ja_tl, jb_tl, jc_tl, jd_tl, aa_tl, bb_tl, cp_tl, cm_tl, ztmp_tl
- Integer (Kind=jpim) :: iprof, ichan
-
- !- End of header --------------------------------------------------------
-
-!* Channels * Profiles
- do ichan = 1, nchannels
- iprof = lprofiles (ichan)
-
-!* Reset
- ja_tl (:) = 0.0_JPRB
- jb_tl (:) = 0.0_JPRB
- jc_tl (:) = 0.0_JPRB
- jd_tl (:) = 0.0_JPRB
-
-!* Coefficients
- aa_tl (:) = 0.0_JPRB
- aa_tl (:) = scatt_aux_tl % b0 (iprof,:) - 1.5_JPRB * angles( iprof) % coszen &
- & * (scatt_aux_tl % asm (ichan,:) * scatt_aux % ssa (ichan,:) * scatt_aux % b1 (iprof,:) &
- & + scatt_aux % asm (ichan,:) * scatt_aux_tl % ssa (ichan,:) * scatt_aux % b1 (iprof,:) &
- & + scatt_aux % asm (ichan,:) * scatt_aux % ssa (ichan,:) * scatt_aux_tl % b1 (iprof,:)) &
- & / scatt_aux % h (ichan,:) &
- & + 1.5_JPRB * scatt_aux % asm (ichan,:) * scatt_aux % ssa (ichan,:) &
- & * angles (iprof) % coszen * scatt_aux % b1 (iprof,:) * scatt_aux_tl % h (ichan,:) &
- & / (scatt_aux % h (ichan,:) * scatt_aux % h (ichan,:))
- aa (:) = scatt_aux % b0 (iprof,:) - 1.5_JPRB * scatt_aux % asm (ichan,:) * scatt_aux % ssa (ichan,:) &
- & * angles (iprof) % coszen * scatt_aux % b1 (iprof,:) / scatt_aux % h (ichan,:)
-
- bb_tl (:) = 0.0_JPRB
- bb_tl (:) = scatt_aux_tl % b1 (iprof,:)
- bb (:) = scatt_aux % b1 (iprof,:)
-
- cp_tl (:) = 0.0_JPRB
- cp_tl (:) = (dp_tl (ichan,:) * scatt_aux % ssa (ichan,:) + dp (ichan,:) * scatt_aux_tl % ssa (ichan,:)) &
- & * (1.0_JPRB - 1.5_JPRB * angles (iprof) % coszen * scatt_aux % asm (ichan,:) * scatt_aux % lambda (ichan,:) &
- & / scatt_aux % h (ichan,:) ) &
- & - 1.5_JPRB * dp (ichan,:) * scatt_aux % ssa (ichan,:) * angles (iprof) % coszen &
- & * (scatt_aux_tl % asm (ichan,:) * scatt_aux % lambda (ichan,:) / scatt_aux % h( ichan,:) &
- & + scatt_aux % asm (ichan,:) * scatt_aux_tl % lambda (ichan,:) / scatt_aux % h (ichan,:) &
- & - scatt_aux % asm (ichan,:) * scatt_aux % lambda (ichan,:) * scatt_aux_tl % h (ichan,:) &
- & / (scatt_aux % h (ichan,:) * scatt_aux % h (ichan,:)))
- cp (:) = dp (ichan,:) * scatt_aux % ssa (ichan,:) * (1.0_JPRB - 1.5_JPRB * scatt_aux % asm (ichan,:) &
- & * angles (iprof) % coszen * scatt_aux % lambda (ichan,:) / scatt_aux % h (ichan,:))
-
- cm_tl (:) = 0.0_JPRB
- cm_tl (:) = (dm_tl (ichan,:) * scatt_aux % ssa (ichan,:) + dm (ichan,:) * scatt_aux_tl % ssa (ichan,:)) &
- & * (1.0_JPRB + 1.5_JPRB * angles (iprof) % coszen * scatt_aux % asm (ichan,:) * &
- & scatt_aux % lambda (ichan,:) / scatt_aux % h (ichan,:)) &
- & + 1.5_JPRB * dm (ichan,:) * scatt_aux % ssa (ichan,:) * angles (iprof) % coszen &
- & * (scatt_aux_tl % asm (ichan,:) * scatt_aux % lambda (ichan,:) / scatt_aux % h (ichan,:) &
- & + scatt_aux % asm (ichan,:) * scatt_aux_tl % lambda (ichan,:) / scatt_aux % h (ichan,:) &
- & - scatt_aux % asm (ichan,:) * scatt_aux % lambda (ichan,:) * scatt_aux_tl % h (ichan,:) &
- & / (scatt_aux % h (ichan,:) * scatt_aux % h (ichan,:)))
- cm (:) = dm (ichan,:) * scatt_aux % ssa (ichan,:) * (1.0_JPRB + 1.5_JPRB * scatt_aux % asm (ichan,:) &
- & * angles (iprof) % coszen * scatt_aux % lambda (ichan,:) / scatt_aux % h (ichan,:))
-
-!* Reset
- ja (:) = 0.0_JPRB
- jb (:) = 0.0_JPRB
- jc (:) = 0.0_JPRB
- jd (:) = 0.0_JPRB
-
-!* Downward radiance source terms
- where (scatt_aux % ssa (ichan,:) > 1.0E-08_JPRB) ! limit depends on mie tables
- ja_tl (:) = -1.0_JPRB * scatt_aux_tl % tau (ichan,:)
- ja (:) = 1.0_JPRB - scatt_aux % tau (ichan,:)
-
- jb_tl (:) = -1.0_JPRB * angles(iprof) % coszen &
- & * (scatt_aux_tl % ext (ichan,:) / (scatt_aux % ext (ichan,:) * scatt_aux % ext (ichan,:)) &
- & *(1.0_JPRB - scatt_aux % tau (ichan,:)) &
- & + scatt_aux_tl % tau (ichan,:) / scatt_aux % ext (ichan,:)) &
- & - scatt_aux_tl % tau (ichan,:) * scatt_aux % dz (iprof,:) - scatt_aux % tau (ichan,:) &
- & * scatt_aux_tl % dz (iprof,:)
- jb (:) = angles (iprof) % coszen / scatt_aux % ext (ichan,:) * (1.0_JPRB - scatt_aux % tau (ichan,:)) &
- & - scatt_aux % tau (ichan,:) * scatt_aux % dz (iprof,:)
-
- ztmp (:) = exp (scatt_aux % dz (iprof,:) * (scatt_aux % lambda (ichan,:) - scatt_aux % ext (ichan,:) &
- & / angles (iprof) % coszen))
- ztmp_tl (:) = ztmp(:) * (scatt_aux_tl % dz (iprof,:) * (scatt_aux % lambda (ichan,:) &
- & - scatt_aux % ext (ichan,:) / angles (iprof) % coszen) &
- & + scatt_aux % dz (iprof,:) * (scatt_aux_tl % lambda (ichan,:) &
- & - scatt_aux_tl % ext (ichan,:) / angles (iprof) % coszen))
-
- jc_tl (:) = scatt_aux_tl % ext (ichan,:) / (scatt_aux % lambda (ichan,:) * angles (iprof) % coszen &
- & - scatt_aux % ext (ichan,:)) &
- & * (ztmp(:) - 1.0_JPRB ) &
- & - scatt_aux % ext (ichan,:) * (scatt_aux_tl % lambda (ichan,:) * angles (iprof) % coszen &
- & - scatt_aux_tl % ext (ichan,:)) &
- & / (scatt_aux % lambda (ichan,:) * angles (iprof) % coszen - scatt_aux % ext (ichan,:)) &
- & / (scatt_aux % lambda (ichan,:) * angles (iprof) % coszen - scatt_aux % ext (ichan,:)) &
- & * ( ztmp(:) - 1.0_JPRB ) &
- & + scatt_aux % ext (ichan,:) / (scatt_aux % lambda (ichan,:) * angles (iprof) % coszen &
- & - scatt_aux % ext (ichan,:)) * ztmp_tl (:)
- jc (:) = scatt_aux % ext (ichan,:) / &
- & (scatt_aux % lambda (ichan,:) * angles (iprof) % coszen - scatt_aux % ext (ichan,:)) * (ztmp(:) - 1.0_JPRB)
-
- ztmp (:) = exp (scatt_aux % dz (iprof,:) * (scatt_aux % lambda (ichan,:) + scatt_aux % ext (ichan,:) &
- & / angles (iprof) % coszen))
- ztmp_tl (:) = ztmp(:) * (scatt_aux_tl % dz (iprof,:) * (scatt_aux % lambda (ichan,:) &
- & + scatt_aux % ext (ichan,:) / angles (iprof) % coszen) &
- & + scatt_aux % dz (iprof,:) * (scatt_aux_tl % lambda (ichan,:) &
- & + scatt_aux_tl % ext (ichan,:) / angles (iprof) % coszen))
-
- jd_tl (:) = scatt_aux_tl % ext (ichan,:) / (scatt_aux % lambda (ichan,:) &
- & * angles (iprof) % coszen + scatt_aux % ext (ichan,:))&
- & * (1.0_JPRB - 1.0_JPRB / ztmp(:) ) &
- & - scatt_aux % ext (ichan,:) * (scatt_aux_tl % lambda (ichan,:) &
- & * angles (iprof) % coszen + scatt_aux_tl % ext (ichan,:)) &
- & / (scatt_aux % lambda (ichan,:) &
- & * angles (iprof) % coszen + scatt_aux % ext (ichan,:)) &
- & / (scatt_aux % lambda (ichan,:) &
- & * angles (iprof) % coszen + scatt_aux % ext (ichan,:)) &
- & * (1.0_JPRB - 1.0_JPRB / ztmp(:)) &
- & + scatt_aux % ext (ichan,:) / (scatt_aux % lambda (ichan,:) &
- & * angles (iprof) % coszen + scatt_aux % ext (ichan,:)) &
- & * ztmp_tl (:) / ztmp (:) / ztmp (:)
- jd (:) = scatt_aux % ext (ichan,:) / (scatt_aux % lambda (ichan,:) &
- & * angles (iprof) % coszen + scatt_aux % ext (ichan,:)) &
- & * (1.0_JPRB - 1.0_JPRB / ztmp (:))
-
- j_do_tl (ichan,:) = ja_tl (:) * aa (:) + ja (:) * aa_tl (:) &
- & + jb_tl (:) * bb (:) + jb (:) * bb_tl (:) &
- & + jc_tl (:) * cp (:) + jc (:) * cp_tl (:) &
- & + jd_tl (:) * cm (:) + jd (:) * cm_tl (:)
- j_do (ichan,:) = ja (:) * aa (:) + jb (:) * bb (:) + jc (:) * cp (:) + jd (:) * cm (:)
-
-!* Upward radiance source terms
- ja_tl (:) = -1.0_JPRB * scatt_aux_tl % tau (ichan,:)
- ja (:) = 1.0_JPRB - scatt_aux % tau (ichan,:)
-
- jb_tl (:) = angles (iprof) % coszen &
- & * (scatt_aux_tl % ext (ichan,:) / (scatt_aux % ext (ichan,:) * scatt_aux % ext (ichan,:)) &
- & * (1.0_JPRB - scatt_aux % tau (ichan,:)) &
- & + scatt_aux_tl % tau (ichan,:) / scatt_aux % ext (ichan,:)) + scatt_aux_tl % dz (iprof,:)
- jb (:) = scatt_aux % dz (iprof,:) - angles (iprof) % coszen / scatt_aux % ext (ichan,:) &
- & * (1.0_JPRB - scatt_aux % tau (ichan,:))
-
- ztmp (:) = exp (scatt_aux % dz (iprof,:) * scatt_aux % lambda (ichan,:))
- ztmp_tl (:) = (scatt_aux_tl % dz (iprof,:) * scatt_aux % lambda (ichan,:) &
- & + scatt_aux % dz (iprof,:) * scatt_aux_tl % lambda (ichan,:)) * ztmp (:)
-
- jc_tl (:) = scatt_aux_tl % ext(ichan,:) / (scatt_aux % ext (ichan,:) + scatt_aux % lambda (ichan,:) &
- & * angles (iprof) % coszen) * (ztmp(:) - scatt_aux % tau (ichan,:)) &
- & - scatt_aux % ext (ichan,:) * (scatt_aux_tl % ext (ichan,:) &
- & + scatt_aux_tl % lambda(ichan,:) * angles(iprof) % coszen) &
- & / (scatt_aux % ext (ichan,:) + scatt_aux % lambda (ichan,:) &
- & * angles (iprof) % coszen) &
- & / (scatt_aux % ext (ichan,:) + scatt_aux % lambda (ichan,:) &
- & * angles (iprof) % coszen) * (ztmp(:) - scatt_aux % tau (ichan,:)) &
- & + scatt_aux % ext (ichan,:) / (scatt_aux % ext (ichan,:) &
- & + scatt_aux % lambda (ichan,:) * angles (iprof) % coszen) &
- & * (ztmp_tl(:) - scatt_aux_tl % tau (ichan,:))
- jc (:) = scatt_aux % ext (ichan,:) / (scatt_aux % ext (ichan,:) + scatt_aux % lambda (ichan,:) &
- & * angles (iprof) % coszen) * (ztmp(:) - scatt_aux % tau (ichan,:))
-
- jd_tl (:) = scatt_aux_tl % ext (ichan,:) / (scatt_aux % ext (ichan,:) - scatt_aux % lambda (ichan,:) &
- & * angles (iprof) % coszen) * (1.0_JPRB / ztmp (:) - scatt_aux % tau (ichan,:)) &
- & - scatt_aux % ext (ichan,:) * (scatt_aux_tl % ext (ichan,:) &
- & - scatt_aux_tl % lambda (ichan,:) * angles (iprof) % coszen) &
- & / (scatt_aux % ext (ichan,:) - scatt_aux % lambda (ichan,:) * angles (iprof) % coszen) &
- & / (scatt_aux % ext (ichan,:) - scatt_aux % lambda (ichan,:) &
- & * angles (iprof) % coszen) * (1.0_JPRB/ztmp(:) - scatt_aux % tau (ichan,:) ) &
- & + scatt_aux % ext (ichan,:) / (scatt_aux % ext (ichan,:) &
- & - scatt_aux % lambda (ichan,:) * angles (iprof) % coszen) &
- & * (-1.0_JPRB * ztmp_tl (:) / ztmp (:) / ztmp (:) - scatt_aux_tl % tau (ichan,:))
- jd (:) = scatt_aux % ext (ichan,:) / (scatt_aux % ext (ichan,:) - scatt_aux % lambda (ichan,:) &
- & * angles (iprof) % coszen) * (1.0_JPRB / ztmp (:) - scatt_aux % tau (ichan,:))
-
- j_up_tl (ichan,:) = ja_tl (:) * aa (:) + ja (:) * aa_tl (:) &
- & + jb_tl (:) * bb (:) + jb (:) * bb_tl (:) &
- & + jc_tl (:) * cp (:) + jc (:) * cp_tl (:) &
- & + jd_tl (:) * cm (:) + jd (:) * cm_tl (:)
- j_up (ichan,:) = ja (:) * aa (:) + jb (:) * bb (:) + jc (:) * cp (:) + jd (:) * cm (:)
- end where
- end do
-
-End subroutine rttov_integratesource_tl
diff --git a/src/LIB/RTTOV/src/rttov_integratesource_tl.interface b/src/LIB/RTTOV/src/rttov_integratesource_tl.interface
deleted file mode 100644
index 6bfd82507334b07f6d03545a571ebec6a64e30c2..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_integratesource_tl.interface
+++ /dev/null
@@ -1,38 +0,0 @@
-INTERFACE
-Subroutine rttov_integratesource_tl (&
- & nwp_levels,&
- & nchannels,&
- & nprofiles,&
- & lprofiles,&
- & angles,&
- & scatt_aux,&
- & scatt_aux_tl,&
- & dp,&
- & dp_tl,&
- & dm,&
- & dm_tl,&
- & j_do,&
- & j_do_tl,&
- & j_up,&
- & j_up_tl)
- Use rttov_types, Only :&
- & profile_scatt_aux ,&
- & geometry_Type
- Use parkind1, Only : jpim ,jprb
- Integer (Kind=jpim), Intent (in) :: nwp_levels
- Integer (Kind=jpim), Intent (in) :: nprofiles
- Integer (Kind=jpim), Intent (in) :: nchannels
- Integer (Kind=jpim), Intent (in) :: lprofiles (nchannels)
- Type (profile_scatt_aux), Intent(in) :: scatt_aux
- Type (profile_scatt_aux), Intent(in) :: scatt_aux_tl
- Type (geometry_Type), Intent(in) :: angles (nprofiles)
- Real (Kind=jprb), Intent (in) , dimension (nchannels,nwp_levels) :: dp
- Real (Kind=jprb), Intent (in) , dimension (nchannels,nwp_levels) :: dm
- Real (Kind=jprb), Intent (inout), dimension (nchannels,nwp_levels) :: j_do
- Real (Kind=jprb), Intent (inout), dimension (nchannels,nwp_levels) :: j_up
- Real (Kind=jprb), Intent (in) , dimension (nchannels,nwp_levels) :: dp_tl
- Real (Kind=jprb), Intent (in) , dimension (nchannels,nwp_levels) :: dm_tl
- Real (Kind=jprb), Intent (inout), dimension (nchannels,nwp_levels) :: j_do_tl
- Real (Kind=jprb), Intent (inout), dimension (nchannels,nwp_levels) :: j_up_tl
-End subroutine rttov_integratesource_tl
-END INTERFACE
diff --git a/src/LIB/RTTOV/src/rttov_interpcubic.F90 b/src/LIB/RTTOV/src/rttov_interpcubic.F90
deleted file mode 100644
index c56bb1cab64c08ec77197522f39076bc45c228fb..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_interpcubic.F90
+++ /dev/null
@@ -1,88 +0,0 @@
-Subroutine rttov_interpcubic (&
- & coef_scatt, &! in
- & tab, &! in
- & itemp, &! in
- & iwc, &! in
- & temp, &! in
- & wc, &! in
- & val) ! out
-
- ! Description:
- ! interface to Numerical Recipes for cubic interpolation
- !
- ! Copyright:
- ! This software was developed within the context of
- ! the EUMETSAT Satellite Application Facility on
- ! Numerical Weather Prediction (NWP SAF), under the
- ! Cooperation Agreement dated 25 November 1998, between
- ! EUMETSAT and the Met Office, UK, by one or more partners
- ! within the NWP SAF. The partners in the NWP SAF are
- ! the Met Office, ECMWF, KNMI and MeteoFrance.
- !
- ! Copyright 2002, EUMETSAT, All Rights Reserved.
- !
- ! Method:
- ! Chevallier, F., and P. Bauer, 2003:
- ! Model rain and clouds over oceans:
- ! comparison with SSM/I observations.
- ! Mon. Wea. Rev., 131, 1240-1255.
- !
- ! Current Code Owner: SAF NWP
- !
- ! History:
- ! Version Date Comment
- ! ------- ---- -------
- ! 1.0 09/2002 Initial version (P. Bauer, E. Moreau)
- ! 1.1 05/2003 RTTOV-7.3 compatible (F. Chevallier)
- ! 1.2 07/2003 E. Moreau
- !
- ! Code Description:
- ! Language: Fortran 90.
- ! Software Standards: "European Standards for Writing and
- ! Documenting Exchangeable Fortran 90 Code".
- !
- ! Declarations:
- ! Modules used:
- ! Imported Type Definitions:
- Use rttov_types, Only : &
- & rttov_scatt_coef
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
-#include "rttov_polcoe.interface"
-
- !subroutine arguments:
- Type(rttov_scatt_coef), Intent(in) :: coef_scatt ! RTTOV_SCATT Coefficients
- Real(Kind=jprb), Intent(in), Dimension(2,4) :: tab ! part of the mie-tables [2x4]
- ! = mie-tab(itemp:itemp+1,ilwc-1:ilwc+2)
- Integer(Kind=jpim), Intent( in) :: itemp, iwc
- Real(Kind=jprb), Intent( in) :: temp, wc ! coord. of the interp. variable.
- Real(Kind=jprb), Intent(out) :: val ! interpolate value
-
- !local
- Real(Kind=jprb), Dimension(4) :: x, y, coef
- Real(Kind=jprb) :: xx, t
- Integer(Kind=jpim) :: i
-
- !- End of header --------------------------------------------------------
-
- !# linear interpolation w.r.t temperature
- do i = 1, 4
- t = (temp - real(itemp))
- y(i) = (1._JPRB - t) * tab(1,i) + t * tab(2,i)
- enddo
-
- x(1) = 10._JPRB**( (real(iwc-2+1)+coef_scatt % offset_water)/coef_scatt % scale_water)
- do i = 2, 4
- x(i) = x(i-1) * coef_scatt % from_scale_water
- enddo
-
- !# cubic interpolation w.r.t water content
- call rttov_polcoe(x, y, 4, coef)
-
- !# interpolate value
- xx = 10._JPRB**( (wc + coef_scatt % offset_water)/coef_scatt % scale_water )
- val = coef(1) + coef(2) * xx + coef(3) * xx**2._JPRB + coef(4) * xx**3._JPRB
-
-End subroutine rttov_interpcubic
diff --git a/src/LIB/RTTOV/src/rttov_interpcubic.interface b/src/LIB/RTTOV/src/rttov_interpcubic.interface
deleted file mode 100644
index 75201d509e31cdb5bd988dfca7e81be3a1543147..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_interpcubic.interface
+++ /dev/null
@@ -1,63 +0,0 @@
-Interface
-!
-Subroutine rttov_interpcubic (&
- coef_scatt, & ! in
- tab, & ! in
- itemp, & ! in
- iwc, & ! in
- temp, & ! in
- wc, & ! in
- val) ! out
-
- ! Description:
- ! interface to Numerical Recipes for cubic interpolation
- !
- ! Copyright:
- ! This software was developed within the context of
- ! the EUMETSAT Satellite Application Facility on
- ! Numerical Weather Prediction (NWP SAF), under the
- ! Cooperation Agreement dated 25 November 1998, between
- ! EUMETSAT and the Met Office, UK, by one or more partners
- ! within the NWP SAF. The partners in the NWP SAF are
- ! the Met Office, ECMWF, KNMI and MeteoFrance.
- !
- ! Copyright 2002, EUMETSAT, All Rights Reserved.
- !
- ! Method:
- ! Chevallier, F., and P. Bauer, 2003:
- ! Model rain and clouds over oceans:
- ! comparison with SSM/I observations.
- ! Mon. Wea. Rev., 131, 1240-1255.
- !
- ! Current Code Owner: SAF NWP
- !
- ! History:
- ! Version Date Comment
- ! ------- ---- -------
- ! 1.0 09/2002 Initial version (P. Bauer, E. Moreau)
- ! 1.1 05/2003 RTTOV-7.3 compatible (F. Chevallier)
- ! 1.2 07/2003 E. Moreau
- !
- ! Code Description:
- ! Language: Fortran 90.
- ! Software Standards: "European Standards for Writing and
- ! Documenting Exchangeable Fortran 90 Code".
- !
- ! Declarations:
- ! Modules used:
- ! Imported Type Definitions:
- Use rttov_types, Only : &
- rttov_scatt_coef
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
- !subroutine arguments:
- Type(rttov_scatt_coef), Intent(in) :: coef_scatt ! RTTOV_SCATT Coefficients
- Real(Kind=jprb), Intent(in), Dimension(2,4) :: tab ! part of the mie-tables [2x4]
- ! = mie-tab(itemp:itemp+1,ilwc-1:ilwc+2)
- Integer(Kind=jpim), Intent( in) :: itemp, iwc
- Real(Kind=jprb), Intent( in) :: temp, wc ! coord. of the interp. variable.
- Real(Kind=jprb), Intent(out) :: val ! interpolate value
-End subroutine rttov_interpcubic
-End Interface
diff --git a/src/LIB/RTTOV/src/rttov_interpcubic_ad.F90 b/src/LIB/RTTOV/src/rttov_interpcubic_ad.F90
deleted file mode 100644
index bfc9a0cd78ddedddacc88e86a397ca3d55468100..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_interpcubic_ad.F90
+++ /dev/null
@@ -1,123 +0,0 @@
-Subroutine rttov_interpcubic_ad (&
- & coef_scatt, &! in
- & tab, &! in
- & itemp, &! in
- & iwc, &! in
- & itype, &! in
- & temp, &! in
- & wc, &! in
- & val, &! out
- & temp_ad, &! inout
- & wc_ad, &! inout
- & val_ad) ! inout
-
- ! Description:
- ! interface to Numerical Recipes for cubic interpolation
- !
- ! Copyright:
- ! This software was developed within the context of
- ! the EUMETSAT Satellite Application Facility on
- ! Numerical Weather Prediction (NWP SAF), under the
- ! Cooperation Agreement dated 25 November 1998, between
- ! EUMETSAT and the Met Office, UK, by one or more partners
- ! within the NWP SAF. The partners in the NWP SAF are
- ! the Met Office, ECMWF, KNMI and MeteoFrance.
- !
- ! Copyright 2002, EUMETSAT, All Rights Reserved.
- !
- ! Method:
- ! - Chevallier, F., and P. Bauer, 2003:
- ! Model rain and clouds over oceans: comparison with SSM/I observations.
- ! Mon. Wea. Rev., 131, 1240-1255.
- ! - Moreau, E., P. Bauer and F. Chevallier, 2002: Microwave radiative transfer modeling in clouds and precipitation.
- ! Part II: Model evaluation.
- ! NWP SAF Report No. NWPSAF-EC-TR-006, 27 pp.
- !
- ! Current Code Owner: SAF NWP
- !
- ! History:
- ! Version Date Comment
- ! ------- ---- -------
- ! 1.0 09/2002 Initial version (E. Moreau)
- ! 1.1 05/2003 RTTOV-7.3 compatible (F. Chevallier)
- ! 1.2 07/2003 E. Moreau
- !
- ! Code Description:
- ! Language: Fortran 90.
- ! Software Standards: "European Standards for Writing and
- ! Documenting Exchangeable Fortran 90 Code".
- !
- ! Declarations:
- ! Modules used:
- ! Imported Type Definitions:
- Use rttov_types, Only : &
- & rttov_scatt_coef
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
-#include "rttov_polcoe.interface"
-
- !subroutine arguments:
- Type(rttov_scatt_coef), Intent(in) :: coef_scatt ! RTTOV_SCATT Coefficients
- Real(Kind=jprb), Intent(in), Dimension(2,4) :: tab ! part of the mie-tables [2x4]
- ! = mie-tab(itemp:itemp+1,iwc-1:iwc+2)
- Integer(Kind=jpim), Intent( in) :: itemp, iwc, itype
- Real(Kind=jprb), Intent( in) :: temp, wc ! coord. of the interp. variable.
- Real(Kind=jprb), Intent(out) :: val ! interpolate value
- Real(Kind=jprb), Intent(inout) :: temp_ad, wc_ad ! coord. of the interp. variable.
- Real(Kind=jprb), Intent(inout) :: val_ad ! interpolate value
-
- !local
- Real(Kind=jprb), Dimension(2) :: x0, y0, cof0
- Real(Kind=jprb), Dimension(4) :: x, y, coef
- Real(Kind=jprb) :: xx, t, u
- Integer(Kind=jpim) :: i
-
- !- End of header --------------------------------------------------------
-
- !# linear interpolation w.r.t temperature
- do i = 1, 4
- t = (temp - real(itemp))
- y(i) = (1._JPRB - t) * tab(1,i) + t * tab(2,i)
- enddo
-
- x(1) = 10._JPRB**( (real(iwc-2+1)+coef_scatt % offset_water)/coef_scatt % scale_water)
- do i = 2, 4
- x(i) = x(i-1) * coef_scatt % from_scale_water
- enddo
-
- !# cubic interpolation w.r.t water content
- call rttov_polcoe(x, y, 4, coef)
-
- !# interpolate value
- xx = 10._JPRB**( (wc + coef_scatt % offset_water)/coef_scatt % scale_water )
- val = coef(1) + coef(2) * xx + coef(3) * xx**2._JPRB + coef(4) * xx**3._JPRB
-
- !# interpolate derivative of the value w.r.t water content
-
- !# interpolate derivative of the value / temp
- !# linear interpolation w.r.t water content
- do i = 1, 2
- u = (wc - real(iwc))
- y0(i) = (1._JPRB - u) * tab(i,2) + u * tab(i,3)
- if (itype == 1) x0(i) = real(itemp-1+i) + coef_scatt % offset_temp_rain ![K]
- if (itype == 2) x0(i) = real(itemp-1+i) + coef_scatt % offset_temp_sp ![K]
- if (itype == 3) x0(i) = real(itemp-1+i) + coef_scatt % offset_temp_liq ![K]
- if (itype == 4) x0(i) = real(itemp-1+i) + coef_scatt % offset_temp_ice ![K]
- enddo
-
- !# linear interpolation w.r.t temp
- call rttov_polcoe(x0, y0, 2, cof0)
-
- !-----------------------------------------------------------
- ! AD code
- !-----------------------------------------------------------
-
- temp_ad = temp_ad + cof0(2) * val_ad
- wc_ad = wc_ad + ( coef(2) + 2._JPRB * coef(3) * xx + 3._JPRB * coef(4) * xx**2._JPRB ) * val_ad
-
- val_ad = 0._JPRB
-
-
-End subroutine rttov_interpcubic_ad
diff --git a/src/LIB/RTTOV/src/rttov_interpcubic_ad.interface b/src/LIB/RTTOV/src/rttov_interpcubic_ad.interface
deleted file mode 100644
index 8a2436959e8e4826777355c594bfe99f01d4be79..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_interpcubic_ad.interface
+++ /dev/null
@@ -1,71 +0,0 @@
-Interface
-!
-Subroutine rttov_interpcubic_ad (&
- coef_scatt, & ! in
- tab, & ! in
- itemp, & ! in
- iwc, & ! in
- itype, & ! in
- temp, & ! in
- wc, & ! in
- val, & ! out
- temp_ad, & ! inout
- wc_ad, & ! inout
- val_ad) ! inout
-
- ! Description:
- ! interface to Numerical Recipes for cubic interpolation
- !
- ! Copyright:
- ! This software was developed within the context of
- ! the EUMETSAT Satellite Application Facility on
- ! Numerical Weather Prediction (NWP SAF), under the
- ! Cooperation Agreement dated 25 November 1998, between
- ! EUMETSAT and the Met Office, UK, by one or more partners
- ! within the NWP SAF. The partners in the NWP SAF are
- ! the Met Office, ECMWF, KNMI and MeteoFrance.
- !
- ! Copyright 2002, EUMETSAT, All Rights Reserved.
- !
- ! Method:
- ! - Chevallier, F., and P. Bauer, 2003:
- ! Model rain and clouds over oceans: comparison with SSM/I observations.
- ! Mon. Wea. Rev., 131, 1240-1255.
- ! - Moreau, E., P. Bauer and F. Chevallier, 2002: Microwave radiative transfer modeling in clouds and precipitation.
- ! Part II: Model evaluation.
- ! NWP SAF Report No. NWPSAF-EC-TR-006, 27 pp.
- !
- ! Current Code Owner: SAF NWP
- !
- ! History:
- ! Version Date Comment
- ! ------- ---- -------
- ! 1.0 09/2002 Initial version (E. Moreau)
- ! 1.1 05/2003 RTTOV-7.3 compatible (F. Chevallier)
- ! 1.2 07/2003 E. Moreau
- !
- ! Code Description:
- ! Language: Fortran 90.
- ! Software Standards: "European Standards for Writing and
- ! Documenting Exchangeable Fortran 90 Code".
- !
- ! Declarations:
- ! Modules used:
- ! Imported Type Definitions:
- Use rttov_types, Only : &
- rttov_scatt_coef
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
- !subroutine arguments:
- Type(rttov_scatt_coef), Intent(in) :: coef_scatt ! RTTOV_SCATT Coefficients
- Real(Kind=jprb), Intent(in), Dimension(2,4) :: tab ! part of the mie-tables [2x4]
- ! = mie-tab(itemp:itemp+1,iwc-1:iwc+2)
- Integer(Kind=jpim), Intent( in) :: itemp, iwc, itype
- Real(Kind=jprb), Intent( in) :: temp, wc ! coord. of the interp. variable.
- Real(Kind=jprb), Intent(out) :: val ! interpolate value
- Real(Kind=jprb), Intent(inout) :: temp_ad, wc_ad ! coord. of the interp. variable.
- Real(Kind=jprb), Intent(inout) :: val_ad ! interpolate value
-End subroutine rttov_interpcubic_ad
-End Interface
diff --git a/src/LIB/RTTOV/src/rttov_interpcubic_tl.F90 b/src/LIB/RTTOV/src/rttov_interpcubic_tl.F90
deleted file mode 100644
index 3bcdd1dde2f14c828e683735edbc911728ca5fa0..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_interpcubic_tl.F90
+++ /dev/null
@@ -1,116 +0,0 @@
-Subroutine rttov_interpcubic_tl (&
- & coef_scatt, &! in
- & tab, &! in
- & itemp, &! in
- & iwc, &! in
- & itype, &! in
- & temp, &! in
- & wc, &! in
- & val, &! out
- & temp_tl, &! in
- & wc_tl, &! in
- & val_tl) ! out
-
- ! Description:
- ! interface to Numerical Recipes for cubic interpolation
- !
- ! Copyright:
- ! This software was developed within the context of
- ! the EUMETSAT Satellite Application Facility on
- ! Numerical Weather Prediction (NWP SAF), under the
- ! Cooperation Agreement dated 25 November 1998, between
- ! EUMETSAT and the Met Office, UK, by one or more partners
- ! within the NWP SAF. The partners in the NWP SAF are
- ! the Met Office, ECMWF, KNMI and MeteoFrance.
- !
- ! Copyright 2002, EUMETSAT, All Rights Reserved.
- !
- ! Method:
- ! - Chevallier, F., and P. Bauer, 2003:
- ! Model rain and clouds over oceans: comparison with SSM/I observations.
- ! Mon. Wea. Rev., 131, 1240-1255.
- ! - Moreau, E., P. Bauer and F. Chevallier, 2002: Microwave radiative transfer modeling in clouds and precipitation.
- ! Part II: Model evaluation.
- ! NWP SAF Report No. NWPSAF-EC-TR-006, 27 pp.
- !
- ! Current Code Owner: SAF NWP
- !
- ! History:
- ! Version Date Comment
- ! ------- ---- -------
- ! 1.0 09/2002 Initial version (E. Moreau)
- ! 1.1 05/2003 RTTOV-7.3 compatible (F. Chevallier)
- ! 1.2 07/2003 E. Moreau
- !
- ! Code Description:
- ! Language: Fortran 90.
- ! Software Standards: "European Standards for Writing and
- ! Documenting Exchangeable Fortran 90 Code".
- !
- ! Declarations:
- ! Modules used:
- ! Imported Type Definitions:
- Use rttov_types, Only : &
- & rttov_scatt_coef
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
-#include "rttov_polcoe.interface"
-
- !subroutine arguments:
- Type(rttov_scatt_coef), Intent(in) :: coef_scatt ! RTTOV_SCATT Coefficients
- Real(Kind=jprb), Intent(in), Dimension(2,4) :: tab ! part of the mie-tables [2x4]
- ! = mie-tab(itemp:itemp+1,iwc-1:iwc+2)
- Integer(Kind=jpim), Intent( in) :: itemp, iwc, itype
- Real(Kind=jprb), Intent( in) :: temp, wc ! coord. of the interp. variable.
- Real(Kind=jprb), Intent(out) :: val ! interpolate value
- Real(Kind=jprb), Intent( in) :: temp_tl, wc_tl ! coord. of the interp. variable.
- Real(Kind=jprb), Intent(out) :: val_tl ! interpolate value
-
- !local
- Real(Kind=jprb), Dimension(2) :: x0, y0, cof0
- Real(Kind=jprb), Dimension(4) :: x, y, coef
- Real(Kind=jprb) :: xx, t, u
- Integer(Kind=jpim) :: i
-
- !- End of header --------------------------------------------------------
-
- !# linear interpolation w.r.t temperature
- do i = 1, 4
- t = (temp - real(itemp))
- y(i) = (1._JPRB - t) * tab(1,i) + t * tab(2,i)
- enddo
-
- x(1) = 10._JPRB**( (real(iwc-2+1)+coef_scatt % offset_water)/coef_scatt % scale_water)
- do i = 2, 4
- x(i) = x(i-1) * coef_scatt % from_scale_water
- enddo
-
- !# cubic interpolation w.r.t water content
- call rttov_polcoe(x, y, 4, coef)
-
- !# interpolate value
- xx = 10._JPRB**( (wc + coef_scatt % offset_water)/coef_scatt % scale_water )
- val = coef(1) + coef(2) * xx + coef(3) * xx**2._JPRB + coef(4) * xx**3._JPRB
-
- !# interpolate derivative of the value w.r.t water content
- val_tl = ( coef(2) + 2._JPRB * coef(3) * xx + 3._JPRB * coef(4) * xx**2._JPRB ) * wc_tl
-
- !# interpolate derivative of the value / temp
- !# linear interpolation w.r.t water content
- do i = 1, 2
- u = (wc - real(iwc))
- y0(i) = (1._JPRB - u) * tab(i,2) + u * tab(i,3)
- if (itype == 1) x0(i) = real(itemp-1+i) + coef_scatt % offset_temp_rain ![K]
- if (itype == 2) x0(i) = real(itemp-1+i) + coef_scatt % offset_temp_sp ![K]
- if (itype == 3) x0(i) = real(itemp-1+i) + coef_scatt % offset_temp_liq ![K]
- if (itype == 4) x0(i) = real(itemp-1+i) + coef_scatt % offset_temp_ice ![K]
- enddo
-
- !# linear interpolation w.r.t temp
- call rttov_polcoe(x0, y0, 2, cof0)
- val_tl = val_tl + cof0(2) * temp_tl
-
-
-End subroutine rttov_interpcubic_tl
diff --git a/src/LIB/RTTOV/src/rttov_interpcubic_tl.interface b/src/LIB/RTTOV/src/rttov_interpcubic_tl.interface
deleted file mode 100644
index 1291172a9d3813abf2ffa1b8479c5c05d4d04a0c..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_interpcubic_tl.interface
+++ /dev/null
@@ -1,71 +0,0 @@
-Interface
-!
-Subroutine rttov_interpcubic_tl (&
- coef_scatt, & ! in
- tab, & ! in
- itemp, & ! in
- iwc, & ! in
- itype, & ! in
- temp, & ! in
- wc, & ! in
- val, & ! out
- temp_tl, & ! in
- wc_tl, & ! in
- val_tl) ! out
-
- ! Description:
- ! interface to Numerical Recipes for cubic interpolation
- !
- ! Copyright:
- ! This software was developed within the context of
- ! the EUMETSAT Satellite Application Facility on
- ! Numerical Weather Prediction (NWP SAF), under the
- ! Cooperation Agreement dated 25 November 1998, between
- ! EUMETSAT and the Met Office, UK, by one or more partners
- ! within the NWP SAF. The partners in the NWP SAF are
- ! the Met Office, ECMWF, KNMI and MeteoFrance.
- !
- ! Copyright 2002, EUMETSAT, All Rights Reserved.
- !
- ! Method:
- ! - Chevallier, F., and P. Bauer, 2003:
- ! Model rain and clouds over oceans: comparison with SSM/I observations.
- ! Mon. Wea. Rev., 131, 1240-1255.
- ! - Moreau, E., P. Bauer and F. Chevallier, 2002: Microwave radiative transfer modeling in clouds and precipitation.
- ! Part II: Model evaluation.
- ! NWP SAF Report No. NWPSAF-EC-TR-006, 27 pp.
- !
- ! Current Code Owner: SAF NWP
- !
- ! History:
- ! Version Date Comment
- ! ------- ---- -------
- ! 1.0 09/2002 Initial version (E. Moreau)
- ! 1.1 05/2003 RTTOV-7.3 compatible (F. Chevallier)
- ! 1.2 07/2003 E. Moreau
- !
- ! Code Description:
- ! Language: Fortran 90.
- ! Software Standards: "European Standards for Writing and
- ! Documenting Exchangeable Fortran 90 Code".
- !
- ! Declarations:
- ! Modules used:
- ! Imported Type Definitions:
- Use rttov_types, Only : &
- rttov_scatt_coef
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
- !subroutine arguments:
- Type(rttov_scatt_coef), Intent(in) :: coef_scatt ! RTTOV_SCATT Coefficients
- Real(Kind=jprb), Intent(in), Dimension(2,4) :: tab ! part of the mie-tables [2x4]
- ! = mie-tab(itemp:itemp+1,iwc-1:iwc+2)
- Integer(Kind=jpim), Intent( in) :: itemp, iwc, itype
- Real(Kind=jprb), Intent( in) :: temp, wc ! coord. of the interp. variable.
- Real(Kind=jprb), Intent(out) :: val ! interpolate value
- Real(Kind=jprb), Intent( in) :: temp_tl, wc_tl ! coord. of the interp. variable.
- Real(Kind=jprb), Intent(out) :: val_tl ! interpolate value
-End subroutine rttov_interpcubic_tl
-End Interface
diff --git a/src/LIB/RTTOV/src/rttov_intex.F90 b/src/LIB/RTTOV/src/rttov_intex.F90
deleted file mode 100644
index 6ad18e1c6fcfaa1eca90961050c0315d3508736a..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_intex.F90
+++ /dev/null
@@ -1,135 +0,0 @@
-!
-Subroutine rttov_INTEX( &
- & klevi , &! in
- & klevf , &! in
- & presi , &! in
- & presf , &! in
- & veci , &! in
- & vecf ) ! out
-
- ! Description:
- ! To interpolate the array vec from the presi levels to presf levels
- !
- ! Copyright:
- !
- ! This software was developed within the context of
- ! the EUMETSAT Satellite Application Facility on
- ! Numerical Weather Prediction (NWP SAF), under the
- ! Cooperation Agreement dated 25 November 1998, between
- ! EUMETSAT and the Met Office, UK, by one or more partners
- ! within the NWP SAF. The partners in the NWP SAF are
- ! the Met Office, ECMWF, KNMI and MeteoFrance.
- !
- ! Copyright 2002, EUMETSAT, All Rights Reserved.
- !
- !
- ! Method:
- ! Linear interpolation in ln(P)
- !
- ! Current Code Owner: SAF NWP
- !
- ! History:
- ! Version Date Comment
- ! ------- ---- -------
- ! 1 09/2002 ECMWF
- ! 1.0 04/12/2003 Optimisation (J Hague and D Salmond ECMWF)
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
- !
- ! Subroutine arguments
- !
- Integer(Kind=jpim), Intent(in) :: klevi ! number of levels of the initial grid
- Integer(Kind=jpim), Intent(in) :: klevf ! number of levels of the final grid
- !
- Real(Kind=jprb), Intent(in), Dimension(klevi) :: presi ! initial grid
- Real(Kind=jprb), Intent(in), Dimension(klevf) :: presf ! final grid
- !
- Real(Kind=jprb), Intent(in), Dimension(klevi) :: veci ! initial vec array
- Real(Kind=jprb), Intent(out), Dimension(klevf) :: vecf ! final vec array
- !
-
- ! Local scalars :
- !
- Integer(Kind=jpim) :: jki, jkf
- Integer(Kind=jpim) :: jhi, jlo
- Real(Kind=jprb) :: slope, t1, t2, p1, p2, lp1, lp2
- Real(Kind=jprb), Dimension(klevi) :: lpresi
- Real(Kind=jprb), Dimension(klevf) :: lpresf
- !
- !- End of header --------------------------------------------------------
-
- vecf(:) = -1000._JPRB
- lpresi(:) = Log( presi(:) )
- lpresf(:) = Log( presf(:) )
-
- do jkf = 1,klevf-1
- if(presf(jkf+1) < presf(jkf)) exit
- enddo
-
- do jki = 1,klevi-1
- if(presi(jki+1) < presi(jki)) exit
- enddo
-
- if(jki /= klevi .OR. jkf /= klevf) THEN
- if(jki /= klevi) write(0,*) (presi(jki),jki=1,klevi)
- if(jkf /= klevf) write(0,*) (presf(jkf),jkf=1,klevf)
-
- Do jkf = 1,klevf
- Do jki = 1,klevi-1
- p1 = presi(jki)
- p2 = presi(jki+1)
- lp1 = lpresi(jki)
- lp2 = lpresi(jki+1)
- If (presf(jkf) >= p1 .And. presf(jkf) < p2) Then
- t1 = veci(jki)
- t2 = veci(jki+1)
- slope = (t1-t2)/(lp1-lp2)
- If (t2 == 0._JPRB) slope = 0._JPRB
- vecf(jkf) = t1 + slope*(lpresf(jkf)-lp1)
- !
- Else If (jki == 1 .And. presf(jkf) < p1) Then
- vecf(jkf) = veci(jki)
- Else If (jki == (klevi-1) .And. vecf(jkf) == -1000._JPRB ) Then
- vecf(jkf) = veci(klevi)
- End If
- End Do
- End Do
-
- ELSE
-
- jkf = 1
- Do While (presf(jkf) < presi(1))
- vecf(jkf) = veci(1)
- jkf = jkf+1
- End Do
- jlo=jkf
-
- jkf = klevf
- Do While (presf(jkf) >= presi(klevi))
- vecf(jkf) = veci(klevi)
- jkf = jkf-1
- End Do
- jhi = jkf
-
- jki = 1
- do jkf = jlo,jhi
- Do While (presf(jkf) >= presi(jki+1))
- jki=jki+1
- End Do
- p1 = presi(jki)
- p2 = presi(jki+1)
- lp1 = lpresi(jki)
- lp2 = lpresi(jki+1)
- t1 = veci(jki)
- t2 = veci(jki+1)
- slope = (t1-t2)/(lp1-lp2)
- if (t2 == 0._JPRB) slope = 0._JPRB
- vecf(jkf) = t1 + slope*(lpresf(jkf)-lp1)
- End Do
-
- ENDIF
-
-
-End Subroutine rttov_INTEX
diff --git a/src/LIB/RTTOV/src/rttov_intex.interface b/src/LIB/RTTOV/src/rttov_intex.interface
deleted file mode 100644
index ed87dfd028ed41d9634c8d5d661f3104c0b23e79..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_intex.interface
+++ /dev/null
@@ -1,24 +0,0 @@
-Interface
-!
-Subroutine rttov_INTEX( &
- & klevi ,& ! in
- & klevf ,& ! in
- & presi ,& ! in
- & presf ,& ! in
- & veci ,& ! in
- & vecf ) ! out
-
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
- Integer(Kind=jpim), Intent(in) :: klevi ! number of levels of the initial grid
- Integer(Kind=jpim), Intent(in) :: klevf ! number of levels of the final grid
- Real(Kind=jprb), Intent(in), Dimension(klevi) :: presi ! initial grid
- Real(Kind=jprb), Intent(in), Dimension(klevf) :: presf ! final grid
- Real(Kind=jprb), Intent(in), Dimension(klevi) :: veci ! initial vec array
- Real(Kind=jprb), Intent(out), Dimension(klevf) :: vecf ! final vec array
-
-
-End Subroutine rttov_INTEX
-End Interface
diff --git a/src/LIB/RTTOV/src/rttov_intex_ad.F90 b/src/LIB/RTTOV/src/rttov_intex_ad.F90
deleted file mode 100644
index 7672d39ed6986daf535b49cc1be9719d018a2b97..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_intex_ad.F90
+++ /dev/null
@@ -1,170 +0,0 @@
-Subroutine rttov_intex_ad( &
- & klevi, &! in
- & klevf, &! in
- & presi, &! inout AD
- & presf, &! inout AD
- & veci, &! inout AD
- & vecf, &! inout AD
- & presi_d, &! in
- & presf_d, &! in
- & veci_d, &! in
- & vecf_d ) ! out
-
- !
- ! This software was developed within the context of
- ! the EUMETSAT Satellite Application Facility on
- ! Numerical Weather Prediction (NWP SAF), under the
- ! Cooperation Agreement dated 25 November 1998, between
- ! EUMETSAT and the Met Office, UK, by one or more partners
- ! within the NWP SAF. The partners in the NWP SAF are
- ! the Met Office, ECMWF, KNMI and MeteoFrance.
- !
- ! Copyright 2002, EUMETSAT, All Rights Reserved.
- !
- ! Description:
- ! AD of routine
- ! to interpolate the array vec from the presi levels to presf levels
- !
- ! Method:
- ! Linear interpolation in ln(P)
- !
- ! Current Code Owner: SAF NWP
- !
- ! History:
- ! Version Date Comment
- ! ------- ---- -------
- ! 1 03/2001 Original code (F. Chevallier)
- ! 1.1 29/03/2005 Add end of header comment (J. Cameron)
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
- !
- ! Subroutine arguments
- !
- Integer(Kind=jpim), Intent(in) :: klevi ! number of levels of the initial grid
- Integer(Kind=jpim), Intent(in) :: klevf ! number of levels of the final grid
- !
- ! AD arrays
- Real(Kind=jprb), Intent(inout), Dimension(klevi) :: presi ! initial grid
- Real(Kind=jprb), Intent(inout), Dimension(klevf) :: presf ! final grid
- Real(Kind=jprb), Intent(inout), Dimension(klevi) :: veci ! initial vec array
- Real(Kind=jprb), Intent(inout), Dimension(klevf) :: vecf ! final vec array
- ! Direct model arrays
- Real(Kind=jprb), Intent(in), Dimension(klevi) :: presi_d ! initial grid
- Real(Kind=jprb), Intent(in), Dimension(klevf) :: presf_d ! final grid
- Real(Kind=jprb), Intent(in), Dimension(klevi) :: veci_d ! initial vec array
- Real(Kind=jprb), Intent(out), Dimension(klevf) :: vecf_d ! final vec array
-
- !
-
-
- ! Local scalars :
- !
- Integer(Kind=jpim) :: jki, jkf
- Real(Kind=jprb) :: slope, t1, t2, p1, p2, lp1, lp2
- Real(Kind=jprb) :: slope_d, t1_d, t2_d, p1_d, p2_d, lp1_d, lp2_d
- Real(Kind=jprb), Dimension(klevi,klevf) :: slope_d2
- Real(Kind=jprb), Dimension(klevf,klevi+1) :: zradt
- Real(Kind=jprb), Dimension(klevi) :: lpresi
- Real(Kind=jprb), Dimension(klevf) :: lpresf
- Real(Kind=jprb), Dimension(klevi) :: lpresi_d
- Real(Kind=jprb), Dimension(klevf) :: lpresf_d
- !
-
- !- End of header --------------------------------------------------------
-
- !
- ! -- Direct computation
- !
-
- vecf_d(:) = -1000._JPRB
- zradt(:,:) = -1000._JPRB
- lpresi_d(:) = Log( presi_d(:) )
- lpresf_d(:) = Log( presf_d(:) )
-
- Do jkf = 1,klevf
- Do jki = 1,klevi-1
- p1_d = presi_d(jki)
- p2_d = presi_d(jki+1)
- lp1_d = lpresi_d(jki)
- lp2_d = lpresi_d(jki+1)
- If (presf_d(jkf) >= p1_d .And. presf_d(jkf) < p2_d) Then
- t1_d = veci_d(jki)
- t2_d = veci_d(jki+1)
- slope_d = (t1_d-t2_d)/(lp1_d-lp2_d)
- If (t2_d == 0._JPRB) Then
- slope_d2(jki,jkf) = 0._JPRB
- Else
- slope_d2(jki,jkf) = slope_d
- Endif
- vecf_d(jkf) = t1_d + slope_d2(jki,jkf)*(lpresf_d(jkf)-lp1_d)
- zradt(jkf,jki) = 0._JPRB
- !
- Else If (jki == 1 .And. presf_d(jkf) < p1_d) Then
- vecf_d(jkf) = veci_d(jki)
- zradt(jkf,jki) = 0._JPRB
- Else If (jki == (klevi-1) .And. vecf_d(jkf) == -1000._JPRB ) Then
- vecf_d(jkf) = veci_d(klevi)
- End If
- zradt(jkf,jki+1) = zradt(jkf,jki)
- End Do
- End Do
-
- !
- ! -- Adjoint computation
- !
-
- lpresi(:) = 0._JPRB
- lpresf(:) = 0._JPRB
- Do jkf = klevf,1,-1
- Do jki = klevi-1, 1, -1
- p1 = 0._JPRB
- p2 = 0._JPRB
- lp1 = 0._JPRB
- lp2 = 0._JPRB
- p1_d = presi_d(jki)
- p2_d = presi_d(jki+1)
- lp1_d = lpresi_d(jki)
- lp2_d = lpresi_d(jki+1)
- If (presf_d(jkf) >= p1_d .And. presf_d(jkf) < p2_d) Then
- t1_d = veci_d(jki)
- t2_d = veci_d(jki+1)
- t1 = 0._JPRB
- t2 = 0._JPRB
- slope = 0._JPRB
- !
- t1 = t1 + vecf(jkf)
- slope = slope + (lpresf_d(jkf)-lp1_d) * vecf(jkf)
- lpresf(jkf) = lpresf(jkf) + slope_d2(jki,jkf) * vecf(jkf)
- lp1 = lp1 - slope_d2(jki,jkf) * vecf(jkf)
- vecf(jkf) = 0._JPRB
- If (t2_d == 0._JPRB) slope = 0._JPRB
- t1 = t1 + slope / (lp1_d-lp2_d)
- t2 = t2 - slope / (lp1_d-lp2_d)
- lp1 = lp1 - slope * (t1_d-t2_d)/(lp1_d-lp2_d)/(lp1_d-lp2_d)
- lp2 = lp2 + slope * (t1_d-t2_d)/(lp1_d-lp2_d)/(lp1_d-lp2_d)
- veci(jki+1) = veci(jki+1) + t2
- t2 = 0._JPRB
- veci(jki) = veci(jki) + t1
- t1 = 0._JPRB
- Else If (jki == 1 .And. presf_d(jkf) < p1_d) Then
- veci(jki) = veci(jki) + vecf(jkf)
- vecf(jkf) = 0._JPRB
- Else If (jki == (klevi-1) .And. zradt(jkf,jki) == -1000._JPRB ) Then
- veci(klevi) = veci(klevi) + vecf(jkf)
- vecf(jkf) = 0._JPRB
- End If
- lpresi(jki+1) = lpresi(jki+1) + lp2
- lpresi(jki) = lpresi(jki) + lp1
- presi(jki+1) = presi(jki+1) + p2
- presi(jki) = presi(jki) + p1
- End Do
- End Do
-
- presf(:) = presf(:) + lpresf(:)/presf_d(:)
- presi(:) = presi(:) + lpresi(:)/presi_d(:)
-
-
-
-End Subroutine rttov_intex_ad
diff --git a/src/LIB/RTTOV/src/rttov_intex_ad.interface b/src/LIB/RTTOV/src/rttov_intex_ad.interface
deleted file mode 100644
index 1ed026f78fd1f0f72e2448928eae9c5cdd94d29e..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_intex_ad.interface
+++ /dev/null
@@ -1,32 +0,0 @@
-Interface
-Subroutine rttov_intex_ad( &
- & klevi, & ! in
- & klevf, & ! in
- & presi, & ! inout AD
- & presf, & ! inout AD
- & veci, & ! inout AD
- & vecf, & ! inout AD
- & presi_d,& ! in
- & presf_d,& ! in
- & veci_d, & ! in
- & vecf_d ) ! out
-
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
- Integer(Kind=jpim), Intent(in) :: klevi ! number of levels of the initial grid
- Integer(Kind=jpim), Intent(in) :: klevf ! number of levels of the final grid
- Real(Kind=jprb), Intent(inout), Dimension(klevi) :: presi ! initial grid
- Real(Kind=jprb), Intent(inout), Dimension(klevf) :: presf ! final grid
- Real(Kind=jprb), Intent(inout), Dimension(klevi) :: veci ! initial vec array
- Real(Kind=jprb), Intent(inout), Dimension(klevf) :: vecf ! final vec array
- Real(Kind=jprb), Intent(in), Dimension(klevi) :: presi_d ! initial grid
- Real(Kind=jprb), Intent(in), Dimension(klevf) :: presf_d ! final grid
- Real(Kind=jprb), Intent(in), Dimension(klevi) :: veci_d ! initial vec array
- Real(Kind=jprb), Intent(out), Dimension(klevf) :: vecf_d ! final vec array
-
-
-
-End Subroutine rttov_intex_ad
-End Interface
diff --git a/src/LIB/RTTOV/src/rttov_intex_tl.F90 b/src/LIB/RTTOV/src/rttov_intex_tl.F90
deleted file mode 100644
index d3dc1d1df5cb898748069423fb437c6b15bb3e95..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_intex_tl.F90
+++ /dev/null
@@ -1,130 +0,0 @@
-Subroutine rttov_intex_tl( &
- & klevi, &! in
- & klevf, &! in
- & presi, &! in TL
- & presf, &! in TL
- & veci, &! in TL
- & vecf, &! inout TL
- & presi_d, &! in
- & presf_d, &! in
- & veci_d, &! in
- & vecf_d ) ! out
-
- !
- ! This software was developed within the context of
- ! the EUMETSAT Satellite Application Facility on
- ! Numerical Weather Prediction (NWP SAF), under the
- ! Cooperation Agreement dated 25 November 1998, between
- ! EUMETSAT and the Met Office, UK, by one or more partners
- ! within the NWP SAF. The partners in the NWP SAF are
- ! the Met Office, ECMWF, KNMI and MeteoFrance.
- !
- ! Copyright 2002, EUMETSAT, All Rights Reserved.
- !
- ! Description:
- ! AD of routine
- ! to interpolate the array vec from the presi levels to the presf levels
- !
- ! Method:
- ! Linear interpolation in ln(P)
- !
- ! Current Code Owner: SAF NWP
- !
- ! History:
- ! Version Date Comment
- ! ------- ---- -------
- ! 1 03/2001 Original code (F. Chevallier)
- ! 1.1 29/03/2005 Add end of header comment (J. Cameron)
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
- !
- ! Subroutine arguments
- !
- Integer(Kind=jpim), Intent(in) :: klevi ! number of levels of the initial grid
- Integer(Kind=jpim), Intent(in) :: klevf ! number of levels of the final grid
- !
- ! TL arrays
- Real(Kind=jprb), Intent(in), Dimension(klevi) :: presi ! initial grid
- Real(Kind=jprb), Intent(in), Dimension(klevf) :: presf ! final grid
- Real(Kind=jprb), Intent(in), Dimension(klevi) :: veci ! initial vec array
- Real(Kind=jprb), Intent(inout), Dimension(klevf) :: vecf ! final vec array
- ! Direct model arrays
- Real(Kind=jprb), Intent(in), Dimension(klevi) :: presi_d ! initial grid
- Real(Kind=jprb), Intent(in), Dimension(klevf) :: presf_d ! final grid
- Real(Kind=jprb), Intent(in), Dimension(klevi) :: veci_d ! initial vec array
- Real(Kind=jprb), Intent(out), Dimension(klevf) :: vecf_d ! final vec array
-
- !
-
-
- ! Local scalars :
- !
- Integer(Kind=jpim) :: jki, jkf
- Real(Kind=jprb) :: slope, t1, t2, p1, p2, lp1, lp2
- Real(Kind=jprb) :: slope_d, t1_d, t2_d, p1_d, p2_d, lp1_d, lp2_d
- !Real, Dimension(klevf,klevi+1) :: zradt
- !Real, Dimension(klevi) :: lpresi
- Real(Kind=jprb), Dimension(klevf) :: lpresf
- Real(Kind=jprb), Dimension(klevi) :: lpresi_d
- Real(Kind=jprb), Dimension(klevf) :: lpresf_d
- !
-
- !- End of header --------------------------------------------------------
-
- !
- ! -- Direct computation
- !
-
- vecf(:) = -1000._JPRB
- vecf_d(:) = -1000._JPRB
- !zradt(:,:) = -1000.
- !lpresi(:) = presi(:)/presi_d(:)
- lpresf(:) = presf(:)/presf_d(:)
- lpresi_d(:) = Log( presi_d(:) )
- lpresf_d(:) = Log( presf_d(:) )
-
- Do jkf = 1,klevf
- Do jki = 1,klevi-1
- p1 = presi(jki)
- p1_d = presi_d(jki)
- p2 = presi(jki+1)
- p2_d = presi_d(jki+1)
- lp1 = p1/p1_d
- !lp1_d = Log(p1_d)
- lp1_d = lpresi_d(jki)
- lp2 = p2/p2_d
- !lp2_d = Log(p2_d)
- lp2_d = lpresi_d(jki+1)
- If (presf_d(jkf) >= p1_d .And. presf_d(jkf) < p2_d) Then
- t1 = veci(jki)
- t1_d = veci_d(jki)
- t2 = veci(jki+1)
- t2_d = veci_d(jki+1)
- slope = ((t1-t2)*(lp1_d-lp2_d)-(t1_d-t2_d)*(lp1-lp2))&
- & /(lp1_d-lp2_d)/(lp1_d-lp2_d)
- slope_d = (t1_d-t2_d)/(lp1_d-lp2_d)
- If (t2_d == 0._JPRB) Then
- slope = 0._JPRB
- slope_d = 0._JPRB
- Endif
- vecf(jkf) = t1 + slope_d*(lpresf(jkf)-lp1) + slope*(lpresf_d(jkf)-lp1_d)
- vecf_d(jkf) = t1_d + slope_d*(lpresf_d(jkf)-lp1_d)
- !zradt(jkf,jki) = 0.
- !
- Else If (jki == 1 .And. presf_d(jkf) < p1_d) Then
- vecf(jkf) = veci(jki)
- vecf_d(jkf) = veci_d(jki)
- !zradt(jkf,jki) = 0.
- Else If (jki == (klevi-1) .And. vecf_d(jkf) == -1000._JPRB ) Then
- vecf(jkf) = veci(klevi)
- vecf_d(jkf) = veci_d(klevi)
- End If
- !zradt(jkf,jki+1) = zradt(jkf,jki)
- End Do
- End Do
-
-
-
-End Subroutine rttov_intex_tl
diff --git a/src/LIB/RTTOV/src/rttov_intex_tl.interface b/src/LIB/RTTOV/src/rttov_intex_tl.interface
deleted file mode 100644
index 86be9d492c2930262a02ab8602c58451d30d43ca..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_intex_tl.interface
+++ /dev/null
@@ -1,32 +0,0 @@
-Interface
-Subroutine rttov_intex_tl( &
- & klevi, & ! in
- & klevf, & ! in
- & presi, & ! in TL
- & presf, & ! in TL
- & veci, & ! in TL
- & vecf, & ! inout TL
- & presi_d,& ! in
- & presf_d,& ! in
- & veci_d, & ! in
- & vecf_d ) ! out
-
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
- Integer(Kind=jpim), Intent(in) :: klevi ! number of levels of the initial grid
- Integer(Kind=jpim), Intent(in) :: klevf ! number of levels of the final grid
- Real(Kind=jprb), Intent(in), Dimension(klevi) :: presi ! initial grid
- Real(Kind=jprb), Intent(in), Dimension(klevf) :: presf ! final grid
- Real(Kind=jprb), Intent(in), Dimension(klevi) :: veci ! initial vec array
- Real(Kind=jprb), Intent(inout), Dimension(klevf) :: vecf ! final vec array
- Real(Kind=jprb), Intent(in), Dimension(klevi) :: presi_d ! initial grid
- Real(Kind=jprb), Intent(in), Dimension(klevf) :: presf_d ! final grid
- Real(Kind=jprb), Intent(in), Dimension(klevi) :: veci_d ! initial vec array
- Real(Kind=jprb), Intent(out), Dimension(klevf) :: vecf_d ! final vec array
-
-
-
-End Subroutine rttov_intex_tl
-End Interface
diff --git a/src/LIB/RTTOV/src/rttov_intext_prof.F90 b/src/LIB/RTTOV/src/rttov_intext_prof.F90
deleted file mode 100644
index 6b4b9ef6f3e22d97ca7273a1fd95c97ac62cf68a..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_intext_prof.F90
+++ /dev/null
@@ -1,568 +0,0 @@
-Subroutine rttov_intext_prof( &
- & profile_in , &! in
- & profile_out , &! inout
- & errorstatus ) ! out
- ! Description:
- ! This routine is for use with the cloud test programs (main_testad and main_testk)
- !
- ! Interpolate and extrapolate an input profile to an output profile
- ! pressure levels
- ! Interpoaltion is spline (or log if rttov_intex is uncommented)
- ! Extrapolation below lowest input level :
- ! adiabatic heating, constant relative humidity, constant O3, CO2 profiles
- ! Extrapolation above highest input level
- ! linear extrapolation in T, Q, O3, CO2
- !
- ! Output pressures and number of levels should be initialised
- ! Cloud liquid water is NOT interpolated/extrapolated
- !
- ! The input surface pressure should be greater than the highest atmospheric
- ! pressure level. This is due to the construction of the arrays for further
- ! interpolation. This limitation could be removed if the surface pressure
- ! is not part of the extrapolation system.
- !
- ! Copyright:
- ! This software was developed within the context of
- ! the EUMETSAT Satellite Application Facility on
- ! Numerical Weather Prediction (NWP SAF), under the
- ! Cooperation Agreement dated 25 November 1998, between
- ! EUMETSAT and the Met Office, UK, by one or more partners
- ! within the NWP SAF. The partners in the NWP SAF are
- ! the Met Office, ECMWF, KNMI and MeteoFrance.
- !
- ! Copyright 2002, EUMETSAT, All Rights Reserved.
- !
- ! Method:
- !
- ! Current Code Owner: SAF NWP
- !
- ! History:
- ! Version Date Comment
- ! ------- ---- -------
- ! 1.0 2002 original (F. Chevalier)
- ! 1.1 01/2003 change rh calculation, add CO2 and
- ! insert rttov_intex calls in comment (P Brunel)
- ! 1.2 08/2006 add test on input surface pressure and
- ! add return status (P. Brunel)
- ! g95 need _jpim adding to some integers
- !
- ! Code Description:
- ! Language: Fortran 90.
- ! Software Standards: "European Standards for Writing and
- ! Documenting Exchangeable Fortran 90 Code".
- !
- ! Declarations:
- ! Modules used:
- Use rttov_const, Only : &
- errorstatus_success,&
- errorstatus_fatal
-
- ! Imported Type Definitions:
- Use rttov_types, Only : &
- & profile_Type
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
-!#include "rttov_intex.interface"
-
- !subroutine arguments:
- Type(profile_Type), Intent(in) :: profile_in
- Type(profile_Type), Intent(inout) :: profile_out
- Integer(Kind=jpim), Intent(out) :: errorstatus
-
-
-
- !local variables:
- Real(Kind=jprb) :: presfin( profile_in%nlevels + profile_out%nlevels )
- Real(Kind=jprb) :: tfin( profile_in%nlevels + profile_out%nlevels )
- Real(Kind=jprb) :: wvvmfin( profile_in%nlevels + profile_out%nlevels )
- Real(Kind=jprb) :: o3vmfin( profile_in%nlevels + profile_out%nlevels )
- Real(Kind=jprb) :: co2vmfin(profile_in%nlevels + profile_out%nlevels )
- Real(Kind=jprb) :: arx( profile_in%nlevels + profile_out%nlevels )
- Real(Kind=jprb) :: ary( profile_in%nlevels + profile_out%nlevels )
- Real(Kind=jprb) :: textr( profile_out%nlevels )
- Real(Kind=jprb) :: aryint( profile_out%nlevels )
- Real(Kind=jprb) :: as( 5, profile_in%nlevels + profile_out%nlevels )
-
- Integer(Kind=jpim) :: klevm
- Integer(Kind=jpim) :: nlevels
- Integer(Kind=jpim) :: levbot
- Integer(Kind=jpim) :: levtop
- Integer(Kind=jpim) :: index
- Integer(Kind=jpim) :: i, j
- Integer(Kind=jpim) :: jlev
- Real(Kind=jprb) :: es
- Real(Kind=jprb) :: wvvs
- Real(Kind=jprb) :: rh
- Real(Kind=jprb) :: const
- Real(Kind=jprb) :: psurf
- Real(Kind=jprb) :: gradt, gradq, grado, gradco2
-
-! Integer(Kind=jpim) :: errorstatus
- Character (len=80) :: errMessage
- Character (len=18) :: NameOfRoutine = 'rttov_intext_prof '
- !- End of header --------------------------------------------------------
-
- errorstatus = errorstatus_success
-
- ! Profile_out should have pressure array and the
- ! number of levels already filled
-
- ! Q and O3 units are ppmv
-
- klevm = profile_in % nlevels
- nlevels = profile_out % nlevels
- psurf = profile_in % s2m % p
-
- ! check if surface pressure is higer or equal to the lowest input
- ! pressure level
- If( profile_in % s2m % p < profile_in % p(klevm) ) Then
- errorstatus = errorstatus_fatal
- Write( errMessage, '( "surface pressure lower than highest pressure level")' )
- Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine)
- Return
- End If
-
- ! Beware NO interpolation of cloud liquid water profile
- ! If CLW array already associated with memory, then fill with 0.
- profile_out % clw_Data = .False.
- If( Associated( profile_out % clw) ) Then
- profile_out % clw(:) = 0._JPRB
- End If
- profile_out % ozone_Data = profile_in % ozone_Data
- profile_out % co2_Data = profile_in % co2_Data
- profile_out % zenangle = profile_in % zenangle
- profile_out % ctp = profile_in % ctp
- profile_out % cfraction = profile_in % cfraction
- profile_out % s2m = profile_in % s2m
- profile_out % skin = profile_in % skin
-
-
-
- presfin(1:klevm) = profile_in % p(1:klevm)
-
- tfin(1:klevm) = profile_in % t(1:klevm)
- wvvmfin(1:klevm) = profile_in % q(1:klevm)
-
- tfin(klevm+1) = profile_in % s2m % t
- wvvmfin(klevm+1) = profile_in % s2m % q
-
- If( profile_out % ozone_Data ) Then
- o3vmfin(1:klevm) = profile_in % o3(1:klevm)
- o3vmfin(klevm+1) = profile_in % s2m % o
- End If
-
- If( profile_out % co2_Data ) Then
- co2vmfin(1:klevm) = profile_in % co2(1:klevm)
- co2vmfin(klevm+1) = profile_in % co2(klevm)
- End If
-
- levbot=0
- Do i=1,profile_out % nlevels
- If(profile_out % p(i) > profile_in % s2m % p ) Then
- levbot=i
- Exit
- Endif
- Enddo
-
- index = klevm
- If (levbot /= 0 ) Then
- !-----Extrapolates temperature below surface pressure-------------------
- !----- => adiabatic heating
-
- const= 287._JPRB/1005._JPRB
- Do i = levbot, nlevels
- textr(i)=profile_out % s2m % t * (profile_out % p(i)/psurf)**const
- Enddo
-
- index=nlevels-levbot+1
- index=index+klevm+1
- tfin((klevm+2):index)= textr(levbot:nlevels)
-
- presfin((klevm+1)) = psurf
- presfin((klevm+2):index) = profile_out % p(levbot:nlevels)
-
- !-----Extrapolates water vapour below surface pressure------------------
- !----- => constant relative humidity
-
- ! Saturated vapour pressure im mb
- es = svp(profile_in % s2m % t)
-
- ! volume mixing ratio for saturation (no unit)
- wvvs = es / psurf
-
- ! relative humidity at 2m
- rh = profile_out % s2m % q * 1e-06 / wvvs
-
-
- Do i = levbot, nlevels
- es = svp(textr(i))
- wvvs = es / profile_out % p(i)
- j = klevm + 2 + i - levbot
- wvvmfin(j) = rh * wvvs * 1e+06
- Enddo
-
- End If
- !-----Extrapolates ozone below surface pressure------------------------
- !----- => constant profile
-
- If( profile_out % ozone_Data ) Then
- o3vmfin((klevm+2):index) = profile_in % o3(klevm)
- End If
-
- !-----Extrapolates CO2 below surface pressure------------------------
- !----- => constant profile
- If( profile_out % co2_Data ) Then
- co2vmfin((klevm+2):index) = profile_in % co2(klevm)
- End If
-
- !-----Extrapolates profile above highest declared level-----------------
- !----- => linear extrapolation -----------------------------------------
-
- levtop = 1
- Do jlev = 1, index
- If(profile_out % p(jlev) >= profile_in % p(1) ) Exit
- levtop = levtop + 1
- Enddo
-
- If (levtop /= 1) Then
- gradt = (tfin(1) - tfin(2)) / (presfin(1)-presfin(2))
- gradq = (wvvmfin(1) - wvvmfin(2)) / (presfin(1)-presfin(2))
- Do jlev=index, 1, -1
- tfin(jlev+levtop-1) = tfin(jlev)
- wvvmfin(jlev+levtop-1) = wvvmfin(jlev)
- presfin(jlev+levtop-1) = presfin(jlev)
- Enddo
-
- index = index + levtop-1
- Do jlev=1,levtop-1
- presfin(jlev) = profile_out % p(jlev)
- tfin(jlev) = tfin(levtop) &
- & + gradt * (presfin(jlev) - presfin(levtop))
- wvvmfin(jlev) = wvvmfin(levtop) &
- & + gradq * (presfin(jlev) - presfin(levtop))
- Enddo
- Endif
-
- If (levtop /= 1 .And. profile_out % ozone_Data) Then
- grado = (o3vmfin(1) - o3vmfin(2)) / (presfin(1)-presfin(2))
- Do jlev=index, 1, -1
- o3vmfin(jlev+levtop-1) = o3vmfin(jlev)
- Enddo
-
- Do jlev=1,levtop-1
- presfin(jlev) = profile_out % p(jlev)
- o3vmfin(jlev) = o3vmfin(levtop) &
- & + grado * (presfin(jlev) - presfin(levtop))
- Enddo
- Endif
-
- If (levtop /= 1 .And. profile_out % co2_Data) Then
- gradco2 = (co2vmfin(1) - co2vmfin(2)) / (presfin(1)-presfin(2))
- Do jlev=index, 1, -1
- co2vmfin(jlev+levtop-1) = co2vmfin(jlev)
- Enddo
-
- Do jlev=1,levtop-1
- presfin(jlev) = profile_out % p(jlev)
- co2vmfin(jlev) = co2vmfin(levtop) &
- & + gradco2 * (presfin(jlev) - presfin(levtop))
- Enddo
- Endif
-
- !-----Interpolates to given pressure grid-------------------------------
-
- arx(1:index)=presfin(1:index)
-
- ary(1:index)=tfin(1:index)
-
- Call spline(arx,ary,profile_out%p,aryint,as,index,nlevels,1_jpim)
- !call rttov_intex(index, nlevels, arx, profile_out%p, ary,aryint)
- profile_out%t(:)=aryint(:)
-
- ary(1:index)=wvvmfin(1:index)
- Call spline(arx,ary,profile_out%p,aryint,as,index,nlevels,1_jpim)
- !call rttov_intex(index, nlevels, arx, profile_out%p, ary,aryint)
- profile_out%q(:)=aryint(:)
-
- !-----Spline interpolation may exceptionnally give negative values------
- !-----for water vapour profiles-----------------------------------------
- !----- => correction
- Do i=1,nlevels
- If (profile_out%q(i) <= 0._JPRB ) profile_out%q(i) = 1.e-03_JPRB
- Enddo
-
-
- If( profile_out % ozone_Data ) Then
- ary(1:index)=o3vmfin(1:index)
- Call spline(arx,ary,profile_out%p,aryint,as,index,nlevels,1_jpim)
- !call rttov_intex(index, nlevels, arx, profile_out%p, ary,aryint)
- profile_out%o3(:)=aryint(:)
- Do i=1,nlevels
- If (profile_out%o3(i) <= 0._JPRB ) profile_out%o3(i) = 1.e-06_JPRB
- Enddo
- Endif
-
-
- If( profile_out % co2_Data ) Then
- ary(1:index)=co2vmfin(1:index)
- Call spline(arx,ary,profile_out%p,aryint,as,index,nlevels,1_jpim)
- !call rttov_intex(index, nlevels, arx, profile_out%p, ary,aryint)
- profile_out%co2(:)=aryint(:)
- Do i=1,nlevels
- If (profile_out%co2(i) <= 0._JPRB ) profile_out%co2(i) = 1.e-06_JPRB
- Enddo
- Endif
-
-
-CONTAINS
-!------------------------------------
-! Saturated vapour pressure im mb
- function svp(temp)
-!
-! This software was developed within the context of
-! the EUMETSAT Satellite Application Facility on
-! Numerical Weather Prediction (NWP SAF), under the
-! Cooperation Agreement dated 25 November 1998, between
-! EUMETSAT and the Met Office, UK, by one or more partners
-! within the NWP SAF. The partners in the NWP SAF are
-! the Met Office, ECMWF, KNMI and MeteoFrance.
-!
-! Copyright 2002, EUMETSAT, All Rights Reserved.
-!
-! Description:
-! Calculates saturated vapour pressure in mb given temperature in K.
-! Value corresponds to SVP over water for temperatures grater than 5 DEG,
-! to SVP over ice for temperatures less that 8 DEG., and to transitional
-! values between.
-!
-! Method:
-! This is the formula used by MET.O.11 AND MET.O.2B.
-!
-! Owner:
-! Marco Matricardi
-!
-! History:
-! Version Date Comment
-! 1 16-8-1999 Marco Matricardi. ECMWF
-!
-! Code description:
-! Language: Fortran 90.
-! Software Standards: "European Standards for Writing and Documenting
-! Exchangeable Fortran 90 code".
-!
-
-
- Use parkind1, Only : jpim ,jprb
- implicit none
-
-! Function type:
- Real(Kind=jprb) :: svp
-
-! Function arguments:
-
-! Scalar arguments with intent in:
- Real(Kind=jprb), intent(in) :: temp
-
-! End of function arguments
-
-
-
-
-! Local arrays:
- Real(Kind=jprb) :: estab(156)
-
-
-
-! Local scalars:
- Real(Kind=jprb) :: tt
- Real(Kind=jprb) :: e0
- Real(Kind=jprb) :: e1
- Integer(Kind=jpim) :: ind
- Integer(Kind=jpim) :: t0
-
-!-----End of header-----------------------------------------------------
-
- data estab(1:60) / &
- & 9.672e-5_JPRB,1.160e-4_JPRB,1.388e-4_JPRB,1.658e-4_JPRB,1.977e-4_JPRB,2.353e-4_JPRB, &
- & 2.796e-4_JPRB,3.316e-4_JPRB,3.925e-4_JPRB,4.638e-4_JPRB,5.472e-4_JPRB,6.444e-4_JPRB, &
- & 7.577e-4_JPRB,8.894e-4_JPRB,1.042e-3_JPRB,1.220e-3_JPRB,1.425e-3_JPRB,1.662e-3_JPRB, &
- & 1.936e-3_JPRB,2.252e-3_JPRB,2.615e-3_JPRB,3.032e-3_JPRB,3.511e-3_JPRB,4.060e-3_JPRB, &
- & 4.688e-3_JPRB,5.406e-3_JPRB,6.225e-3_JPRB,7.159e-3_JPRB,8.223e-3_JPRB,9.432e-3_JPRB, &
- & 1.080e-2_JPRB,1.236e-2_JPRB,1.413e-2_JPRB,1.612e-2_JPRB,1.838e-2_JPRB,2.092e-2_JPRB, &
- & 2.380e-2_JPRB,2.703e-2_JPRB,3.067e-2_JPRB,3.476e-2_JPRB,3.935e-2_JPRB,4.449e-2_JPRB, &
- & 5.026e-2_JPRB,5.671e-2_JPRB,6.393e-2_JPRB,7.198e-2_JPRB,8.097e-2_JPRB,9.098e-2_JPRB, &
- & 1.021e-1_JPRB,1.145e-1_JPRB,1.283e-1_JPRB,1.436e-1_JPRB,1.606e-1_JPRB,1.794e-1_JPRB, &
- & 2.002e-1_JPRB,2.233e-1_JPRB,2.488e-1_JPRB,2.769e-1_JPRB,3.079e-1_JPRB,3.421e-1_JPRB/
-
- data estab(61:120) / &
- & 3.798e-1_JPRB,4.213e-1_JPRB,4.669e-1_JPRB,5.170e-1_JPRB,5.720e-1_JPRB,6.323e-1_JPRB, &
- & 6.985e-1_JPRB,7.709e-1_JPRB,8.502e-1_JPRB,9.370e-1_JPRB, 1.032_JPRB, 1.135_JPRB, &
- & 1.248_JPRB, 1.371_JPRB, 1.506_JPRB, 1.652_JPRB, 1.811_JPRB, 1.984_JPRB, &
- & 2.172_JPRB, 2.376_JPRB, 2.597_JPRB, 2.889_JPRB, 3.097_JPRB, 3.522_JPRB, &
- & 3.8619_JPRB, 4.2148_JPRB, 4.5451_JPRB, 4.8981_JPRB, 5.2753_JPRB, 5.678_JPRB, &
- & 6.1078_JPRB, 6.5662_JPRB, 7.0547_JPRB, 7.5753_JPRB, 8.1294_JPRB, 8.7192_JPRB, &
- & 9.3465_JPRB, 10.013_JPRB, 10.722_JPRB, 11.474_JPRB, 12.272_JPRB, 13.119_JPRB, &
- & 14.017_JPRB, 14.969_JPRB, 15.977_JPRB, 17.044_JPRB, 18.173_JPRB, 19.367_JPRB, &
- & 20.630_JPRB, 21.964_JPRB, 23.373_JPRB, 24.861_JPRB, 26.430_JPRB, 28.086_JPRB, &
- & 29.831_JPRB, 31.671_JPRB, 33.608_JPRB, 35.649_JPRB, 37.796_JPRB, 40.055_JPRB/
-
- data estab(121:156) / &
- & 42.430_JPRB, 44.927_JPRB, 47.551_JPRB, 50.307_JPRB, 53.200_JPRB, 56.236_JPRB, &
- & 59.422_JPRB, 62.762_JPRB, 66.264_JPRB, 69.934_JPRB, 73.777_JPRB, 77.803_JPRB, &
- & 82.015_JPRB, 86.423_JPRB, 91.034_JPRB, 95.855_JPRB, 100.89_JPRB, 106.16_JPRB, &
- & 111.66_JPRB, 117.40_JPRB, 123.40_JPRB, 129.65_JPRB, 136.17_JPRB, 142.98_JPRB, &
- & 150.07_JPRB, 157.46_JPRB, 165.16_JPRB, 173.18_JPRB, 181.53_JPRB, 190.22_JPRB, &
- & 199.26_JPRB, 208.67_JPRB, 218.45_JPRB, 228.61_JPRB, 239.18_JPRB, 250.16_JPRB/
-
-
- tt=temp-183.15_JPRB ! 183.15_JPRB = 273.15_JPRB - 90
- if (tt.le.0._JPRB) then
- svp=estab(1)
- else
- ind=int(tt)+1
- ind=min(ind,155)
- t0=ind-1
- e0=estab(ind)
- e1=estab(ind+1)
- svp=e0+(tt-t0)*(e1-e0)
- endif
-
- end function svp
-!
-!
- subroutine spline(xi,yi,xo,yo,as,ni,no,ii)
-
-! SPLINE, VERSION OF 17 JUL 81
-! update on Aug 3rd 2006 by P. Brunel (MeteoFrance)
-! do not allow increment of variable l when m reaches maximum
-!
- Use parkind1, Only : jpim ,jprb
-
- implicit none
-
- Integer(Kind=jpim) :: ni, no, ii
- Real(Kind=jprb) :: xi(ni)
- Real(Kind=jprb) :: yi(ni)
- Real(Kind=jprb) :: xo(no)
- Real(Kind=jprb) :: yo(no)
- Real(Kind=jprb) :: as(5,ni)
-
- Integer(Kind=jpim) :: nim1, i, j, k, l, m
- Real(Kind=jprb) :: xm, xn, xx
- Real(Kind=jprb) :: c(4)
-
- if(ii.eq.1) call cubist(ni,xi,yi,as)
- nim1=ni-1
- m=1
- do 150 j=1,no
- xx=xo(j)
- do 100 i=m,nim1
- l=i
- xm=xi(i)
- xn=xi(i+1)
- if(xx.eq.xm) go to 120
- if(xx.eq.xn) go to 110
- if(xx.gt.xm.and.xx.lt.xn) go to 130
- 100 continue
- 110 continue
-
- if(m .le. nim1) l = l+1 ! added by P.Brunel
- !l=l+1 ! removed by P. Brunel
-
- 120 continue
- yo(j)=yi(l)
- m=l
- go to 150
- 130 continue
- do k=1,4
- c(k)=as(k,l)
- enddo
- yo(j)=c(1)+xx*(c(2)+xx*(c(3)+xx*c(4)))
- m=l
- 150 continue
- end subroutine spline
-
- subroutine cubist(n,x,y,as)
-
-! CUBIST, VERSION OF 17 JUL 81
-! CALLED BY 'SPLINE'
-! CUBIC SPLINE GENERATOR BY W.HIBBARD, MOD'D BY H.WOOLF. SECOND DERIV.
-! NOT CONTINUOUS. THE DEGREES OF FREEDOM GAINED ARE USED IN AN
-! ATTEMPT TO AVOID OSCILLATIONS.
-! FIT TO THE POINTS (X(I),Y(I)) I=1,...,N .
-!
-! update on Aug 3rd 2006 by P. Brunel (MeteoFrance)
-! allow subroutine to run properly even if two
-! successive values of x are identical
-! This may occur when surface pressure is identical
-! to the pressure of an atmospheric level
-!
- Use parkind1, Only : jpim ,jprb
- implicit none
- Integer(Kind=jpim) :: n
- Real(Kind=jprb) :: x(n),y(n),as(5,n)
-
- Integer(Kind=jpim) :: m,i
- Real(Kind=jprb) :: t, w, z, s, u, v
- Real(Kind=jprb) :: zs, zq, ws, wq
- Real(Kind=jprb) :: aa, ba, ca, da
- Logical :: flagpb, flagprec ! added by P.Brunel
-
- m=n-1
- flagpb=.false. ! added by P.Brunel
-
- do i=1,m
-
- flagprec = flagpb ! added by P.Brunel
- flagpb = x(i) .eq. x(i+1) ! added by P.Brunel
- if( flagpb )cycle ! added by P.Brunel
-
- if(i .eq. 1) go to 110
- t=(y(i+1)-y(i-1))/(x(i+1)-x(i-1))
- go to 120
- 110 continue
- w=(y(2)+y(3))/2.0_JPRB
- z=(x(2)+x(3))/2.0_JPRB
- t=(w-y(1))/(z-x(1))
- t=2.0_JPRB*(y(2)-y(1))/(x(2)-x(1))-t
- 120 continue
- if(i .eq. m) go to 130
- s=(y(i+2)-y(i))/(x(i+2)-x(i))
- go to 140
- 130 continue
- w=(y(n-1)+y(n-2))/2.0_JPRB
- z=(x(n-1)+x(n-2))/2.0_JPRB
- s=(y(n)-w)/(x(n)-z)
- s=2.0_JPRB*(y(n)-y(n-1))/(x(n)-x(n-1))-s
- 140 continue
- u=y(i+1)
- v=y(i)
- w=(x(i+1)+x(i))/2.0_JPRB
- z=(x(i+1)-x(i))/2.0_JPRB
- zs=z*z
- zq=z*zs
- ws=w*w
- wq=w*ws
- aa=.5*(u+v)-.25*z*(s-t)
- ba=.75*(u-v)/z-.25*(s+t)
- ca=.25*(s-t)/z
- da=.25*(s+t)/zs-.25*(u-v)/zq
- as(1,i)=aa-ba*w+ca*ws-da*wq
- as(2,i)=ba-2.0_JPRB*ca*w+3.0_JPRB*da*ws
- as(3,i)=ca-3.0_JPRB*da*w
- as(4,i)=da
- as(5,i)=0._JPRB
- if(flagprec) then ! test added by P.Brunel
- as(1,i-1) = as(1,i)
- as(2,i-1) = as(2,i)
- as(3,i-1) = as(3,i)
- as(4,i-1) = as(4,i)
- as(5,i-1) = as(5,i)
- end if
- enddo
- end subroutine cubist
-
-
-End Subroutine rttov_intext_prof
diff --git a/src/LIB/RTTOV/src/rttov_intext_prof.interface b/src/LIB/RTTOV/src/rttov_intext_prof.interface
deleted file mode 100644
index 3175a02f2dc6f0c6029afe9d0247d583bd46c3b1..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_intext_prof.interface
+++ /dev/null
@@ -1,20 +0,0 @@
-Interface
-!
-Subroutine rttov_intext_prof( &
- & profile_in , & ! in
- & profile_out , & ! inout
- & errorstatus ) ! out
-
- Use rttov_types, Only : &
- profile_Type
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
- Type(profile_Type), Intent(in) :: profile_in
- Type(profile_Type), Intent(inout) :: profile_out
- Integer(Kind=jpim), Intent(out) :: errorstatus
-
-
-End Subroutine rttov_intext_prof
-End Interface
diff --git a/src/LIB/RTTOV/src/rttov_k.F90 b/src/LIB/RTTOV/src/rttov_k.F90
deleted file mode 100644
index f2439a8bad75862bba062dc8ed2e0051578ad7c5..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_k.F90
+++ /dev/null
@@ -1,981 +0,0 @@
-!
-Subroutine rttov_k( &
- & errorstatus, &! out
- & nfrequencies, &! in
- & nchannels, &! in
- & nbtout, &! in
- & nprofiles, &! in
- & channels, &! in
- & polarisations, &! in
- & lprofiles, &! in
- & profiles, &! in
- & coef, &! in
- & addcloud, &! in
- & switchrad, &! in
- & calcemis, &! in
- & emissivity, &! inout direct model
- & profiles_k, &! inout K mat on profile variables
- & emissivity_k, &! inout K mat on surface emissivity
- & transmission, &! inout K model
- & transmission_k, &! inout K input
- & radiancedata, &! inout direct model (input due to pointers alloc)
- & radiance_k ) ! inout OPTIONAL K radiances
- !
- ! Description:
- ! K matrix of rttov_direct
- ! to compute multi-channel level to space transmittances,
- ! top of atmosphere and level to space radiances and brightness
- ! temperatures and optionally surface emissivities, for many
- ! profiles in a single call, for satellite
- ! infrared or microwave sensors. The code requires a coefficient file
- ! for each sensor for which simulated radiances are requested.
- !
- ! Copyright:
- ! This software was developed within the context of
- ! the EUMETSAT Satellite Application Facility on
- ! Numerical Weather Prediction (NWP SAF), under the
- ! Cooperation Agreement dated 25 November 1998, between
- ! EUMETSAT and the Met Office, UK, by one or more partners
- ! within the NWP SAF. The partners in the NWP SAF are
- ! the Met Office, ECMWF, KNMI and MeteoFrance.
- !
- ! Copyright 2002, EUMETSAT, All Rights Reserved.
- !
- ! Method: The methodology is described in the following:
- !
- ! Eyre J.R. and H.M. Woolf 1988 Transmittance of atmospheric gases
- ! in the microwave region: a fast model. Applied Optics 27 3244-3249
- !
- ! Eyre J.R. 1991 A fast radiative transfer model for satellite sounding
- ! systems. ECMWF Research Dept. Tech. Memo. 176 (available from the
- ! librarian at ECMWF).
- !
- ! Saunders R.W., M. Matricardi and P. Brunel 1999 An Improved Fast Radiative
- ! Transfer Model for Assimilation of Satellite Radiance Observations.
- ! QJRMS, 125, 1407-1425.
- !
- ! Matricardi, M., F. Chevallier and S. Tjemkes 2001 An improved general
- ! fast radiative transfer model for the assimilation of radiance
- ! observations. ECMWF Research Dept. Tech. Memo. 345
- ! (available from the librarian at ECMWF).
- !
- ! Current Code Owner: SAF NWP
- !
- ! History:
- ! Version Date Comment
- ! ------- ---- -------
- ! 1.1 01/12/2002 New F90 code with structures (P Brunel A Smith)
- ! 1.2 02/01/2003 More comments added (R Saunders)
- ! 1.3 24/01/2003 Error return code by input profile (P Brunel)
- ! Add WV Continuum and CO2 capability
- ! 1.4 02/06/2004 Change tests on id_comp_lvl == 7 by tests on
- ! fmv_model_ver (P. Brunel)
- ! 1.5 17/02/2005 Changed to allow calls from RTTOV_SCATT_K and
- ! RTTOV_CLD_K. (A. Collard)
- ! 1.6 24/08/2005 More changes so routine still works for clear
- ! sky RTTOV (R.Saunders)
- !
- ! Code Description:
- ! Language: Fortran 90.
- ! Software Standards: "European Standards for Writing and
- ! Documenting Exchangeable Fortran 90 Code".
- ! A user guide and technical documentation is available at
- ! http://www.metoffice.com/research/interproj/nwpsaf/rtm/index.html
- !
- ! Declarations:
- ! Modules used:
- ! Imported Parameters:
- Use rttov_const, Only : &
- & errorstatus_success ,&
- & errorstatus_warning ,&
- & errorstatus_fatal ,&
- & max_optical_depth ,&
- & sensor_id_mw ,&
- & sensor_id_ir
-
- ! Imported Type Definitions:
- Use rttov_types, Only : &
- & rttov_coef ,&
- & profile_Type ,&
- & geometry_Type ,&
- & predictors_Type,&
- & profile_aux ,&
- & transmission_Type ,&
- & radiance_Type ,&
- & radiance_aux
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
-#include "rttov_errorreport.interface"
-#include "rttov_profout_k.interface"
-#include "rttov_checkinput.interface"
-#include "rttov_profaux.interface"
-#include "rttov_setgeometry.interface"
-#include "rttov_setpredictors.interface"
-#include "rttov_setpredictors_8.interface"
-#include "rttov_transmit.interface"
-#include "rttov_calcemis_ir.interface"
-#include "rttov_calcemis_mw.interface"
-#include "rttov_integrate.interface"
-#include "rttov_profaux_k.interface"
-#include "rttov_setpredictors_k.interface"
-#include "rttov_setpredictors_8_k.interface"
-#include "rttov_transmit_k.interface"
-#include "rttov_calcemis_mw_k.interface"
-#include "rttov_integrate_k.interface"
-
- !subroutine arguments:
- Integer(Kind=jpim), Intent(in) :: nfrequencies
- Integer(Kind=jpim), Intent(in) :: nchannels
- Integer(Kind=jpim), Intent(in) :: nbtout
- Integer(Kind=jpim), Intent(in) :: nprofiles
- Integer(Kind=jpim), Intent(in) :: channels(nfrequencies)
- Integer(Kind=jpim), Intent(in) :: polarisations(nchannels,3)
- Integer(Kind=jpim), Intent(in) :: lprofiles(nfrequencies)
-
- Logical, Intent(in) :: addcloud
- Logical, Intent(in) :: switchrad ! true if input is BT
- Type(profile_Type), Intent(in) :: profiles(nprofiles)
- Type(rttov_coef), Intent(in) :: coef
- Logical, Intent(in) :: calcemis(nchannels)
- Integer(Kind=jpim), Intent(out) :: errorstatus(nprofiles)
- Real(Kind=jprb), Intent(inout) :: emissivity(nchannels)
- Type(transmission_Type), Intent(inout) :: transmission! in because of meme allocation
- Type(radiance_Type), Intent(inout) :: radiancedata! in because of meme allocation
-
-
- Type(profile_Type), Intent(inout) :: profiles_k(nchannels) ! Normally this has size nbtout but is nchannels
- ! for calls from RTTOV_CLD_K and RTTOV_SCATT_K.
- Real(Kind=jprb), Intent(inout) :: emissivity_k(nchannels)
- Type(transmission_Type), Intent(inout) :: transmission_k ! in because of meme allocation
- Type(radiance_Type), Intent(inout), optional :: radiance_k
-
-
-
-
- !local variables:
- Integer(Kind=jpim) :: freq
- Integer(Kind=jpim) :: i, j, ii ! loop index
- Integer(Kind=jpim) :: alloc_status(16) ! memory allocation status
- Logical :: addcosmic ! switch for adding temp of cosmic background
-
-
- Logical :: local_rad_k ! false if an input K radiance is provided
- Real(Kind=jprb) :: reflectivity(nchannels) ! surface reflectivity
- Real(Kind=jprb) :: reflectivity_k(nchannels) ! K surface reflectivity
- Real(Kind=jprb) :: od_layer(coef%nlevels,nchannels) ! layer optical depth
- Real(Kind=jprb) :: opdp_ref(coef%nlevels,nfrequencies) ! layer optical depth before threshold
-
- Character (len=80) :: errMessage
- Character (len=8) :: NameOfRoutine = 'rttov_k '
-
- Type(geometry_Type) :: angles(nprofiles) ! geometry angles
- Type(predictors_Type) :: predictors(nprofiles) ! predictors
- Type(profile_aux) :: aux_prof(nprofiles) ! auxillary profiles informations
-
-
-
- Type(radiance_Type) :: radiancedata_k ! Local structure for K radiances
- Type(predictors_Type) :: predictors_k(nchannels) ! K of above predictors
- Type(profile_aux) :: aux_prof_k(nchannels) ! K of above aux_prof
- Type(radiance_aux) :: auxrad
- Type(profile_Type) :: profiles_k_all(nchannels)
- !- End of header ------------------------------------------------------
-
-
- !-------------
- !0. initialize
- !-------------
-
- errorstatus(:) = errorstatus_success
- alloc_status(:) = 0
-
- !------------------------------------------------------
- !1. check input data is within suitable physical limits
- !------------------------------------------------------
- Do i = 1, nprofiles
-
- Call rttov_checkinput( &
- & profiles( i ), &!in
- & coef, &!in
- & errorstatus(i) ) !out
-
- End Do
-
- ! 1.1 test check input return code
- !-----------------------------_---
- If ( any( errorstatus(:) == errorstatus_warning ) ) Then
- Do i = 1, nprofiles
- If ( errorstatus(i) == errorstatus_warning ) Then
- Write( errMessage, '( "checkinput warning error for profile",i4)' ) i
- Call Rttov_ErrorReport (errorstatus_warning, errMessage, NameOfRoutine)
- End If
- End Do
- End If
-
- If ( any( errorstatus(:) == errorstatus_fatal ) ) Then
- Do i = 1, nprofiles
- If ( errorstatus(i) == errorstatus_fatal ) Then
- ! Some unphysical values; Do not run RTTOV
- Write( errMessage, '( "checkinput fatal error for profile",i4)' ) i
- Call Rttov_ErrorReport (errorstatus_fatal, errMessage, NameOfRoutine)
- End If
- End Do
- ! nothing processed so all profiles get the fatal error code
- ! user will know which profile
- errorstatus(:) = errorstatus_fatal
- Return
- End If
-
-
-
- !-----------------------------------------
- !2. determine cloud top and surface levels
- !-----------------------------------------
- Do i = 1, nprofiles
- If( coef % id_sensor == sensor_id_mw ) Then
- Allocate( aux_prof(i) % debye_prof( 5 , coef%nlevels ), stat= alloc_status(1) )
- If( alloc_status(1) /= 0 ) Then
- errorstatus(:) = errorstatus_fatal
- Write( errMessage, '( "allocation of debye_prof")' )
- Call Rttov_ErrorReport (errorstatus_fatal, errMessage, NameOfRoutine)
- Return
- End If
- Endif
- Call rttov_profaux( &
- & profiles(i), &! in
- & coef, &! in
- & aux_prof(i)) ! inout
- End Do
-
-
-
- !------------------------------------------------------------------
- !3. set up common geometric variables for transmittance calculation
- !------------------------------------------------------------------
-
- Do i = 1, nprofiles
- Call rttov_setgeometry( &
- & profiles(i), &! in
- & coef, &! in
- & angles(i) ) ! out
- End Do
-
-
-
- !------------------------------------------
- !5. calculate transmittance path predictors
- !------------------------------------------
-
- Do i = 1, nprofiles
- predictors(i) % nlevels = coef % nlevels
- predictors(i) % nmixed = coef % nmixed
- predictors(i) % nwater = coef % nwater
- predictors(i) % nozone = coef % nozone
- predictors(i) % nwvcont = coef % nwvcont
- predictors(i) % nco2 = coef % nco2
- predictors(i) % ncloud = 0 ! (can be set to 1 inside setpredictors)
-
- Allocate( predictors(i) % mixedgas&
- & ( coef%nmixed , coef%nlevels ) ,stat= alloc_status(1))
- Allocate( predictors(i) % watervapour&
- & ( coef%nwater , coef%nlevels ) ,stat= alloc_status(2))
- Allocate( predictors(i) % clw&
- & ( coef%nlevels ) ,stat= alloc_status(3))
- If( coef%nozone > 0 ) Then
- Allocate( predictors(i) % ozone&
- & ( coef%nozone , coef%nlevels ) ,stat= alloc_status(4))
- End If
- If( coef%nwvcont > 0 ) Then
- Allocate( predictors(i) % wvcont&
- & ( coef%nwvcont , coef%nlevels ) ,stat= alloc_status(5))
- End If
- If( coef%nco2 > 0 ) Then
- Allocate( predictors(i) % co2&
- & ( coef%nco2 , coef%nlevels ) ,stat= alloc_status(6))
- End If
- If( Any(alloc_status /= 0) ) Then
- errorstatus(:) = errorstatus_fatal
- Write( errMessage, '( "allocation of predictors")' )
- Call Rttov_ErrorReport (errorstatus_fatal, errMessage, NameOfRoutine)
- Return
- End If
-
- If (coef%fmv_model_ver == 7) Then
- Call rttov_setpredictors( &
- & profiles(i), &! in
- & angles(i), &! in
- & coef, &! in
- & predictors(i) ) ! inout (in because of mem allocation)
-
- Else If (coef%fmv_model_ver == 8) Then
- Call rttov_setpredictors_8( &
- & profiles(i), &! in
- & angles(i), &! in
- & coef, &! in
- & predictors(i) ) ! inout (in because of mem allocation)
-
- Else
- errorstatus(:) = errorstatus_fatal
- Write( errMessage,&
- & '( "Unexpected RTTOV compatibility version number" )' )
- Call Rttov_ErrorReport (errorstatus_fatal, errMessage, NameOfRoutine)
- Return
- End If
-
- End Do ! Profile loop
-
-
- !----------------------------------------------
- !6. calculate optical depths and transmittances
- !----------------------------------------------
-
- Call rttov_transmit( &
- & nfrequencies, &! in
- & nchannels, &! in
- & nprofiles, &! in
- & coef%nlevels, &! in
- & channels, &! in
- & polarisations, &! in
- & lprofiles, &! in
- & predictors, &! in
- & aux_prof, &! in
- & coef, &! in
- & transmission, &! inout
- & od_layer, &! out
- & opdp_ref) ! out
-
- !--------------------------------------
- !7. calculate channel emissivity values
- !--------------------------------------
-
- If ( Any(calcemis) ) Then
- ! calculate surface emissivity for selected channels
- ! and reflectivity
- If ( coef % id_sensor == sensor_id_ir ) Then
- !Infrared
- Call rttov_calcemis_ir( &
- & profiles, &! in
- & angles, &! in
- & coef, &! in
- & nfrequencies, &! in
- & nprofiles, &! in
- & channels, &! in
- & lprofiles, &! in
- & calcemis, &! in
- & emissivity ) ! inout
- reflectivity(:) = 1 - emissivity(:)
-
- Elseif ( coef % id_sensor == sensor_id_mw ) Then
- !Microwave
- Call rttov_calcemis_mw ( &
- & profiles, &! in
- & angles, &! in
- & coef, &! in
- & nfrequencies, &! in
- & nchannels, &! in
- & nprofiles, &! in
- & channels, &! in
- & polarisations, &! in
- & lprofiles, &! in
- & transmission, &! in
- & calcemis, &! in
- & emissivity, &! inout
- & reflectivity, &! out
- & errorstatus ) ! out
- If ( Any( errorstatus == errorstatus_fatal ) ) Then
- errorstatus(:) = errorstatus_fatal
- Return
- End If
- Else
- ! Hires
- Call rttov_calcemis_ir( &
- & profiles, &! in
- & angles, &! in
- & coef, &! in
- & nfrequencies, &! in
- & nprofiles, &! in
- & channels, &! in
- & lprofiles, &! in
- & calcemis, &! in
- & emissivity ) ! inout
- reflectivity(:) = 1 - emissivity(:)
- End If
-
- ! reflectivity for other channels
- Where( .Not. calcemis(:) )
- reflectivity(:) = 1 - emissivity(:)
- End Where
-
- Else
- ! reflectivity for all channels
- reflectivity(:) = 1._JPRB - emissivity(:)
- End If
-
-
- !--------------------------------------------
- !8. integrate the radiative transfer equation
- !--------------------------------------------
- allocate(auxrad % layer (coef % nlevels, nchannels),stat= alloc_status(1))
- allocate(auxrad % surfair (nchannels),stat= alloc_status(2))
- allocate(auxrad % skin (nchannels),stat= alloc_status(3))
- allocate(auxrad % cosmic (nchannels),stat= alloc_status(4))
- allocate(auxrad % up (coef % nlevels, nchannels),stat= alloc_status(5))
- allocate(auxrad % down (coef % nlevels, nchannels),stat= alloc_status(6))
- If ( addcloud ) then
- allocate(auxrad % down_cloud (coef % nlevels, nchannels),stat= alloc_status(7))
- End If
- If( Any(alloc_status /= 0) ) Then
- errorstatus(:) = errorstatus_fatal
- Write( errMessage, '( "allocation of aux radiances")' )
- Call Rttov_ErrorReport (errorstatus_fatal, errMessage, NameOfRoutine)
- Return
- End If
-
- addcosmic = ( coef % id_sensor == sensor_id_mw )
- Call rttov_integrate( &
- & addcloud, &! in
- & addcosmic, &! in
- & nfrequencies, &! in
- & nchannels, &! in
- & nbtout, &! in
- & nprofiles, &! in
- & angles, &! in
- & channels, &! in
- & polarisations, &! in
- & lprofiles, &! in
- & emissivity, &! in
- & reflectivity, &! in
- & transmission, &! in
- & profiles, &! in
- & aux_prof, &! in
- & coef, &! in
- & radiancedata, &! inout
- & auxrad ) ! inout
-
-
-
- ! K matrix
- !----------------
-
- !
- ! allocate memory for intermediate variables
- Do i = 1, nchannels
- aux_prof_k(i) % nearestlev_surf = 0 ! no meaning
- aux_prof_k(i) % pfraction_surf = 0._JPRB ! calculated
- aux_prof_k(i) % nearestlev_ctp = 0 ! no meaning
- aux_prof_k(i) % pfraction_ctp = 0._JPRB ! calculated
- aux_prof_k(i) % cfraction = 0._JPRB ! calculated
- If( coef % id_sensor == sensor_id_mw ) Then
- Allocate( aux_prof_k(i) % debye_prof( 5 , coef%nlevels ) ,stat= alloc_status(1))
- If( alloc_status(1) /= 0 ) Then
- errorstatus(:) = errorstatus_fatal
- Write( errMessage, '( "allocation of K debye_prof")' )
- Call Rttov_ErrorReport (errorstatus_fatal, errMessage, NameOfRoutine)
- Return
- End If
- aux_prof_k(i) % debye_prof(:,:) = 0._JPRB
- Endif
- End Do
-
- Do i = 1, nchannels
- freq=polarisations(i, 2)
- j = lprofiles(freq)
- Allocate( predictors_k(i) % mixedgas ( coef%nmixed , coef%nlevels ),stat= alloc_status(1))
- Allocate( predictors_k(i) % watervapour( coef%nwater , coef%nlevels ),stat= alloc_status(2))
- Allocate( predictors_k(i) % clw ( coef%nlevels ) ,stat= alloc_status(3))
- Allocate( profiles_k_all(i) % p(coef%nlevels ) ,stat= alloc_status(1))
- Allocate( profiles_k_all(i) % t(coef%nlevels ) ,stat= alloc_status(1))
- Allocate( profiles_k_all(i) % q(coef%nlevels ) ,stat= alloc_status(1))
- Allocate( profiles_k_all(i) % o3(coef%nlevels ) ,stat= alloc_status(1))
- Allocate( profiles_k_all(i) % clw(coef%nlevels ) ,stat= alloc_status(1))
-
- If( Any(alloc_status /= 0) ) Then
- errorstatus(:) = errorstatus_fatal
- Write( errMessage, '( "allocation of K predictors")' )
- Call Rttov_ErrorReport (errorstatus_fatal, errMessage, NameOfRoutine)
- Return
- End If
-
- If(Present(radiance_k)) Then
-
- local_rad_k = .false.
- Do ii=1, coef%nlevels
- profiles_k_all(i) % clw (ii) = profiles_k(i) % clw (ii)
- profiles_k_all(i) % o3 (ii) = profiles_k(i) % o3 (ii)
- profiles_k_all(i) % t (ii) = profiles_k(i) % t (ii)
- profiles_k_all(i) % q (ii) = profiles_k(i) % q (ii)
- profiles_k_all(i) % p (ii) = profiles_k(i) % p (ii)
- Enddo
- profiles_k_all(i) % s2m % t = profiles_k(i) % s2m % t
- profiles_k_all(i) % s2m % u = profiles_k(i) % s2m % u
- profiles_k_all(i) % s2m % v = profiles_k(i) % s2m % v
- profiles_k_all(i) % s2m % q = profiles_k(i) % s2m % q
- profiles_k_all(i) % s2m % p = profiles_k(i) % s2m % p
- profiles_k_all(i) % skin % t = profiles_k(i) % skin % t
- profiles_k_all(i) % skin % fastem(1) = profiles_k(i) % skin % fastem(1)
- profiles_k_all(i) % skin % fastem(2) = profiles_k(i) % skin % fastem(2)
- profiles_k_all(i) % skin % fastem(3) = profiles_k(i) % skin % fastem(3)
- profiles_k_all(i) % skin % fastem(4) = profiles_k(i) % skin % fastem(4)
- profiles_k_all(i) % skin % fastem(5) = profiles_k(i) % skin % fastem(5)
- profiles_k_all(i) % ctp = profiles_k(i) % ctp
- profiles_k_all(i) % cfraction = profiles_k(i) % cfraction
- profiles_k_all(i) % nlevels = profiles_k(i) % nlevels
- ELSE
- Do ii=1, coef%nlevels
- profiles_k_all(i) % clw (ii) = 0.0_JPRB
- profiles_k_all(i) % o3 (ii) = 0.0_JPRB
- profiles_k_all(i) % t (ii) = 0.0_JPRB
- profiles_k_all(i) % q (ii) = 0.0_JPRB
- profiles_k_all(i) % p (ii) = 0.0_JPRB
- Enddo
- profiles_k_all(i) % s2m % t =0.0_JPRB
- profiles_k_all(i) % s2m % u =0.0_JPRB
- profiles_k_all(i) % s2m % v =0.0_JPRB
- profiles_k_all(i) % s2m % q =0.0_JPRB
- profiles_k_all(i) % s2m % p =0.0_JPRB
- profiles_k_all(i) % skin % t =0.0_JPRB
- profiles_k_all(i) % skin % fastem(1) =0.0_JPRB
- profiles_k_all(i) % skin % fastem(2) =0.0_JPRB
- profiles_k_all(i) % skin % fastem(3) =0.0_JPRB
- profiles_k_all(i) % skin % fastem(4) =0.0_JPRB
- profiles_k_all(i) % skin % fastem(5) =0.0_JPRB
- profiles_k_all(i) % ctp =0.0_JPRB
- profiles_k_all(i) % cfraction =0.0_JPRB
- profiles_k_all(i) % nlevels = coef % nlevels
- END IF
-
- predictors_k(i) % mixedgas(:,:) = 0._JPRB
- predictors_k(i) % watervapour(:,:) = 0._JPRB
- predictors_k(i) % clw(:) = 0._JPRB
- predictors_k(i) % nlevels = predictors(j) % nlevels
- predictors_k(i) % nmixed = predictors(j) % nmixed
- predictors_k(i) % nwater = predictors(j) % nwater
- predictors_k(i) % nozone = predictors(j) % nozone
- predictors_k(i) % nwvcont = predictors(j) % nwvcont
- predictors_k(i) % nco2 = predictors(j) % nco2
- predictors_k(i) % ncloud = predictors(j) % ncloud
-
- If( predictors_k(i) % nozone > 0 ) Then
- Allocate( predictors_k(i) % ozone&
- & ( coef%nozone , coef%nlevels ) ,stat= alloc_status(1))
- If( Any(alloc_status /= 0) ) Then
- errorstatus(:) = errorstatus_fatal
- Write( errMessage, '( "allocation of K predictors")' )
- Call Rttov_ErrorReport (errorstatus_fatal, errMessage, NameOfRoutine)
- Return
- End If
- predictors_k(i) % ozone(:,:) = 0._JPRB
- End If
-
- If( predictors_k(i) % nwvcont > 0 ) Then
- Allocate( predictors_k(i) % wvcont&
- & ( coef%nwvcont , coef%nlevels ) ,stat= alloc_status(1))
- If( Any(alloc_status /= 0) ) Then
- errorstatus(:) = errorstatus_fatal
- Write( errMessage, '( "allocation of K predictors")' )
- Call Rttov_ErrorReport (errorstatus_fatal, errMessage, NameOfRoutine)
- Return
- End If
- predictors_k(i) % wvcont(:,:) = 0._JPRB
- End If
-
- If( predictors_k(i) % nco2 > 0 ) Then
- Allocate( predictors_k(i) % co2&
- & ( coef%nco2 , coef%nlevels ) ,stat= alloc_status(1))
- If( Any(alloc_status /= 0) ) Then
- errorstatus(:) = errorstatus_fatal
- Write( errMessage, '( "allocation of K predictors")' )
- Call Rttov_ErrorReport (errorstatus_fatal, errMessage, NameOfRoutine)
- Return
- End If
- predictors_k(i) % co2(:,:) = 0._JPRB
- End If
- End Do
-
- reflectivity_k(:) = 0._JPRB
-
- !--------------------------------------------
- !8. integrate the radiative transfer equation
- !--------------------------------------------
- If(Present(radiance_k)) Then
-
- ! use the subroutine argument for K radiances
- addcosmic = ( coef % id_sensor == sensor_id_mw )
- Call rttov_integrate_k( &
- & addcloud, &! in
- & addcosmic, &! in
- & switchrad, &! in
- & nfrequencies, &! in
- & nchannels, &! in
- & nbtout, &! in
- & nprofiles, &! in
- & angles, &! in
- & channels, &! in
- & polarisations, &! in
- & lprofiles, &! in
- & emissivity, &! in
- & emissivity_k, &! inout
- & reflectivity, &! in
- & reflectivity_k, &! inout
- & transmission, &! in
- & transmission_k, &! inout
- & profiles, &! in
- & profiles_k_all, &! inout (input only due to mem alloc)
- & aux_prof, &! in
- & aux_prof_k, &! inout
- & coef, &! in
- & radiancedata, &! in
- & auxrad , &! in
- & radiance_k ) ! inout (output if converstion Bt -> rad)
-
- Else
-
-
- local_rad_k = .true.
-
-
- ! create a local structure for input K radiances
- Allocate( radiancedata_k % clear ( nchannels ) ,stat= alloc_status(1))
- Allocate( radiancedata_k % cloudy ( nchannels ) ,stat= alloc_status(2))
- Allocate( radiancedata_k % total ( nchannels ) ,stat= alloc_status(3))
- Allocate( radiancedata_k % bt ( nchannels ) ,stat= alloc_status(4))
- Allocate( radiancedata_k % bt_clear ( nchannels ) ,stat= alloc_status(5))
- Allocate( radiancedata_k % out ( nbtout ) ,stat= alloc_status(4))
- Allocate( radiancedata_k % out_clear( nbtout ) ,stat= alloc_status(5))
- Allocate( radiancedata_k % upclear ( nchannels ) ,stat= alloc_status(6))
- Allocate( radiancedata_k % reflclear( nchannels ) ,stat= alloc_status(7))
- Allocate( radiancedata_k % overcast ( coef % nlevels, nchannels ) ,stat= alloc_status(8))
- Allocate( radiancedata_k % downcld ( coef % nlevels, nchannels ) ,stat= alloc_status(9))
- Allocate( radiancedata_k % total_out ( nbtout ) ,stat= alloc_status(10))
- Allocate( radiancedata_k % clear_out ( nbtout ) ,stat= alloc_status(11))
- If( Any(alloc_status /= 0) ) Then
- errorstatus(:) = errorstatus_fatal
- Write( errMessage, '( "allocation of K radiances")' )
- Call Rttov_ErrorReport (errorstatus_fatal, errMessage, NameOfRoutine)
- Return
- End If
- radiancedata_k % clear(:) = 0._JPRB
- radiancedata_k % clear_out(:) = 0._JPRB
- radiancedata_k % out_clear(:) = 0._JPRB
- radiancedata_k % cloudy(:) = 0._JPRB
- radiancedata_k % bt_clear(:) = 0._JPRB
- radiancedata_k % upclear(:) = 0._JPRB
- radiancedata_k % reflclear(:) = 0._JPRB
- radiancedata_k % overcast(:,:) = 0._JPRB
- radiancedata_k % downcld(:,:) = 0._JPRB
-
- radiancedata_k % bt(:) = 0._JPRB
- radiancedata_k % total(:) = 0._JPRB
- radiancedata_k % out(:) = 1._JPRB
- radiancedata_k % total_out(:) = 1._JPRB
-
- addcosmic = ( coef % id_sensor == sensor_id_mw )
- Call rttov_integrate_k( &
- & addcloud, &! in
- & addcosmic, &! in
- & switchrad, &! in
- & nfrequencies, &! in
- & nchannels, &! in
- & nbtout, &! in
- & nprofiles, &! in
- & angles, &! in
- & channels, &! in
- & polarisations, &! in
- & lprofiles, &! in
- & emissivity, &! in
- & emissivity_k, &! inout
- & reflectivity, &! in
- & reflectivity_k, &! inout
- & transmission, &! in
- & transmission_k, &! inout
- & profiles, &! in
- & profiles_k_all, &! inout (input only due to mem alloc)
- & aux_prof, &! in
- & aux_prof_k, &! inout
- & coef, &! in
- & radiancedata, &! in
- & auxrad , &! in
- & radiancedata_k ) ! inout (output if converstion Bt -> rad)
- Endif
-
-
- If ( Any(calcemis) ) Then
- ! calculate surface emissivity for selected channels
- ! and reflectivity
- If ( coef % id_sensor == sensor_id_ir ) Then
- !Infrared
- emissivity_k(:) = -reflectivity_k(:) + emissivity_k(:)
-
- Elseif ( coef % id_sensor == sensor_id_mw ) Then
- !Microwave
- Call rttov_calcemis_mw_k ( &
- & profiles, &! in
- & profiles_k_all, &! inout
- & angles, &! in
- & coef, &! in
- & nfrequencies, &! in
- & nchannels, &! in
- & nprofiles, &! in
- & channels, &! in
- & polarisations, &! in
- & lprofiles, &! in
- & transmission, &! in
- & transmission_k, &! inout
- & calcemis, &! in
- & emissivity_k, &! inout
- & reflectivity_k ) ! inout
- Else
- ! Hires
- emissivity_k(:) = -reflectivity_k(:) + emissivity_k(:)
- End If
-
- ! reflectivity for other channels
- Where( .Not. calcemis(:) )
- emissivity_k(:) = -reflectivity_k(:) + emissivity_k(:)
- End Where
-
- Else
- ! reflectivity for all channels
- emissivity_k(:) = -reflectivity_k(:) + emissivity_k(:)
- End If
-
- !K of optical depths and transmittances
-
- Call rttov_transmit_k( &
- & nfrequencies, &! in
- & nchannels, &! in
- & nprofiles, &! in
- & coef%nlevels, &! in
- & polarisations, &! in
- & channels, &! in
- & lprofiles, &! in
- & predictors, &! in
- & predictors_k, &! inout
- & aux_prof, &! in
- & aux_prof_k, &! inout
- & coef, &! in
- & od_layer, &! in
- & opdp_ref, &! in
- & transmission, &! in
- & transmission_k ) ! inout
-
- ! K of Predictors RTTOV-7 RTTOV-8
- If (coef%fmv_model_ver == 7) Then
- Call rttov_setpredictors_k( &
- & nfrequencies, &! in
- & nchannels, &! in
- & nprofiles, &! in
- & coef%nlevels, &! in
- & angles, &! in
- & polarisations, &! in
- & lprofiles, &! in
- & profiles, &! in
- & profiles_k_all,&! inout
- & coef, &! in
- & predictors, &! in
- & predictors_k ) ! inout
- Else If (coef%fmv_model_ver == 8) Then
- Call rttov_setpredictors_8_k( &
- & nfrequencies, &! in
- & nchannels, &! in
- & nprofiles, &! in
- & coef%nlevels, &! in
- & angles, &! in
- & polarisations, &! in
- & lprofiles, &! in
- & profiles, &! in
- & profiles_k_all,&! inout
- & coef, &! in
- & predictors, &! in
- & predictors_k ) ! inout
- End If
-
- ! K on cloud top and surface levels
- Call rttov_profaux_k( &
- & nfrequencies, &! in
- & nchannels, &! in
- & nprofiles, &! in
- & polarisations, &! in
- & lprofiles, &! in
- & profiles, &! in
- & profiles_k_all,&! inout
- & coef, &! in
- & aux_prof, &! in
- & aux_prof_k ) ! inout
-
- If (coef % id_sensor == sensor_id_mw .AND. local_rad_k ) Then
- ! We have K wrt all calculated TBs - but user wants K for
- ! instrument channels, so K code only requires an extra routine to modify
- ! output. In AD code we simply exclude unused channels. Note only required
- ! for microwave calculations.
-
- Call rttov_profout_k( &
- & nfrequencies, &! in
- & nchannels, &! in
- & nbtout, &! in
- & nprofiles, &! in
- & channels, &! in
- & lprofiles, &! in
- & polarisations, &! in
- & coef, &! in
- & angles, &! in
- & profiles_k_all, &! in
- & profiles_k) ! Out
-
- Do i = 1, nbtout
- Enddo
-
- Else
- !profiles_k = profiles_k_all
- Do i = 1, nchannels
- profiles_k(i) % nlevels = profiles_k_all(i) % nlevels
- profiles_k(i) % s2m % t = profiles_k_all(i) % s2m % t
- profiles_k(i) % s2m % q = profiles_k_all(i) % s2m % q
- profiles_k(i) % s2m % p = profiles_k_all(i) % s2m % p
- profiles_k(i) % s2m % u = profiles_k_all(i) % s2m % u
- profiles_k(i) % s2m % v = profiles_k_all(i) % s2m % v
- profiles_k(i) % skin % t = profiles_k_all(i) % skin % t
- profiles_k(i) % skin % fastem(1) = profiles_k_all(i) % skin % fastem(1)
- profiles_k(i) % skin % fastem(2) = profiles_k_all(i) % skin % fastem(2)
- profiles_k(i) % skin % fastem(3) = profiles_k_all(i) % skin % fastem(3)
- profiles_k(i) % skin % fastem(4) = profiles_k_all(i) % skin % fastem(4)
- profiles_k(i) % skin % fastem(5) = profiles_k_all(i) % skin % fastem(5)
- profiles_k(i) % ctp = profiles_k_all(i) % ctp
- profiles_k(i) % cfraction = profiles_k_all(i) % cfraction
-
- Do ii=1,coef%nlevels
- profiles_k(i) % t(ii) = profiles_k_all(i) % t(ii)
- profiles_k(i) % q(ii) = profiles_k_all(i) % q(ii)
- profiles_k(i) % o3(ii) = profiles_k_all(i) % o3(ii)
- profiles_k(i) % clw(ii) = profiles_k_all(i) % clw(ii)
- End Do
- End Do
- End If
-
- !--------------------
- !9. deallocate memory
- !--------------------
- Do i = 1, nprofiles
- Deallocate( predictors(i) % mixedgas ,stat= alloc_status(1))
- Deallocate( predictors(i) % watervapour ,stat= alloc_status(2))
- Deallocate( predictors(i) % clw ,stat= alloc_status(3))
- If( predictors(i) % nozone > 0 ) Then
- Deallocate( predictors(i) % ozone ,stat= alloc_status(4))
- End If
- If( predictors(i) % nwvcont > 0 ) Then
- Deallocate( predictors(i) % wvcont ,stat= alloc_status(5))
- End If
- If( predictors(i) % nco2 > 0 ) Then
- Deallocate( predictors(i) % co2 ,stat= alloc_status(6))
- End If
- If( Any(alloc_status /= 0) ) Then
- errorstatus(:) = errorstatus_fatal
- Write( errMessage, '( "deallocation of predictors")' )
- Call Rttov_ErrorReport (errorstatus_fatal, errMessage, NameOfRoutine)
- Return
- End If
- End Do
-
- Do i = 1, nchannels
- Deallocate( predictors_k(i) % mixedgas ,stat= alloc_status(1))
- Deallocate( predictors_k(i) % watervapour ,stat= alloc_status(2))
- Deallocate( predictors_k(i) % clw ,stat= alloc_status(3))
- If( predictors_k(i) % nozone > 0 ) Then
- Deallocate( predictors_k(i) % ozone ,stat= alloc_status(4))
- End If
- If( predictors_k(i) % nwvcont > 0 ) Then
- Deallocate( predictors_k(i) % wvcont ,stat= alloc_status(5))
- End If
- If( predictors_k(i) % nco2 > 0 ) Then
- Deallocate( predictors_k(i) % co2 ,stat= alloc_status(6))
- End If
- If( Any(alloc_status /= 0) ) Then
- errorstatus(:) = errorstatus_fatal
- Write( errMessage, '( "deallocation of K edictors")' )
- Call Rttov_ErrorReport (errorstatus_fatal, errMessage, NameOfRoutine)
- Return
- End If
- End Do
-
- Deallocate(auxrad % layer ,stat= alloc_status(1))
- Deallocate(auxrad % surfair ,stat= alloc_status(2))
- Deallocate(auxrad % skin ,stat= alloc_status(3))
- Deallocate(auxrad % cosmic ,stat= alloc_status(4))
- Deallocate(auxrad % up ,stat= alloc_status(5))
- Deallocate(auxrad % down ,stat= alloc_status(6))
- If ( addcloud ) Then
- Deallocate(auxrad % down_cloud ,stat= alloc_status(7))
- End If
- If( Any(alloc_status /= 0) ) Then
- errorstatus(:) = errorstatus_fatal
- Write( errMessage, '( "deallocation of aux radiances")' )
- Call Rttov_ErrorReport (errorstatus_fatal, errMessage, NameOfRoutine)
- Return
- End If
-
- Do i = 1, nprofiles
- If( coef % id_sensor == sensor_id_mw ) Then
- If( Associated( aux_prof(i) % debye_prof) ) Then
- Deallocate( aux_prof(i) % debye_prof ,stat= alloc_status(1))
- If( Any(alloc_status /= 0) ) Then
- errorstatus(:) = errorstatus_fatal
- Write( errMessage, '( "deallocation of debye profile")' )
- Call Rttov_ErrorReport (errorstatus_fatal, errMessage, NameOfRoutine)
- End If
- End If
- Endif
- End Do
- Do i = 1, nchannels
- If( coef % id_sensor == sensor_id_mw ) Then
- If( Associated( aux_prof_k(i) % debye_prof) ) Then
- Deallocate( aux_prof_k(i) % debye_prof ,stat= alloc_status(1))
- If( Any(alloc_status /= 0) ) Then
- errorstatus(:) = errorstatus_fatal
- Write( errMessage, '( "deallocation of K debye profile")' )
- Call Rttov_ErrorReport (errorstatus_fatal, errMessage, NameOfRoutine)
- End If
- End If
- Endif
- End Do
-
- Do i = 1, nchannels
- If( Associated( profiles_k_all(i) % p )) Then
- Deallocate( profiles_k_all(i) % p ,stat= alloc_status(1))
- Deallocate( profiles_k_all(i) % t ,stat= alloc_status(2))
- Deallocate( profiles_k_all(i) % q ,stat= alloc_status(3))
- Deallocate( profiles_k_all(i) % o3 ,stat= alloc_status(4))
- Deallocate( profiles_k_all(i) % clw ,stat= alloc_status(5))
- If( Any(alloc_status /= 0) ) Then
- errorstatus(:) = errorstatus_fatal
- Write( errMessage, '( "deallocation of profiles_k_all")' )
- Call Rttov_ErrorReport (errorstatus_fatal, errMessage, NameOfRoutine)
- Return
- End If
- End If
- End do
-
- If( local_rad_k ) Then
- Deallocate( radiancedata_k % clear ,stat= alloc_status(1))
- Deallocate( radiancedata_k % cloudy ,stat= alloc_status(2))
- Deallocate( radiancedata_k % total ,stat= alloc_status(3))
- Deallocate( radiancedata_k % bt ,stat= alloc_status(4))
- Deallocate( radiancedata_k % bt_clear ,stat= alloc_status(5))
- Deallocate( radiancedata_k % out ,stat= alloc_status(4))
- Deallocate( radiancedata_k % out_clear ,stat= alloc_status(5))
- Deallocate( radiancedata_k % upclear ,stat= alloc_status(6))
- Deallocate( radiancedata_k % reflclear ,stat= alloc_status(7))
- Deallocate( radiancedata_k % overcast ,stat= alloc_status(8))
- Deallocate( radiancedata_k % downcld ,stat= alloc_status(9))
- Deallocate( radiancedata_k % total_out ,stat= alloc_status(10))
- Deallocate( radiancedata_k % clear_out ,stat= alloc_status(11))
- If( Any(alloc_status /= 0) ) Then
- errorstatus(:) = errorstatus_fatal
- Write( errMessage, '( "deallocation of K radiances")' )
- Call Rttov_ErrorReport (errorstatus_fatal, errMessage, NameOfRoutine)
- Return
- End If
- End If
-
-End Subroutine rttov_k
diff --git a/src/LIB/RTTOV/src/rttov_k.interface b/src/LIB/RTTOV/src/rttov_k.interface
deleted file mode 100644
index 33eb205304810fa9517c46b06da984da29187856..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_k.interface
+++ /dev/null
@@ -1,73 +0,0 @@
-Interface
-!
-Subroutine rttov_k( &
- errorstatus, & ! out
- nfrequencies, & ! in
- nchannels, & ! in
- nbtout, & ! in
- nprofiles, & ! in
- channels, & ! in
- polarisations, & ! in
- lprofiles, & ! in
- profiles, & ! in
- coef, & ! in
- addcloud, & ! in
- switchrad, & ! in
- calcemis, & ! in
- emissivity, & ! inout direct model
- profiles_k, & ! inout K mat on profile variables
- emissivity_k, & ! inout K mat on surface emissivity
- transmission, & ! inout K model
- transmission_k,& ! inout K input
- radiancedata, & ! inout direct model (input due to pointers alloc)
- radiance_k ) ! inout OPTIONAL K radiances
- Use rttov_const, Only : &
- errorstatus_success ,&
- errorstatus_warning ,&
- errorstatus_fatal ,&
- max_optical_depth ,&
- sensor_id_mw ,&
- sensor_id_ir
-
- Use rttov_types, Only : &
- rttov_coef ,&
- profile_Type ,&
- geometry_Type ,&
- predictors_Type,&
- profile_aux ,&
- transmission_Type ,&
- radiance_Type ,&
- radiance_aux
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
- !subroutine arguments:
- Integer(Kind=jpim), Intent(in) :: nfrequencies
- Integer(Kind=jpim), Intent(in) :: nchannels
- Integer(Kind=jpim), Intent(in) :: nbtout
- Integer(Kind=jpim), Intent(in) :: nprofiles
- Integer(Kind=jpim), Intent(in) :: channels(nfrequencies)
- Integer(Kind=jpim), Intent(in) :: polarisations(nchannels,3)
- Integer(Kind=jpim), Intent(in) :: lprofiles(nfrequencies)
- Logical, Intent(in) :: addcloud
- Logical, Intent(in) :: switchrad ! true if input is BT
- Type(profile_Type), Intent(in) :: profiles(nprofiles)
- Type(rttov_coef), Intent(in) :: coef
- Logical, Intent(in) :: calcemis(nchannels)
- Integer(Kind=jpim), Intent(out) :: errorstatus(nprofiles)
- Real(Kind=jprb), Intent(inout) :: emissivity(nchannels)
- Type(transmission_Type), Intent(inout) :: transmission! in because of meme allocation
- Type(radiance_Type), Intent(inout) :: radiancedata! in because of meme allocation
-
-
- Type(profile_Type), Intent(inout) :: profiles_k(nchannels)
- Real(Kind=jprb), Intent(inout) :: emissivity_k(nchannels)
- Type(transmission_Type), Intent(inout) :: transmission_k ! in because of meme allocation
- Type(radiance_Type), Intent(inout), optional :: radiance_k
-
-
-
-
-End Subroutine rttov_k
-End Interface
diff --git a/src/LIB/RTTOV/src/rttov_mieproc.F90 b/src/LIB/RTTOV/src/rttov_mieproc.F90
deleted file mode 100644
index 36de1e142a3e8cc1f67d5311aeb725bb4b742264..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_mieproc.F90
+++ /dev/null
@@ -1,153 +0,0 @@
-!
-Subroutine rttov_mieproc (&
- & nwp_levels, &! in
- & nchannels, &! in
- & nprofiles, &! in
- & frequencies, &! in
- & lprofiles, &! in
- & cld_profiles, &! in
- & coef_rttov, &! in
- & coef_scatt, &! in
- & scatt_aux) ! inout
- !
- ! Description:
- ! Calculates scattering parameters from Mie tables
- !
- ! Copyright:
- ! This software was developed within the context of
- ! the EUMETSAT Satellite Application Facility on
- ! Numerical Weather Prediction (NWP SAF), under the
- ! Cooperation Agreement dated 25 November 1998, between
- ! EUMETSAT and the Met Office, UK, by one or more partners
- ! within the NWP SAF. The partners in the NWP SAF are
- ! the Met Office, ECMWF, KNMI and MeteoFrance.
- !
- ! Copyright 2002, EUMETSAT, All Rights Reserved.
- !
- ! Method:
- ! - Bauer, P., 2002: Microwave radiative transfer modeling in clouds and precipitation.
- ! Part I: Model description.
- ! NWP SAF Report No. NWPSAF-EC-TR-005, 27 pp.
- ! - Chevallier, F., and P. Bauer, 2003:
- ! Model rain and clouds over oceans: comparison with SSM/I observations.
- ! Mon. Wea. Rev., 131, 1240-1255.
- ! - Moreau, E., P. Bauer and F. Chevallier, 2002: Microwave radiative transfer modeling in clouds and precipitation.
- ! Part II: Model evaluation.
- ! NWP SAF Report No. NWPSAF-EC-TR-006, 27 pp.
- !
- ! Current Code Owner: SAF NWP
- !
- ! History:
- ! Version Date Comment
- ! ------- ---- -------
- ! 1.0 09/2002 Initial version (P. Bauer, E. Moreau)
- ! 1.1 05/2003 RTTOV7.3 compatible (F. Chevallier)
- ! 1.2 11/2004 Clean-up (P. Bauer)
- !
- ! Code Description:
- ! Language: Fortran 90.
- ! Software Standards: "European Standards for Writing and
- ! Documenting Exchangeable Fortran 90 Code".
- !
- !
- ! Declarations:
- ! Modules used:
- ! Imported Type Definitions:
-
- Use rttov_types, Only : &
- & rttov_coef ,&
- & profile_scatt_aux ,&
- & profile_cloud_Type ,&
- & rttov_scatt_coef
-
- Use parkind1, Only : jpim,jprb
-
- Implicit None
-
-!* Subroutine arguments:
- Integer (Kind=jpim), Intent (in) :: nwp_levels ! Number of NWP levels
- Integer (Kind=jpim), Intent (in) :: nchannels ! Number of channels*profiles=radiances
- Integer (Kind=jpim), Intent (in) :: nprofiles ! Number of profiles
- Integer (Kind=jpim), Intent (in) :: frequencies (nchannels) ! Frequency indices
- Integer (Kind=jpim), Intent (in) :: lprofiles (nchannels) ! Profile indices
-
- Type (profile_cloud_Type), Intent (in) :: cld_profiles (nprofiles) ! Cloud profiles on NWP levels
- Type (rttov_coef), Intent (in) :: coef_rttov ! RTTOV Coefficients
- Type (rttov_scatt_coef), Intent (in) :: coef_scatt ! RTTOV_SCATT Coefficients
- Type (profile_scatt_aux), Intent (inout) :: scatt_aux ! Auxiliary profile variables
-
-!* Local variables:
- Integer (Kind=jpim) :: iwc, itemp, itype, ichan, iprof, ifreq, ilayer
- Real (Kind=jprb) :: wc, temp, kp, ap, gp, s_k, s_a, s_g
-
- !- End of header --------------------------------------------------------
-
-!* Loops over channels, levels, hydrometeor types
- nchan_loop: do ichan = 1, nchannels
- iprof = lprofiles (ichan)
- ifreq = frequencies (ichan)
-
- nlayer_loop: do ilayer = 1, nwp_levels
- ntype_loop: do itype = 1, coef_scatt % nhydro - 1
-
- wc = 0.0_JPRB
-
- select case (itype)
- case (1_jpim)
- if (scatt_aux % rain (iprof,ilayer) .gt. 0.0_JPRB) &
- & wc = coef_scatt % scale_water * log10 (scatt_aux % rain (iprof,ilayer)) - coef_scatt % offset_water
- temp = cld_profiles (iprof) % t (ilayer) - coef_scatt % offset_temp_rain
- case (2_jpim)
- if (scatt_aux % sp (iprof,ilayer) .gt. 0.0_JPRB) &
- & wc = coef_scatt % scale_water * log10 (scatt_aux % sp (iprof,ilayer)) - coef_scatt % offset_water
- temp = cld_profiles (iprof) % t (ilayer) - coef_scatt % offset_temp_sp
- case (3_jpim)
- if (scatt_aux % clw (iprof,ilayer) .gt. 0.0_JPRB) &
- & wc = coef_scatt % scale_water * log10 (scatt_aux % clw (iprof,ilayer)) - coef_scatt % offset_water
- temp = cld_profiles (iprof) % t (ilayer) - coef_scatt % offset_temp_liq
- case (4_jpim)
- if (scatt_aux % ciw (iprof,ilayer) .gt. 0.0_JPRB) &
- & wc = coef_scatt % scale_water * log10 (scatt_aux % ciw (iprof,ilayer)) - coef_scatt % offset_water
- temp = cld_profiles (iprof) % t (ilayer) - coef_scatt % offset_temp_ice
- end select
-
-!* Nearest index for Mie-table: LWC/IWC
- iwc = floor (wc)
- if (iwc > coef_scatt % mwc - 1) iwc = coef_scatt % mwc - 1
-
-!* Nearest index for Mie-table: T (w/o melting layer)
- itemp = anint (temp)
- if (itemp < 1) itemp = 1
- if (itemp > coef_scatt % mtemp - 1) itemp = coef_scatt % mtemp - 1
-
- if (iwc >= 1) then
- s_k = coef_scatt % ext (ifreq,itype,itemp,iwc+1) - coef_scatt % ext (ifreq,itype,itemp,iwc)
- s_a = coef_scatt % ssa (ifreq,itype,itemp,iwc+1) - coef_scatt % ssa (ifreq,itype,itemp,iwc)
- s_g = coef_scatt % asp (ifreq,itype,itemp,iwc+1) - coef_scatt % asp (ifreq,itype,itemp,iwc)
-
- kp = coef_scatt % ext (ifreq,itype,itemp,iwc) + s_k * (wc - iwc)
- ap = coef_scatt % ssa (ifreq,itype,itemp,iwc) + s_a * (wc - iwc)
- gp = coef_scatt % asp (ifreq,itype,itemp,iwc) + s_g * (wc - iwc)
- else
- kp = 1.0E-10_JPRB
- ap = 0.0_JPRB
- gp = 0.0_JPRB
- endif
-
- scatt_aux % ext (ichan,ilayer) = scatt_aux % ext (ichan,ilayer) + kp
- scatt_aux % ssa (ichan,ilayer) = scatt_aux % ssa (ichan,ilayer) + kp * ap
- scatt_aux % asm (ichan,ilayer) = scatt_aux % asm (ichan,ilayer) + kp * ap * gp
- enddo ntype_loop
- enddo nlayer_loop
- enddo nchan_loop
-
- do ilayer = 1, nwp_levels
- where (scatt_aux % asm (:,ilayer) > 0.0_JPRB) &
- & scatt_aux % asm (:,ilayer) = scatt_aux % asm (:,ilayer) / scatt_aux % ssa (:,ilayer)
- where (scatt_aux % ssa (:,ilayer) > 0.0_JPRB) &
- & scatt_aux % ssa (:,ilayer) = scatt_aux % ssa (:,ilayer) / scatt_aux % ext (:,ilayer)
- where (scatt_aux % ext (:,ilayer) >= 20.0_JPRB) &
- & scatt_aux % ext (:,ilayer) = 20.0_JPRB
- enddo
-
-End subroutine rttov_mieproc
diff --git a/src/LIB/RTTOV/src/rttov_mieproc.interface b/src/LIB/RTTOV/src/rttov_mieproc.interface
deleted file mode 100644
index 3c42fc410f1ee72f79cfc9c81c4c0ae1ce04dfed..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_mieproc.interface
+++ /dev/null
@@ -1,28 +0,0 @@
-INTERFACE
-Subroutine rttov_mieproc (&
- & nwp_levels,&
- & nchannels,&
- & nprofiles,&
- & frequencies,&
- & lprofiles,&
- & cld_profiles,&
- & coef_rttov,&
- & coef_scatt,&
- & scatt_aux)
- Use rttov_types, Only :&
- & rttov_coef ,&
- & profile_scatt_aux ,&
- & profile_cloud_Type ,&
- & rttov_scatt_coef
- Use parkind1, Only : jpim,jprb
- Integer (Kind=jpim), Intent (in) :: nwp_levels
- Integer (Kind=jpim), Intent (in) :: nchannels
- Integer (Kind=jpim), Intent (in) :: nprofiles
- Integer (Kind=jpim), Intent (in) :: frequencies (nchannels)
- Integer (Kind=jpim), Intent (in) :: lprofiles (nchannels)
- Type (profile_cloud_Type), Intent (in) :: cld_profiles (nprofiles)
- Type (rttov_coef), Intent (in) :: coef_rttov
- Type (rttov_scatt_coef), Intent (in) :: coef_scatt
- Type (profile_scatt_aux), Intent (inout) :: scatt_aux
-End subroutine rttov_mieproc
-END INTERFACE
diff --git a/src/LIB/RTTOV/src/rttov_mieproc_ad.F90 b/src/LIB/RTTOV/src/rttov_mieproc_ad.F90
deleted file mode 100644
index 933a32525beac4c5416768b6039871187fab1594..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_mieproc_ad.F90
+++ /dev/null
@@ -1,288 +0,0 @@
-!
-Subroutine rttov_mieproc_ad (&
- & nwp_levels, &! in
- & nchannels, &! in
- & nprofiles, &! in
- & frequencies, &! in
- & lprofiles, &! in
- & cld_profiles, &! in
- & cld_profiles_ad, &! inout
- & coef_rttov, &! in
- & coef_scatt, &! in
- & scatt_aux, &! inout
- & scatt_aux_ad) ! inout
- !
- ! Description:
- ! Calculates scattering parameters from Mie tables
- !
- ! Copyright:
- ! This software was developed within the context of
- ! the EUMETSAT Satellite Application Facility on
- ! Numerical Weather Prediction (NWP SAF), under the
- ! Cooperation Agreement dated 25 November 1998, between
- ! EUMETSAT and the Met Office, UK, by one or more partners
- ! within the NWP SAF. The partners in the NWP SAF are
- ! the Met Office, ECMWF, KNMI and MeteoFrance.
- !
- ! Copyright 2002, EUMETSAT, All Rights Reserved.
- !
- ! Method:
- ! - Bauer, P., 2002: Microwave radiative transfer modeling in clouds and precipitation.
- ! Part I: Model description.
- ! NWP SAF Report No. NWPSAF-EC-TR-005, 27 pp.
- ! - Chevallier, F., and P. Bauer, 2003:
- ! Model rain and clouds over oceans: comparison with SSM/I observations.
- ! Mon. Wea. Rev., 131, 1240-1255.
- ! - Moreau, E., P. Bauer and F. Chevallier, 2002: Microwave radiative transfer modeling in clouds and precipitation.
- ! Part II: Model evaluation.
- ! NWP SAF Report No. NWPSAF-EC-TR-006, 27 pp.
- !
- ! Current Code Owner: SAF NWP
- !
- ! History:
- ! Version Date Comment
- ! ------- ---- -------
- ! 1.0 09/2002 Initial version (E. Moreau)
- ! 1.1 05/2003 RTTOV7.3 compatible (F. Chevallier)
- ! 1.3 03/2004 Polarimetry code added (R. Saunders)
- ! 1.4 11/2004 Clean-up (P. Bauer)
- !
- ! Code Description:
- ! Language: Fortran 90.
- ! Software Standards: "European Standards for Writing and
- ! Documenting Exchangeable Fortran 90 Code".
- !
- !
- ! Declarations:
- ! Modules used:
- ! Imported Type Definitions:
-
- Use rttov_types, Only : &
- & rttov_coef ,&
- & profile_scatt_aux ,&
- & profile_cloud_Type ,&
- & rttov_scatt_coef
-
- Use parkind1, Only : jpim ,jprb
-
- Implicit None
-
-!* Subroutine arguments:
- Integer (Kind=jpim), Intent (in) :: nwp_levels ! Number of NWP levels
- Integer (Kind=jpim), Intent (in) :: nchannels ! Number of channels*profiles=radiances
- Integer (Kind=jpim), Intent (in) :: nprofiles ! Number of profiles
- Integer (Kind=jpim), Intent (in) :: frequencies (nchannels) ! Frequency indices
- Integer (Kind=jpim), Intent (in) :: lprofiles (nchannels) ! Profile indices
-
- Type (profile_cloud_Type), Intent (in) :: cld_profiles (nprofiles) ! Cloud profiles on NWP levels
- Type (profile_cloud_Type), Intent (inout) :: cld_profiles_ad (nprofiles) ! Cloud profiles on NWP levels
- Type (rttov_coef), Intent (in) :: coef_rttov ! RTTOV Coefficients
- Type (rttov_scatt_coef), Intent (in) :: coef_scatt ! RTTOV_SCATT Coefficients
- Type (profile_scatt_aux), Intent (inout) :: scatt_aux ! Auxiliary profile variables
- Type (profile_scatt_aux), Intent (inout) :: scatt_aux_ad ! Auxiliary profile variables
-
-!* Local variables:
- Integer (Kind=jpim) :: iwc, itemp, itype, ichan, iprof, ifreq, ilayer
- Real (Kind=jprb) :: wc , temp , kp , ap , gp , s_k , s_a , s_g , zln10
- Real (Kind=jprb) :: wc_ad, temp_ad, kp_ad, ap_ad, gp_ad, s_k_ad, s_a_ad, s_g_ad
-
- Real (Kind=jprb), dimension (nchannels,nwp_levels) :: ext, ssa, asm
-
- !- End of header --------------------------------------------------------
-
- zln10 = log (10.0_JPRB)
-
-!* Loops over channels, levels, hydrometeor types
- nchan_loop1: do ichan = 1, nchannels
- iprof = lprofiles (ichan)
- ifreq = frequencies (ichan)
-
- nlayer_loop1: do ilayer = 1, nwp_levels
- ntype_loop1: do itype = 1, coef_scatt % nhydro - 1
-
- wc = 0.0_JPRB
-
- select case (itype)
- case (1_jpim)
- if (scatt_aux % rain (iprof,ilayer) .gt. 0.0_JPRB) &
- & wc = coef_scatt % scale_water * log10 (scatt_aux % rain (iprof,ilayer)) - coef_scatt % offset_water
- temp = cld_profiles (iprof) % t (ilayer) - coef_scatt % offset_temp_rain
- case (2_jpim)
- if (scatt_aux % sp (iprof,ilayer) .gt. 0.0_JPRB) &
- & wc = coef_scatt % scale_water * log10 (scatt_aux % sp (iprof,ilayer)) - coef_scatt % offset_water
- temp = cld_profiles (iprof) % t (ilayer) - coef_scatt % offset_temp_sp
- case (3_jpim)
- if (scatt_aux % clw (iprof,ilayer) .gt. 0.0_JPRB) &
- & wc = coef_scatt % scale_water * log10 (scatt_aux % clw (iprof,ilayer)) - coef_scatt % offset_water
- temp = cld_profiles (iprof) % t (ilayer) - coef_scatt % offset_temp_liq
- case (4_jpim)
- if (scatt_aux % ciw (iprof,ilayer) .gt. 0.0_JPRB) &
- & wc = coef_scatt % scale_water * log10 (scatt_aux % ciw (iprof,ilayer)) - coef_scatt % offset_water
- temp = cld_profiles (iprof) % t (ilayer) - coef_scatt % offset_temp_ice
- end select
-
-!* Nearest index for Mie-table: LWC/IWC
- iwc = floor (wc)
- if (iwc > coef_scatt % mwc - 1) iwc = coef_scatt % mwc - 1
-
-!* Nearest index for Mie-table: T (w/o melting layer)
- itemp = anint (temp)
- if (itemp < 1) itemp = 1
- if (itemp > coef_scatt % mtemp - 1) itemp = coef_scatt % mtemp - 1
-
- if (iwc >= 1) then
- s_k = coef_scatt % ext (ifreq,itype,itemp,iwc+1) - coef_scatt % ext (ifreq,itype,itemp,iwc)
- s_a = coef_scatt % ssa (ifreq,itype,itemp,iwc+1) - coef_scatt % ssa (ifreq,itype,itemp,iwc)
- s_g = coef_scatt % asp (ifreq,itype,itemp,iwc+1) - coef_scatt % asp (ifreq,itype,itemp,iwc)
-
- kp = coef_scatt % ext (ifreq,itype,itemp,iwc) + s_k * (wc - iwc)
- ap = coef_scatt % ssa (ifreq,itype,itemp,iwc) + s_a * (wc - iwc)
- gp = coef_scatt % asp (ifreq,itype,itemp,iwc) + s_g * (wc - iwc)
- else
- kp = 1.0E-10_JPRB
- ap = 0.0_JPRB
- gp = 0.0_JPRB
- endif
-
- scatt_aux % ext (ichan,ilayer) = scatt_aux % ext (ichan,ilayer) + kp
- scatt_aux % ssa (ichan,ilayer) = scatt_aux % ssa (ichan,ilayer) + kp * ap
- scatt_aux % asm (ichan,ilayer) = scatt_aux % asm (ichan,ilayer) + kp * ap * gp
- enddo ntype_loop1
- enddo nlayer_loop1
- enddo nchan_loop1
-
- ext (:,:) = scatt_aux % ext (:,:)
- ssa (:,:) = scatt_aux % ssa (:,:)
- asm (:,:) = scatt_aux % asm (:,:)
-
- do ilayer = 1, nwp_levels
- where (scatt_aux % asm (:,ilayer) > 0.0_JPRB) &
- & scatt_aux % asm (:,ilayer) = scatt_aux % asm (:,ilayer) / scatt_aux % ssa (:,ilayer)
- where (scatt_aux % ssa (:,ilayer) > 0.0_JPRB) &
- & scatt_aux % ssa (:,ilayer) = scatt_aux % ssa (:,ilayer) / scatt_aux % ext (:,ilayer)
- where (scatt_aux % ext (:,ilayer) >= 20.0_JPRB) &
- & scatt_aux % ext (:,ilayer) = 20.0_JPRB
- enddo
-
-!* ADJOINT PART
- do ilayer = 1, nwp_levels
- where (ssa (:,ilayer) > 0.0_JPRB )
- scatt_aux_ad % ext (:,ilayer) = scatt_aux_ad % ext (:,ilayer) - scatt_aux_ad % ssa (:,ilayer) * ssa (:,ilayer) &
- & / (ext (:,ilayer) * ext (:,ilayer))
- scatt_aux_ad % ssa (:,ilayer) = scatt_aux_ad % ssa (:,ilayer) / ext (:,ilayer)
- endwhere
-
- where (asm (:,ilayer) > 0.0_JPRB )
- scatt_aux_ad % ssa (:,ilayer) = scatt_aux_ad % ssa (:,ilayer) - scatt_aux_ad % asm (:,ilayer) * asm (:,ilayer) &
- & / (ssa (:,ilayer) * ssa (:,ilayer))
- scatt_aux_ad % asm (:,ilayer) = scatt_aux_ad % asm (:,ilayer) / ssa (:,ilayer)
- endwhere
-
- where (ext (:,ilayer) >= 20.0_JPRB) scatt_aux_ad % ext (:,ilayer) = 0.0_JPRB
- enddo
-
-!* Loops over channels, levels, hydrometeor types
- nchan_loop2: do ichan = 1, nchannels
- iprof = lprofiles (ichan)
- ifreq = frequencies (ichan)
-
- nlayer_loop2: do ilayer = nwp_levels, 1, -1
- ntype_loop2: do itype = coef_scatt % nhydro - 1, 1, -1
-
- wc = 0.0_JPRB
-
- select case (itype)
- case (1_jpim)
- if (scatt_aux % rain (iprof,ilayer) > 0.0_JPRB) &
- & wc = coef_scatt % scale_water * log10(scatt_aux % rain(iprof,ilayer)) - coef_scatt % offset_water
- temp = cld_profiles(iprof) % t(ilayer) - coef_scatt % offset_temp_rain
- case (2_jpim)
- if (scatt_aux % sp (iprof,ilayer) > 0.0_JPRB) &
- & wc = coef_scatt % scale_water * log10(scatt_aux % sp(iprof,ilayer)) - coef_scatt % offset_water
- temp = cld_profiles(iprof) % t(ilayer) - coef_scatt % offset_temp_sp
- case (3_jpim)
- if (scatt_aux % clw (iprof,ilayer) > 0.0_JPRB) &
- & wc = coef_scatt % scale_water * log10(scatt_aux % clw(iprof,ilayer)) - coef_scatt % offset_water
- temp = cld_profiles(iprof) % t(ilayer) - coef_scatt % offset_temp_liq
- case (4_jpim)
- if (scatt_aux % ciw (iprof,ilayer) > 0.0_JPRB) &
- & wc = coef_scatt % scale_water * log10(scatt_aux % ciw(iprof,ilayer)) - coef_scatt % offset_water
- temp = cld_profiles(iprof) % t(ilayer) - coef_scatt % offset_temp_ice
- end select
-
-!* Nearest index for Mie-table: LWC/IWC
- iwc = floor (wc)
- if (iwc > coef_scatt % mwc - 1) iwc = coef_scatt % mwc - 1
-
-!* Nearest index for Mie-table: T (w/o melting layer)
- itemp = anint (temp)
- if (itemp < 1) itemp = 1
- if (itemp > coef_scatt % mtemp - 1) itemp = coef_scatt % mtemp - 1
-
- if (iwc >= 1) then
- s_k = coef_scatt % ext (ifreq,itype,itemp,iwc+1) - coef_scatt % ext (ifreq,itype,itemp,iwc)
- s_a = coef_scatt % ssa (ifreq,itype,itemp,iwc+1) - coef_scatt % ssa (ifreq,itype,itemp,iwc)
- s_g = coef_scatt % asp (ifreq,itype,itemp,iwc+1) - coef_scatt % asp (ifreq,itype,itemp,iwc)
-
- kp = coef_scatt % ext (ifreq,itype,itemp,iwc) + s_k * (wc - iwc)
- ap = coef_scatt % ssa (ifreq,itype,itemp,iwc) + s_a * (wc - iwc)
- gp = coef_scatt % asp (ifreq,itype,itemp,iwc) + s_g * (wc - iwc)
- else
- kp = 1.0E-10_JPRB
- ap = 0.0_JPRB
- gp = 0.0_JPRB
- endif
-
- kp_ad = 0.0_JPRB
- ap_ad = 0.0_JPRB
- gp_ad = 0.0_JPRB
- temp_ad = 0.0_JPRB
- wc_ad = 0.0_JPRB
-
- kp_ad = kp_ad + ap * gp * scatt_aux_ad % asm (ichan,ilayer)
- ap_ad = ap_ad + kp * gp * scatt_aux_ad % asm (ichan,ilayer)
- gp_ad = gp_ad + kp * ap * scatt_aux_ad % asm (ichan,ilayer)
-
- kp_ad = kp_ad + ap * scatt_aux_ad % ssa (ichan,ilayer)
- ap_ad = ap_ad + kp * scatt_aux_ad % ssa (ichan,ilayer)
-
- kp_ad = kp_ad + scatt_aux_ad % ext (ichan,ilayer)
-
- if (iwc >= 1) then
- wc_ad = wc_ad + s_g * gp_ad
- gp_ad = 0.0_JPRB
- wc_ad = wc_ad + s_a * ap_ad
- ap_ad = 0.0_JPRB
- wc_ad = wc_ad + s_k * kp_ad
- kp_ad = 0.0_JPRB
- else
- kp_ad = 0.0_JPRB
- ap_ad = 0.0_JPRB
- gp_ad = 0.0_JPRB
- endif
-
- select case (itype)
- case (1_jpim)
- if (scatt_aux % rain (iprof,ilayer) > 0.0_JPRB) &
- & scatt_aux_ad % rain (iprof,ilayer) = scatt_aux_ad % rain (iprof,ilayer) + coef_scatt % scale_water * wc_ad &
- & / (zln10 * scatt_aux % rain (iprof,ilayer))
- case (2_jpim)
- if (scatt_aux % sp (iprof,ilayer) > 0.0_JPRB) &
- & scatt_aux_ad % sp (iprof,ilayer) = scatt_aux_ad % sp (iprof,ilayer) + coef_scatt % scale_water * wc_ad &
- & / (zln10 * scatt_aux % sp (iprof,ilayer))
- case (3_jpim)
- if (scatt_aux % clw (iprof,ilayer) > 0.0_JPRB) &
- & scatt_aux_ad % clw (iprof,ilayer) = scatt_aux_ad % clw (iprof,ilayer) + coef_scatt % scale_water * wc_ad &
- & / (zln10 * scatt_aux % clw (iprof,ilayer))
- case (4_jpim)
- if (scatt_aux % ciw (iprof,ilayer) > 0.0_JPRB ) &
- & scatt_aux_ad % ciw (iprof,ilayer) = scatt_aux_ad % ciw (iprof,ilayer) + coef_scatt % scale_water * wc_ad &
- & / (zln10 * scatt_aux % ciw (iprof,ilayer))
- end select
- wc_ad = 0.0_JPRB
-
- enddo ntype_loop2
- enddo nlayer_loop2
- enddo nchan_loop2
-
-End subroutine rttov_mieproc_ad
diff --git a/src/LIB/RTTOV/src/rttov_mieproc_ad.interface b/src/LIB/RTTOV/src/rttov_mieproc_ad.interface
deleted file mode 100644
index 0d2e213cd7bea01d4a1150fb2c7b629c9ea00fa7..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_mieproc_ad.interface
+++ /dev/null
@@ -1,32 +0,0 @@
-INTERFACE
-Subroutine rttov_mieproc_ad (&
- & nwp_levels,&
- & nchannels,&
- & nprofiles,&
- & frequencies,&
- & lprofiles,&
- & cld_profiles,&
- & cld_profiles_ad,&
- & coef_rttov,&
- & coef_scatt,&
- & scatt_aux,&
- & scatt_aux_ad)
- Use rttov_types, Only :&
- & rttov_coef ,&
- & profile_scatt_aux ,&
- & profile_cloud_Type ,&
- & rttov_scatt_coef
- Use parkind1, Only : jpim ,jprb
- Integer (Kind=jpim), Intent (in) :: nwp_levels
- Integer (Kind=jpim), Intent (in) :: nchannels
- Integer (Kind=jpim), Intent (in) :: nprofiles
- Integer (Kind=jpim), Intent (in) :: frequencies (nchannels)
- Integer (Kind=jpim), Intent (in) :: lprofiles (nchannels)
- Type (profile_cloud_Type), Intent (in) :: cld_profiles (nprofiles)
- Type (profile_cloud_Type), Intent (inout) :: cld_profiles_ad (nprofiles)
- Type (rttov_coef), Intent (in) :: coef_rttov
- Type (rttov_scatt_coef), Intent (in) :: coef_scatt
- Type (profile_scatt_aux), Intent (inout) :: scatt_aux
- Type (profile_scatt_aux), Intent (inout) :: scatt_aux_ad
-End subroutine rttov_mieproc_ad
-END INTERFACE
diff --git a/src/LIB/RTTOV/src/rttov_mieproc_k.F90 b/src/LIB/RTTOV/src/rttov_mieproc_k.F90
deleted file mode 100644
index bd1813d2501a1d7e581ecaa3004366c4c38c9fb1..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_mieproc_k.F90
+++ /dev/null
@@ -1,289 +0,0 @@
-!
-Subroutine rttov_mieproc_k (&
- & nwp_levels, &! in
- & nchannels, &! in
- & nprofiles, &! in
- & frequencies, &! in
- & lprofiles, &! in
- & cld_profiles, &! in
- & cld_profiles_k, &! inout
- & coef_rttov, &! in
- & coef_scatt, &! in
- & scatt_aux, &! inout
- & scatt_aux_k) ! inout
- !
- ! Description:
- ! Calculates scattering parameters from Mie tables
- !
- ! Copyright:
- ! This software was developed within the context of
- ! the EUMETSAT Satellite Application Facility on
- ! Numerical Weather Prediction (NWP SAF), under the
- ! Cooperation Agreement dated 25 November 1998, between
- ! EUMETSAT and the Met Office, UK, by one or more partners
- ! within the NWP SAF. The partners in the NWP SAF are
- ! the Met Office, ECMWF, KNMI and MeteoFrance.
- !
- ! Copyright 2002, EUMETSAT, All Rights Reserved.
- !
- ! Method:
- ! - Bauer, P., 2002: Microwave radiative transfer modeling in clouds and precipitation.
- ! Part I: Model description.
- ! NWP SAF Report No. NWPSAF-EC-TR-005, 27 pp.
- ! - Chevallier, F., and P. Bauer, 2003:
- ! Model rain and clouds over oceans: comparison with SSM/I observations.
- ! Mon. Wea. Rev., 131, 1240-1255.
- ! - Moreau, E., P. Bauer and F. Chevallier, 2002: Microwave radiative transfer modeling in clouds and precipitation.
- ! Part II: Model evaluation.
- ! NWP SAF Report No. NWPSAF-EC-TR-006, 27 pp.
- !
- ! Current Code Owner: SAF NWP
- !
- ! History:
- ! Version Date Comment
- ! ------- ---- -------
- ! 1.0 09/2002 Initial version (E. Moreau)
- ! 1.1 05/2003 RTTOV7.3 compatible (F. Chevallier)
- ! 1.3 03/2004 Polarimetry code added (R. Saunders)
- ! 1.4 11/2004 Clean-up (P. Bauer)
- ! 1.5 02/2005 K-Code (A. Collard)
- !
- ! Code Description:
- ! Language: Fortran 90.
- ! Software Standards: "European Standards for Writing and
- ! Documenting Exchangeable Fortran 90 Code".
- !
- !
- ! Declarations:
- ! Modules used:
- ! Imported Type Definitions:
-
- Use rttov_types, Only : &
- & rttov_coef ,&
- & profile_scatt_aux ,&
- & profile_cloud_Type ,&
- & rttov_scatt_coef
-
- Use parkind1, Only : jpim ,jprb
-
- Implicit None
-
-!* Subroutine arguments:
- Integer (Kind=jpim), Intent (in) :: nwp_levels ! Number of NWP levels
- Integer (Kind=jpim), Intent (in) :: nchannels ! Number of channels*profiles=radiances
- Integer (Kind=jpim), Intent (in) :: nprofiles ! Number of profiles
- Integer (Kind=jpim), Intent (in) :: frequencies (nchannels) ! Frequency indices
- Integer (Kind=jpim), Intent (in) :: lprofiles (nchannels) ! Profile indices
-
- Type (profile_cloud_Type), Intent (in) :: cld_profiles (nprofiles) ! Cloud profiles on NWP levels
- Type (profile_cloud_Type), Intent (inout) :: cld_profiles_k (nchannels) ! Cloud profiles on NWP levels
- Type (rttov_coef), Intent (in) :: coef_rttov ! RTTOV Coefficients
- Type (rttov_scatt_coef), Intent (in) :: coef_scatt ! RTTOV_SCATT Coefficients
- Type (profile_scatt_aux), Intent (inout) :: scatt_aux ! Auxiliary profile variables
- Type (profile_scatt_aux), Intent (inout) :: scatt_aux_k ! Auxiliary profile variables
-
-!* Local variables:
- Integer (Kind=jpim) :: iwc, itemp, itype, ichan, iprof, ifreq, ilayer
- Real (Kind=jprb) :: wc , temp , kp , ap , gp , s_k , s_a , s_g , zln10
- Real (Kind=jprb) :: wc_k, temp_k, kp_k, ap_k, gp_k, s_k_k, s_a_k, s_g_k
-
- Real (Kind=jprb), dimension (nchannels,nwp_levels) :: ext, ssa, asm
-
- !- End of header --------------------------------------------------------
-
- zln10 = log (10.0_JPRB)
-
-!* Loops over channels, levels, hydrometeor types
- nchan_loop1: do ichan = 1, nchannels
- iprof = lprofiles (ichan)
- ifreq = frequencies (ichan)
-
- nlayer_loop1: do ilayer = 1, nwp_levels
- ntype_loop1: do itype = 1, coef_scatt % nhydro - 1
-
- wc = 0.0_JPRB
-
- select case (itype)
- case (1_jpim)
- if (scatt_aux % rain (iprof,ilayer) .gt. 0.0_JPRB) &
- & wc = coef_scatt % scale_water * log10 (scatt_aux % rain (iprof,ilayer)) - coef_scatt % offset_water
- temp = cld_profiles (iprof) % t (ilayer) - coef_scatt % offset_temp_rain
- case (2_jpim)
- if (scatt_aux % sp (iprof,ilayer) .gt. 0.0_JPRB) &
- & wc = coef_scatt % scale_water * log10 (scatt_aux % sp (iprof,ilayer)) - coef_scatt % offset_water
- temp = cld_profiles (iprof) % t (ilayer) - coef_scatt % offset_temp_sp
- case (3_jpim)
- if (scatt_aux % clw (iprof,ilayer) .gt. 0.0_JPRB) &
- & wc = coef_scatt % scale_water * log10 (scatt_aux % clw (iprof,ilayer)) - coef_scatt % offset_water
- temp = cld_profiles (iprof) % t (ilayer) - coef_scatt % offset_temp_liq
- case (4_jpim)
- if (scatt_aux % ciw (iprof,ilayer) .gt. 0.0_JPRB) &
- & wc = coef_scatt % scale_water * log10 (scatt_aux % ciw (iprof,ilayer)) - coef_scatt % offset_water
- temp = cld_profiles (iprof) % t (ilayer) - coef_scatt % offset_temp_ice
- end select
-
-!* Nearest index for Mie-table: LWC/IWC
- iwc = floor (wc)
- if (iwc > coef_scatt % mwc - 1) iwc = coef_scatt % mwc - 1
-
-!* Nearest index for Mie-table: T (w/o melting layer)
- itemp = anint (temp)
- if (itemp < 1) itemp = 1
- if (itemp > coef_scatt % mtemp - 1) itemp = coef_scatt % mtemp - 1
-
- if (iwc >= 1) then
- s_k = coef_scatt % ext (ifreq,itype,itemp,iwc+1) - coef_scatt % ext (ifreq,itype,itemp,iwc)
- s_a = coef_scatt % ssa (ifreq,itype,itemp,iwc+1) - coef_scatt % ssa (ifreq,itype,itemp,iwc)
- s_g = coef_scatt % asp (ifreq,itype,itemp,iwc+1) - coef_scatt % asp (ifreq,itype,itemp,iwc)
-
- kp = coef_scatt % ext (ifreq,itype,itemp,iwc) + s_k * (wc - iwc)
- ap = coef_scatt % ssa (ifreq,itype,itemp,iwc) + s_a * (wc - iwc)
- gp = coef_scatt % asp (ifreq,itype,itemp,iwc) + s_g * (wc - iwc)
- else
- kp = 1.0E-10_JPRB
- ap = 0.0_JPRB
- gp = 0.0_JPRB
- endif
-
- scatt_aux % ext (ichan,ilayer) = scatt_aux % ext (ichan,ilayer) + kp
- scatt_aux % ssa (ichan,ilayer) = scatt_aux % ssa (ichan,ilayer) + kp * ap
- scatt_aux % asm (ichan,ilayer) = scatt_aux % asm (ichan,ilayer) + kp * ap * gp
- enddo ntype_loop1
- enddo nlayer_loop1
- enddo nchan_loop1
-
- ext (:,:) = scatt_aux % ext (:,:)
- ssa (:,:) = scatt_aux % ssa (:,:)
- asm (:,:) = scatt_aux % asm (:,:)
-
- do ilayer = 1, nwp_levels
- where (scatt_aux % asm (:,ilayer) > 0.0_JPRB) &
- & scatt_aux % asm (:,ilayer) = scatt_aux % asm (:,ilayer) / scatt_aux % ssa (:,ilayer)
- where (scatt_aux % ssa (:,ilayer) > 0.0_JPRB) &
- & scatt_aux % ssa (:,ilayer) = scatt_aux % ssa (:,ilayer) / scatt_aux % ext (:,ilayer)
- where (scatt_aux % ext (:,ilayer) >= 20.0_JPRB) &
- & scatt_aux % ext (:,ilayer) = 20.0_JPRB
- enddo
-
-!* ADJOINT PART
- do ilayer = 1, nwp_levels
- where (ssa (:,ilayer) > 0.0_JPRB )
- scatt_aux_k % ext (:,ilayer) = scatt_aux_k % ext (:,ilayer) - scatt_aux_k % ssa (:,ilayer) * ssa (:,ilayer) &
- & / (ext (:,ilayer) * ext (:,ilayer))
- scatt_aux_k % ssa (:,ilayer) = scatt_aux_k % ssa (:,ilayer) / ext (:,ilayer)
- endwhere
-
- where (asm (:,ilayer) > 0.0_JPRB )
- scatt_aux_k % ssa (:,ilayer) = scatt_aux_k % ssa (:,ilayer) - scatt_aux_k % asm (:,ilayer) * asm (:,ilayer) &
- & / (ssa (:,ilayer) * ssa (:,ilayer))
- scatt_aux_k % asm (:,ilayer) = scatt_aux_k % asm (:,ilayer) / ssa (:,ilayer)
- endwhere
-
- where (ext (:,ilayer) >= 20.0_JPRB) scatt_aux_k % ext (:,ilayer) = 0.0_JPRB
- enddo
-
-!* Loops over channels, levels, hydrometeor types
- nchan_loop2: do ichan = 1, nchannels
- iprof = lprofiles (ichan)
- ifreq = frequencies (ichan)
-
- nlayer_loop2: do ilayer = nwp_levels, 1, -1
- ntype_loop2: do itype = coef_scatt % nhydro - 1, 1, -1
-
- wc = 0.0_JPRB
-
- select case (itype)
- case (1_jpim)
- if (scatt_aux % rain (iprof,ilayer) > 0.0_JPRB) &
- & wc = coef_scatt % scale_water * log10(scatt_aux % rain(iprof,ilayer)) - coef_scatt % offset_water
- temp = cld_profiles(iprof) % t(ilayer) - coef_scatt % offset_temp_rain
- case (2_jpim)
- if (scatt_aux % sp (iprof,ilayer) > 0.0_JPRB) &
- & wc = coef_scatt % scale_water * log10(scatt_aux % sp(iprof,ilayer)) - coef_scatt % offset_water
- temp = cld_profiles(iprof) % t(ilayer) - coef_scatt % offset_temp_sp
- case (3_jpim)
- if (scatt_aux % clw (iprof,ilayer) > 0.0_JPRB) &
- & wc = coef_scatt % scale_water * log10(scatt_aux % clw(iprof,ilayer)) - coef_scatt % offset_water
- temp = cld_profiles(iprof) % t(ilayer) - coef_scatt % offset_temp_liq
- case (4_jpim)
- if (scatt_aux % ciw (iprof,ilayer) > 0.0_JPRB) &
- & wc = coef_scatt % scale_water * log10(scatt_aux % ciw(iprof,ilayer)) - coef_scatt % offset_water
- temp = cld_profiles(iprof) % t(ilayer) - coef_scatt % offset_temp_ice
- end select
-
-!* Nearest index for Mie-table: LWC/IWC
- iwc = floor (wc)
- if (iwc > coef_scatt % mwc - 1) iwc = coef_scatt % mwc - 1
-
-!* Nearest index for Mie-table: T (w/o melting layer)
- itemp = anint (temp)
- if (itemp < 1) itemp = 1
- if (itemp > coef_scatt % mtemp - 1) itemp = coef_scatt % mtemp - 1
-
- if (iwc >= 1) then
- s_k = coef_scatt % ext (ifreq,itype,itemp,iwc+1) - coef_scatt % ext (ifreq,itype,itemp,iwc)
- s_a = coef_scatt % ssa (ifreq,itype,itemp,iwc+1) - coef_scatt % ssa (ifreq,itype,itemp,iwc)
- s_g = coef_scatt % asp (ifreq,itype,itemp,iwc+1) - coef_scatt % asp (ifreq,itype,itemp,iwc)
-
- kp = coef_scatt % ext (ifreq,itype,itemp,iwc) + s_k * (wc - iwc)
- ap = coef_scatt % ssa (ifreq,itype,itemp,iwc) + s_a * (wc - iwc)
- gp = coef_scatt % asp (ifreq,itype,itemp,iwc) + s_g * (wc - iwc)
- else
- kp = 1.0E-10_JPRB
- ap = 0.0_JPRB
- gp = 0.0_JPRB
- endif
-
- kp_k = 0.0_JPRB
- ap_k = 0.0_JPRB
- gp_k = 0.0_JPRB
- temp_k = 0.0_JPRB
- wc_k = 0.0_JPRB
-
- kp_k = kp_k + ap * gp * scatt_aux_k % asm (ichan,ilayer)
- ap_k = ap_k + kp * gp * scatt_aux_k % asm (ichan,ilayer)
- gp_k = gp_k + kp * ap * scatt_aux_k % asm (ichan,ilayer)
-
- kp_k = kp_k + ap * scatt_aux_k % ssa (ichan,ilayer)
- ap_k = ap_k + kp * scatt_aux_k % ssa (ichan,ilayer)
-
- kp_k = kp_k + scatt_aux_k % ext (ichan,ilayer)
-
- if (iwc >= 1) then
- wc_k = wc_k + s_g * gp_k
- gp_k = 0.0_JPRB
- wc_k = wc_k + s_a * ap_k
- ap_k = 0.0_JPRB
- wc_k = wc_k + s_k * kp_k
- kp_k = 0.0_JPRB
- else
- kp_k = 0.0_JPRB
- ap_k = 0.0_JPRB
- gp_k = 0.0_JPRB
- endif
-
- select case (itype)
- case (1_jpim)
- if (scatt_aux % rain (iprof,ilayer) > 0.0_JPRB) &
- & scatt_aux_k % rain (ichan,ilayer) = scatt_aux_k % rain (ichan,ilayer) + coef_scatt % scale_water * wc_k &
- & / (zln10 * scatt_aux % rain (iprof,ilayer))
- case (2_jpim)
- if (scatt_aux % sp (iprof,ilayer) > 0.0_JPRB) &
- & scatt_aux_k % sp (ichan,ilayer) = scatt_aux_k % sp (ichan,ilayer) + coef_scatt % scale_water * wc_k &
- & / (zln10 * scatt_aux % sp (iprof,ilayer))
- case (3_jpim)
- if (scatt_aux % clw (iprof,ilayer) > 0.0_JPRB) &
- & scatt_aux_k % clw (ichan,ilayer) = scatt_aux_k % clw (ichan,ilayer) + coef_scatt % scale_water * wc_k &
- & / (zln10 * scatt_aux % clw (iprof,ilayer))
- case (4_jpim)
- if (scatt_aux % ciw (iprof,ilayer) > 0.0_JPRB ) &
- & scatt_aux_k % ciw (ichan,ilayer) = scatt_aux_k % ciw (ichan,ilayer) + coef_scatt % scale_water * wc_k &
- & / (zln10 * scatt_aux % ciw (iprof,ilayer))
- end select
- wc_k = 0.0_JPRB
-
- enddo ntype_loop2
- enddo nlayer_loop2
- enddo nchan_loop2
-
-End subroutine rttov_mieproc_k
diff --git a/src/LIB/RTTOV/src/rttov_mieproc_k.interface b/src/LIB/RTTOV/src/rttov_mieproc_k.interface
deleted file mode 100644
index 07826a71048d3e0814d45f49a22a9f16033b086d..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_mieproc_k.interface
+++ /dev/null
@@ -1,32 +0,0 @@
-INTERFACE
-Subroutine rttov_mieproc_k (&
- & nwp_levels,&
- & nchannels,&
- & nprofiles,&
- & frequencies,&
- & lprofiles,&
- & cld_profiles,&
- & cld_profiles_k,&
- & coef_rttov,&
- & coef_scatt,&
- & scatt_aux,&
- & scatt_aux_k)
- Use rttov_types, Only :&
- & rttov_coef ,&
- & profile_scatt_aux ,&
- & profile_cloud_Type ,&
- & rttov_scatt_coef
- Use parkind1, Only : jpim ,jprb
- Integer (Kind=jpim), Intent (in) :: nwp_levels
- Integer (Kind=jpim), Intent (in) :: nchannels
- Integer (Kind=jpim), Intent (in) :: nprofiles
- Integer (Kind=jpim), Intent (in) :: frequencies (nchannels)
- Integer (Kind=jpim), Intent (in) :: lprofiles (nchannels)
- Type (profile_cloud_Type), Intent (in) :: cld_profiles (nprofiles)
- Type (profile_cloud_Type), Intent (inout) :: cld_profiles_k (nchannels)
- Type (rttov_coef), Intent (in) :: coef_rttov
- Type (rttov_scatt_coef), Intent (in) :: coef_scatt
- Type (profile_scatt_aux), Intent (inout) :: scatt_aux
- Type (profile_scatt_aux), Intent (inout) :: scatt_aux_k
-End subroutine rttov_mieproc_k
-END INTERFACE
diff --git a/src/LIB/RTTOV/src/rttov_mieproc_tl.F90 b/src/LIB/RTTOV/src/rttov_mieproc_tl.F90
deleted file mode 100644
index 44e04a31571aac337d28ded0f5b50d55a9d2fdf8..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_mieproc_tl.F90
+++ /dev/null
@@ -1,197 +0,0 @@
-!
-Subroutine rttov_mieproc_tl (&
- & nwp_levels, &! in
- & nchannels, &! in
- & nprofiles, &! in
- & frequencies, &! in
- & lprofiles, &! in
- & cld_profiles, &! in
- & cld_profiles_tl, &! in
- & coef_rttov, &! in
- & coef_scatt, &! in
- & scatt_aux, &! inout
- & scatt_aux_tl) ! inout
- !
- ! Description:
- ! Calculates scattering parameters from Mie tables
- !
- ! Copyright:
- ! This software was developed within the context of
- ! the EUMETSAT Satellite Application Facility on
- ! Numerical Weather Prediction (NWP SAF), under the
- ! Cooperation Agreement dated 25 November 1998, between
- ! EUMETSAT and the Met Office, UK, by one or more partners
- ! within the NWP SAF. The partners in the NWP SAF are
- ! the Met Office, ECMWF, KNMI and MeteoFrance.
- !
- ! Copyright 2002, EUMETSAT, All Rights Reserved.
- !
- ! Method:
- ! - Bauer, P., 2002: Microwave radiative transfer modeling in clouds and precipitation.
- ! Part I: Model description.
- ! NWP SAF Report No. NWPSAF-EC-TR-005, 27 pp.
- ! - Chevallier, F., and P. Bauer, 2003:
- ! Model rain and clouds over oceans: comparison with SSM/I observations.
- ! Mon. Wea. Rev., 131, 1240-1255.
- ! - Moreau, E., P. Bauer and F. Chevallier, 2002: Microwave radiative transfer modeling in clouds and precipitation.
- ! Part II: Model evaluation.
- ! NWP SAF Report No. NWPSAF-EC-TR-006, 27 pp.
- !
- ! Current Code Owner: SAF NWP
- !
- ! History:
- ! Version Date Comment
- ! ------- ---- -------
- ! 1.0 09/2002 Initial version (P. Bauer, E. Moreau)
- ! 1.1 05/2003 RTTOV7.3 compatible (F. Chevallier)
- ! 1.2 11/2004 Clean-up (P. Bauer)
- !
- ! Code Description:
- ! Language: Fortran 90.
- ! Software Standards: "European Standards for Writing and
- ! Documenting Exchangeable Fortran 90 Code".
- !
- !
- ! Declarations:
- ! Modules used:
- ! Imported Type Definitions:
-
- Use rttov_types, Only : &
- & rttov_coef ,&
- & profile_scatt_aux ,&
- & profile_cloud_Type ,&
- & rttov_scatt_coef
-
- Use parkind1, Only : jpim ,jprb
-
- Implicit None
-
-!* Subroutine arguments:
- Integer (Kind=jpim), Intent (in) :: nwp_levels ! Number of NWP levels
- Integer (Kind=jpim), Intent (in) :: nchannels ! Number of channels*profiles=radiances
- Integer (Kind=jpim), Intent (in) :: nprofiles ! Number of profiles
- Integer (Kind=jpim), Intent (in) :: frequencies (nchannels) ! Frequency indices
- Integer (Kind=jpim), Intent (in) :: lprofiles (nchannels) ! Profile indices
-
- Type (profile_cloud_Type), Intent (in) :: cld_profiles (nprofiles) ! Cloud profiles on NWP levels
- Type (profile_cloud_Type), Intent (in) :: cld_profiles_tl (nprofiles) ! Cloud profiles on NWP levels
- Type (rttov_coef), Intent (in) :: coef_rttov ! RTTOV Coefficients
- Type (rttov_scatt_coef), Intent (in) :: coef_scatt ! RTTOV_SCATT Coefficients
- Type (profile_scatt_aux), Intent (inout) :: scatt_aux ! Auxiliary profile variables
- Type (profile_scatt_aux), Intent (inout) :: scatt_aux_tl ! Auxiliary profile variables
-
-!* Local variables:
- Integer (Kind=jpim) :: iwc, itemp, itype, ichan, ifreq, iprof, ilayer
- Real (Kind=jprb) :: wc , temp , kp , ap , gp , s_k , s_a , s_g , zln10
- Real (Kind=jprb) :: wc_tl, temp_tl, kp_tl, ap_tl, gp_tl, s_k_tl, s_a_tl, s_g_tl
-
- !- End of header --------------------------------------------------------
-
- zln10 = log (10.0_JPRB)
-
-!* Loops over channels, levels, hydrometeor types
- nchan_loop: do ichan = 1, nchannels
- iprof = lprofiles (ichan)
- ifreq = frequencies (ichan)
-
- nlayer_loop: do ilayer = 1, nwp_levels
- ntype_loop: do itype = 1, coef_scatt % nhydro - 1
-
- wc_tl = 0.0_JPRB
- wc = 0.0_JPRB
-
- select case (itype)
- case (1_jpim)
- if (scatt_aux % rain (iprof,ilayer) > 0.0_JPRB) then
- wc = coef_scatt % scale_water * log10 (scatt_aux % rain (iprof,ilayer)) - coef_scatt % offset_water
- wc_tl = coef_scatt % scale_water * scatt_aux_tl % rain (iprof,ilayer) &
- & / (zln10 * scatt_aux % rain (iprof,ilayer))
- endif
- temp = cld_profiles(iprof) % t(ilayer) - coef_scatt % offset_temp_rain
- case (2_jpim)
- if (scatt_aux % sp (iprof,ilayer) > 0.0_JPRB) then
- wc = coef_scatt % scale_water * log10 (scatt_aux % sp (iprof,ilayer)) - coef_scatt % offset_water
- wc_tl = coef_scatt % scale_water * scatt_aux_tl % sp (iprof,ilayer) &
- & / (zln10 * scatt_aux % sp (iprof,ilayer))
- endif
- temp = cld_profiles(iprof) % t(ilayer) - coef_scatt % offset_temp_sp
- case (3_jpim)
- if (scatt_aux % clw (iprof,ilayer) > 0.0_JPRB) then
- wc = coef_scatt % scale_water * log10 (scatt_aux % clw (iprof,ilayer)) - coef_scatt % offset_water
- wc_tl = coef_scatt % scale_water * scatt_aux_tl % clw (iprof,ilayer) &
- & / (zln10 * scatt_aux % clw (iprof,ilayer))
- endif
- temp = cld_profiles(iprof) % t(ilayer) - coef_scatt % offset_temp_liq
- case (4_jpim)
- if (scatt_aux % ciw (iprof,ilayer) > 0.0_JPRB) then
- wc = coef_scatt % scale_water * log10 (scatt_aux % ciw (iprof,ilayer)) - coef_scatt % offset_water
- wc_tl = coef_scatt % scale_water * scatt_aux_tl % ciw (iprof,ilayer) &
- & / (zln10 * scatt_aux % ciw (iprof,ilayer))
- endif
- temp = cld_profiles(iprof) % t(ilayer) - coef_scatt % offset_temp_ice
- end select
-
-!* nearest index for Mie-table: LWC/IWC
- iwc = floor (wc)
- if (iwc > coef_scatt % mwc - 1) iwc = coef_scatt % mwc - 1
-
-!* nearest index for Mie-table: T (w/o melting layer)
- itemp = anint (temp)
- if (itemp < 1) itemp = 1
- if (itemp > coef_scatt % mtemp - 1) itemp = coef_scatt % mtemp - 1
-
- if (iwc >= 1) then
- s_k = coef_scatt % ext (ifreq,itype,itemp,iwc+1) - coef_scatt % ext (ifreq,itype,itemp,iwc)
- s_a = coef_scatt % ssa (ifreq,itype,itemp,iwc+1) - coef_scatt % ssa (ifreq,itype,itemp,iwc)
- s_g = coef_scatt % asp (ifreq,itype,itemp,iwc+1) - coef_scatt % asp (ifreq,itype,itemp,iwc)
-
- kp = coef_scatt % ext (ifreq,itype,itemp,iwc) + s_k * (wc - iwc)
- kp_tl = s_k * wc_tl
-
- ap = coef_scatt % ssa (ifreq,itype,itemp,iwc) + s_a * (wc - iwc)
- ap_tl = s_a * wc_tl
-
- gp = coef_scatt % asp (ifreq,itype,itemp,iwc) + s_g * (wc - iwc)
- gp_tl = s_g * wc_tl
- else
- kp = 1.0E-10_JPRB
- ap = 0.0_JPRB
- gp = 0.0_JPRB
- kp_tl = 0.0_JPRB
- ap_tl = 0.0_JPRB
- gp_tl = 0.0_JPRB
- endif
-
- scatt_aux % ext (ichan,ilayer) = scatt_aux % ext (ichan,ilayer) + kp
- scatt_aux_tl % ext (ichan,ilayer) = scatt_aux_tl % ext (ichan,ilayer) + kp_tl
-
- scatt_aux % ssa (ichan,ilayer) = scatt_aux % ssa (ichan,ilayer) + kp * ap
- scatt_aux_tl % ssa (ichan,ilayer) = scatt_aux_tl % ssa (ichan,ilayer) + kp_tl * ap + kp * ap_tl
-
- scatt_aux % asm (ichan,ilayer) = scatt_aux % asm (ichan,ilayer) + kp * ap * gp
- scatt_aux_tl % asm (ichan,ilayer) = scatt_aux_tl % asm (ichan,ilayer) + kp_tl * ap * gp &
- & + kp * ap_tl * gp + kp * ap * gp_tl
- enddo ntype_loop
- enddo nlayer_loop
- enddo nchan_loop
-
- do ilayer = 1, nwp_levels
- where (scatt_aux % asm (:,ilayer) > 0.0_JPRB)
- scatt_aux_tl % asm (:,ilayer) = scatt_aux_tl % asm (:,ilayer) / scatt_aux % ssa (:,ilayer) &
- & - scatt_aux_tl % ssa (:,ilayer) * scatt_aux % asm (:,ilayer) &
- & / scatt_aux % ssa (:,ilayer) / scatt_aux % ssa (:,ilayer)
- scatt_aux % asm (:,ilayer) = scatt_aux % asm (:,ilayer) / scatt_aux % ssa (:,ilayer)
- endwhere
- where (scatt_aux % ssa (:,ilayer) > 0.0_JPRB)
- scatt_aux_tl % ssa (:,ilayer) = (scatt_aux_tl % ssa (:,ilayer) * scatt_aux % ext (:,ilayer) &
- & - scatt_aux % ssa (:,ilayer) * scatt_aux_tl % ext (:,ilayer)) &
- & / (scatt_aux % ext (:,ilayer) * scatt_aux % ext (:,ilayer))
- scatt_aux % ssa (:,ilayer) = scatt_aux % ssa (:,ilayer) / scatt_aux % ext (:,ilayer)
- endwhere
- where (scatt_aux % ext (:,ilayer) >= 20.0_JPRB)
- scatt_aux_tl % ext (:,ilayer) = 0.0_JPRB
- scatt_aux % ext (:,ilayer) = 20.0_JPRB
- endwhere
- enddo
-
-End subroutine rttov_mieproc_tl
diff --git a/src/LIB/RTTOV/src/rttov_mieproc_tl.interface b/src/LIB/RTTOV/src/rttov_mieproc_tl.interface
deleted file mode 100644
index 149266a95c4e77a641e30b53fffa6b9f968f841d..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_mieproc_tl.interface
+++ /dev/null
@@ -1,32 +0,0 @@
-INTERFACE
-Subroutine rttov_mieproc_tl (&
- & nwp_levels,&
- & nchannels,&
- & nprofiles,&
- & frequencies,&
- & lprofiles,&
- & cld_profiles,&
- & cld_profiles_tl,&
- & coef_rttov,&
- & coef_scatt,&
- & scatt_aux,&
- & scatt_aux_tl)
- Use rttov_types, Only :&
- & rttov_coef ,&
- & profile_scatt_aux ,&
- & profile_cloud_Type ,&
- & rttov_scatt_coef
- Use parkind1, Only : jpim ,jprb
- Integer (Kind=jpim), Intent (in) :: nwp_levels
- Integer (Kind=jpim), Intent (in) :: nchannels
- Integer (Kind=jpim), Intent (in) :: nprofiles
- Integer (Kind=jpim), Intent (in) :: frequencies (nchannels)
- Integer (Kind=jpim), Intent (in) :: lprofiles (nchannels)
- Type (profile_cloud_Type), Intent (in) :: cld_profiles (nprofiles)
- Type (profile_cloud_Type), Intent (in) :: cld_profiles_tl (nprofiles)
- Type (rttov_coef), Intent (in) :: coef_rttov
- Type (rttov_scatt_coef), Intent (in) :: coef_scatt
- Type (profile_scatt_aux), Intent (inout) :: scatt_aux
- Type (profile_scatt_aux), Intent (inout) :: scatt_aux_tl
-End subroutine rttov_mieproc_tl
-END INTERFACE
diff --git a/src/LIB/RTTOV/src/rttov_opencoeff.F90 b/src/LIB/RTTOV/src/rttov_opencoeff.F90
deleted file mode 100644
index 19dacb2156dd6e44ae5bd6a2f30b046b34d552bd..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_opencoeff.F90
+++ /dev/null
@@ -1,207 +0,0 @@
-!
-Subroutine rttov_opencoeff (&
- & errorstatus,&
- & coeffname, &
- & file_id, &
- & for_output, &
- & lbinary )
- ! Description:
- ! Opens a file given by the name "coeffname" with logical
- ! unit file_id for output (for_output= .true.) or input and returns
- ! the error status errorstatus.
- ! If file_id input is zero the routine uses the first free logical unit.
- ! The optional logical argument lbinary determines the expected data storage.
- ! If lbinary is false or not present the file is assumed as a sequential
- ! formatted, in other case it is sequential unformatted.
- !
- ! Copyright:
- ! This software was developed within the context of
- ! the EUMETSAT Satellite Application Facility on
- ! Numerical Weather Prediction (NWP SAF), under the
- ! Cooperation Agreement dated 25 November 1998, between
- ! EUMETSAT and the Met Office, UK, by one or more partners
- ! within the NWP SAF. The partners in the NWP SAF are
- ! the Met Office, ECMWF, KNMI and MeteoFrance.
- !
- ! Copyright 2002, EUMETSAT, All Rights Reserved.
- !
- ! Method:
- !
- ! Current Code Owner: SAF NWP
- !
- ! History:
- ! Version Date Comment
- ! ------- ---- -------
- ! 1.0 01/12/2002 New F90 code with structures (P Brunel A Smith)
- !
- ! Code Description:
- ! Language: Fortran 90.
- ! Software Standards: "European Standards for Writing and
- ! Documenting Exchangeable Fortran 90 Code".
- !
- ! Declarations:
- ! Imported Parameters:
- Use rttov_const, Only : &
- & errorstatus_success ,&
- & errorstatus_warning ,&
- & errorstatus_fatal
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
-#include "rttov_errorreport.interface"
-
- ! subroutine arguments
- ! scalar arguments with intent(in):
- Character (*), Intent (in) :: coeffname ! filename of the coefficient file
- Logical, Optional, Intent (in) :: for_output ! file access mode
- Logical, Optional, Intent (in) :: lbinary ! if binary file wanted
-
- ! scalar arguments with intent(inout):
- Integer(Kind=jpim), Intent(inout) :: file_id
-
- ! scalar arguments with intent(out):
- Integer(Kind=jpim), Intent(out) :: errorstatus
-
-
-
- ! Local Scalars:
- Character (len=8) :: file_status
- Character (len=8) :: file_action
- Character (len=16):: file_form
- Integer(Kind=jpim) :: file_output ! 1 for output; 0 for input
- Logical :: file_Open
- Logical :: existence
- Integer(Kind=jpim) :: file_unit
- Integer(Kind=jpim) :: io_status
-
- Character (len=80) :: errMessage
- Character (len=16) :: NameOfRoutine = 'rttov_opencoeff '
- !- End of header --------------------------------------------------------
-
- file_unit = file_id
-
- ! Consider file_id argument to determine unit for open
- ! Be careful of the following loop for searching
- ! the first free logical unit. It has been observed that
- ! with some high level compiler options it can have some
- ! side effect, like returning file_id with 0 value.
- If( file_id <= 0 ) Then
- ! get the first free logical unit
-
-
- ! --------------------------------------------
- ! Initialise logical unit number and file_open
- ! --------------------------------------------
-
- file_unit = 9
- file_Open = .True.
-
-
- ! ------------------------------
- ! Start open loop for file_id search
- ! ------------------------------
-
- file_search: Do
-
- ! -- Increment logical unit number
- file_unit = file_unit + 1
-
- ! -- Check if file is open
- Inquire( file_unit, OPENED = file_Open )
-
- ! -- Is this file_id available?
- If ( .Not. file_Open ) Exit file_search
-
- End Do file_search
-
- Endif
-
- If( file_id <= 0 .and. file_unit >= 9) Then
- file_id = file_unit
- End If
-
-
- ! Consider lbinary option to create the option
- If(Present(lbinary)) Then
- If(lbinary) Then
- file_form = 'unformatted'
- Else
- file_form = 'formatted'
- Endif
- Else
- file_form = 'formatted'
- Endif
-
- ! mode access
- If(Present(for_output)) Then
- If(for_output) Then
- file_output = 1
- Else
- file_output = 0
- Endif
- Else
- file_output = 0
- Endif
-
- !#--------------------------------------------------------------------------#
- !# -- Check data file existence -- #
- !#--------------------------------------------------------------------------#
-
- Inquire( FILE = coeffname, EXIST = existence )
- If ( file_output == 0 ) Then
- ! -- If data file does not exist, return an error
-
- If ( .Not. existence ) Then
- errorstatus = errorstatus_fatal
- Write( errMessage, '( "Coefficient file, ", a, " not found." )' ) &
- & Trim( coeffname )
- Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine)
- Return
- End If
-
- ! -- Set OPEN keywords for reading
- file_status = 'OLD '
- file_action = 'READ '
-
- Else
-
- ! -- If data file does exist, output a warning message
- If ( existence ) Then
- errorstatus = errorstatus_warning
- Write( errMessage, '( "Coefficient file, ", a, " will be overwritten." )' ) &
- & Trim( coeffname )
- Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine)
- End If
-
- ! -- Set OPEN keywords for writing
- file_status = 'REPLACE'
- file_action = 'WRITE'
-
- End If
-
- !#--------------------------------------------------------------------------#
- !# -- Open the data file -- #
- !#--------------------------------------------------------------------------#
-
- Open( file_id, FILE = coeffname, &
- & STATUS = Trim( file_status ), &
- & ACTION = Trim( file_action ), &
- & ACCESS = 'SEQUENTIAL', &
- & FORM = Trim( file_form ), &
- & IOSTAT = io_status )
-
- If ( io_status /= 0 ) Then
- errorstatus = errorstatus_fatal
- Write( errMessage, '( "Error opening ", a, ". IOSTAT = ", i5 )' ) &
- & coeffname, io_status
- Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine)
- Return
- End If
-
-
- errorstatus = errorstatus_success
-
-
-
-End Subroutine rttov_opencoeff
diff --git a/src/LIB/RTTOV/src/rttov_opencoeff.interface b/src/LIB/RTTOV/src/rttov_opencoeff.interface
deleted file mode 100644
index 16e23039d74c268fc340d25531d147a86e98b050..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_opencoeff.interface
+++ /dev/null
@@ -1,29 +0,0 @@
-Interface
-!
-Subroutine rttov_opencoeff (&
- & errorstatus,&
- & coeffname, &
- & file_id, &
- & for_output, &
- & lbinary )
- Use rttov_const, Only : &
- errorstatus_success ,&
- errorstatus_warning ,&
- errorstatus_fatal
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
-
- Character (*), Intent (in) :: coeffname ! filename of the coefficient file
- Logical, Optional, Intent (in) :: for_output ! file access mode
- Logical, Optional, Intent (in) :: lbinary ! if binary file wanted
-
- Integer(Kind=jpim), Intent(inout) :: file_id
-
- Integer(Kind=jpim), Intent(out) :: errorstatus
-
-
-
-End Subroutine rttov_opencoeff
-End Interface
diff --git a/src/LIB/RTTOV/src/rttov_polcoe.F90 b/src/LIB/RTTOV/src/rttov_polcoe.F90
deleted file mode 100644
index a6739c9a75137fc59c15e18ccf7532c31f40e5b0..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_polcoe.F90
+++ /dev/null
@@ -1,48 +0,0 @@
-SUBROUTINE rttov_polcoe(x,y,n,cof)
- !
- ! Description:
- ! Numerical Recipes Routine for cubic interpolation
- !
- ! History:
- ! Version Date Comment
- ! ------- ---- -------
- ! 1 07/10/2004 Added history
- ! 1.1 29/03/2005 Add end of header comment (J. Cameron)
- !
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
- Integer(Kind=jpim) :: n,NMAX
- Real(Kind=jprb) :: cof(n),x(n),y(n)
- PARAMETER (NMAX=15)
- Integer(Kind=jpim) :: i,j,k
- Real(Kind=jprb) :: b,ff,phi,s(NMAX)
-
- !- End of header --------------------------------------------------------
-
- do i=1,n
- s(i)=0._JPRB
- cof(i)=0._JPRB
- enddo
- s(n)=-x(1)
- do i=2,n
- do j=n+1-i,n-1
- s(j)=s(j)-x(i)*s(j+1)
- enddo
- s(n)=s(n)-x(i)
- enddo
- do j=1,n
- phi=n
- do k=n-1,1,-1
- phi=k*s(k+1)+x(j)*phi
- enddo
- ff=y(j)/phi
- b=1._JPRB
- do k=n,1,-1
- cof(k)=cof(k)+b*ff
- b=s(k)+x(j)*b
- enddo
- enddo
-
-END SUBROUTINE rttov_polcoe
-! (C) Copr. 1986-92 Numerical Recipes Software
diff --git a/src/LIB/RTTOV/src/rttov_polcoe.interface b/src/LIB/RTTOV/src/rttov_polcoe.interface
deleted file mode 100644
index dc058e6403c8c79631fb24e663238261fee78934..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_polcoe.interface
+++ /dev/null
@@ -1,10 +0,0 @@
-Interface
- Subroutine rttov_polcoe (x, y, n, cof)
- Use parkind1, Only: jpim, jprb
- Implicit None
- Integer (Kind=jpim) :: n
- Real (Kind=jprb), Dimension (n) :: y
- Real (Kind=jprb), Dimension (n) :: x
- Real (Kind=jprb), Dimension (n) :: cof
- End Subroutine rttov_polcoe
-End Interface
diff --git a/src/LIB/RTTOV/src/rttov_profaux.F90 b/src/LIB/RTTOV/src/rttov_profaux.F90
deleted file mode 100644
index 8ee35720ed59ef2805b1311c40e0c905f82b9bff..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_profaux.F90
+++ /dev/null
@@ -1,125 +0,0 @@
-!
-Subroutine rttov_profaux( &
- & prof, &! in
- & coef, &! in
- & aux) ! inout
- !
- ! Description:
- ! Calculates some variables related to the input profile.
- ! variables are nearest surface level, nearest cloud top level
- ! and Debye terms for MW
- ! The reason of having a separate structure for these
- ! variables is that the input profiles should be "read only"
- ! in RTTOV context.
- !
- ! Copyright:
- ! This software was developed within the context of
- ! the EUMETSAT Satellite Application Facility on
- ! Numerical Weather Prediction (NWP SAF), under the
- ! Cooperation Agreement dated 25 November 1998, between
- ! EUMETSAT and the Met Office, UK, by one or more partners
- ! within the NWP SAF. The partners in the NWP SAF are
- ! the Met Office, ECMWF, KNMI and MeteoFrance.
- !
- ! Copyright 2002, EUMETSAT, All Rights Reserved.
- !
- ! Method:
- !
- ! Current Code Owner: SAF NWP
- !
- ! History:
- ! Version Date Comment
- ! ------- ---- -------
- ! 1.0 01/12/2002 New F90 code with structures (P Brunel A Smith)
- !
- ! Code Description:
- ! Language: Fortran 90.
- ! Software Standards: "European Standards for Writing and
- ! Documenting Exchangeable Fortran 90 Code".
- !
- ! Declarations:
- ! Modules used:
- ! Imported Parameters:
- Use rttov_const, Only : &
- & sensor_id_mw, &! sensor id number for MW
- & mwcldtop , &! Upper level for lwp calcs
- & dcoeff ! debye coefficients
-
- ! Imported Type Definitions:
- Use rttov_types, Only : &
- & rttov_coef ,&
- & profile_Type ,&
- & profile_aux
-
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
- !subroutine arguments:
- Type(profile_Type), Intent(in) :: prof ! profile
- Type(rttov_coef) , Intent(in) :: coef ! coefficients
- Type(profile_aux) , Intent(inout) :: aux ! auxilary profile info
-
-
-
- !local
- Integer(Kind=jpim) :: lev
- Real(Kind=jprb) :: v ! temperature ratio
- !- End of header --------------------------------------------------------
-
- !-----------------------------------------
- !2. determine cloud top and surface levels
- !-----------------------------------------
-
- !nearest level above surface
- Do lev = prof % nlevels - 1, 1, -1
- If ( prof % s2m % p > coef % ref_prfl_p( lev ) ) Exit
- End Do
- aux % nearestlev_surf = lev + 1
- aux % pfraction_surf = &
- & (coef % ref_prfl_p(aux % nearestlev_surf) - prof % s2m % p)&
- & / coef % dp(aux % nearestlev_surf)
-
- If( coef % id_sensor /= sensor_id_mw ) Then
- !nearest level above cloud top
- Do lev = prof % nlevels-1, 1, -1
- If ( prof % ctp > coef % ref_prfl_p(lev) ) Exit
- End Do
- aux % nearestlev_ctp = lev+1
- aux % pfraction_ctp =&
- & (coef % ref_prfl_p(aux % nearestlev_ctp) - prof % ctp)&
- & / coef % dp(aux % nearestlev_ctp)
- aux % cfraction = prof%cfraction
- Else
- ! for micro waves do not consider clouds in the RTTOV basis routines
- aux % nearestlev_ctp = prof % nlevels-1
- aux % pfraction_ctp = 0._JPRB
- aux % cfraction = 0._JPRB
- Endif
-
- ! Description:
- ! To calculate individual debye terms for temperature
- ! at each level. There are five debye terms. These
- ! will be used in fastem and opdep to calculate
- ! permittivity which is required for surface emissivity
- ! and cloud modelling
- !
- ! Method:
- ! The model is a hybrid of LIEBE MPM 1993 and the PIOM laboratory
- ! measurements reported by ELLISON et al. 1999.
-
- If ( prof % clw_Data ) Then
- Do lev = mwcldtop, prof % nlevels
- v = 300.0_JPRB / prof % t(lev) - 1.0_JPRB
- aux % debye_prof(1,lev) = dcoeff(1) - dcoeff(2) * v + dcoeff(3) * v*v
- aux % debye_prof(2,lev) = dcoeff(4) * aux % debye_prof(1,lev)
- aux % debye_prof(3,lev) = dcoeff(5) * v + dcoeff(6)
- aux % debye_prof(4,lev) = dcoeff(7) * aux % debye_prof(3,lev)
- aux % debye_prof(5,lev) = dcoeff(8)
- Enddo
-
- Endif
-
-
-
-End Subroutine rttov_profaux
diff --git a/src/LIB/RTTOV/src/rttov_profaux.interface b/src/LIB/RTTOV/src/rttov_profaux.interface
deleted file mode 100644
index 3f74b0e39163d717cb8513297f864e95c588b04a..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_profaux.interface
+++ /dev/null
@@ -1,28 +0,0 @@
-Interface
-!
-Subroutine rttov_profaux( &
- prof, & ! in
- coef, & ! in
- aux) ! inout
- Use rttov_const, Only : &
- sensor_id_mw, & ! sensor id number for MW
- mwcldtop , & ! Upper level for lwp calcs
- dcoeff ! debye coefficients
-
- Use rttov_types, Only : &
- rttov_coef ,&
- profile_Type ,&
- profile_aux
-
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
- Type(profile_Type), Intent(in) :: prof ! profile
- Type(rttov_coef) , Intent(in) :: coef ! coefficients
- Type(profile_aux) , Intent(inout) :: aux ! auxilary profile info
-
-
-
-End Subroutine rttov_profaux
-End Interface
diff --git a/src/LIB/RTTOV/src/rttov_profaux_ad.F90 b/src/LIB/RTTOV/src/rttov_profaux_ad.F90
deleted file mode 100644
index ff0b772063185f44c8f8ec1c38708d6b142f8e6a..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_profaux_ad.F90
+++ /dev/null
@@ -1,107 +0,0 @@
-Subroutine rttov_profaux_ad( &
- & prof, &! in
- & prof_ad, &! inout
- & coef, &! in
- & aux, &! in
- & aux_ad) ! inout
- !
- ! Description:
- ! AD of rttov_profaux
- !
- ! Copyright:
- ! This software was developed within the context of
- ! the EUMETSAT Satellite Application Facility on
- ! Numerical Weather Prediction (NWP SAF), under the
- ! Cooperation Agreement dated 25 November 1998, between
- ! EUMETSAT and the Met Office, UK, by one or more partners
- ! within the NWP SAF. The partners in the NWP SAF are
- ! the Met Office, ECMWF, KNMI and MeteoFrance.
- !
- ! Copyright 2002, EUMETSAT, All Rights Reserved.
- !
- ! Method:
- !
- ! Current Code Owner: SAF NWP
- !
- ! History:
- ! Version Date Comment
- ! ------- ---- -------
- ! 1.0 07/10/2004 Added history
- ! 1.1 29/03/2005 Add end of header comment (J. Cameron)
- !
- ! Code Description:
- ! Language: Fortran 90.
- ! Software Standards: "European Standards for Writing and
- ! Documenting Exchangeable Fortran 90 Code".
- !
- ! Declarations:
- ! Modules used:
- ! Imported Parameters:
-
- Use rttov_const, Only : &
- & sensor_id_mw, &! sensor id number for MW
- & mwcldtop , &! Upper level for lwp calcs
- & dcoeff ! debye coefficients
-
- Use rttov_types, Only : &
- & rttov_coef ,&
- & profile_Type ,&
- & profile_aux
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
- !subroutine arguments:
- Type(profile_Type), Intent(in) :: prof
- Type(profile_Type), Intent(inout):: prof_ad
- Type(rttov_coef) , Intent(in) :: coef
- Type(profile_aux) , Intent(in) :: aux
- Type(profile_aux) , Intent(inOUT):: aux_ad
-
-
-
- ! local
- Integer(Kind=jpim) :: lev
- Real(Kind=jprb) :: v ! temperature ratio
- Real(Kind=jprb) :: v_ad ! temperature ratio
-
- !- End of header --------------------------------------------------------
-
- If ( prof % clw_Data ) Then
- Do lev = prof % nlevels, mwcldtop, -1
- v = 300.0_JPRB / prof % t(lev) - 1.0_JPRB
-
- aux_ad % debye_prof(3,lev) = aux_ad % debye_prof(3,lev) +&
- & aux_ad % debye_prof(4,lev) * dcoeff(7)
-
- v_ad = aux_ad % debye_prof(3,lev) * dcoeff(5)
-
- aux_ad % debye_prof(1,lev) = aux_ad % debye_prof(1,lev) +&
- & aux_ad % debye_prof(2,lev) * dcoeff(4)
-
- v_ad = v_ad + aux_ad % debye_prof(1,lev) *&
- & (- dcoeff(2) + 2 * dcoeff(3) * v)
-
- prof_ad % t(lev) = prof_ad % t(lev) + v_ad *&
- & (-300.0_JPRB / prof % t(lev)**2)
-
- Enddo
- !aux_ad % debye_prof(:,:) = 0.
- Endif
-
- If( coef % id_sensor /= sensor_id_mw ) Then
- !nearest level above cloud top
- prof_ad%cfraction = prof_ad%cfraction + aux_ad % cfraction
-
- prof_ad % ctp = prof_ad % ctp - aux_ad % pfraction_ctp /&
- & coef % dp(aux % nearestlev_ctp)
- !Else
- ! for micro waves do not consider clouds in the RTTOV basis routines
- Endif
-
- !nearest level above surface
- prof_ad % s2m % p = prof_ad % s2m % p - aux_ad % pfraction_surf /&
- & coef % dp(aux % nearestlev_surf)
-
-
-End Subroutine rttov_profaux_ad
diff --git a/src/LIB/RTTOV/src/rttov_profaux_ad.interface b/src/LIB/RTTOV/src/rttov_profaux_ad.interface
deleted file mode 100644
index 00dec2c952b5a506f9d526622f57bae9f6db7b8f..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_profaux_ad.interface
+++ /dev/null
@@ -1,31 +0,0 @@
-Interface
-Subroutine rttov_profaux_ad( &
- prof, & ! in
- prof_ad, & ! inout
- coef, & ! in
- aux, & ! in
- aux_ad) ! inout
-
- Use rttov_const, Only : &
- sensor_id_mw, & ! sensor id number for MW
- mwcldtop , & ! Upper level for lwp calcs
- dcoeff ! debye coefficients
-
- Use rttov_types, Only : &
- rttov_coef ,&
- profile_Type ,&
- profile_aux
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
- Type(profile_Type), Intent(in) :: prof
- Type(profile_Type), Intent(inout):: prof_ad
- Type(rttov_coef) , Intent(in) :: coef
- Type(profile_aux) , Intent(in) :: aux
- Type(profile_aux) , Intent(inOUT):: aux_ad
-
-
-
-End Subroutine rttov_profaux_ad
-End Interface
diff --git a/src/LIB/RTTOV/src/rttov_profaux_k.F90 b/src/LIB/RTTOV/src/rttov_profaux_k.F90
deleted file mode 100644
index c6cae302ac15eed36c17714e28fcbbb147716520..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_profaux_k.F90
+++ /dev/null
@@ -1,152 +0,0 @@
-Subroutine rttov_profaux_k( &
- & nfrequencies, &! in
- & nchannels, &! in
- & nprofiles, &! in
- & polarisations, &! in
- & lprofiles, &! in
- & profiles, &! in
- & profiles_k, &! inout
- & coef, &! in
- & aux_prof, &! in
- & aux_prof_k ) ! inout
- !
- ! Description:
- ! K of rttov_profaux
- !
- ! Copyright:
- ! This software was developed within the context of
- ! the EUMETSAT Satellite Application Facility on
- ! Numerical Weather Prediction (NWP SAF), under the
- ! Cooperation Agreement dated 25 November 1998, between
- ! EUMETSAT and the Met Office, UK, by one or more partners
- ! within the NWP SAF. The partners in the NWP SAF are
- ! the Met Office, ECMWF, KNMI and MeteoFrance.
- !
- ! Copyright 2005, EUMETSAT, All Rights Reserved.
- !
- ! Method:
- !
- ! Current Code Owner: SAF NWP
- !
- ! History:
- ! Version Date Comment
- ! ------- ---- -------
- ! 1.0 22/06/2005 initial (P Brunel)
- ! based on version 1.0 (07/10/04) of AD code
- !
- ! Code Description:
- ! Language: Fortran 90.
- ! Software Standards: "European Standards for Writing and
- ! Documenting Exchangeable Fortran 90 Code".
- !
- ! Declarations:
- ! Modules used:
- ! Imported Parameters:
-
- Use rttov_const, Only : &
- & sensor_id_mw, &! sensor id number for MW
- & mwcldtop , &! Upper level for lwp calcs
- & dcoeff ! debye coefficients
-
- Use rttov_types, Only : &
- & rttov_coef ,&
- & profile_Type ,&
- & profile_aux
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
- !subroutine arguments:
- Integer(Kind=jpim), Intent(in) :: nfrequencies ! Number of frequencies
- Integer(Kind=jpim), Intent(in) :: nchannels ! Number of output radiances
- Integer(Kind=jpim), Intent(in) :: nprofiles ! Number of profiles
- Integer(Kind=jpim), Intent(in) :: polarisations(nchannels,3) ! polarisation indices
- Integer(Kind=jpim), Intent(in) :: lprofiles(nfrequencies) ! Profiles indices
-
- Type(profile_Type), Target, Intent(in) :: profiles(nprofiles)
- Type(profile_Type), Target, Intent(inout) :: profiles_k(nchannels)
- Type(profile_aux), Target, Intent(in) :: aux_prof(nprofiles)
- Type(profile_aux), Target, Intent(inout) :: aux_prof_k(nchannels)
- Type(rttov_coef), Intent(in) :: coef
-
- !local variables:
- Type(profile_Type), Pointer :: prof
- Type(profile_Type), Pointer :: prof_k
- Type(profile_aux) , Pointer :: aux
- Type(profile_aux) , Pointer :: aux_k
-
- Integer(Kind=jpim) :: lev
- Integer(Kind=jpim) :: i
- Integer(Kind=jpim) :: j
- Integer(Kind=jpim) :: freq
-
- Real(Kind=jprb) :: v ! temperature ratio
- Real(Kind=jprb) :: v_k ! temperature ratio
- !- End of header --------------------------------------------------------
- nullify ( prof )
- nullify ( prof_k )
- nullify ( aux )
- nullify ( aux_k )
-
- Do i = 1, nchannels
- freq=polarisations(i,2)
- j = lprofiles( freq )
-
- prof => profiles(j)
- aux => aux_prof(j)
- prof_k => profiles_k(i)
- aux_k => aux_prof_k(i)
-
- If ( prof % clw_Data ) Then
- Do lev = prof % nlevels, mwcldtop, -1
- v = 300.0_JPRB / prof % t(lev) - 1.0_JPRB
-
- aux_k % debye_prof(3,lev) = aux_k % debye_prof(3,lev) +&
- & aux_k % debye_prof(4,lev) * dcoeff(7)
-
- v_k = aux_k % debye_prof(3,lev) * dcoeff(5)
-
- aux_k % debye_prof(1,lev) = aux_k % debye_prof(1,lev) +&
- & aux_k % debye_prof(2,lev) * dcoeff(4)
-
- v_k = v_k + aux_k % debye_prof(1,lev) *&
- & (- dcoeff(2) + 2 * dcoeff(3) * v)
-
- prof_k % t(lev) = prof_k % t(lev) + v_k *&
- & (-300.0_JPRB / prof % t(lev)**2)
-
- Enddo
- !aux_k % debye_prof(:,:) = 0.
- Endif
-
- !nearest level above surface
- prof_k % s2m % p = prof_k % s2m % p - aux_k % pfraction_surf /&
- & coef % dp(aux % nearestlev_surf)
-
- End Do
-
- If( coef % id_sensor /= sensor_id_mw ) Then
- Do i = 1, nchannels
- freq=polarisations(i,2)
- j = lprofiles( freq )
-
- prof => profiles(j)
- aux => aux_prof(j)
- prof_k => profiles_k(i)
- aux_k => aux_prof_k(i)
- !nearest level above cloud top
- prof_k%cfraction = prof_k%cfraction + aux_k % cfraction
-
- prof_k % ctp = prof_k % ctp - aux_k % pfraction_ctp /&
- & coef % dp(aux % nearestlev_ctp)
- End Do
- !Else
- ! for micro waves do not consider clouds in the RTTOV basis routines
- Endif
-
- nullify ( prof )
- nullify ( prof_k )
- nullify ( aux )
- nullify ( aux_k )
-
-End Subroutine rttov_profaux_k
diff --git a/src/LIB/RTTOV/src/rttov_profaux_k.interface b/src/LIB/RTTOV/src/rttov_profaux_k.interface
deleted file mode 100644
index 329a39a9747653ea9ba3fd1db74a903dd8fefb47..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_profaux_k.interface
+++ /dev/null
@@ -1,42 +0,0 @@
-Interface
-!
-Subroutine rttov_profaux_k( &
- & nfrequencies, &! in
- & nchannels, &! in
- & nprofiles, &! in
- & polarisations, &! in
- & lprofiles, &! in
- & profiles, &! in
- & profiles_k, &! inout
- & coef, &! in
- & aux_prof, &! in
- & aux_prof_k ) ! inout
-
- Use rttov_const, Only : &
- & sensor_id_mw, &! sensor id number for MW
- & mwcldtop , &! Upper level for lwp calcs
- & dcoeff ! debye coefficients
-
- Use rttov_types, Only : &
- & rttov_coef ,&
- & profile_Type ,&
- & profile_aux
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
- !subroutine arguments:
- Integer(Kind=jpim), Intent(in) :: nfrequencies ! Number of frequencies
- Integer(Kind=jpim), Intent(in) :: nchannels ! Number of output radiances
- Integer(Kind=jpim), Intent(in) :: nprofiles ! Number of profiles
- Integer(Kind=jpim), Intent(in) :: polarisations(nchannels,3) ! polarisation indices
- Integer(Kind=jpim), Intent(in) :: lprofiles(nfrequencies) ! Profiles indices
-
- Type(profile_Type), Target, Intent(in) :: profiles(nprofiles)
- Type(profile_Type), Target, Intent(inout) :: profiles_k(nchannels)
- Type(profile_aux), Target, Intent(in) :: aux_prof(nprofiles)
- Type(profile_aux), Target, Intent(inout) :: aux_prof_k(nchannels)
- Type(rttov_coef), Intent(in) :: coef
-
-End Subroutine rttov_profaux_k
-End Interface
diff --git a/src/LIB/RTTOV/src/rttov_profaux_tl.F90 b/src/LIB/RTTOV/src/rttov_profaux_tl.F90
deleted file mode 100644
index 4d8d2e4c8bbb877b32920eb7d17e3a41cd197213..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_profaux_tl.F90
+++ /dev/null
@@ -1,118 +0,0 @@
-Subroutine rttov_profaux_tl( &
- & prof, &! in
- & prof_tl, &! in
- & coef, &! in
- & aux, &! in
- & aux_tl) ! out
- !
- ! Description:
- ! TL of rttov_profaux
- !
- ! Copyright:
- ! This software was developed within the context of
- ! the EUMETSAT Satellite Application Facility on
- ! Numerical Weather Prediction (NWP SAF), under the
- ! Cooperation Agreement dated 25 November 1998, between
- ! EUMETSAT and the Met Office, UK, by one or more partners
- ! within the NWP SAF. The partners in the NWP SAF are
- ! the Met Office, ECMWF, KNMI and MeteoFrance.
- !
- ! Copyright 2002, EUMETSAT, All Rights Reserved.
- !
- ! Method:
- !
- ! Current Code Owner: SAF NWP
- !
- ! History:
- ! Version Date Comment
- ! ------- ---- -------
- ! 1.0 07/10/2004 Added history
- ! 1.1 29/03/2005 Add end of header comment (J. Cameron)
- !
- ! Code Description:
- ! Language: Fortran 90.
- ! Software Standards: "European Standards for Writing and
- ! Documenting Exchangeable Fortran 90 Code".
- !
- ! Declarations:
- ! Modules used:
- ! Imported Parameters:
-
- Use rttov_const, Only : &
- & sensor_id_mw, &! sensor id number for MW
- & mwcldtop , &! Upper level for lwp calcs
- & dcoeff ! debye coefficients
-
- Use rttov_types, Only : &
- & rttov_coef ,&
- & profile_Type ,&
- & profile_aux
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
- !subroutine arguments:
- Type(profile_Type), Intent(in) :: prof
- Type(profile_Type), Intent(in) :: prof_tl
- Type(rttov_coef) , Intent(in) :: coef
- Type(profile_aux) , Intent(in) :: aux
- Type(profile_aux) , Intent(inout) :: aux_tl
-
-
-
- ! local
- Integer(Kind=jpim) :: lev
- Real(Kind=jprb) :: v ! temperature ratio
- Real(Kind=jprb) :: v_tl ! temperature ratio
-
- !- End of header --------------------------------------------------------
-
- !-----------------------------------------
- !2. determine cloud top and surface levels
- !-----------------------------------------
-
- !nearest level above surface
- aux_tl % pfraction_surf =&
- & - prof_tl % s2m % p / coef % dp(aux % nearestlev_surf)
-
-
- If( coef % id_sensor /= sensor_id_mw ) Then
- !nearest level above cloud top
- aux_tl % pfraction_ctp =&
- & - prof_tl % ctp / coef % dp(aux % nearestlev_ctp)
- aux_tl % cfraction = prof_tl%cfraction
- Else
- ! for micro waves do not consider clouds in the RTTOV basis routines
- aux_tl % pfraction_ctp = 0._JPRB
- aux_tl % cfraction = 0._JPRB
- Endif
-
-
- ! Description:
- ! To calculate individual debye terms for temperature
- ! at each level. There are five debye terms. These
- ! will be used in fastem and opdep to calculate
- ! permittivity which is required for surface emissivity
- ! and cloud modelling
- !
- ! Method:
- ! The model is a hybrid of LIEBE MPM 1993 and the PIOM laboratory
- ! measurements reported by ELLISON et al. 1999.
-
- If ( prof % clw_Data ) Then
- Do lev = mwcldtop, prof % nlevels
- v = 300.0_JPRB / prof % t(lev) - 1.0_JPRB
- v_tl = -300.0_JPRB * prof_tl % t(lev) / prof % t(lev)**2
- aux_tl % debye_prof(1,lev) = - dcoeff(2) * v_tl +&
- & 2 * dcoeff(3) * v_tl * v
- aux_tl % debye_prof(2,lev) = dcoeff(4) * aux_tl % debye_prof(1,lev)
- aux_tl % debye_prof(3,lev) = dcoeff(5) * v_tl
- aux_tl % debye_prof(4,lev) = dcoeff(7) * aux_tl % debye_prof(3,lev)
- aux_tl % debye_prof(5,lev) = 0._JPRB
- Enddo
-
- Endif
-
-
-
-End Subroutine rttov_profaux_tl
diff --git a/src/LIB/RTTOV/src/rttov_profaux_tl.interface b/src/LIB/RTTOV/src/rttov_profaux_tl.interface
deleted file mode 100644
index 93594701b0c86e3dda90e93b6ee0031a4b348e2a..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_profaux_tl.interface
+++ /dev/null
@@ -1,31 +0,0 @@
-Interface
-Subroutine rttov_profaux_tl( &
- prof, & ! in
- prof_tl, & ! in
- coef, & ! in
- aux, & ! in
- aux_tl) ! out
-
- Use rttov_const, Only : &
- sensor_id_mw, & ! sensor id number for MW
- mwcldtop , & ! Upper level for lwp calcs
- dcoeff ! debye coefficients
-
- Use rttov_types, Only : &
- rttov_coef ,&
- profile_Type ,&
- profile_aux
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
- Type(profile_Type), Intent(in) :: prof
- Type(profile_Type), Intent(in) :: prof_tl
- Type(rttov_coef) , Intent(in) :: coef
- Type(profile_aux) , Intent(in) :: aux
- Type(profile_aux) , Intent(inout) :: aux_tl
-
-
-
-End Subroutine rttov_profaux_tl
-End Interface
diff --git a/src/LIB/RTTOV/src/rttov_profout_k.F90 b/src/LIB/RTTOV/src/rttov_profout_k.F90
deleted file mode 100644
index 0044645662017f828e458c1a3bf3bf09aa0243d5..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_profout_k.F90
+++ /dev/null
@@ -1,196 +0,0 @@
-!
-Subroutine rttov_profout_k( &
- nfrequencies, & ! in
- nchannels, & ! in
- nbtout, & ! in
- nprofiles, & ! in
- channels, & ! in
- lprofiles, & ! in
- polarisations, & ! in
- coef, & ! in
- geometry, & ! in
- profiles_k_all, & ! in
- profiles_k) ! Out
- ! Description:
- ! To convert an K-matrix brightness temperatures with 1, 2 or 4 polarisations
- ! polarisation requested by the user.
- ! There are seven options:
- ! 0. Return average of V and H polarisation.
- ! 1. Return AMSU-style mix polarisation (nominal V at nadir)
- ! 2. Return AMSU-style mix polarisation (nominal H at nadir)
- ! 3. Return Vertical polarisation
- ! 4. Return Horizontal polarisation
- ! 5. Return vertical and horizontal polarisation
- ! 6. Return full Stokes vector
- !
- ! For IR channels this variable is not required, and one unpolarised brightness
- ! temperature is computed.
- !
- ! Note options 0-4 return one polarisation per channel. Option 5 returns
- ! 2 polarisations per channel and option 6 four polarisations per channel.
- ! Note also that for options 1-3 two polarisations must be computed in RTTOV,
- ! even though only one is returned. For this reason rad%bt is replaced by
- ! rad%out, where rad%out has length of number of output channels, whereas
- ! rad%bt has length of all brightness temperatures computed in RTTOV.
- !
- ! Copyright:
- ! This software was developed within the context of
- ! the EUMETSAT Satellite Application Facility on
- ! Numerical Weather Prediction (NWP SAF), under the
- ! Cooperation Agreement dated 25 November 1998, between
- ! EUMETSAT and the Met Office, UK, by one or more partners
- ! within the NWP SAF. The partners in the NWP SAF are
- ! the Met Office, ECMWF, KNMI and MeteoFrance.
- !
- ! Copyright 2003, EUMETSAT, All Rights Reserved.
- !
- ! Method: Uses band correction coefficients for each channel
- ! read in from RT coefficient file.
- !
- ! Current Code Owner: SAF NWP
- !
- ! History:
- ! Version Date Comment
- ! ------- ---- -------
- ! 1.0 10/07/2003 New code required for polarimetric RTTOV (Steve English)
- ! 1.1 13/10/2006 Corrected bug in pol_id (R Saunders)
- ! Code Description:
- ! Language: Fortran 90.
- ! Software Standards: "European Standards for Writing and
- ! Documenting Exchangeable Fortran 90 Code".
- !
- ! Declarations:
- ! Modules used:
- ! Imported Type Definitions:
-
- Use rttov_const, only : &
- npolar_return, &
- npolar_compute, &
- pol_v , &
- pol_h
-
- Use rttov_types, Only : &
- rttov_coef ,&
- profile_Type ,&
- geometry_Type
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
- !subroutine arguments:
- Integer(Kind=jpim), Intent(in) :: nbtout
- Integer(Kind=jpim), Intent(in) :: nchannels
- Integer(Kind=jpim), Intent(in) :: nfrequencies
- Integer(Kind=jpim), Intent(in) :: nprofiles
- Type(geometry_Type), Intent(in) ,Target :: geometry(nprofiles)
- Integer(Kind=jpim), Intent(in) :: channels(nfrequencies)
- Integer(Kind=jpim), Intent(in) :: polarisations(nchannels,3)
- Integer(Kind=jpim), Intent(in) :: lprofiles(nfrequencies)
- Type(rttov_coef), Intent(in) :: coef ! Coefficients
- Type(profile_Type), Intent(inout) ,Target :: profiles_k(nbtout)
- Type(profile_Type), Intent(inout) ,Target :: profiles_k_all(nchannels)
-
- ! radiances are expressed in mw/cm-1/ster/sq.m
- ! and temperatures in Kelvin
-
- !local variables:
- Real(Kind=jprb) :: emissfactor_h,emissfactor_v
- Integer(Kind=jpim) :: chan,i,j,ich,ich2,pol_id,ii
- !Type(geometry_Type), Pointer :: geom
-
- !- End of header ------------------------------------------------------
-
- ich2=1
- Do i=1,nfrequencies
- chan = channels(i)
- pol_id = 0
- pol_id = coef % fastem_polar(chan) + 1
- ich = polarisations(i,1)
- If (pol_id >= 4) then
- ! Return all calculated polarisations (or just computed TB for IR channels)
- Do j=1,polarisations(i,3)
- profiles_k(ich2+j-1) % s2m % t = profiles_k_all(ich+j-1) % s2m % t
- profiles_k(ich2+j-1) % s2m % q = profiles_k_all(ich+j-1) % s2m % q
- profiles_k(ich2+j-1) % s2m % p = profiles_k_all(ich+j-1) % s2m % p
- profiles_k(ich2+j-1) % s2m % u = profiles_k_all(ich+j-1) % s2m % u
- profiles_k(ich2+j-1) % s2m % v = profiles_k_all(ich+j-1) % s2m % v
- profiles_k(ich2+j-1) % skin % t = profiles_k_all(ich+j-1) % skin % t
- profiles_k(ich2+j-1) % skin % fastem(1) = profiles_k_all(ich+j-1) % skin % fastem(1)
- profiles_k(ich2+j-1) % skin % fastem(2) = profiles_k_all(ich+j-1) % skin % fastem(2)
- profiles_k(ich2+j-1) % skin % fastem(3) = profiles_k_all(ich+j-1) % skin % fastem(3)
- profiles_k(ich2+j-1) % skin % fastem(4) = profiles_k_all(ich+j-1) % skin % fastem(4)
- profiles_k(ich2+j-1) % skin % fastem(5) = profiles_k_all(ich+j-1) % skin % fastem(5)
- profiles_k(ich2+j-1) % ctp = profiles_k_all(ich+j-1) % ctp
- profiles_k(ich2+j-1) % cfraction = profiles_k_all(ich+j-1) % cfraction
- Do ii=1,coef%nlevels
- profiles_k(ich2+j-1) % t(ii) = profiles_k_all(ich+j-1) % t(ii)
- profiles_k(ich2+j-1) % q(ii) = profiles_k_all(ich+j-1) % q(ii)
- profiles_k(ich2+j-1) % o3(ii) = profiles_k_all(ich+j-1) % o3(ii)
- profiles_k(ich2+j-1) % clw(ii) = profiles_k_all(ich+j-1) % clw(ii)
- enddo
- End Do
- Else If (pol_id == 1) then
- ! Return average of V and H polarisation
- profiles_k(ich2) % s2m % t = profiles_k_all(ich) % s2m % t + profiles_k_all(ich+1) % s2m % t
- profiles_k(ich2) % s2m % q = profiles_k_all(ich) % s2m % q + profiles_k_all(ich+1) % s2m % q
- profiles_k(ich2) % s2m % p = profiles_k_all(ich) % s2m % p + profiles_k_all(ich+1) % s2m % p
- profiles_k(ich2) % s2m % u = profiles_k_all(ich) % s2m % u + profiles_k_all(ich+1) % s2m % u
- profiles_k(ich2) % s2m % v = profiles_k_all(ich) % s2m % v + profiles_k_all(ich+1) % s2m % v
- profiles_k(ich2) % skin % t = profiles_k_all(ich) % skin % t + profiles_k_all(ich+1) % skin % t
- profiles_k(ich2) % skin % fastem(1) = profiles_k_all(ich) % skin % fastem(1) + profiles_k_all(ich+1) % skin % fastem(1)
- profiles_k(ich2) % skin % fastem(2) = profiles_k_all(ich) % skin % fastem(2) + profiles_k_all(ich+1) % skin % fastem(2)
- profiles_k(ich2) % skin % fastem(3) = profiles_k_all(ich) % skin % fastem(3) + profiles_k_all(ich+1) % skin % fastem(3)
- profiles_k(ich2) % skin % fastem(4) = profiles_k_all(ich) % skin % fastem(4) + profiles_k_all(ich+1) % skin % fastem(4)
- profiles_k(ich2) % skin % fastem(5) = profiles_k_all(ich) % skin % fastem(5) + profiles_k_all(ich+1) % skin % fastem(5)
- profiles_k(ich2) % ctp = profiles_k_all(ich) % ctp + profiles_k_all(ich+1) % ctp
- profiles_k(ich2) % cfraction = profiles_k_all(ich) % cfraction + profiles_k_all(ich+1) % cfraction
- Do ii=1,coef%nlevels
- profiles_k(ich2) % t(ii) = profiles_k_all(ich) % t(ii) + profiles_k_all(ich+1) % t(ii)
- profiles_k(ich2) % q(ii) = profiles_k_all(ich) % q(ii) + profiles_k_all(ich+1) % q(ii)
- profiles_k(ich2) % o3(ii) = profiles_k_all(ich) % o3(ii) + profiles_k_all(ich+1) % o3(ii)
- profiles_k(ich2) % clw(ii) = profiles_k_all(ich) % clw(ii) + profiles_k_all(ich+1) % clw(ii)
- enddo
- Else
- !geom => geometry( lprofiles(i) )
- emissfactor_v = pol_v(1,pol_id)+pol_v(2,pol_id)+pol_v(3,pol_id)
- emissfactor_h = pol_h(1,pol_id)+pol_h(2,pol_id)+pol_h(3,pol_id)
- profiles_k(ich2) % s2m % t = profiles_k_all(ich) % s2m % t*emissfactor_v +&
- profiles_k_all(ich+1) % s2m % t*emissfactor_h
- profiles_k(ich2) % s2m % q = profiles_k_all(ich) % s2m % q*emissfactor_v + &
- profiles_k_all(ich+1) % s2m % q*emissfactor_h
- profiles_k(ich2) % s2m % p = profiles_k_all(ich) % s2m % p*emissfactor_v + &
- profiles_k_all(ich+1) % s2m % p*emissfactor_h
- profiles_k(ich2) % s2m % u = profiles_k_all(ich) % s2m % u*emissfactor_v + &
- profiles_k_all(ich+1) % s2m % u*emissfactor_h
- profiles_k(ich2) % s2m % v = profiles_k_all(ich) % s2m % v*emissfactor_v + &
- profiles_k_all(ich+1) % s2m % v*emissfactor_h
- profiles_k(ich2) % skin % t = profiles_k_all(ich) % skin % t*emissfactor_v + &
- profiles_k_all(ich+1) % skin % t*emissfactor_h
- profiles_k(ich2) % skin % fastem(1) = profiles_k_all(ich) % skin % fastem(1)*emissfactor_v + &
- profiles_k_all(ich+1) % skin % fastem(1)*emissfactor_h
- profiles_k(ich2) % skin % fastem(2) = profiles_k_all(ich) % skin % fastem(2)*emissfactor_v + &
- profiles_k_all(ich+1) % skin % fastem(2)*emissfactor_h
- profiles_k(ich2) % skin % fastem(3) = profiles_k_all(ich) % skin % fastem(3)*emissfactor_v + &
- profiles_k_all(ich+1) % skin % fastem(3)*emissfactor_h
- profiles_k(ich2) % skin % fastem(4) = profiles_k_all(ich) % skin % fastem(4)*emissfactor_v + &
- profiles_k_all(ich+1) % skin % fastem(4)*emissfactor_h
- profiles_k(ich2) % skin % fastem(5) = profiles_k_all(ich) % skin % fastem(5)*emissfactor_v + &
- profiles_k_all(ich+1) % skin % fastem(5)*emissfactor_h
- profiles_k(ich2) % ctp = profiles_k_all(ich) % ctp*emissfactor_v + &
- profiles_k_all(ich+1) % ctp*emissfactor_h
- profiles_k(ich2) % cfraction = profiles_k_all(ich) % cfraction*emissfactor_v + &
- profiles_k_all(ich+1) % cfraction*emissfactor_h
- Do ii=1,coef%nlevels
- profiles_k(ich2) % t(ii) = profiles_k_all(ich) % t(ii)*emissfactor_v +&
- profiles_k_all(ich+1) % t(ii)*emissfactor_h
- profiles_k(ich2) % q(ii) = profiles_k_all(ich) % q(ii)*emissfactor_v + &
- profiles_k_all(ich+1) % q(ii)*emissfactor_h
- profiles_k(ich2) % o3(ii) = profiles_k_all(ich) % o3(ii)*emissfactor_v + &
- profiles_k_all(ich+1) % o3(ii)*emissfactor_h
- profiles_k(ich2) % clw(ii) = profiles_k_all(ich) % clw(ii)*emissfactor_v + &
- profiles_k_all(ich+1) % clw(ii)*emissfactor_h
- enddo
- End If
- ich2 = ich2 + npolar_return(pol_id)
- End Do
-End Subroutine rttov_profout_k
diff --git a/src/LIB/RTTOV/src/rttov_profout_k.interface b/src/LIB/RTTOV/src/rttov_profout_k.interface
deleted file mode 100644
index 72613358cf7e10463ca5476cf61d1ad6bf35b106..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_profout_k.interface
+++ /dev/null
@@ -1,44 +0,0 @@
-Interface
- !
- Subroutine rttov_profout_k( &
- nfrequencies, & ! in
- nchannels, & ! in
- nbtout, & ! in
- nprofiles, & ! in
- channels, & ! in
- lprofiles, & ! in
- polarisations, & ! in
- coef, & ! in
- geometry, & ! in
- profiles_k_all, & ! in
- profiles_k) ! Out
-
- Use rttov_const, only : &
- npolar_return, &
- npolar_compute, &
- pol_v , &
- pol_h
-
- Use rttov_types, Only : &
- rttov_coef ,&
- profile_Type ,&
- geometry_Type
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
- !subroutine arguments:
- Integer(Kind=jpim), Intent(in) :: nbtout
- Integer(Kind=jpim), Intent(in) :: nchannels
- Integer(Kind=jpim), Intent(in) :: nfrequencies
- Integer(Kind=jpim), Intent(in) :: nprofiles
- Type(geometry_Type), Intent(in) ,Target :: geometry(nprofiles)
- Integer(Kind=jpim), Intent(in) :: channels(nfrequencies)
- Integer(Kind=jpim), Intent(in) :: polarisations(nchannels,3)
- Integer(Kind=jpim), Intent(in) :: lprofiles(nfrequencies)
- Type(rttov_coef), Intent(in) :: coef ! Coefficients
- Type(profile_Type), Intent(inout) ,Target :: profiles_k(nbtout)
- Type(profile_Type), Intent(inout) ,Target :: profiles_k_all(nchannels)
-
- End Subroutine rttov_profout_k
-End Interface
diff --git a/src/LIB/RTTOV/src/rttov_q2v.F90 b/src/LIB/RTTOV/src/rttov_q2v.F90
deleted file mode 100644
index 0f4cb99f5cd59d54012cdb0363247075e9a942dc..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_q2v.F90
+++ /dev/null
@@ -1,142 +0,0 @@
-!
-Subroutine rttov_q2v (&
- & h2o_unit, &! in
- & h2o, &! in
- & gaz_id, &! in
- & q_gaz, &! in
- & v_gaz ) ! inout
- !
- ! Description:
- ! Conversion of specific concentration to volume mixing ratio gases.
- ! Gases are defined by the "gas_id_xxx" codes in the rttov_const module
- ! Method use an equivalent molecular weight of wet air
- !
- ! Copyright:
- !
- ! This software was developed within the context of
- ! the EUMETSAT Satellite Application Facility on
- ! Numerical Weather Prediction (NWP SAF), under the
- ! Cooperation Agreement dated 25 November 1998, between
- ! EUMETSAT and the Met Office, UK, by one or more partners
- ! within the NWP SAF. The partners in the NWP SAF are
- ! the Met Office, ECMWF, KNMI and MeteoFrance.
- !
- ! Copyright 2002, EUMETSAT, All Rights Reserved.
- !
- !
- !
- ! Current Code Owner: SAF NWP
- !
- ! History:
- ! Version Date Comment
- ! 1.0 27/01/2003 Original code. (P. Brunel)
- ! 1.1 13/02/2003 Remove capability of array of gases (P. Brunel)
- !
- ! Code Description:
- ! FORTRAN 90, following AAPP standards
- !
- ! Declarations
- !
- ! Global variables:
- ! Modules used:
- ! Imported Parameters:
- Use rttov_const, Only : &
- & mair ,&
- & mh2o ,&
- & mo3 ,&
- & mco2 ,&
- & mn2o ,&
- & mco ,&
- & mch4 ,&
- & gas_id_mixed ,&
- & gas_id_watervapour ,&
- & gas_id_ozone ,&
- & gas_id_wvcont ,&
- & gas_id_co2 ,&
- & gas_id_n2o ,&
- & gas_id_co ,&
- & gas_id_ch4 ,&
- & gas_unit_specconc ,&
- & gas_unit_ppmv
-
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
- ! Subroutine arguments
- ! Scalar arguments with intent(in):
- Integer(Kind=jpim) , Intent (in) :: h2o_unit ! Water vapour input unit
- ! 1 = specific concent. (kg/kg)
- ! 2 = volume mixing ratio (ppmv)
- ! (see gaz id codes in module rttov_const)
- Real(Kind=jprb) , Intent (in) :: h2o ! Water Vapour content in unit h2o_unit
-
- Integer(Kind=jpim) , Intent (in) :: gaz_id ! Gaz identification number
- ! (see gaz id codes in module rttov_const)
- Real(Kind=jprb) , Intent (in) :: q_gaz ! specific concentration for gaz (kg/kg)
- Real(Kind=jprb) , Intent (inout):: v_gaz ! volume mixing ratio for gaz (ppmv)
-
-
-
-
- ! Local parameter
- Real(Kind=jprb), Parameter :: eps = mh2o / mair
-
-
-
- ! Local variables
- Real(Kind=jprb) :: Mwet ! equivalent molecular weight of wet air (g)
- Real(Kind=jprb) :: v_h2o ! volume mixing ratio for Water Vapour (v/v)
-
- !- End of header --------------------------------------------------------
-
- ! Calculate volume mixing ratio (no unit: v/v) for Water Vapour
- If( h2o_unit == gas_unit_specconc ) then
- v_h2o = h2o / (eps * (1-h2o) + h2o)
- Else If( h2o_unit == gas_unit_ppmv ) then
- v_h2o = h2o * 1.e-06_JPRB
- Else
- v_h2o = 0._JPRB
- End If
-
- ! Humid air molar mass
- Mwet = (1 - v_h2o)*Mair + v_h2o*Mh2o
-
- ! Calculate volume mixing ratio for gaz (ppmv)
- Select Case( gaz_id )
- Case( gas_id_mixed )
- ! keep same value for Mixed gases
- v_gaz = q_gaz
-
- Case( gas_id_watervapour )
- v_gaz = q_gaz * Mwet / Mh2o * 1.e+06_JPRB
- !v_gaz = q_gaz * 1.60771704e+6
-
- Case( gas_id_ozone )
- v_gaz = q_gaz * Mwet / Mo3 * 1.e+06_JPRB
- !v_gaz = q_gaz * 6.03504e+5
-
- Case( gas_id_wvcont )
- v_gaz = q_gaz * Mwet / Mh2o * 1.e+06_JPRB
-
- Case( gas_id_co2 )
- v_gaz = q_gaz * Mwet / Mco2 * 1.e+06_JPRB
-
- Case( gas_id_n2o )
- v_gaz = q_gaz * Mwet / Mn2o * 1.e+06_JPRB
-
- Case( gas_id_co )
- v_gaz = q_gaz * Mwet / Mco * 1.e+06_JPRB
-
- Case( gas_id_ch4 )
- v_gaz = q_gaz * Mwet / Mch4 * 1.e+06_JPRB
-
- Case Default
- v_gaz = 0._JPRB
-
- End Select
-
-
-
-
-End Subroutine rttov_q2v
diff --git a/src/LIB/RTTOV/src/rttov_q2v.interface b/src/LIB/RTTOV/src/rttov_q2v.interface
deleted file mode 100644
index be151eeaa7260cfc803a5e0c9f6a854599fe8897..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_q2v.interface
+++ /dev/null
@@ -1,47 +0,0 @@
-Interface
-!
-Subroutine rttov_q2v (&
- & h2o_unit, & ! in
- & h2o, & ! in
- & gaz_id, & ! in
- & q_gaz, & ! in
- & v_gaz ) ! inout
- Use rttov_const, Only : &
- mair ,&
- mh2o ,&
- mo3 ,&
- mco2 ,&
- mn2o ,&
- mco ,&
- mch4 ,&
- gas_id_mixed ,&
- gas_id_watervapour ,&
- gas_id_ozone ,&
- gas_id_wvcont ,&
- gas_id_co2 ,&
- gas_id_n2o ,&
- gas_id_co ,&
- gas_id_ch4 ,&
- gas_unit_specconc ,&
- gas_unit_ppmv
-
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
- Integer(Kind=jpim) , Intent (in) :: h2o_unit ! Water vapour input unit
- ! 1 = specific concent. (kg/kg)
- ! 2 = volume mixing ratio (ppmv)
- ! (see gaz id codes in module rttov_const)
- Real(Kind=jprb) , Intent (in) :: h2o ! Water Vapour content in unit h2o_unit
-
- Integer(Kind=jpim) , Intent (in) :: gaz_id ! Gaz identification number
- ! (see gaz id codes in module rttov_const)
- Real(Kind=jprb) , Intent (in) :: q_gaz ! specific concentration for gaz (kg/kg)
- Real(Kind=jprb) , Intent (inout):: v_gaz ! volume mixing ratio for gaz (ppmv)
-
-
-
-
-End Subroutine rttov_q2v
-End Interface
diff --git a/src/LIB/RTTOV/src/rttov_readcoeffs.F90 b/src/LIB/RTTOV/src/rttov_readcoeffs.F90
deleted file mode 100644
index f0d2755da70e5236e928ab4bb6e498ac95ea07cf..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_readcoeffs.F90
+++ /dev/null
@@ -1,356 +0,0 @@
-!
-Subroutine rttov_readcoeffs (&
- & errorstatus, &! out
- & coef, &! out
- & instrument, &! in Optional
- & kmyproc, &! in Optional
- & kioproc, &! in Optional
- & file_id, &! in Optional
- & channels ) ! in Optional
- ! Description:
- !
- ! Read an ASCII or binary coefficient file and allocate coeff structure
- ! arrays according to the optional list of channels.
- !!!!!!!
- ! This version can run in a distibuted mode :
- ! IO PE will read the data which are broadcasted to the other pes.
- ! Be careful any 'reading' modifications in rttov_readcoeffs_ascii or
- ! rttov_readcoeffs_binary may have to be reported in rttov_distribcoeffs
- !!!!!!!
- ! The optional arguments instrument and file_id determines whether the
- ! file is already opened or not
- ! if "instrument" is present the routine will try to open
- ! the corresponding binary file (extension .bin) in read only mode.
- ! If it fails then it tries to open the ASCII file (extension .dat)
- ! File is closed before return.
- ! if "instrument" is not present but file_id is present the routine will
- ! access to the coefficient file already opened with the logical unit file_id.
- ! The ASCII/binary test is performed by reading the first characters, binary
- ! files will always start by "%RTTOV_COEFF" characters. An ASCII file cannot
- ! contain such a string at the beginning of the file because it will be
- ! considered as a section name which will not be recognised. File is NOT
- ! closed on return.
- ! The user can provide an optional list of channels in "channels" argument
- ! array to reduce the output coefficient structure to this list. This
- ! can be important for reducing the memory allocation required when running
- ! with advanced IR sounders (e.g. AIRS or IASI). If the user
- ! wants all channels the "channels" argument shall not be present.
- !
- !
- ! Copyright:
- ! This software was developed within the context of
- ! the EUMETSAT Satellite Application Facility on
- ! Numerical Weather Prediction (NWP SAF), under the
- ! Cooperation Agreement dated 25 November 1998, between
- ! EUMETSAT and the Met Office, UK, by one or more partners
- ! within the NWP SAF. The partners in the NWP SAF are
- ! the Met Office, ECMWF, KNMI and MeteoFrance.
- !
- ! Copyright 2002, EUMETSAT, All Rights Reserved.
- !
- ! Method:
- !
- ! Current Code Owner: SAF NWP
- !
- ! History:
- ! Version Date Comment
- ! ------- ---- -------
- ! 1.0 01/12/2002 New F90 code with structures (P Brunel A Smith)
- ! 1.1 02/01/2003 A few comments added (R Saunders)
- ! 1.2 03/05/2004 Add specific RTTOV8 CO2 variable (P. Brunel)
- ! 1.3 02/06/2004 Change tests on id_comp_lvl == 7 by tests on fmv_model_ver (P. Brunel)
- ! 1.4 08/09/2004 Change ascii/binary file test to use Inquire (J. Cameron)
- !
- ! Code Description:
- ! Language: Fortran 90.
- ! Software Standards: "European Standards for Writing and
- ! Documenting Exchangeable Fortran 90 Code".
- !
- ! Declarations:
- ! Modules used:
- ! Imported Parameters:
- Use rttov_const, Only : &
- & version ,&
- & release ,&
- & minor_version ,&
- & errorstatus_info ,&
- & errorstatus_success ,&
- & errorstatus_fatal
-
-
- ! Imported Type Definitions:
- Use rttov_types, Only : &
- & rttov_coef
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
-#include "rttov_coeffname.interface"
-#include "rttov_opencoeff.interface"
-#include "rttov_errorreport.interface"
-#include "rttov_readcoeffs_binary.interface"
-#include "rttov_readcoeffs_ascii.interface"
-
- ! subroutine arguments
- ! scalar arguments with intent(in):
- Integer(Kind=jpim), Optional, Intent(in) :: kmyproc ! logical processor id
- Integer(Kind=jpim), Optional, Intent(in) :: kioproc ! procs dedicated for io
- Integer(Kind=jpim), Optional, Intent (in) :: instrument(3) ! (platform, satellite identification, instrument) number
- Integer(Kind=jpim), Optional, Intent (in) :: file_id ! file logical unit number
- Integer(Kind=jpim), Optional, Intent (in) :: channels(:) ! list of channels to extract
-
-
- ! scalar arguments with intent(out):
- Integer(Kind=jpim), Intent (out) :: errorstatus ! return code
- Type( rttov_coef ), Intent (out) :: coef ! coefficients
-
- ! Local Scalars:
- Logical :: file_toclose
- Logical :: file_binary
- Logical :: existence
- Logical,save :: first=.true.
- Integer(Kind=jpim) :: file_lu
- Integer(Kind=jpim) :: imyproc,iioproc
-
- Character (len=256):: coeffname ! file name for coefficient file
- Character (len=20) :: file_form
- Character (len=80) :: errMessage
- Character (len=16) :: NameOfRoutine = 'rttov_readcoeffs'
-
-
- !- End of header --------------------------------------------------------
-
- ! 0 Initialise variables
- !---------------------------------------------
- errorstatus = errorstatus_success
-
- If ( .Not. Present (kmyproc) ) Then
- imyproc = 1
- Else
- imyproc = kmyproc
- Endif
-
- If ( .Not. Present (kioproc) ) Then
- iioproc = 1
- Else
- iioproc = kioproc
- Endif
-
- If (imyproc == iioproc ) then
- file_toclose = .False.
- file_binary = .False.
-
- If ( .Not. Present (file_id) ) Then
- file_lu = 0
- Else
- file_lu = file_id
- Endif
-
- If( first ) Then
- Write( errMessage, '( "RTTOV library version ",i2,1x,i1,".",i1 )' )&
- & version, release, minor_version
- Call Rttov_ErrorReport (errorstatus_info, errMessage, NameOfRoutine)
- first = .false.
- End If
-
- ! 1 Beginning of coefficient opening sequence
- !---------------------------------------------
-
- ! test arguments instrument and file_id to decide whether to open
- ! the file or not.
- If ( Present (instrument ) ) Then
-
- ! Binary filename
- Call rttov_coeffname ( errorstatus, instrument, coeffname, lbinary = .True. )
- If ( errorstatus /= errorstatus_success ) Then
- Return
- Endif
-
- ! test existence of binary file
- Inquire( FILE = coeffname, EXIST = existence )
- If ( existence ) Then
- Write( errMessage, '( "open binary coefficient file ",a )' )&
- & Trim(coeffname)
- Call Rttov_ErrorReport (errorstatus_info, errMessage, NameOfRoutine)
- ! Open binary file
- Call rttov_opencoeff ( errorstatus, coeffname, file_lu, lbinary = .True. )
- If ( errorstatus /= errorstatus_success ) Then
- ! Binary open fails, try ASCII access
- ! ASCII filename
- Call rttov_coeffname ( errorstatus, instrument, coeffname )
- If ( errorstatus /= errorstatus_success ) Then
- Return
- Endif
- ! Open ASCII file
- Call rttov_opencoeff ( errorstatus, coeffname, file_lu)
- If ( errorstatus /= errorstatus_success ) Then
- Return
- Endif
- Endif
-
- Else
- ! Try to open ASCII format
- ! ASCII filename
- Call rttov_coeffname ( errorstatus, instrument, coeffname )
- If ( errorstatus /= errorstatus_success ) Then
- Return
- Endif
- Write( errMessage, '( "open ASCII coefficient file ",a )' )&
- & Trim(coeffname)
- Call Rttov_ErrorReport (errorstatus_info, errMessage, NameOfRoutine)
- ! Open ASCII file
- Call rttov_opencoeff ( errorstatus, coeffname, file_lu)
- If ( errorstatus /= errorstatus_success ) Then
- Return
- Endif
-
- End If
- file_toclose = .True.
-
- Else
- ! instrument argument missing
- If ( .Not. Present (file_id) ) Then
- ! file_id argument missing
- errorstatus = errorstatus_fatal
- Write( errMessage, '( "instrument and file_id missing arguments." )' )
- Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine)
- Return
- Endif
- Endif
-
- ! Find out if the file is ascii or binary
- ! The inquire should work even if the file was opened externally
- INQUIRE(file_lu,FORM=file_form)
- IF ( file_form == 'FORMATTED' ) THEN
- file_binary = .FALSE.
- ELSEIF ( file_form == 'UNFORMATTED' ) THEN
- file_binary = .TRUE.
- ELSE
- errorstatus = errorstatus_fatal
- Write( errMessage, '(a)' ) 'Unknown file format: '//file_form
- CALL Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine)
- RETURN
- ENDIF
-
- ! End of coefficient opening sequence
- !-------------------------------------
- Endif
-
-
- ! 2 initialize coef structure for all single types
- !---------------------------------------------
- coef % id_platform = 0
- coef % id_sat = 0
- coef % id_inst = 0
- coef % id_sensor = 0
- coef % id_comp_lvl = 0
- coef % id_creation_date = (/ 0, 0, 0 /)
- coef % id_creation = 'xxxx'
- coef % id_Common_name = 'xxxx'
- coef % fmv_model_def = 'xxxx'
- coef % fmv_model_ver = 0
- coef % fmv_chn = 0
- coef % fmv_gas = 0
- coef % nmixed = 0
- coef % nwater = 0
- coef % nozone = 0
- coef % nwvcont = 0
- coef % nco2 = 0
- coef % nn2o = 0
- coef % nco = 0
- coef % nch4 = 0
- coef % nlevels = 0
- coef % fc_speedl = 0
- coef % fc_planck_c1 = 0
- coef % fc_planck_c2 = 0
- coef % fc_sat_height = 0
- coef % fastem_ver = 0
- coef % fastem_coef_nb = 0
- coef % ssirem_ver = 0
-
- Nullify(coef % gaz_units)
- Nullify(coef % mixedgas)
- Nullify(coef % watervapour)
- Nullify(coef % ozone)
- Nullify(coef % wvcont)
- Nullify(coef % co2)
- Nullify(coef % n2o)
- Nullify(coef % co)
- Nullify(coef % ch4)
- Nullify(coef % fmv_gas_id)
- Nullify(coef % fmv_gas_pos)
- Nullify(coef % fmv_var)
- Nullify(coef % fmv_lvl)
- Nullify(coef % ff_ori_chn)
- Nullify(coef % ff_val_chn)
- Nullify(coef % ff_cwn)
- Nullify(coef % ff_bco)
- Nullify(coef % ff_bcs)
- Nullify(coef % ff_gam)
- Nullify(coef % fastem_polar)
- Nullify(coef % ssirem_chn)
- Nullify(coef % ssirem_a0)
- Nullify(coef % ssirem_a1)
- Nullify(coef % ssirem_a2)
- Nullify(coef % ssirem_xzn1)
- Nullify(coef % ssirem_xzn2)
- Nullify(coef % fastem_coef)
- Nullify(coef % ref_prfl_t)
- Nullify(coef % ref_prfl_mr)
- Nullify(coef % lim_prfl_p)
- Nullify(coef % lim_prfl_tmax)
- Nullify(coef % lim_prfl_tmin)
- Nullify(coef % lim_prfl_gmax)
- Nullify(coef % lim_prfl_gmin)
- Nullify(coef % ref_prfl_p)
-
- If (imyproc == iioproc ) then
- ! 3 Read binary file
- !-------------------
- If( file_binary ) Then
- If( Present ( channels ) ) Then
- Call rttov_readcoeffs_binary (&
- & errorstatus, &! out
- & coef, &! inout
- & file_lu, &! in
- & channels = channels ) ! in Optional
- Else
- Call rttov_readcoeffs_binary (&
- & errorstatus, &! out
- & coef, &! inout
- & file_lu ) ! in
- Endif
-
- ! 4 If no Binary file then read ASCII file
- !-----------------------------------------
- Else
- If( Present ( channels ) ) Then
- Call rttov_readcoeffs_ascii (&
- & errorstatus, &! out
- & coef, &! inout
- & file_lu, &! in
- & channels = channels ) ! in Optional
- Else
- Call rttov_readcoeffs_ascii (&
- & errorstatus, &! out
- & coef, &! inout
- & file_lu ) ! in
- Endif
-
- Endif
-
- If( errorstatus /= errorstatus_success ) then
- ! Do not add any fatal/warning messages
- Return
- End If
-
- If( file_toclose ) Then
- Close ( unit = file_lu )
- Endif
-
- Write( errMessage, '( "fast model version compatibility ",i2 )' )coef % fmv_model_ver
- Call Rttov_ErrorReport (errorstatus_info, errMessage, NameOfRoutine)
- Endif
-
-
-End Subroutine rttov_readcoeffs
diff --git a/src/LIB/RTTOV/src/rttov_readcoeffs.interface b/src/LIB/RTTOV/src/rttov_readcoeffs.interface
deleted file mode 100644
index 905aba5f4b104333e254de0e71675beb430a6962..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_readcoeffs.interface
+++ /dev/null
@@ -1,55 +0,0 @@
-Interface
-!
-Subroutine rttov_readcoeffs (&
- & errorstatus, & ! out
- & coef, & ! out
- & instrument, & ! in Optional
- & kmyproc, & ! in Optional
- & kioproc, & ! in Optional
- & file_id, & ! in Optional
- & channels ) ! in Optional
- Use rttov_const, Only : &
- version ,&
- release ,&
- minor_version ,&
- rttov_magic_string ,&
- sensor_id_mw ,&
- sensor_id_ir ,&
- errorstatus_info ,&
- errorstatus_success ,&
- errorstatus_fatal ,&
- gas_id_mixed ,&
- gas_id_watervapour ,&
- gas_id_ozone ,&
- gas_id_wvcont ,&
- gas_id_co2 ,&
- gas_id_n2o ,&
- gas_id_co ,&
- gas_id_ch4 ,&
- gas_unit_specconc ,&
- gas_unit_ppmv ,&
- earthradius ,&
- gas_name ,&
- pressure_top
-
-
- Use rttov_types, Only : &
- rttov_coef
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
- Integer(Kind=jpim), Optional, Intent(in) :: kmyproc ! logical processor id
- Integer(Kind=jpim), Optional, Intent(in) :: kioproc ! processor dedicated for io
- Integer(Kind=jpim), Optional, Intent (in) :: instrument(3) ! (platform, satellite identification, instrument) number
- Integer(Kind=jpim), Optional, Intent (in) :: file_id ! file logical unit number
- Integer(Kind=jpim), Optional, Intent (in) :: channels(:) ! list of channels to extract
-
-
- Integer(Kind=jpim), Intent (out) :: errorstatus ! return code
- Type( rttov_coef ), Intent (out) :: coef ! coefficients
-
-
-
-End Subroutine rttov_readcoeffs
-End Interface
diff --git a/src/LIB/RTTOV/src/rttov_readcoeffs_ascii.F90 b/src/LIB/RTTOV/src/rttov_readcoeffs_ascii.F90
deleted file mode 100644
index 26ebf9008b7be2cdb24f52e76a5fa48fa48c6811..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_readcoeffs_ascii.F90
+++ /dev/null
@@ -1,1094 +0,0 @@
-!
-Subroutine rttov_readcoeffs_ascii (&
- & errorstatus, &! out
- & coef, &! inout
- & file_lu, &! in
- & channels ) ! in Optional
- ! Description:
- !
- ! Read an ASCII coefficient file and fills coeff structure
- ! arrays according to the optional list of channels.
- !
- ! The user can provide an optional list of channels in "channels" argument
- ! array to reduce the output coefficient structure to this list. This
- ! can be important for reducing the memory allocation required when running
- ! with advanced IR sounders (e.g. AIRS or IASI). If the user
- ! wants all channels the "channels" argument shall not be present.
- !
- !
- ! Copyright:
- ! This software was developed within the context of
- ! the EUMETSAT Satellite Application Facility on
- ! Numerical Weather Prediction (NWP SAF), under the
- ! Cooperation Agreement dated 25 November 1998, between
- ! EUMETSAT and the Met Office, UK, by one or more partners
- ! within the NWP SAF. The partners in the NWP SAF are
- ! the Met Office, ECMWF, KNMI and MeteoFrance.
- !
- ! Copyright 2002, EUMETSAT, All Rights Reserved.
- !
- ! Method:
- !
- ! Current Code Owner: SAF NWP
- !
- ! History:
- ! Version Date Comment
- ! ------- ---- -------
- ! 1.0 01/12/2002 New F90 code with structures (P Brunel A Smith)
- ! 1.1 02/01/2003 A few comments added (R Saunders)
- ! 1.2 24/01/2003 Add return when section END encountered (P Brunel)
- ! any I/O error is coded as fatal
- ! Add GAZ_UNITS section
- ! 1.3 02/06/2004 New format for FMV section with RTTOV8 (P. Brunel)
- ! 1.4 15/06/2004 Corrected array dimension for coef % fmv_gas_pos (R Saunders)
- !
- ! Code Description:
- ! Language: Fortran 90.
- ! Software Standards: "European Standards for Writing and
- ! Documenting Exchangeable Fortran 90 Code".
- !
- ! Declarations:
- ! Modules used:
- ! Imported Parameters:
- Use rttov_const, Only : &
- & version_compatible_min ,&
- & version_compatible_max ,&
- & sensor_id_hi ,&
- & sensor_id_mw ,&
- & sensor_id_ir ,&
- & errorstatus_success ,&
- & errorstatus_fatal ,&
- & gas_id_mixed ,&
- & gas_id_watervapour ,&
- & gas_id_ozone ,&
- & gas_id_wvcont ,&
- & gas_id_co2 ,&
- & gas_id_n2o ,&
- & gas_id_co ,&
- & gas_id_ch4 ,&
- & sensor_name , &
- & ngases_max ,&
- & gas_name , &
- & gas_unit_specconc
-
-
- ! Imported Type Definitions:
- Use rttov_types, Only : &
- & rttov_coef
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
-#include "rttov_opencoeff.interface"
-#include "rttov_errorreport.interface"
-#include "rttov_skipcommentline.interface"
-#include "rttov_deletecomment.interface"
-#include "rttov_cmpuc.interface"
-#include "rttov_findnextsection.interface"
-
- ! subroutine arguments
- ! scalar arguments with intent(in):
- Integer(Kind=jpim), Intent (in) :: file_lu ! file logical unit number
- Integer(Kind=jpim), Optional, Intent (in) :: channels(:) ! list of channels to extract
-
- ! scalar arguments with intent(inout):
- Type( rttov_coef ), Intent (inout) :: coef ! coefficients
-
- ! scalar arguments with intent(out):
- Integer(Kind=jpim), Intent (out) :: errorstatus ! return code
-
-
-
- ! Local Scalars:
- Integer(Kind=jpim) :: file_channels
- Logical :: for_output
- Integer(Kind=jpim) :: file_lu_coef
- Logical :: all_channels
- Integer(Kind=jpim) :: io_status
- Integer(Kind=jpim) :: alloc_status(10)
- Real(Kind=jprb) :: pres
- Integer(Kind=jpim) :: i,j,k,l,n
- Integer(Kind=jpim) :: index
-
- ! pointers for generic inputs
- Integer(Kind=jpim) :: nvalues
- Real(Kind=jprb), Pointer :: values0(:)
- Real(Kind=jprb), Pointer :: values1(:)
- Real(Kind=jprb), Pointer :: values2(:)
- Real(Kind=jprb), Pointer :: values3(:)
- Real(Kind=jprb), Pointer :: values4(:)
- Integer(Kind=jpim), Pointer :: ivalues0(:)
- Integer(Kind=jpim), Pointer :: ivalues1(:)
- Real(Kind=jprb), Pointer :: coeffsarray(:,:,:)
-
- Character(len=16) :: input_string
- Character(len=32) :: gas_Type
- Character(len=21) :: section
- Character (len=80) :: errMessage
- Character (len=22) :: NameOfRoutine = 'rttov_readcoeffs_ascii'
-
- !- End of header --------------------------------------------------------
-
- ! 0 Initialise variables
- !---------------------------------------------
- errorstatus = errorstatus_success
- alloc_status(:) = 0
-
- ! test presence of channels argument
- If( Present ( channels ) ) Then
- all_channels = .False.
- Else
- all_channels = .True.
- Endif
-
-
- !read the file
- readfile: Do
- Call rttov_findnextsection( file_lu, io_status, section )
- If ( io_status < 0 ) Exit !end-of-file
-
- ! error message if any problem when reading
- errMessage = 'io status while reading section '//section
-
- Select Case( Trim(section) )
-
-
- Case( 'IDENTIFICATION' )
- ! Identification section
- ! 6 lines
- Call rttov_skipcommentline ( file_lu, io_status )
- If(io_status /= 0) Then
- Call Rttov_ErrorReport (io_status, errMessage, NameOfRoutine)
- errorstatus = errorstatus_fatal
- Return
- Endif
-
- Read( file_lu, *, iostat = io_status )&
- & coef % id_platform,&
- & coef % id_sat,&
- & coef % id_inst
- If(io_status /= 0) Then
- Call Rttov_ErrorReport (io_status, errMessage, NameOfRoutine)
- errorstatus = errorstatus_fatal
- Return
- Endif
-
- Read( file_lu, *, iostat = io_status ) coef % id_Common_name
- If(io_status /= 0) Then
- Call Rttov_ErrorReport (io_status, errMessage, NameOfRoutine)
- errorstatus = errorstatus_fatal
- Return
- Endif
-
- Read( file_lu, *, iostat = io_status ) input_string
- If(io_status /= 0) Then
- Call Rttov_ErrorReport (io_status, errMessage, NameOfRoutine)
- errorstatus = errorstatus_fatal
- Return
- Endif
- Select Case (input_string)
- Case (sensor_name(sensor_id_ir))
- coef % id_sensor = sensor_id_ir ! Infrared
- Case (sensor_name(sensor_id_mw))
- coef % id_sensor = sensor_id_mw ! Micro Wave
- Case (sensor_name(sensor_id_hi))
- coef % id_sensor = sensor_id_hi ! High resolution
- Case default
- coef % id_sensor = sensor_id_ir
- End Select
-
- Read( file_lu, *, iostat = io_status ) coef % id_comp_lvl
- If(io_status /= 0) Then
- Call Rttov_ErrorReport (io_status, errMessage, NameOfRoutine)
- errorstatus = errorstatus_fatal
- Return
- Endif
- ! Error if the compatibility version of the coefficient file
- ! is not in the range defined by the constant module
- If( coef % id_comp_lvl < version_compatible_min .Or.&
- & coef % id_comp_lvl > version_compatible_max ) Then
- errorstatus = errorstatus_fatal
- Write( errMessage,&
- & '( "Version of coefficient file is incompatible with RTTOV library")' )
- Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine)
- Return
- Endif
-
- Read( file_lu, *, iostat = io_status ) coef % id_creation
- If(io_status /= 0) Then
- Call Rttov_ErrorReport (io_status, errMessage, NameOfRoutine)
- errorstatus = errorstatus_fatal
- Return
- Endif
-
- Read( file_lu, *, iostat = io_status ) coef % id_creation_date
- If(io_status /= 0) Then
- Call Rttov_ErrorReport (io_status, errMessage, NameOfRoutine)
- errorstatus = errorstatus_fatal
- Return
- Endif
-
- Case ('LINE-BY-LINE')
-
- Case ('FAST_MODEL_VARIABLES')
- Call rttov_skipcommentline ( file_lu, io_status )
- If(io_status /= 0) Then
- Call Rttov_ErrorReport (io_status, errMessage, NameOfRoutine)
- errorstatus = errorstatus_fatal
- Return
- Endif
-
- ! fast model variables definition
- Read( file_lu, *, iostat = io_status ) coef % fmv_model_def
- If(io_status /= 0) Then
- Call Rttov_ErrorReport (io_status, errMessage, NameOfRoutine)
- errorstatus = errorstatus_fatal
- Return
- Endif
-
- If( coef % id_comp_lvl > 7 ) then
- ! fast model variables version
- Read( file_lu, *, iostat = io_status ) coef % fmv_model_ver
- If(io_status /= 0) Then
- Call Rttov_ErrorReport (io_status, errMessage, NameOfRoutine)
- errorstatus = errorstatus_fatal
- Return
- Endif
- Else
- coef % fmv_model_ver = 7
- Endif
-
- ! number of channels stored
- Read( file_lu, *, iostat = io_status ) coef % fmv_chn
- If(io_status /= 0) Then
- Call Rttov_ErrorReport (io_status, errMessage, NameOfRoutine)
- errorstatus = errorstatus_fatal
- Return
- Endif
-
- ! Take care of the user list of channels
- ! file_channels store the number of channels in the file
- ! coef % fmv_chn is the number of channels that the user requests
- file_channels = coef % fmv_chn
- If( .Not. all_channels ) Then
- coef % fmv_chn = Size( channels )
- Endif
-
- ! number of gases in file
- Read( file_lu, *, iostat = io_status ) coef % fmv_gas
- If(io_status /= 0) Then
- Call Rttov_ErrorReport (io_status, errMessage, NameOfRoutine)
- errorstatus = errorstatus_fatal
- Return
- Endif
-
- ! allocate arrays of FAST_MODEL_VARIABLES section
- Allocate ( coef % fmv_gas_id ( coef % fmv_gas ), stat=alloc_status(1))
- Allocate ( coef % fmv_gas_pos( ngases_max ), stat=alloc_status(2))
- Allocate ( coef % fmv_var ( coef % fmv_gas ), stat=alloc_status(3))
- Allocate ( coef % fmv_lvl ( coef % fmv_gas ), stat=alloc_status(4))
- If( Any(alloc_status /= 0) ) Then
- errorstatus = errorstatus_fatal
- Write( errMessage, '( "allocation of fmv coefs arrays")' )
- Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine)
- Return
- End If
-
- index = 0
- Do n = 1, coef % fmv_gas
- ! gas id. number i gas_id list (fmv_gas)
- Read(file_lu,'(a)',iostat=io_status) gas_Type
- If(io_status /= 0) Then
- Call Rttov_ErrorReport (io_status, errMessage, NameOfRoutine)
- errorstatus = errorstatus_fatal
- Return
- Endif
- Call Rttov_deletecomment(gas_Type)
-
- Do i = 1, ngases_max
- If ( rttov_cmpuc( gas_Type , gas_name(i) ) ) Then
- index = index + 1
- coef % fmv_gas_id(index) = i
- Exit
- End If
- End Do
- If ( index == 0 ) Write(*,'(a)') &
- & 'Error: gas type ' // Trim(gas_Type) // ' not recognised'
- ! store also the indice of this gas in the
- ! identification list
- ! so fmv_gas_pos(1) will give position of MxG in the file
- coef % fmv_gas_pos(coef % fmv_gas_id(index)) = index
-
- ! number of variables/predictors by gaz
- ! number of levels(pres/absorber) by gaz (fmv_gas
- Read(file_lu,* ,iostat=io_status)&
- & coef % fmv_var(index), coef % fmv_lvl(index)
- If(io_status /= 0) Then
- Call Rttov_ErrorReport (io_status, errMessage, NameOfRoutine)
- errorstatus = errorstatus_fatal
- Return
- Endif
-
- ! Transfer information to some "classical" variables
- ! with more common names
- ! Note that the number of levels is taken from the Mixed Gases line
- Select Case( coef % fmv_gas_id(index) )
- Case( gas_id_mixed )
- coef % nmixed = coef % fmv_var(index)
- coef % nlevels = coef % fmv_lvl(index)
- Case( gas_id_watervapour )
- coef % nwater = coef % fmv_var(index)
- Case( gas_id_ozone )
- coef % nozone = coef % fmv_var(index)
- Case( gas_id_wvcont )
- coef % nwvcont = coef % fmv_var(index)
- Case( gas_id_co2 )
- coef % nco2 = coef % fmv_var(index)
- Case( gas_id_n2o )
- coef % nn2o = coef % fmv_var(index)
- Case( gas_id_co )
- coef % nco = coef % fmv_var(index)
- Case( gas_id_ch4 )
- coef % nch4 = coef % fmv_var(index)
- End Select
- End Do
-
- ! Initialise the gaz units arary with defaults values
- ! (specific concetration kg/kg)
- Allocate ( coef % gaz_units ( coef % fmv_gas ), stat=alloc_status(1) )
- If( Any(alloc_status /= 0) ) Then
- Write( errMessage, '( "allocation of gaz units coefs arrays")' )
- Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine)
- Return
- End If
- coef % gaz_units( : ) = gas_unit_specconc
-
- Case ('FILTER_FUNCTIONS')
- Call rttov_skipcommentline ( file_lu, io_status )
- If(io_status /= 0) Then
- Call Rttov_ErrorReport (io_status, errMessage, NameOfRoutine)
- errorstatus = errorstatus_fatal
- Return
- Endif
-
- !allocate FILTER_FUNCTIONS section array size is fmv_chn
- Allocate ( coef % ff_ori_chn( coef % fmv_chn ), stat=alloc_status(1) )
- Allocate ( coef % ff_val_chn( coef % fmv_chn ), stat=alloc_status(2) )
- Allocate ( coef % ff_cwn( coef % fmv_chn ), stat=alloc_status(3) )
- Allocate ( coef % ff_bco( coef % fmv_chn ), stat=alloc_status(4) )
- Allocate ( coef % ff_bcs( coef % fmv_chn ), stat=alloc_status(5) )
- Allocate ( coef % ff_gam( coef % fmv_chn ), stat=alloc_status(6) )
- If( Any(alloc_status /= 0) ) Then
- errorstatus = errorstatus_fatal
- Write( errMessage, '( "allocation of ff coefs arrays")' )
- Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine)
- Return
- End If
-
-
- If ( all_channels ) Then
- Do i = 1, coef % fmv_chn
- Read( file_lu, *, iostat = io_status )&
- & coef % ff_ori_chn(i), &
- & coef % ff_val_chn(i), &
- & coef % ff_cwn(i), &
- & coef % ff_bco(i), &
- & coef % ff_bcs(i), &
- & coef % ff_gam(i)
- If(io_status /= 0) Then
- errorstatus = errorstatus_fatal
- Call Rttov_ErrorReport (io_status, errMessage, NameOfRoutine)
- errorstatus = errorstatus_fatal
- Return
- Endif
- End Do
- Else
- Allocate ( ivalues0( file_channels ), stat=alloc_status(1) )
- Allocate ( ivalues1( file_channels ), stat=alloc_status(2) )
- Allocate ( values0( file_channels ), stat=alloc_status(3) )
- Allocate ( values1( file_channels ), stat=alloc_status(4) )
- Allocate ( values2( file_channels ), stat=alloc_status(5) )
- Allocate ( values3( file_channels ), stat=alloc_status(6) )
- If( Any(alloc_status /= 0) ) Then
- errorstatus = errorstatus_fatal
- Write( errMessage, '( "allocation of ff coefs arrays")' )
- Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine)
- Return
- End If
- Do i = 1, file_channels
- Read( file_lu, *, iostat = io_status )&
- & ivalues0(i),&
- & ivalues1(i),&
- & values0(i) ,&
- & values1(i) ,&
- & values2(i) ,&
- & values3(i)
- If(io_status /= 0) Then
- Call Rttov_ErrorReport (io_status, errMessage, NameOfRoutine)
- errorstatus = errorstatus_fatal
- Return
- Endif
- End Do
- coef % ff_ori_chn(:) = ivalues0 ( channels(:) )
- coef % ff_val_chn(:) = ivalues1 ( channels(:) )
- coef % ff_cwn(:) = values0 ( channels(:) )
- coef % ff_bco(:) = values1 ( channels(:) )
- coef % ff_bcs(:) = values2 ( channels(:) )
- coef % ff_gam(:) = values3 ( channels(:) )
- Deallocate ( ivalues0, stat=alloc_status(1) )
- Deallocate ( ivalues1, stat=alloc_status(2) )
- Deallocate ( values0, stat=alloc_status(3) )
- Deallocate ( values1, stat=alloc_status(4) )
- Deallocate ( values2, stat=alloc_status(5) )
- Deallocate ( values3, stat=alloc_status(6) )
- If( Any(alloc_status /= 0) ) Then
- errorstatus = errorstatus_fatal
- Write( errMessage, '( "deallocation of ff coefs arrays")' )
- Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine)
- Return
- End If
- Endif
-
-
- Case ('FUNDAMENTAL_CONSTANTS')
- Call rttov_skipcommentline ( file_lu, io_status )
- If(io_status /= 0) Then
- Call Rttov_ErrorReport (io_status, errMessage, NameOfRoutine)
- errorstatus = errorstatus_fatal
- Return
- Endif
-
- ! speed of light (cm/s)
- Read(file_lu,*,iostat=io_status) coef % fc_speedl
- If(io_status /= 0) Then
- Call Rttov_ErrorReport (io_status, errMessage, NameOfRoutine)
- errorstatus = errorstatus_fatal
- Return
- Endif
-
- ! first radiation constant (mW/(m2*sr*cm-4))
- ! second radiation constant (cm*K)
- Read(file_lu,*,iostat=io_status) coef % fc_planck_c1, coef % fc_planck_c2
- If(io_status /= 0) Then
- Call Rttov_ErrorReport (io_status, errMessage, NameOfRoutine)
- errorstatus = errorstatus_fatal
- Return
- Endif
-
- ! satellite nominal altitude (km)
- Read(file_lu,*,iostat=io_status) coef % fc_sat_height
- If(io_status /= 0) Then
- Call Rttov_ErrorReport (io_status, errMessage, NameOfRoutine)
- errorstatus = errorstatus_fatal
- Return
- Endif
-
- Case ('FASTEM')
- Call rttov_skipcommentline ( file_lu, io_status )
- If(io_status /= 0) Then
- Call Rttov_ErrorReport (io_status, errMessage, NameOfRoutine)
- errorstatus = errorstatus_fatal
- Return
- Endif
-
- ! fastem version number
- Read(file_lu,*,iostat=io_status) coef % fastem_ver
- If(io_status /= 0) Then
- Call Rttov_ErrorReport (io_status, errMessage, NameOfRoutine)
- errorstatus = errorstatus_fatal
- Return
- Endif
-
- ! number of coefficients
- Read(file_lu,*,iostat=io_status) coef % fastem_coef_nb
- If(io_status /= 0) Then
- Call Rttov_ErrorReport (io_status, errMessage, NameOfRoutine)
- errorstatus = errorstatus_fatal
- Return
- Endif
-
-
- Allocate ( coef % fastem_coef ( coef % fastem_coef_nb ), stat=alloc_status(1) )
- Allocate ( coef % fastem_polar ( coef % fmv_chn ), stat=alloc_status(2) )
- If( Any(alloc_status /= 0) ) Then
- errorstatus = errorstatus_fatal
- Write( errMessage, '( "allocation of fastem coefs arrays")' )
- Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine)
- Return
- End If
-
- ! coefficients (fastem_coef_nb)
- Read(file_lu,*,iostat=io_status) (coef % fastem_coef(i), i= 1, coef % fastem_coef_nb)
- If(io_status /= 0) Then
- Call Rttov_ErrorReport (io_status, errMessage, NameOfRoutine)
- errorstatus = errorstatus_fatal
- Return
- Endif
-
- ! polarisation of each channel
- If( all_channels ) Then
- Read(file_lu,*,iostat=io_status) (coef % fastem_polar(i), i= 1, coef % fmv_chn)
- Else
- Allocate ( ivalues0( file_channels ), stat=alloc_status(1) )
- If( Any(alloc_status /= 0) ) Then
- errorstatus = errorstatus_fatal
- Write( errMessage, '( "allocation of fastem coefs arrays")' )
- Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine)
- Return
- End If
- Read(file_lu,*,iostat=io_status) ( ivalues0(i), i= 1, file_channels)
- coef % fastem_polar(:) = ivalues0( channels (:) )
- Deallocate ( ivalues0, stat=alloc_status(1) )
- If( Any(alloc_status /= 0) ) Then
- errorstatus = errorstatus_fatal
- Write( errMessage, '( "deallocation of fastem coefs arrays")' )
- Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine)
- Return
- End If
- Endif
- If(io_status /= 0) Then
- Call Rttov_ErrorReport (io_status, errMessage, NameOfRoutine)
- errorstatus = errorstatus_fatal
- Return
- Endif
-
-
- !-------------------------------------------------------
- Case ('SSIREM')
- Call rttov_skipcommentline ( file_lu, io_status )
- If(io_status /= 0) Then
- Call Rttov_ErrorReport (io_status, errMessage, NameOfRoutine)
- errorstatus = errorstatus_fatal
- Return
- Endif
-
- ! version number
- Read(file_lu,*,iostat=io_status) coef % ssirem_ver
- If(io_status /= 0) Then
- Call Rttov_ErrorReport (io_status, errMessage, NameOfRoutine)
- errorstatus = errorstatus_fatal
- Return
- Endif
-
- Allocate ( coef % ssirem_chn ( coef % fmv_chn ), stat=alloc_status(1) )
- Allocate ( coef % ssirem_a0 ( coef % fmv_chn ), stat=alloc_status(2) )
- Allocate ( coef % ssirem_a1 ( coef % fmv_chn ), stat=alloc_status(3) )
- Allocate ( coef % ssirem_a2 ( coef % fmv_chn ), stat=alloc_status(4) )
- Allocate ( coef % ssirem_xzn1( coef % fmv_chn ), stat=alloc_status(5) )
- Allocate ( coef % ssirem_xzn2( coef % fmv_chn ), stat=alloc_status(6) )
- If( Any(alloc_status /= 0) ) Then
- errorstatus = errorstatus_fatal
- Write( errMessage, '( "allocation of ssirem coefs arrays")' )
- Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine)
- Return
- End If
-
- If( all_channels ) Then
- Do i = 1, coef % fmv_chn
-
- ! original chan number
- ! constant coef
- ! first order coef
- ! second order coef
- ! 1st exponent on zenith angle
- ! 2nd exponent on zenith angle
- Read(file_lu,*,iostat=io_status)&
- & coef % ssirem_chn(i), &
- & coef % ssirem_a0(i), &
- & coef % ssirem_a1(i), &
- & coef % ssirem_a2(i), &
- & coef % ssirem_xzn1(i),&
- & coef % ssirem_xzn2(i)
- If(io_status /= 0) Then
- Call Rttov_ErrorReport (io_status, errMessage, NameOfRoutine)
- errorstatus = errorstatus_fatal
- Return
- Endif
-
- End Do
- Else
- Allocate ( ivalues0( file_channels ), stat=alloc_status(1) )
- Allocate ( values0( file_channels ), stat=alloc_status(2) )
- Allocate ( values1( file_channels ), stat=alloc_status(3) )
- Allocate ( values2( file_channels ), stat=alloc_status(4) )
- Allocate ( values3( file_channels ), stat=alloc_status(5) )
- Allocate ( values4( file_channels ), stat=alloc_status(6) )
- If( Any(alloc_status /= 0) ) Then
- errorstatus = errorstatus_fatal
- Write( errMessage, '( "allocation of ssirem coefs arrays")' )
- Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine)
- Return
- End If
- Do i = 1, file_channels
- Read( file_lu, *, iostat = io_status )&
- & ivalues0(i),&
- & values0(i) ,&
- & values1(i) ,&
- & values2(i) ,&
- & values3(i) ,&
- & values4(i)
- If(io_status /= 0) Then
- errorstatus = errorstatus_fatal
- Call Rttov_ErrorReport (io_status, errMessage, NameOfRoutine)
- errorstatus = errorstatus_fatal
- Return
- Endif
- End Do
- coef % ssirem_chn(:) = ivalues0 ( channels(:) )
- coef % ssirem_a0(:) = values0 ( channels(:) )
- coef % ssirem_a1(:) = values1 ( channels(:) )
- coef % ssirem_a2(:) = values2 ( channels(:) )
- coef % ssirem_xzn1(:) = values3 ( channels(:) )
- coef % ssirem_xzn2(:) = values4 ( channels(:) )
- Deallocate ( ivalues0, stat=alloc_status(1) )
- Deallocate ( values0, stat=alloc_status(2) )
- Deallocate ( values1, stat=alloc_status(3) )
- Deallocate ( values2, stat=alloc_status(4) )
- Deallocate ( values3, stat=alloc_status(5) )
- Deallocate ( values4, stat=alloc_status(6) )
- If( Any(alloc_status /= 0) ) Then
- errorstatus = errorstatus_fatal
- Write( errMessage, '( "deallocation of ssirem coefs arrays")' )
- Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine)
- Return
- End If
- Endif
-
- !-------------------------------------------------------
- Case ('GAZ_UNITS')
- ! the array has already been allocated and initialised
- ! to specific concentration (kg/kg)
- !
- ! This section needs one input line per gaz
- ! in the same order as the gaz list defined inside
- !
- ! This is defining the units used for the sections
- ! REFERENCE_PROFILE and PROFILE_LIMITS
- !
- Call rttov_skipcommentline ( file_lu, io_status )
- If(io_status /= 0) Then
- Call Rttov_ErrorReport (io_status, errMessage, NameOfRoutine)
- errorstatus = errorstatus_fatal
- Return
- Endif
-
- Do n = 1, coef % fmv_gas
- Call rttov_skipcommentline (file_lu, io_status)
- If(io_status /= 0) Then
- errorstatus = errorstatus_fatal
- Return
- Endif
-
- Read( file_lu, *, iostat=io_status ) coef % gaz_units( n )
- If(io_status /= 0) Then
- Call Rttov_ErrorReport (io_status, errMessage, NameOfRoutine)
- errorstatus = errorstatus_fatal
- Return
- Endif
-
- End Do
-
- !-------------------------------------------------------
- Case ('REFERENCE_PROFILE')
- Call rttov_skipcommentline ( file_lu, io_status )
- If(io_status /= 0) Then
- Call Rttov_ErrorReport (io_status, errMessage, NameOfRoutine)
- errorstatus = errorstatus_fatal
- Return
- Endif
-
- Allocate ( coef % ref_prfl_p ( coef % fmv_lvl(gas_id_mixed) ), stat=alloc_status(1) )
- Allocate ( coef % ref_prfl_t ( coef % fmv_lvl(gas_id_mixed), coef % fmv_gas ), stat=alloc_status(2) )
- Allocate ( coef % ref_prfl_mr( coef % fmv_lvl(gas_id_mixed), coef % fmv_gas ), stat=alloc_status(3) )
- If( Any(alloc_status /= 0) ) Then
- Write( errMessage, '( "allocation of ref profile coefs arrays")' )
- Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine)
- Return
- End If
-
- Do n = 1, coef % fmv_gas
- Call rttov_skipcommentline (file_lu, io_status)
- If(io_status /= 0) Then
- errorstatus = errorstatus_fatal
- Return
- Endif
-
- ! units for reference gaz concentration is
- ! specified in GAZ_UNITS section (default is specific concentration (kg/kg))
- !
- Do i = 1, coef % nlevels
- Read( file_lu, *, iostat=io_status ) &
- & pres ,&
- & coef % ref_prfl_t ( i, n ) ,&
- & coef % ref_prfl_mr ( i, n )
- If(io_status /= 0) Then
- Call Rttov_ErrorReport (io_status, errMessage, NameOfRoutine)
- errorstatus = errorstatus_fatal
- Return
- Endif
- If( coef % fmv_gas_id(n) == gas_id_mixed) coef % ref_prfl_p( i ) = pres
- End Do
-
- End Do
-
- !-------------------------------------------------------
- Case ('PROFILE_LIMITS')
- Call rttov_skipcommentline ( file_lu, io_status )
- If(io_status /= 0) Then
- Call Rttov_ErrorReport (io_status, errMessage, NameOfRoutine)
- errorstatus = errorstatus_fatal
- Return
- Endif
-
- Allocate ( coef % lim_prfl_p( coef % fmv_lvl(gas_id_mixed) ), stat=alloc_status(1) )
- Allocate ( coef % lim_prfl_tmax( coef % fmv_lvl(gas_id_mixed) ), stat=alloc_status(2) )
- Allocate ( coef % lim_prfl_tmin( coef % fmv_lvl(gas_id_mixed) ), stat=alloc_status(3) )
- Allocate ( coef % lim_prfl_gmin( coef % fmv_lvl(gas_id_mixed), coef % fmv_gas ), stat=alloc_status(4) )
- Allocate ( coef % lim_prfl_gmax( coef % fmv_lvl(gas_id_mixed), coef % fmv_gas ), stat=alloc_status(5) )
- If( Any(alloc_status /= 0) ) Then
- errorstatus = errorstatus_fatal
- Write( errMessage, '( "allocation of profile limits arrays")' )
- Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine)
- Return
- End If
-
- Do l = 1, coef % nlevels
- ! pressure (hPa) (levels)
- ! max temperature (K) (levels)
- ! min temperature (K) (levels)
- Read(file_lu,*,iostat=io_status)&
- & coef % lim_prfl_p(l), coef % lim_prfl_tmax(l), coef % lim_prfl_tmin(l)
- If(io_status /= 0) Then
- Call Rttov_ErrorReport (io_status, errMessage, NameOfRoutine)
- errorstatus = errorstatus_fatal
- Return
- Endif
- End Do
-
- Do n = 1, coef % fmv_gas
- Call rttov_skipcommentline ( file_lu, io_status )
- If(io_status /= 0) Then
- Call Rttov_ErrorReport (io_status, errMessage, NameOfRoutine)
- errorstatus = errorstatus_fatal
- Return
- Endif
-
- Do i = 1, coef % nlevels
- ! max specific concentration (kg/kg) (levels, gases)
- ! min specific concentration (kg/kg) (levels, gases)
- ! or
- ! max volume mixing r (ppmv) (levels, gases)
- ! min volume mixing r (ppmv) (levels, gases)
- ! according to
- ! units specified in GAZ_UNITS section (default is specific concentration (kg/kg))
- Read(file_lu,*,iostat=io_status) &
- & pres, coef % lim_prfl_gmax( i , n ), coef % lim_prfl_gmin( i , n)
- If(io_status /= 0) Then
- Call Rttov_ErrorReport (io_status, errMessage, NameOfRoutine)
- errorstatus = errorstatus_fatal
- Return
- Endif
- End Do
-
- End Do
-
- !-------------------------------------------------------
- Case ('FAST_COEFFICIENTS','COEF_SUB_FILES')
- Call rttov_skipcommentline ( file_lu, io_status )
- If(io_status /= 0) Then
- Call Rttov_ErrorReport (io_status, errMessage, NameOfRoutine)
- errorstatus = errorstatus_fatal
- Return
- Endif
-
- ! If section is COEF_SUB_FILES then coefficients for each gaz is stored
- ! in separate files.
- ! This possibility could be used to store very large coefficient files
- ! (large number of channels or gases)
- ! Section contains 1 line per gaz in the same order as the
- ! FAST_MODEL_VARIABLES section
- ! line indicates the filename of the coefficient for that gas
- !
- ! No verification is done on the file.
- ! header lines starting with "!" sign are skipped
-
- ! loop on gases
- Do n = 1, coef % fmv_gas
- Call rttov_skipcommentline ( file_lu, io_status )
- If(io_status /= 0) Then
- Call Rttov_ErrorReport (io_status, errMessage, NameOfRoutine)
- errorstatus = errorstatus_fatal
- Return
- Endif
-
- ! read dummy string of gas name or filename of the sub_coefficient file
- Read( file_lu, *, iostat=io_status ) input_string
- If(io_status /= 0) Then
- Call Rttov_ErrorReport (io_status, errMessage, NameOfRoutine)
- errorstatus = errorstatus_fatal
- Return
- Endif
-
- ! Case of Sub coefficient files
- ! Open the file and skip the header
- If( Trim(section) == 'COEF_SUB_FILES') Then
- file_lu_coef = 0
- for_output = .False.
- Call rttov_opencoeff (errorstatus, input_string, file_lu_coef, for_output)
- If ( errorstatus /= 0 ) Then
- errorstatus = errorstatus_fatal
- Write( errMessage, '( "Error opening sub_coef file" )' )
- Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine)
- Return
- Endif
- Call rttov_skipcommentline ( file_lu_coef, io_status )
- If(io_status /= 0) Then
- Write( errMessage, &
- & '( "I/O error while reading sub_coef file ",i5 )' ) io_status
- Call Rttov_ErrorReport (io_status, errMessage, NameOfRoutine)
- errorstatus = errorstatus_fatal
- Return
- Endif
- Else
- file_lu_coef = file_lu
- Endif
-
- Select Case( coef % fmv_gas_id(n) )
-
- Case(gas_id_mixed)
- nvalues = coef % nmixed
- Allocate ( coef % mixedgas ( coef % nlevels, coef % fmv_chn, coef % nmixed), stat= alloc_status(1))
- If( Any(alloc_status /= 0) ) Then
- errorstatus = errorstatus_fatal
- Write( errMessage, '( "allocation of MxG coefs arrays")' )
- Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine)
- Return
- End If
- If( all_channels ) Then
- coeffsarray => coef % mixedgas
- Else
- Allocate( coeffsarray( coef % nlevels, file_channels, coef % nmixed ), stat= alloc_status(1))
- If( Any(alloc_status /= 0) ) Then
- errorstatus = errorstatus_fatal
- Write( errMessage, '( "allocation of MxG coefs arrays")' )
- Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine)
- Return
- End If
-
- Endif
-
- Case(gas_id_watervapour)
- nvalues = coef % nwater
- Allocate ( coef % watervapour ( coef % nlevels, coef % fmv_chn, coef % nwater), stat= io_status)
- If( Any(alloc_status /= 0) ) Then
- errorstatus = errorstatus_fatal
- Write( errMessage, '( "allocation of WV coefs arrays")' )
- Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine)
- Return
- End If
- If( all_channels ) Then
- coeffsarray => coef % watervapour
- Else
- Allocate( coeffsarray( coef % nlevels, file_channels, coef % nwater ), stat= alloc_status(1))
- If( Any(alloc_status /= 0) ) Then
- errorstatus = errorstatus_fatal
- Write( errMessage, '( "allocation of WV coefs arrays")' )
- Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine)
- Return
- End If
- Endif
-
- Case(gas_id_ozone)
- nvalues = coef % nozone
- Allocate ( coef % ozone ( coef % nlevels, coef % fmv_chn, coef % nozone), stat= alloc_status(1))
- If( Any(alloc_status /= 0) ) Then
- errorstatus = errorstatus_fatal
- Write( errMessage, '( "allocation of O3 coefs arrays")' )
- Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine)
- Return
- End If
- If( all_channels ) Then
- coeffsarray => coef % ozone
- Else
- Allocate( coeffsarray( coef % nlevels, file_channels, coef % nozone ), stat= alloc_status(1))
- If( Any(alloc_status /= 0) ) Then
- errorstatus = errorstatus_fatal
- Write( errMessage, '( "allocation of O3 coefs arrays")' )
- Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine)
- Return
- End If
- Endif
-
- Case(gas_id_wvcont)
- nvalues = coef % nwvcont
- Allocate ( coef % wvcont ( coef % nlevels, coef % fmv_chn, coef % nwvcont), stat= alloc_status(1))
- If( Any(alloc_status /= 0) ) Then
- errorstatus = errorstatus_fatal
- Write( errMessage, '( "allocation of WV continuum coefs arrays")' )
- Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine)
- Return
- End If
- If( all_channels ) Then
- coeffsarray => coef % wvcont
- Else
- Allocate( coeffsarray( coef % nlevels, file_channels, coef % nwvcont ), stat= alloc_status(1))
- If( Any(alloc_status /= 0) ) Then
- errorstatus = errorstatus_fatal
- Write( errMessage, '( "allocation of WV continuum coefs arrays")' )
- Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine)
- Return
- End If
- Endif
-
- Case(gas_id_co2)
- nvalues = coef % nco2
- Allocate ( coef % co2 ( coef % nlevels, coef % fmv_chn, coef % nco2), stat= alloc_status(1))
- If( Any(alloc_status /= 0) ) Then
- errorstatus = errorstatus_fatal
- Write( errMessage, '( "allocation of CO2 coefs arrays")' )
- Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine)
- Return
- End If
- If( all_channels ) Then
- coeffsarray => coef % co2
- Else
- Allocate( coeffsarray( coef % nlevels, file_channels, coef % nco2 ), stat= alloc_status(1))
- If( Any(alloc_status /= 0) ) Then
- errorstatus = errorstatus_fatal
- Write( errMessage, '( "allocation of CO2 coefs arrays")' )
- Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine)
- Return
- End If
- Endif
-
- Case(gas_id_n2o)
- nvalues = coef % nn2o
- Allocate ( coef % n2o ( coef % nlevels, coef % fmv_chn, coef % nn2o), stat= alloc_status(1))
- If( Any(alloc_status /= 0) ) Then
- errorstatus = errorstatus_fatal
- Write( errMessage, '( "allocation of N2O coefs arrays")' )
- Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine)
- Return
- End If
- If( all_channels ) Then
- coeffsarray => coef % n2o
- Else
- Allocate( coeffsarray( coef % nlevels, file_channels, coef % nn2o ), stat= alloc_status(1))
- If( Any(alloc_status /= 0) ) Then
- errorstatus = errorstatus_fatal
- Write( errMessage, '( "allocation of N2O coefs arrays")' )
- Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine)
- Return
- End If
- Endif
-
- Case(gas_id_co)
- nvalues = coef % nco
- Allocate ( coef % co ( coef % nlevels, coef % fmv_chn, coef % nco), stat= alloc_status(1))
- If( Any(alloc_status /= 0) ) Then
- errorstatus = errorstatus_fatal
- Write( errMessage, '( "allocation of CO coefs arrays")' )
- Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine)
- Return
- End If
- If( all_channels ) Then
- coeffsarray => coef % co
- Else
- Allocate( coeffsarray( coef % nlevels, file_channels, coef % nco ), stat= alloc_status(1))
- If( Any(alloc_status /= 0) ) Then
- errorstatus = errorstatus_fatal
- Write( errMessage, '( "allocation of CO coefs arrays")' )
- Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine)
- Return
- End If
- Endif
-
- Case(gas_id_ch4)
- nvalues = coef % nch4
- Allocate ( coef % ch4 ( coef % nlevels, coef % fmv_chn, coef % nch4), stat= alloc_status(1))
- If( Any(alloc_status /= 0) ) Then
- errorstatus = errorstatus_fatal
- Write( errMessage, '( "allocation of CH4 coefs arrays")' )
- Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine)
- Return
- End If
- If( all_channels ) Then
- coeffsarray => coef % ch4
- Else
- Allocate( coeffsarray( coef % nlevels, file_channels, coef % nch4 ), stat= alloc_status(1))
- If( Any(alloc_status /= 0) ) Then
- errorstatus = errorstatus_fatal
- Write( errMessage, '( "allocation of CH4 coefs arrays")' )
- Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine)
- Return
- End If
- Endif
-
-
- End Select
-
- Read( file_lu_coef, *, iostat=io_status ) (((coeffsarray(i,j,k), &
- & i = 1, coef % nlevels),&
- & j = 1, file_channels),&
- & k = 1, nvalues)
- If(io_status /= 0) Then
- errmessage = 'erreur lecture'
- Call Rttov_ErrorReport (io_status, errMessage, NameOfRoutine)
- errorstatus = errorstatus_fatal
- Return
- Endif
-
- If( .Not. all_channels ) Then
- Select Case( coef % fmv_gas_id(n) )
-
- Case(gas_id_mixed)
- coef % mixedgas( : , : , : ) = coeffsarray( : , channels(:) , : )
- Case(gas_id_watervapour)
- coef % watervapour( : , : , : ) = coeffsarray( : , channels(:) , : )
- Case(gas_id_ozone)
- coef % ozone( : , : , : ) = coeffsarray( : , channels(:) , : )
- Case(gas_id_wvcont)
- coef % wvcont( : , : , : ) = coeffsarray( : , channels(:) , : )
- Case(gas_id_co2)
- coef % co2( : , : , : ) = coeffsarray( : , channels(:) , : )
- Case(gas_id_n2o)
- coef % n2o( : , : , : ) = coeffsarray( : , channels(:) , : )
- Case(gas_id_co)
- coef % co( : , : , : ) = coeffsarray( : , channels(:) , : )
- Case(gas_id_ch4)
- coef % ch4( : , : , : ) = coeffsarray( : , channels(:) , : )
- !
- End Select
- Deallocate ( coeffsarray, stat=alloc_status(1) )
- If( Any(alloc_status /= 0) ) Then
- errorstatus = errorstatus_fatal
- Write( errMessage, '( "deallocation of intermediate coefs array")' )
- Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine)
- Return
- End If
- Endif
-
- ! For COEF_SUB_FILES close the intermediate coef file
- If( Trim(section) == 'COEF_SUB_FILES') Then
- Close( unit = file_lu_coef )
- Endif
-
- End Do
-
-
- !-------------------------------------------------------
- Case ('END')
- Return
-
- Case default
-
- Cycle readfile
-
- End Select
-
- End Do readfile
-
-
-
-
-End Subroutine rttov_readcoeffs_ascii
diff --git a/src/LIB/RTTOV/src/rttov_readcoeffs_ascii.interface b/src/LIB/RTTOV/src/rttov_readcoeffs_ascii.interface
deleted file mode 100644
index c8f57192710f1c6997d5e436626962dde5c142e4..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_readcoeffs_ascii.interface
+++ /dev/null
@@ -1,51 +0,0 @@
-Interface
-!
-Subroutine rttov_readcoeffs_ascii (&
- & errorstatus, & ! out
- & coef, & ! inout
- & file_lu, & ! in
- & channels ) ! in Optional
- Use rttov_const, Only : &
- version_compatible_min ,&
- version_compatible_max ,&
- sensor_id_hi ,&
- sensor_id_mw ,&
- sensor_id_ir ,&
- errorstatus_success ,&
- errorstatus_info ,&
- errorstatus_fatal ,&
- gas_id_mixed ,&
- gas_id_watervapour ,&
- gas_id_ozone ,&
- gas_id_wvcont ,&
- gas_id_co2 ,&
- gas_id_n2o ,&
- gas_id_co ,&
- gas_id_ch4 ,&
- platform_name ,&
- inst_name ,&
- sensor_name ,&
- ngases_max ,&
- gas_name ,&
- gas_unit_specconc ,&
- gas_unit_ppmv
-
-
- Use rttov_types, Only : &
- rttov_coef
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
-
- Integer(Kind=jpim), Intent (in) :: file_lu ! file logical unit number
- Integer(Kind=jpim), Optional, Intent (in) :: channels(:) ! list of channels to extract
-
- Type( rttov_coef ), Intent (inout) :: coef ! coefficients
-
- Integer(Kind=jpim), Intent (out) :: errorstatus ! return code
-
-
-
-End Subroutine rttov_readcoeffs_ascii
-End Interface
diff --git a/src/LIB/RTTOV/src/rttov_readcoeffs_binary.F90 b/src/LIB/RTTOV/src/rttov_readcoeffs_binary.F90
deleted file mode 100644
index df5c41a142fbfa30e4a4458ad9086ea7078fd002..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_readcoeffs_binary.F90
+++ /dev/null
@@ -1,824 +0,0 @@
-!
-Subroutine rttov_readcoeffs_binary (&
- & errorstatus, &! out
- & coef, &! inout
- & file_lu, &! in
- & channels ) ! in Optional
- ! Description:
- !
- ! Read an binary coefficient file and fills coeff structure
- ! arrays according to the optional list of channels.
- !
- ! The user can provide an optional list of channels in "channels" argument
- ! array to reduce the output coefficient structure to this list. This
- ! can be important for reducing the memory allocation required when running
- ! with advanced IR sounders (e.g. AIRS or IASI). If the user
- ! wants all channels the "channels" argument shall not be present.
- !
- !
- ! Copyright:
- ! This software was developed within the context of
- ! the EUMETSAT Satellite Application Facility on
- ! Numerical Weather Prediction (NWP SAF), under the
- ! Cooperation Agreement dated 25 November 1998, between
- ! EUMETSAT and the Met Office, UK, by one or more partners
- ! within the NWP SAF. The partners in the NWP SAF are
- ! the Met Office, ECMWF, KNMI and MeteoFrance.
- !
- ! Copyright 2002, EUMETSAT, All Rights Reserved.
- !
- ! Method:
- !
- ! Current Code Owner: SAF NWP
- !
- ! History:
- ! Version Date Comment
- ! ------- ---- -------
- ! 1.0 01/12/2002 New F90 code with structures (P Brunel A Smith)
- ! 1.1 02/01/2003 A few comments added (R Saunders)
- ! 1.2 24/01/2003 add tests on all read statements (P Brunel)
- ! one record per channel for coefficients in binary format
- ! New header to allow checking R4<->R8
- ! 1.3 06/05/2003 Remove "optional" attribute of argument file_lu (P Brunel)
- ! 1.4 02/06/2004 New format for FMV section with RTTOV8 (P. Brunel)
- ! 1.5 15/06/2004 Corrected array dimension for coef % fmv_gas_pos (R Saunders)
- !
- ! Code Description:
- ! Language: Fortran 90.
- ! Software Standards: "European Standards for Writing and
- ! Documenting Exchangeable Fortran 90 Code".
- !
- ! Declarations:
- ! Modules used:
- ! Imported Parameters:
- Use rttov_const, Only : &
- & rttov_magic_string ,&
- & rttov_magic_number ,&
- & version_compatible_min ,&
- & version_compatible_max ,&
- & errorstatus_success ,&
- & errorstatus_fatal ,&
- & gas_id_mixed ,&
- & gas_id_watervapour ,&
- & gas_id_ozone ,&
- & gas_id_wvcont ,&
- & gas_id_co2 ,&
- & gas_id_n2o ,&
- & gas_id_co ,&
- & gas_id_ch4 ,&
- & ngases_max
-
-
- ! Imported Type Definitions:
- Use rttov_types, Only : &
- & rttov_coef
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
-#include "rttov_errorreport.interface"
-
- ! subroutine arguments
- ! scalar arguments with intent(in):
- Integer(Kind=jpim), Intent (in) :: file_lu ! file logical unit number
- Integer(Kind=jpim), Optional, Intent (in) :: channels(:) ! list of channels to extract
-
- ! scalar arguments with intent(inout):
- Type( rttov_coef ), Intent (inout) :: coef ! coefficients
-
- ! scalar arguments with intent(out):
- Integer(Kind=jpim), Intent (out) :: errorstatus ! return code
-
- ! Local Scalars:
- Integer(Kind=jpim) :: file_channels
- Logical :: all_channels
- Integer(Kind=jpim) :: io_status
- Integer(Kind=jpim) :: alloc_status(11)
- Integer(Kind=jpim) :: n
- Integer(Kind=jpim) :: chn
- Integer(Kind=jpim) :: i
-
- ! pointers for generic inputs
- Real(Kind=jprb), Pointer :: values0(:)
- Real(Kind=jprb), Pointer :: values1(:)
- Real(Kind=jprb), Pointer :: values2(:)
- Real(Kind=jprb), Pointer :: values3(:)
- Real(Kind=jprb), Pointer :: values4(:)
- Integer(Kind=jpim), Pointer :: ivalues0(:)
- Integer(Kind=jpim), Pointer :: ivalues1(:)
-
- Character (len=16) :: bin_check_string
- Real(Kind=jprb) :: bin_check_number
- Real(Kind=jprb) :: bin_check_value
- Character (len=80) :: errMessage
- Character (len=23) :: NameOfRoutine = 'rttov_readcoeffs_binary'
-
- !- End of header --------------------------------------------------------
-
- ! 0 Initialise variables
- !---------------------------------------------
- errorstatus = errorstatus_success
- alloc_status(:) = 0
-
- ! test presence of channels argument
- If( Present ( channels ) ) Then
- all_channels = .False.
- Else
- all_channels = .True.
- Endif
-
-
- ! 3 Read binary file
- !-------------------
- ! Binary file
- Read(file_lu, iostat = io_status ) bin_check_string, bin_check_number
- If(io_status /= 0) Then
- errMessage = 'io status while reading header'
- Call Rttov_ErrorReport (io_status, errMessage, NameOfRoutine)
- errorstatus = errorstatus_fatal
- Return
- Endif
-
- ! Verification of header string
- if ( bin_check_string /= rttov_magic_string ) Then
- errMessage = 'Wrong header string in file'
- errorstatus = errorstatus_fatal
- Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine)
- Return
- End If
-
-
- ! Verification of single/double precision using a 5 digit number
- ! with exponent 12, which is always Ok for single precision
- bin_check_value = 1._JPRB - abs ( bin_check_number - rttov_magic_number )
- if ( bin_check_value > 1.01_JPRB .or. bin_check_value < 0.99_JPRB ) Then
- errMessage = 'File created with a different real precision (R4<->R8)'
- errorstatus = errorstatus_fatal
- Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine)
- Return
- End If
-
- errMessage = 'io status while reading IDENTIFICATION'
- Read(file_lu, iostat = io_status )&
- & coef % id_platform, &
- & coef % id_sat, &
- & coef % id_inst, &
- & coef % id_sensor
- If(io_status /= 0) Then
- Call Rttov_ErrorReport (io_status, errMessage, NameOfRoutine)
- errorstatus = errorstatus_fatal
- Return
- Endif
- Read(file_lu, iostat = io_status )&
- & coef % id_comp_lvl, &
- & coef % id_creation_date, &
- & coef % id_creation, &
- & coef % id_Common_name
- If(io_status /= 0) Then
- Call Rttov_ErrorReport (io_status, errMessage, NameOfRoutine)
- errorstatus = errorstatus_fatal
- Return
- Endif
-
- errMessage = 'io status while reading FAST_MODEL_VARIABLES'
- If( coef % id_comp_lvl <= 7 ) then
- Read(file_lu, iostat = io_status )&
- & coef % fmv_model_def, &
- & coef % fmv_chn, &
- & coef % fmv_gas
- coef % fmv_model_ver = 7
- Else
- Read(file_lu, iostat = io_status )&
- & coef % fmv_model_def, &
- & coef % fmv_model_ver, &
- & coef % fmv_chn, &
- & coef % fmv_gas
- Endif
-
- If(io_status /= 0) Then
- Call Rttov_ErrorReport (io_status, errMessage, NameOfRoutine)
- errorstatus = errorstatus_fatal
- Return
- Endif
-
- ! Error if the compatibility version of the coefficient file
- ! is not in the range defined by the constant module
- If( coef % id_comp_lvl < version_compatible_min .Or.&
- & coef % id_comp_lvl > version_compatible_max ) Then
- errorstatus = errorstatus_fatal
- Write( errMessage,&
- & '( "Version of coefficient file is incompatible with RTTOV library")' )
- Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine)
- Return
- Endif
-
- ! Take care of the user list of channels
- ! file_channels store the number of channels in the file
- ! coef % fmv_chn is the number of channels that the user requests
- file_channels = coef % fmv_chn
- If( .Not. all_channels ) Then
- coef % fmv_chn = Size( channels )
- Endif
-
- Allocate ( coef % fmv_gas_id ( coef % fmv_gas ), stat=alloc_status(1))
- Allocate ( coef % fmv_gas_pos( ngases_max ), stat=alloc_status(2))
- Allocate ( coef % fmv_var ( coef % fmv_gas ), stat=alloc_status(3))
- Allocate ( coef % fmv_lvl ( coef % fmv_gas ), stat=alloc_status(4))
- Allocate ( coef % ff_ori_chn( coef % fmv_chn ), stat=alloc_status(5) )
- Allocate ( coef % ff_val_chn( coef % fmv_chn ), stat=alloc_status(6) )
- Allocate ( coef % ff_cwn( coef % fmv_chn ), stat=alloc_status(7) )
- Allocate ( coef % ff_bco( coef % fmv_chn ), stat=alloc_status(8) )
- Allocate ( coef % ff_bcs( coef % fmv_chn ), stat=alloc_status(9) )
- Allocate ( coef % ff_gam( coef % fmv_chn ), stat=alloc_status(10) )
- Allocate ( coef % gaz_units( coef % fmv_gas ), stat=alloc_status(11) )
- If( Any(alloc_status /= 0) ) Then
- errorstatus = errorstatus_fatal
- Write( errMessage, '( "allocation of coefs arrays")' )
- Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine)
- Return
- End If
-
-
- Read(file_lu, iostat = io_status )&
- & coef % fmv_gas_id, &
- & coef % fmv_gas_pos, &
- & coef % fmv_var, &
- & coef % fmv_lvl
- If(io_status /= 0) Then
- Call Rttov_ErrorReport (io_status, errMessage, NameOfRoutine)
- errorstatus = errorstatus_fatal
- Return
- Endif
-
- Do n = 1, coef % fmv_gas
- Select Case( coef % fmv_gas_id(n) )
- Case( gas_id_mixed )
- coef % nmixed = coef % fmv_var(n)
- coef % nlevels = coef % fmv_lvl(n)
- Case( gas_id_watervapour )
- coef % nwater = coef % fmv_var(n)
- Case( gas_id_ozone )
- coef % nozone = coef % fmv_var(n)
- Case( gas_id_wvcont )
- coef % nwvcont = coef % fmv_var(n)
- Case( gas_id_co2 )
- coef % nco2 = coef % fmv_var(n)
- Case( gas_id_n2o )
- coef % nn2o = coef % fmv_var(n)
- Case( gas_id_co )
- coef % nco = coef % fmv_var(n)
- Case( gas_id_ch4 )
- coef % nch4 = coef % fmv_var(n)
- End Select
- End Do
-
- errMessage = 'io status while reading GAZ_UNITS'
- Read(file_lu, iostat = io_status )&
- & coef % gaz_units
- If(io_status /= 0) Then
- Call Rttov_ErrorReport (io_status, errMessage, NameOfRoutine)
- errorstatus = errorstatus_fatal
- Return
- Endif
-
- errMessage = 'io status while reading FILTER_FUNCTIONS'
- If( all_channels ) Then
- Read(file_lu, iostat = io_status )&
- & coef % ff_ori_chn, &
- & coef % ff_val_chn, &
- & coef % ff_cwn, &
- & coef % ff_bco, &
- & coef % ff_bcs, &
- & coef % ff_gam
- If(io_status /= 0) Then
- Call Rttov_ErrorReport (io_status, errMessage, NameOfRoutine)
- errorstatus = errorstatus_fatal
- Return
- Endif
- Else
- Allocate ( ivalues0( file_channels ), stat=alloc_status(1) )
- Allocate ( ivalues1( file_channels ), stat=alloc_status(2) )
- Allocate ( values0( file_channels ), stat=alloc_status(3) )
- Allocate ( values1( file_channels ), stat=alloc_status(4) )
- Allocate ( values2( file_channels ), stat=alloc_status(5) )
- Allocate ( values3( file_channels ), stat=alloc_status(6) )
- If( Any(alloc_status /= 0) ) Then
- errorstatus = errorstatus_fatal
- Write( errMessage, '( "allocation of ff coefs arrays")' )
- Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine)
- Return
- End If
-
- Read(file_lu, iostat = io_status )&
- & ivalues0, &
- & ivalues1, &
- & values0, &
- & values1, &
- & values2, &
- & values3
- If(io_status /= 0) Then
- Call Rttov_ErrorReport (io_status, errMessage, NameOfRoutine)
- errorstatus = errorstatus_fatal
- Return
- Endif
- coef % ff_ori_chn(:) = ivalues0 ( channels(:) )
- coef % ff_val_chn(:) = ivalues1 ( channels(:) )
- coef % ff_cwn(:) = values0 ( channels(:) )
- coef % ff_bco(:) = values1 ( channels(:) )
- coef % ff_bcs(:) = values2 ( channels(:) )
- coef % ff_gam(:) = values3 ( channels(:) )
- Deallocate ( ivalues0, stat=alloc_status(1) )
- Deallocate ( ivalues1, stat=alloc_status(2) )
- Deallocate ( values0, stat=alloc_status(3) )
- Deallocate ( values1, stat=alloc_status(4) )
- Deallocate ( values2, stat=alloc_status(5) )
- Deallocate ( values3, stat=alloc_status(6) )
- If( Any(alloc_status /= 0) ) Then
- errorstatus = errorstatus_fatal
- Write( errMessage, '( "deallocation of ff coefs arrays")' )
- Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine)
- Return
- End If
- Endif
-
- errMessage = 'io status while reading FUNDAMENTAL_CONSTANTS'
- Read(file_lu, iostat = io_status )&
- & coef % fc_speedl, &
- & coef % fc_planck_c1, &
- & coef % fc_planck_c2, &
- & coef % fc_sat_height
- If(io_status /= 0) Then
- Call Rttov_ErrorReport (io_status, errMessage, NameOfRoutine)
- errorstatus = errorstatus_fatal
- Return
- Endif
-
- errMessage = 'io status while reading EMISSIVITY model versions'
- Read(file_lu, iostat = io_status )&
- & coef % fastem_ver, &
- & coef % ssirem_ver
- If(io_status /= 0) Then
- Call Rttov_ErrorReport (io_status, errMessage, NameOfRoutine)
- errorstatus = errorstatus_fatal
- Return
- Endif
-
- errMessage = 'io status while reading FASTEM'
- If( coef % fastem_ver >= 1 ) Then
- Read(file_lu, iostat = io_status ) coef % fastem_coef_nb
- If(io_status /= 0) Then
- Call Rttov_ErrorReport (io_status, errMessage, NameOfRoutine)
- errorstatus = errorstatus_fatal
- Return
- Endif
- Allocate ( coef % fastem_coef ( coef % fastem_coef_nb ), stat=alloc_status(1) )
- Allocate ( coef % fastem_polar ( coef % fmv_chn ), stat=alloc_status(2) )
- If( Any(alloc_status /= 0) ) Then
- errorstatus = errorstatus_fatal
- Write( errMessage, '( "allocation of fastem coefs arrays")' )
- Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine)
- Return
- End If
-
- If( all_channels ) Then
- Read(file_lu, iostat = io_status )&
- & coef % fastem_coef ,&
- & coef % fastem_polar
- If(io_status /= 0) Then
- Call Rttov_ErrorReport (io_status, errMessage, NameOfRoutine)
- errorstatus = errorstatus_fatal
- Return
- Endif
- Else
- Allocate ( ivalues0( file_channels ), stat=alloc_status(1) )
- If( Any(alloc_status /= 0) ) Then
- errorstatus = errorstatus_fatal
- Write( errMessage, '( "allocation of fastem coefs arrays")' )
- Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine)
- Return
- End If
- Read(file_lu, iostat = io_status )&
- & coef % fastem_coef,&
- & ivalues0
- If(io_status /= 0) Then
- Call Rttov_ErrorReport (io_status, errMessage, NameOfRoutine)
- errorstatus = errorstatus_fatal
- Return
- Endif
- coef % fastem_polar(:) = ivalues0( channels (:) )
- Deallocate ( ivalues0, stat=alloc_status(1) )
- If( Any(alloc_status /= 0) ) Then
- errorstatus = errorstatus_fatal
- Write( errMessage, '( "deallocation of fastem coefs arrays")' )
- Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine)
- Return
- End If
- Endif
- Endif
-
- errMessage = 'io status while reading SSIREM'
- If( coef % ssirem_ver >= 1 ) Then
- Allocate ( coef % ssirem_chn ( coef % fmv_chn ), stat=alloc_status(1) )
- Allocate ( coef % ssirem_a0 ( coef % fmv_chn ), stat=alloc_status(2) )
- Allocate ( coef % ssirem_a1 ( coef % fmv_chn ), stat=alloc_status(3) )
- Allocate ( coef % ssirem_a2 ( coef % fmv_chn ), stat=alloc_status(4) )
- Allocate ( coef % ssirem_xzn1( coef % fmv_chn ), stat=alloc_status(5) )
- Allocate ( coef % ssirem_xzn2( coef % fmv_chn ), stat=alloc_status(6) )
- If( Any(alloc_status /= 0) ) Then
- errorstatus = errorstatus_fatal
- Write( errMessage, '( "allocation of ssirem coefs arrays")' )
- Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine)
- Return
- End If
-
- If( all_channels ) Then
- Read(file_lu, iostat = io_status )&
- & coef % ssirem_chn, &
- & coef % ssirem_a0, &
- & coef % ssirem_a1, &
- & coef % ssirem_a2, &
- & coef % ssirem_xzn1,&
- & coef % ssirem_xzn2
- If(io_status /= 0) Then
- Call Rttov_ErrorReport (io_status, errMessage, NameOfRoutine)
- errorstatus = errorstatus_fatal
- Return
- Endif
- Else
- Allocate ( ivalues0( file_channels ), stat=alloc_status(1) )
- Allocate ( values0( file_channels ), stat=alloc_status(2) )
- Allocate ( values1( file_channels ), stat=alloc_status(3) )
- Allocate ( values2( file_channels ), stat=alloc_status(4) )
- Allocate ( values3( file_channels ), stat=alloc_status(5) )
- Allocate ( values4( file_channels ), stat=alloc_status(6) )
- If( Any(alloc_status /= 0) ) Then
- errorstatus = errorstatus_fatal
- Write( errMessage, '( "allocation of ssirem coefs arrays")' )
- Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine)
- Return
- End If
- Read(file_lu, iostat = io_status )&
- & ivalues0, &
- & values0, &
- & values1, &
- & values2, &
- & values3, &
- & values4
- If(io_status /= 0) Then
- Call Rttov_ErrorReport (io_status, errMessage, NameOfRoutine)
- errorstatus = errorstatus_fatal
- Return
- Endif
- coef % ssirem_chn(:) = ivalues0 ( channels(:) )
- coef % ssirem_a0(:) = values0 ( channels(:) )
- coef % ssirem_a1(:) = values1 ( channels(:) )
- coef % ssirem_a2(:) = values2 ( channels(:) )
- coef % ssirem_xzn1(:) = values3 ( channels(:) )
- coef % ssirem_xzn2(:) = values4 ( channels(:) )
- Deallocate ( ivalues0, stat=alloc_status(1) )
- Deallocate ( values0, stat=alloc_status(2) )
- Deallocate ( values1, stat=alloc_status(3) )
- Deallocate ( values2, stat=alloc_status(4) )
- Deallocate ( values3, stat=alloc_status(5) )
- Deallocate ( values4, stat=alloc_status(6) )
- If( Any(alloc_status /= 0) ) Then
- errorstatus = errorstatus_fatal
- Write( errMessage, '( "deallocation of ssirem coefs arrays")' )
- Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine)
- Return
- End If
- Endif
- Endif
-
- Allocate ( coef % ref_prfl_p ( coef % fmv_lvl(gas_id_mixed) ), stat=alloc_status(1) )
- Allocate ( coef % ref_prfl_t ( coef % fmv_lvl(gas_id_mixed), coef % fmv_gas ), stat=alloc_status(2) )
- Allocate ( coef % ref_prfl_mr( coef % fmv_lvl(gas_id_mixed), coef % fmv_gas ), stat=alloc_status(3) )
-
- Allocate ( coef % lim_prfl_p( coef % fmv_lvl(gas_id_mixed) ), stat=alloc_status(4) )
- Allocate ( coef % lim_prfl_tmax( coef % fmv_lvl(gas_id_mixed) ), stat=alloc_status(5) )
- Allocate ( coef % lim_prfl_tmin( coef % fmv_lvl(gas_id_mixed) ), stat=alloc_status(6) )
- Allocate ( coef % lim_prfl_gmin( coef % fmv_lvl(gas_id_mixed), coef % fmv_gas ), stat=alloc_status(7) )
- Allocate ( coef % lim_prfl_gmax( coef % fmv_lvl(gas_id_mixed), coef % fmv_gas ), stat=alloc_status(8) )
- If( Any(alloc_status /= 0) ) Then
- errorstatus = errorstatus_fatal
- Write( errMessage, '( "allocation of fmv coefs arrays")' )
- Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine)
- Return
- End If
-
- errMessage = 'io status while reading REFERENCE PROFILE'
- Read(file_lu, iostat = io_status )&
- & coef % ref_prfl_p, &
- & coef % ref_prfl_t, &
- & coef % ref_prfl_mr
- If(io_status /= 0) Then
- Call Rttov_ErrorReport (io_status, errMessage, NameOfRoutine)
- errorstatus = errorstatus_fatal
- Return
- Endif
-
- errMessage = 'io status while reading PROFILE LIMITS'
- Read(file_lu, iostat = io_status )&
- & coef % lim_prfl_p, &
- & coef % lim_prfl_tmax, &
- & coef % lim_prfl_tmin, &
- & coef % lim_prfl_gmax, &
- & coef % lim_prfl_gmin
- If(io_status /= 0) Then
- Call Rttov_ErrorReport (io_status, errMessage, NameOfRoutine)
- errorstatus = errorstatus_fatal
- Return
- Endif
-
- ! FAST COEFFICIENT section
- errMessage = 'io status while reading Mixed gases coefs'
- If ( coef % nmixed > 0 ) Then
- Allocate ( &
- & coef % mixedgas ( &
- & coef % nlevels , &
- & coef % fmv_chn , &
- & coef % nmixed ), &
- & stat= alloc_status(1))
- If( Any(alloc_status /= 0) ) Then
- errorstatus = errorstatus_fatal
- Write( errMessage, '( "allocation of mixed gaz coefs array")' )
- Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine)
- Return
- End If
-
- i = 1
- Do chn = 1, file_channels
- If( all_channels ) Then
- Read(file_lu, iostat = io_status ) coef % mixedgas(: , chn , :)
- Else If( chn == channels( i ) ) Then
- Read(file_lu, iostat = io_status ) coef % mixedgas(: , i , :)
- If( i < coef % fmv_chn ) Then
- i = i + 1
- End If
- Else
- Read(file_lu, iostat = io_status )
- End If
- If(io_status /= 0) Then
- Call Rttov_ErrorReport (io_status, errMessage, NameOfRoutine)
- errorstatus = errorstatus_fatal
- Return
- Endif
- End Do
-
- Endif
-
-
- errMessage = 'io status while reading Water vapour coefs'
- If ( coef % nwater > 0 ) Then
- Allocate ( &
- & coef % watervapour ( &
- & coef % nlevels , &
- & coef % fmv_chn , &
- & coef % nwater ), &
- & stat= alloc_status(1))
- If( Any(alloc_status /= 0) ) Then
- errorstatus = errorstatus_fatal
- Write( errMessage, '( "allocation of water vapour coefs array")' )
- Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine)
- Return
- End If
-
- i = 1
- Do chn = 1, file_channels
- If( all_channels ) Then
- Read(file_lu, iostat = io_status ) coef % watervapour(: , chn , :)
- Else If( chn == channels( i ) ) Then
- Read(file_lu, iostat = io_status ) coef % watervapour(: , i , :)
- If( i < coef % fmv_chn ) Then
- i = i + 1
- End If
- Else
- Read(file_lu, iostat = io_status )
- End If
- If(io_status /= 0) Then
- Call Rttov_ErrorReport (io_status, errMessage, NameOfRoutine)
- errorstatus = errorstatus_fatal
- Return
- Endif
- End Do
-
- Endif
-
- errMessage = 'io status while reading Ozone coefs'
- If ( coef % nozone > 0 ) Then
- Allocate ( &
- & coef % ozone ( &
- & coef % nlevels , &
- & coef % fmv_chn , &
- & coef % nozone ), &
- & stat= alloc_status(1))
- If( Any(alloc_status /= 0) ) Then
- errorstatus = errorstatus_fatal
- Write( errMessage, '( "allocation of ozone coefs array")' )
- Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine)
- Return
- End If
-
- i = 1
- Do chn = 1, file_channels
- If( all_channels ) Then
- Read(file_lu, iostat = io_status ) coef % ozone(: , chn , :)
- Else If( chn == channels( i ) ) Then
- Read(file_lu, iostat = io_status ) coef % ozone(: , i , :)
- If( i < coef % fmv_chn ) Then
- i = i + 1
- End If
- Else
- Read(file_lu, iostat = io_status )
- End If
- If(io_status /= 0) Then
- Call Rttov_ErrorReport (io_status, errMessage, NameOfRoutine)
- errorstatus = errorstatus_fatal
- Return
- Endif
- End Do
- Endif
-
- errMessage = 'io status while reading WV continuum coefs'
- If ( coef % nwvcont > 0 ) Then
- Allocate ( &
- & coef % wvcont ( &
- & coef % nlevels , &
- & coef % fmv_chn , &
- & coef % nwvcont ), &
- & stat= alloc_status(1))
- If( Any(alloc_status /= 0) ) Then
- errorstatus = errorstatus_fatal
- Write( errMessage, '( "allocation of WV continuum coefs array")' )
- Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine)
- Return
- End If
-
- i = 1
- Do chn = 1, file_channels
- If( all_channels ) Then
- Read(file_lu, iostat = io_status ) coef % wvcont(: , chn , :)
- Else If( chn == channels( i ) ) Then
- Read(file_lu, iostat = io_status ) coef % wvcont(: , i , :)
- If( i < coef % fmv_chn ) Then
- i = i + 1
- End If
- Else
- Read(file_lu, iostat = io_status )
- End If
- If(io_status /= 0) Then
- Call Rttov_ErrorReport (io_status, errMessage, NameOfRoutine)
- errorstatus = errorstatus_fatal
- Return
- Endif
- End Do
- Endif
-
- errMessage = 'io status while reading CO2 coefs'
- If ( coef % nco2 > 0 ) Then
- Allocate ( &
- & coef % co2 ( &
- & coef % nlevels , &
- & coef % fmv_chn , &
- & coef % nco2 ), &
- & stat= alloc_status(1))
- If( Any(alloc_status /= 0) ) Then
- errorstatus = errorstatus_fatal
- Write( errMessage, '( "allocation of CO2 coefs array")' )
- Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine)
- Return
- End If
-
- i = 1
- Do chn = 1, file_channels
- If( all_channels ) Then
- Read(file_lu, iostat = io_status ) coef % co2(: , chn , :)
- Else If( chn == channels( i ) ) Then
- Read(file_lu, iostat = io_status ) coef % co2(: , i , :)
- If( i < coef % fmv_chn ) Then
- i = i + 1
- End If
- Else
- Read(file_lu, iostat = io_status )
- End If
- If(io_status /= 0) Then
- Call Rttov_ErrorReport (io_status, errMessage, NameOfRoutine)
- errorstatus = errorstatus_fatal
- Return
- Endif
- End Do
- Endif
-
- errMessage = 'io status while reading N2O coefs'
- If ( coef % nn2o > 0 ) Then
- Allocate ( &
- & coef % n2o ( &
- & coef % nlevels , &
- & coef % fmv_chn , &
- & coef % nn2o ), &
- & stat= alloc_status(1))
- If( Any(alloc_status /= 0) ) Then
- errorstatus = errorstatus_fatal
- Write( errMessage, '( "allocation of N2O coefs array")' )
- Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine)
- Return
- End If
-
- i = 1
- Do chn = 1, file_channels
- If( all_channels ) Then
- Read(file_lu, iostat = io_status ) coef % n2o(: , chn , :)
- Else If( chn == channels( i ) ) Then
- Read(file_lu, iostat = io_status ) coef % n2o(: , i , :)
- If( i < coef % fmv_chn ) Then
- i = i + 1
- End If
- Else
- Read(file_lu, iostat = io_status )
- End If
- If(io_status /= 0) Then
- Call Rttov_ErrorReport (io_status, errMessage, NameOfRoutine)
- errorstatus = errorstatus_fatal
- Return
- Endif
- End Do
- Endif
-
- errMessage = 'io status while reading CO coefs'
- If ( coef % nco > 0 ) Then
- Allocate ( &
- & coef % co ( &
- & coef % nlevels , &
- & coef % fmv_chn , &
- & coef % nco ), &
- & stat= alloc_status(1))
- If( Any(alloc_status /= 0) ) Then
- errorstatus = errorstatus_fatal
- Write( errMessage, '( "allocation of CO coefs array")' )
- Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine)
- Return
- End If
-
- i = 1
- Do chn = 1, file_channels
- If( all_channels ) Then
- Read(file_lu, iostat = io_status ) coef % co(: , chn , :)
- Else If( chn == channels( i ) ) Then
- Read(file_lu, iostat = io_status ) coef % co(: , i , :)
- If( i < coef % fmv_chn ) Then
- i = i + 1
- End If
- Else
- Read(file_lu, iostat = io_status )
- End If
- If(io_status /= 0) Then
- Call Rttov_ErrorReport (io_status, errMessage, NameOfRoutine)
- errorstatus = errorstatus_fatal
- Return
- Endif
- End Do
- Endif
-
- errMessage = 'io status while reading CH4 coefs'
- If ( coef % nch4 > 0 ) Then
- Allocate ( &
- & coef % ch4 ( &
- & coef % nlevels , &
- & coef % fmv_chn , &
- & coef % nch4 ), &
- & stat= alloc_status(1))
- If( Any(alloc_status /= 0) ) Then
- errorstatus = errorstatus_fatal
- Write( errMessage, '( "allocation of CH4 coefs array")' )
- Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine)
- Return
- End If
-
- i = 1
- Do chn = 1, file_channels
- If( all_channels ) Then
- Read(file_lu, iostat = io_status ) coef % ch4(: , chn , :)
- Else If( chn == channels( i ) ) Then
- Read(file_lu, iostat = io_status ) coef % ch4(: , i , :)
- If( i < coef % fmv_chn ) Then
- i = i + 1
- End If
- Else
- Read(file_lu, iostat = io_status )
- End If
- If(io_status /= 0) Then
- Call Rttov_ErrorReport (io_status, errMessage, NameOfRoutine)
- errorstatus = errorstatus_fatal
- Return
- Endif
- End Do
- Endif
-
- !
- ! Here add reading of new sections for binary format in order to keep compatibility with
- ! previous versions
- !
-
-
-
-End Subroutine rttov_readcoeffs_binary
diff --git a/src/LIB/RTTOV/src/rttov_readcoeffs_binary.interface b/src/LIB/RTTOV/src/rttov_readcoeffs_binary.interface
deleted file mode 100644
index eba9258fd8c904482d5b2dcc9953a3fd60edd438..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_readcoeffs_binary.interface
+++ /dev/null
@@ -1,51 +0,0 @@
-Interface
-!
-Subroutine rttov_readcoeffs_binary (&
- & errorstatus, & ! out
- & coef, & ! inout
- & file_lu, & ! in
- & channels ) ! in Optional
- Use rttov_const, Only : &
- rttov_magic_string ,&
- rttov_magic_number ,&
- version_compatible_min ,&
- version_compatible_max ,&
- sensor_id_hi ,&
- sensor_id_mw ,&
- sensor_id_ir ,&
- errorstatus_success ,&
- errorstatus_fatal ,&
- gas_id_mixed ,&
- gas_id_watervapour ,&
- gas_id_ozone ,&
- gas_id_wvcont ,&
- gas_id_co2 ,&
- gas_id_n2o ,&
- gas_id_co ,&
- gas_id_ch4 ,&
- platform_name ,&
- inst_name ,&
- sensor_name ,&
- ngases_max ,&
- gas_name ,&
- gas_unit_specconc ,&
- gas_unit_ppmv
-
- Use rttov_types, Only : &
- rttov_coef
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
-
- Integer(Kind=jpim), Intent (in) :: file_lu ! file logical unit number
- Integer(Kind=jpim), Optional, Intent (in) :: channels(:) ! list of channels to extract
-
- Type( rttov_coef ), Intent (inout) :: coef ! coefficients
-
- Integer(Kind=jpim), Intent (out) :: errorstatus ! return code
-
-
-
-End Subroutine rttov_readcoeffs_binary
-End Interface
diff --git a/src/LIB/RTTOV/src/rttov_readscattcoeffs.F90 b/src/LIB/RTTOV/src/rttov_readscattcoeffs.F90
deleted file mode 100644
index 85a6e93945a809afab06e059126a22d72a3c200a..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_readscattcoeffs.F90
+++ /dev/null
@@ -1,223 +0,0 @@
-!+ routine to read Mie coeficient file
-!
-Subroutine rttov_readscattcoeffs (&
- & errorstatus, &! out
- & coef_rttov, &! in
- & coef_scatt, &! out
- & file_id ) ! in Optional
-
- !
- ! This software was developed within the context of
- ! the EUMETSAT Satellite Application Facility on
- ! Numerical Weather Prediction (NWP SAF), under the
- ! Cooperation Agreement dated 25 November 1998, between
- ! EUMETSAT and the Met Office, UK, by one or more partners
- ! within the NWP SAF. The partners in the NWP SAF are
- ! the Met Office, ECMWF, KNMI and MeteoFrance.
- !
- ! Copyright 2002, EUMETSAT, All Rights Reserved.
- !
- ! Description:
- ! to initialise Mie look-up table
- !
- ! Method:
- !
- ! Current code owner: saf nwp
- !
- ! History:
- ! version date comment
- ! ------- ---- -------
- ! 1.0 09/2002 RTTOV7 compatible (ECMWF)
- ! 1.1 05/2003 RTTOV7.3 compatible (ECMWF)
- ! 1.2 10/2004 Change stop to return (J Cameron)
- ! 1.3 10/2004 Make file_id optional in analogy with rttov_readcoeffs (J Cameron)
-
- ! Imported Type Definitions:
- Use rttov_types, Only : &
- & rttov_coef, &
- & rttov_scatt_coef
-
- Use rttov_const, Only : &
- & inst_name ,&
- & platform_name ,&
- & errorstatus_info ,&
- & errorstatus_success ,&
- & errorstatus_fatal
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
-#include "rttov_errorreport.interface"
-#include "rttov_findnextsection.interface"
-#include "rttov_skipcommentline.interface"
-#include "rttov_opencoeff.interface"
-
- ! subroutine arguments
- ! scalar arguments with intent(out):
- Integer(Kind=jpim), Intent (out) :: errorstatus ! return code
-
- ! scalar arguments with optional intent(in):
- Integer(Kind=jpim), Optional, Intent (in) :: file_id ! file logical unit number
-
- ! array arguments with intent(in):
- Type( rttov_coef ), Intent (in) :: coef_rttov ! clear-sky coefficients
-
- ! array arguments with intent(out):
- Type( rttov_scatt_coef ), Intent (out) :: coef_scatt ! coefficients
-
-! local variables
- Integer(Kind=jpim) :: file_lu, io_status, inst, platform, i, j, k
- Logical :: existence
- Logical :: file_toclose
- Logical :: file_open
- Character (len=32) :: NameOfRoutine = 'rttov_readscattcoeffs' ! name for error message
- Character (len=132) :: ErrMessage ! error message string
- Character (len=256) :: coeffname ! file name for coefficient file
- Character (len=21) :: section
-
- !- End of header --------------------------------------------------------
-
- errorstatus = errorstatus_success
-
- If ( Present (file_id) ) Then
- ! Scatt coefficient file has been opened externally
- file_lu = file_id
- file_toclose = .FALSE.
-
- Inquire( file_lu, OPENED = file_open )
- If ( .NOT. file_open ) Then
- errorstatus = errorstatus_fatal
- Write( errMessage, '( "File is not open on unit: ",i5 )' ) file_lu
- Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine)
- Return
- End If
- Else
- ! Open the scatt coefficients internally
- file_lu = 0
- file_toclose = .TRUE.
-
- platform = coef_rttov % id_platform
- inst = coef_rttov % id_inst
- coeffname = 'mietable_'//Trim(platform_name(platform))//'_'//Trim(inst_name(inst))//'.dat'
-
- Inquire( FILE = coeffname, EXIST = existence )
- If ( .NOT. existence ) Then
- errorstatus = errorstatus_fatal
- Write( errMessage, '( "Coefficient file, ", a, " not found." )' ) &
- & Trim( coeffname )
- Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine)
- Return
- End If
-
- Call rttov_opencoeff (errorstatus, coeffname, file_lu)
-
- If (errorstatus /= errorstatus_success) Then
- ! rttov_opencoeff will have already reported an error
- errorstatus = errorstatus_fatal
- Return
- Endif
- Endif
-
- readfile: Do
- Call rttov_findnextsection( file_lu, io_status, section )
- If ( io_status < 0 ) Exit readfile !end-of-file
-
- ! error message if any problem when reading
- errMessage = 'io status while reading section '//section
- Call rttov_skipcommentline ( file_lu, io_status )
- If(io_status /= 0) Then
- Call Rttov_ErrorReport (io_status, errMessage, NameOfRoutine)
- errorstatus = errorstatus_fatal
- Return
- Endif
-
- Select Case( Trim(section) )
-
-
- Case( 'IDENTIFICATION' )
- Read(file_lu,*) ! platform instrument in id
- Read(file_lu,*) ! platform instrument in letters
- Read(file_lu,*) ! sensor type [ir,mw,hi]
- Read(file_lu,*) ! RTTOV compatibility version
- Read(file_lu,*) ! version
- Read(file_lu,*) ! creation date
-
- Case( 'DIMENSIONS')
- Read(file_lu,*) coef_scatt%mfreqm, coef_scatt%mtype, coef_scatt%mtemp, coef_scatt%mwc
- If (coef_scatt%mtype /= 4) Then
- errorstatus = errorstatus_fatal
- errMessage = 'Wrond number of hydrometeors in parameter file (should ne 4)'
- ! liquid prec., solid prec., ice water, liquid water, water vapour
- Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine)
- Return
- Endif
- coef_scatt % nhydro = coef_scatt%mtype + 1
-
- Case( 'FREQUENCIES')
- Allocate (coef_scatt % mie_freq(coef_scatt%mfreqm))
- Read(file_lu,*) coef_scatt%mie_freq (:)
-
- Case( 'HYDROMETEOR')
- Read(file_lu,*)
-
- Case( 'CONVERSIONS')
- Read(file_lu,*) coef_scatt%conv_rain(:)
- Read(file_lu,*) coef_scatt%conv_sp (:)
- coef_scatt%conv_rain(:) = 1._JPRB/coef_scatt%conv_rain(:)
- coef_scatt%conv_sp (:) = 1._JPRB/coef_scatt%conv_sp (:)
- Read(file_lu,*) coef_scatt%conv_liq(:)
- Read(file_lu,*) coef_scatt%conv_ice(:)
- Read(file_lu,*)
- Read(file_lu,*) coef_scatt%offset_temp_rain
- Read(file_lu,*) coef_scatt%offset_temp_sp
- Read(file_lu,*) coef_scatt%offset_temp_liq
- Read(file_lu,*) coef_scatt%offset_temp_ice
- Read(file_lu,*)
- Read(file_lu,*) coef_scatt%scale_water, coef_scatt%offset_water
- coef_scatt%scale_water = 1._JPRB/coef_scatt%scale_water
- coef_scatt%offset_water = - coef_scatt%offset_water
- coef_scatt%from_scale_water = 10**( 1._JPRB / coef_scatt%scale_water )
-
- Case( 'EXTINCTION')
- Allocate (coef_scatt % ext(coef_scatt%mfreqm, coef_scatt%mtype, coef_scatt%mtemp, coef_scatt%mwc))
- ! The loops should be inverted for better efficiency, but generation program currently not appropriate
- Do i = 1, coef_scatt%mfreqm
- Do j = 1, coef_scatt%mtype
- Do k = 1, coef_scatt%mtemp
- Read(file_lu,'(5(1x,e23.16))') coef_scatt % ext(i,j,k,:)
- Enddo
- Enddo
- Enddo
-
- Case( 'ALBEDO')
- Allocate (coef_scatt % ssa(coef_scatt%mfreqm, coef_scatt%mtype, coef_scatt%mtemp, coef_scatt%mwc))
- Do i = 1, coef_scatt%mfreqm
- Do j = 1, coef_scatt%mtype
- Do k = 1, coef_scatt%mtemp
- Read(file_lu,'(5(1x,e23.16))') coef_scatt % ssa(i,j,k,:)
- Enddo
- Enddo
- Enddo
-
- Case( 'ASYMMETRY')
- Allocate (coef_scatt % asp(coef_scatt%mfreqm, coef_scatt%mtype, coef_scatt%mtemp, coef_scatt%mwc))
- Do i = 1, coef_scatt%mfreqm
- Do j = 1, coef_scatt%mtype
- Do k = 1, coef_scatt%mtemp
- Read(file_lu,'(5(1x,e23.16))') coef_scatt % asp(i,j,k,:)
- Enddo
- Enddo
- Enddo
-
- Case default
- Cycle readfile
-
- End Select
-
- End Do readfile
-
- If ( file_toclose ) Then
- Close ( unit = file_lu )
- Endif
-
-End Subroutine rttov_readscattcoeffs
diff --git a/src/LIB/RTTOV/src/rttov_readscattcoeffs.interface b/src/LIB/RTTOV/src/rttov_readscattcoeffs.interface
deleted file mode 100644
index ec9a9812f51ad4c70dfae5944ec9241599efb8fd..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_readscattcoeffs.interface
+++ /dev/null
@@ -1,38 +0,0 @@
-Interface
- !
- Subroutine rttov_readscattcoeffs (&
- & errorstatus, &! out
- & coef_rttov, &! in
- & coef_scatt, &! out
- & file_id ) ! in Optional
-
- ! Imported Type Definitions:
- Use rttov_types, Only : &
- & rttov_coef, &
- & rttov_scatt_coef
-
- Use rttov_const, Only : &
- & inst_name ,&
- & platform_name ,&
- & errorstatus_info ,&
- & errorstatus_success ,&
- & errorstatus_fatal
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
- ! subroutine arguments
- ! scalar arguments with intent(out):
- Integer(Kind=jpim), Intent (out) :: errorstatus ! return code
-
- ! scalar arguments with optional intent(in):
- Integer(Kind=jpim), Optional, Intent (in) :: file_id ! file logical unit number
-
- ! array arguments with intent(in):
- Type( rttov_coef ), Intent (in) :: coef_rttov ! clear-sky coefficients
-
- ! array arguments with intent(out):
- Type( rttov_scatt_coef ), Intent (out) :: coef_scatt ! coefficients
-
- End Subroutine rttov_readscattcoeffs
-End Interface
diff --git a/src/LIB/RTTOV/src/rttov_scatt.F90 b/src/LIB/RTTOV/src/rttov_scatt.F90
deleted file mode 100644
index 6cad3f421a826ec85ba9cc3f6b3df3bac84a0d33..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_scatt.F90
+++ /dev/null
@@ -1,357 +0,0 @@
-!
-Subroutine rttov_scatt( &
- & errorstatus, &! out
- & nwp_levels, &! in
- & nrt_levels, &! in
- & nfrequencies, &! in
- & nchannels, &! in
- & nbtout, &! in
- & nprofiles, &! in
- & polarisations, &! in
- & channels, &! in
- & frequencies, &! in
- & lprofiles, &! in
- & lsprofiles, &! in
- & profiles, &! inout (to invalid clw absorption)
- & cld_profiles, &! in
- & coef_rttov, &! in
- & coef_scatt, &! in
- & calcemiss, &! in
- & emissivity_in, &! inout
- & cld_radiance ) ! inout
-
- ! Description:
- ! to compute microwave multi-channel radiances and brightness
- ! temperatures for many profiles per call in a cloudy and/or rainy sky.
- !
- ! Copyright:
- ! This software was developed within the context of
- ! the EUMETSAT Satellite Application Facility on
- ! Numerical Weather Prediction (NWP SAF), under the
- ! Cooperation Agreement dated 25 November 1998, between
- ! EUMETSAT and the Met Office, UK, by one or more partners
- ! within the NWP SAF. The partners in the NWP SAF are
- ! the Met Office, ECMWF, KNMI and MeteoFrance.
- !
- ! Copyright 2002, EUMETSAT, All Rights Reserved.
- !
- ! Method / Validation :
- ! --------------------
- ! - Bauer, P., 2002: Microwave radiative transfer modeling in clouds and precipitation.
- ! Part I: Model description.
- ! NWP SAF Report No. NWPSAF-EC-TR-005, 21 pp.
- ! - Moreau, E., P. Bauer and F. Chevallier, 2002: Microwave radiative transfer modeling in clouds and precipitation.
- ! Part II: Model evaluation.
- ! NWP SAF Report No. NWPSAF-EC-TR-006, 27 pp.
- ! - Chevallier, F., and P. Bauer, 2003:
- ! Model rain and clouds over oceans:comparison with SSM/I observations. Mon. Wea. Rev., 131, 1240-1255.
- ! - Smith, E. A., P. Bauer, F. S. Marzano, C. D. Kummerow, D. McKague, A. Mugnai, G. Panegrossi, 2002:
- ! Intercomparison of microwave radiative transfer models for precipitating clouds.
- ! IEEE Trans. Geosci. Remote Sens. 40, 541-549.
- !
- ! Current Code Owner: SAF NWP
- !
- ! History:
- ! Version Date Comment
- ! ------- ---- -------
- ! 1.0 09/2002 Initial version (F. Chevallier)
- ! 1.1 05/2003 RTTOV7.3 compatible (F. Chevallier)
- ! 1.2 03/2004 Added polarimetry (R. Saunders)
- ! 1.3 08/2004 Polarimetry fixes (U. O'Keeffe)
- ! 1.4 11/2004 Clean-up (P. Bauer)
- ! 1.5 07/2005 Polarimetry fixes after re-write (U O'Keeffe)
- ! 1.6 11/2005 Add errorstatus to iniscatt arguments and use a temporary
- ! radiance type for the calcpolarisation call (J Cameron)
- !
- !
- ! Code Description:
- ! Language: Fortran 90.
- ! Software Standards: "European Standards for Writing and
- ! Documenting Exchangeable Fortran 90 Code".
- !
- ! Declarations:
- ! Modules used:
- ! Imported Parameters:
-
- Use rttov_const, Only : &
- & sensor_id_mw ,&
- & errorstatus_success ,&
- & errorstatus_fatal
-
- Use rttov_types, Only : &
- & rttov_coef ,&
- & rttov_scatt_coef ,&
- & geometry_Type ,&
- & profile_Type ,&
- & profile_cloud_Type ,&
- & profile_scatt_aux ,&
- & transmission_Type ,&
- & radiance_Type ,&
- & radiance_cloud_Type
-
- Use parkind1, Only : jpim ,jprb
-
- Implicit None
-
-#include "rttov_direct.interface"
-#include "rttov_iniscatt.interface"
-#include "rttov_eddington.interface"
-#include "rttov_errorreport.interface"
-#include "rttov_calcpolarisation.interface"
-
-!* Subroutine arguments:
- Integer (Kind=jpim), Intent (in) :: nwp_levels ! Number of levels
- Integer (Kind=jpim), Intent (in) :: nrt_levels ! Number of levels
- Integer (Kind=jpim), Intent (in) :: nprofiles ! Number of profiles
- Integer (Kind=jpim), Intent (in) :: nfrequencies ! Number of frequencies
- Integer (Kind=jpim), Intent (in) :: nchannels ! Number of channels*profiles=radiances
- Integer (Kind=jpim), Intent (in) :: nbtout ! Number of output radiances
- Integer (Kind=jpim), Intent (in) :: channels (nfrequencies) ! Channel indices
- Integer (Kind=jpim), Intent (in) :: frequencies (nchannels) ! Frequency indices
- Integer (Kind=jpim), Intent (in) :: polarisations (nchannels,3) ! Polarisation indices
- Integer (Kind=jpim), Intent (in) :: lprofiles (nfrequencies) ! Profile indices
- Integer (Kind=jpim), Intent (in) :: lsprofiles (nchannels) ! Profile indices
- Integer (Kind=jpim), Intent (out) :: errorstatus (nprofiles) ! Error return flag
-
- Logical, Intent (in) :: calcemiss (nchannels) ! Switch for emmissivity calculation
- Real (Kind=jprb), Intent (in) :: emissivity_in (nchannels) ! Surface emmissivity
-
- Type (profile_Type), Intent (inout) :: profiles (nprofiles) ! Atmospheric profiles
- Type (rttov_coef), Intent (in) :: coef_rttov ! RTTOV Coefficients
- Type (rttov_scatt_coef), Intent (in) :: coef_scatt ! RTTOV_SCATT Coefficients
- Type (profile_cloud_Type), Intent (in) :: cld_profiles (nprofiles) ! Cloud profiles with NWP levels
- Type (radiance_cloud_Type), Intent (inout) :: cld_radiance ! Radiances
-
- Integer (Kind=jpim), target :: sa__mclayer (nchannels)
-
- Real (kind=jprb), target :: r__clear_out (nbtout)
- Real (kind=jprb), target :: r__out (nbtout)
- Real (kind=jprb), target :: r__out_clear (nbtout)
- Real (kind=jprb), target :: r__total_out (nbtout)
- Real (kind=jprb), target :: r__clear (nchannels)
- Real (kind=jprb), target :: r__cloudy (nchannels)
- Real (kind=jprb), target :: r__total (nchannels)
- Real (kind=jprb), target :: r__bt (nchannels)
- Real (kind=jprb), target :: r__bt_clear (nchannels)
- Real (kind=jprb), target :: r__upclear (nchannels)
- Real (kind=jprb), target :: r__dnclear (nchannels)
- Real (kind=jprb), target :: r__reflclear (nchannels)
- Real (Kind=jprb), target :: r__overcast (nrt_levels,nchannels)
- Real (Kind=jprb), target :: r__downcld (nrt_levels,nchannels)
-
- Real (Kind=jprb), target :: t__tau_surf (nchannels)
- Real (Kind=jprb), target :: t__tau_layer (nrt_levels,nchannels)
- Real (Kind=jprb), target :: t__od_singlelayer (nrt_levels,nchannels)
-
- Real (Kind=jprb), target :: sa__ccmax (nprofiles)
- Real (Kind=jprb), target :: sa__ems_bnd (nchannels)
- Real (Kind=jprb), target :: sa__ref_bnd (nchannels)
- Real (Kind=jprb), target :: sa__ems_cld (nchannels)
- Real (Kind=jprb), target :: sa__ref_cld (nchannels)
-
- Real (Kind=jprb), target :: sa__tbd (nprofiles,nwp_levels+1)
-
- Real (Kind=jprb), target :: sa__delta (nchannels,nwp_levels)
- Real (Kind=jprb), target :: sa__tau (nchannels,nwp_levels)
- Real (Kind=jprb), target :: sa__ext (nchannels,nwp_levels)
- Real (Kind=jprb), target :: sa__ssa (nchannels,nwp_levels)
- Real (Kind=jprb), target :: sa__asm (nchannels,nwp_levels)
- Real (Kind=jprb), target :: sa__lambda (nchannels,nwp_levels)
- Real (Kind=jprb), target :: sa__h (nchannels,nwp_levels)
-
- Real (Kind=jprb), target :: sa__b0 (nprofiles,nwp_levels)
- Real (Kind=jprb), target :: sa__b1 (nprofiles,nwp_levels)
- Real (Kind=jprb), target :: sa__bn (nprofiles,nwp_levels)
- Real (Kind=jprb), target :: sa__dz (nprofiles,nwp_levels)
- Real (Kind=jprb), target :: sa__clw (nprofiles,nwp_levels)
- Real (Kind=jprb), target :: sa__ciw (nprofiles,nwp_levels)
- Real (Kind=jprb), target :: sa__rain (nprofiles,nwp_levels)
- Real (Kind=jprb), target :: sa__sp (nprofiles,nwp_levels)
-
-!* Local variables:
- Logical :: addcloud, switchrad
- Integer (Kind=jpim) :: iprof, ichan
- Real (Kind=jprb) :: emissivity (nchannels)
-
- Type (transmission_Type) :: transmission
- Type (geometry_Type) :: angles (nprofiles)
- Type (profile_scatt_aux) :: scatt_aux
- Type (radiance_Type) :: radiance
- Type (radiance_Type) :: cld_radiance_tmp
-
- Character (len=80) :: errMessage
- Character (len=15) :: NameOfRoutine = 'rttov_scatt '
-
- !- End of header --------------------------------------------------------
-
- errorstatus(:) = errorstatus_success
-
- radiance % clear_out => r__clear_out
- radiance % out => r__out
- radiance % out_clear => r__out_clear
- radiance % total_out => r__total_out
- radiance % clear => r__clear
- radiance % cloudy => r__cloudy
- radiance % total => r__total
- radiance % bt => r__bt
- radiance % bt_clear => r__bt_clear
- radiance % upclear => r__upclear
- radiance % dnclear => r__dnclear
- radiance % reflclear => r__reflclear
- radiance % overcast => r__overcast
- radiance % downcld => r__downcld
-
- transmission % tau_surf => t__tau_surf
- transmission % tau_layer => t__tau_layer
- transmission % od_singlelayer => t__od_singlelayer
-
- scatt_aux % ccmax => sa__ccmax
- scatt_aux % ems_bnd => sa__ems_bnd
- scatt_aux % ref_bnd => sa__ref_bnd
- scatt_aux % ems_cld => sa__ems_cld
- scatt_aux % ref_cld => sa__ref_cld
- scatt_aux % tbd => sa__tbd
- scatt_aux % mclayer => sa__mclayer
- scatt_aux % delta => sa__delta
- scatt_aux % tau => sa__tau
- scatt_aux % ext => sa__ext
- scatt_aux % ssa => sa__ssa
- scatt_aux % asm => sa__asm
- scatt_aux % lambda => sa__lambda
- scatt_aux % h => sa__h
- scatt_aux % b0 => sa__b0
- scatt_aux % b1 => sa__b1
- scatt_aux % bn => sa__bn
- scatt_aux % dz => sa__dz
- scatt_aux % clw => sa__clw
- scatt_aux % ciw => sa__ciw
- scatt_aux % rain => sa__rain
- scatt_aux % sp => sa__sp
-
-!* 1. Gas absorption
- switchrad = .true. ! input to RTTOV is BT
- addcloud = .false.
-
- ! No calculation of CLW absorption inside "classical" RTTOV
- If ( Any(.Not.profiles (:) % clw_Data) ) Then
- ! warning message
- profiles (:) % clw_Data = .False.
- End If
-
- emissivity (:) = emissivity_in (:)
-
- Call rttov_direct( &
- & errorstatus, &! out
- & nfrequencies, &! in
- & nchannels, &! in
- & nbtout, &! in
- & nprofiles, &! in
- & channels, &! in
- & polarisations, &! in
- & lprofiles, &! in
- & profiles, &! in
- & coef_rttov, &! in
- & addcloud, &! in
- & calcemiss, &! in
- & emissivity, &! inout
- & transmission, &! inout
- & radiance ) ! inout
-
- If ( any( errorstatus(:) == errorstatus_fatal ) ) Then
- Write( errMessage, '( "error in rttov_direct")' )
- Call Rttov_ErrorReport (errorstatus_fatal, errMessage, NameOfRoutine)
- Return
- End If
-
- scatt_aux % ems_cld (:) = emissivity_in (:)
- scatt_aux % ref_cld (:) = 1.0_JPRB - emissivity_in (:)
-
-!* 2. Initialisations for Eddington
- Call rttov_iniscatt( &
- & errorstatus, &! out
- & nwp_levels, &! in
- & nrt_levels, &! in
- & nfrequencies, &! in
- & nchannels, &! in
- & nprofiles, &! in
- & polarisations, &! in
- & channels, &! in
- & frequencies, &! in
- & lprofiles, &! in
- & lsprofiles, &! in
- & profiles, &! in
- & cld_profiles, &! in
- & coef_rttov, &! in
- & coef_scatt, &! in
- & transmission, &! in
- & calcemiss, &! in
- & angles, &! out
- & scatt_aux) ! inout
-
- If ( any( errorstatus(:) == errorstatus_fatal ) ) Then
- Write( errMessage, '( "error in rttov_iniscatt")' )
- Call Rttov_ErrorReport (errorstatus_fatal, errMessage, NameOfRoutine)
- Return
- End If
-
-!* 3. Eddington (in temperature space)
- Call rttov_eddington( &
- & nwp_levels, &! in
- & nchannels, &! in
- & nprofiles, &! in
- & lsprofiles, &! in
- & angles, &! in
- & profiles, &! in
- & cld_profiles, &! in
- & scatt_aux, &! in
- & cld_radiance) ! inout
-
-!* 4. Combine clear and cloudy parts
- Do ichan = 1, nchannels
- iprof = lsprofiles (ichan)
-
- cld_radiance % total (ichan) = radiance % total (ichan)
- cld_radiance % clear (ichan) = radiance % clear (ichan)
- cld_radiance % bt_clear (ichan) = radiance % bt (ichan)
- cld_radiance % bt (ichan) = cld_radiance % bt (ichan) * scatt_aux % ccmax (iprof) &
- & + radiance % bt (ichan) * (1.0_JPRB - scatt_aux % ccmax (iprof))
- End Do
-
-!* 5. Mix polarisations
-
- If (coef_rttov % id_sensor == sensor_id_mw) Then
-
- ! Point a temporary radiance type at cld_radiance
- cld_radiance_tmp % clear => cld_radiance % clear
- cld_radiance_tmp % clear_out => cld_radiance % clear_out
- cld_radiance_tmp % cloudy => cld_radiance % cloudy
- cld_radiance_tmp % total => cld_radiance % total
- cld_radiance_tmp % total_out => cld_radiance % total_out
- cld_radiance_tmp % out => cld_radiance % out
- cld_radiance_tmp % out_clear => cld_radiance % out_clear
- cld_radiance_tmp % bt => cld_radiance % bt
- cld_radiance_tmp % bt_clear => cld_radiance % bt_clear
- cld_radiance_tmp % upclear => cld_radiance % upclear
- cld_radiance_tmp % dnclear => cld_radiance % dnclear
- cld_radiance_tmp % reflclear => cld_radiance % reflclear
- cld_radiance_tmp % overcast => cld_radiance % overcast
- cld_radiance_tmp % downcld => cld_radiance % downcld
-
- Call rttov_calcpolarisation( &
- & nfrequencies, &! in
- & nchannels, &! in
- & nprofiles, &! in
- & angles, &! in
- & channels, &! in
- & polarisations, &! in
- & lprofiles, &! in
- & coef_rttov, &! in
- & cld_radiance_tmp )! inout
- Else
- radiance%out = radiance%bt
- radiance%out_clear = radiance%bt_clear
- cld_radiance%out = cld_radiance%bt
- cld_radiance%out_clear = cld_radiance%bt_clear
- End If
-
-End Subroutine rttov_scatt
diff --git a/src/LIB/RTTOV/src/rttov_scatt.interface b/src/LIB/RTTOV/src/rttov_scatt.interface
deleted file mode 100644
index 3b4b2fda72fd25d80f08610538511ac66c16596c..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_scatt.interface
+++ /dev/null
@@ -1,53 +0,0 @@
-INTERFACE
-Subroutine rttov_scatt(&
- & errorstatus,&
- & nwp_levels,&
- & nrt_levels,&
- & nfrequencies,&
- & nchannels,&
- & nbtout,&
- & nprofiles,&
- & polarisations,&
- & channels,&
- & frequencies,&
- & lprofiles,&
- & lsprofiles,&
- & profiles,&
- & cld_profiles,&
- & coef_rttov,&
- & coef_scatt,&
- & calcemiss,&
- & emissivity_in,&
- & cld_radiance )
- Use rttov_types, Only :&
- & rttov_coef ,&
- & rttov_scatt_coef ,&
- & geometry_Type ,&
- & profile_Type ,&
- & profile_cloud_Type ,&
- & profile_scatt_aux ,&
- & transmission_Type ,&
- & radiance_Type ,&
- & radiance_cloud_Type
- Use parkind1, Only : jpim ,jprb
- Integer (Kind=jpim), Intent (in) :: nwp_levels
- Integer (Kind=jpim), Intent (in) :: nrt_levels
- Integer (Kind=jpim), Intent (in) :: nprofiles
- Integer (Kind=jpim), Intent (in) :: nfrequencies
- Integer (Kind=jpim), Intent (in) :: nchannels
- Integer (Kind=jpim), Intent (in) :: nbtout
- Integer (Kind=jpim), Intent (in) :: channels (nfrequencies)
- Integer (Kind=jpim), Intent (in) :: frequencies (nchannels)
- Integer (Kind=jpim), Intent (in) :: polarisations (nchannels,3)
- Integer (Kind=jpim), Intent (in) :: lprofiles (nfrequencies)
- Integer (Kind=jpim), Intent (in) :: lsprofiles (nchannels)
- Integer (Kind=jpim), Intent (out) :: errorstatus (nprofiles)
- Logical, Intent (in) :: calcemiss (nchannels)
- Real (Kind=jprb), Intent (in) :: emissivity_in (nchannels)
- Type (profile_Type), Intent (inout) :: profiles (nprofiles)
- Type (rttov_coef), Intent (in) :: coef_rttov
- Type (rttov_scatt_coef), Intent (in) :: coef_scatt
- Type (profile_cloud_Type), Intent (in) :: cld_profiles (nprofiles)
- Type (radiance_cloud_Type), Intent (inout) :: cld_radiance
-End Subroutine rttov_scatt
-END INTERFACE
diff --git a/src/LIB/RTTOV/src/rttov_scatt_ad.F90 b/src/LIB/RTTOV/src/rttov_scatt_ad.F90
deleted file mode 100644
index 913e714a3fd4f35e90461d2b6c4699be014e67c3..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_scatt_ad.F90
+++ /dev/null
@@ -1,635 +0,0 @@
-!
-Subroutine rttov_scatt_ad( &
- & errorstatus, &! out
- & nwp_levels, &! in
- & nrt_levels, &! in
- & nfrequencies, &! in
- & nchannels, &! in
- & nbtout, &! in
- & nprofiles, &! in
- & polarisations, &! in
- & channels, &! in
- & frequencies, &! in
- & lprofiles, &! in
- & lsprofiles, &! in
- & profiles, &! inout
- & cld_profiles, &! in
- & coef_rttov, &! in
- & coef_scatt, &! in
- & calcemiss, &! in
- & emissivity_in, &! inout
- & profiles_ad, &! inout
- & cld_profiles_ad, &! inout
- & emissivity_in_ad, &! inout
- & cld_radiance, &! inout
- & cld_radiance_ad) ! inout
-
- ! Description:
- ! AD of subroutine
- ! to compute microwave multi-channel radiances and brightness
- ! temperatures for many profiles per call in a cloudy and/or rainy sky.
- !
- ! According to the argument switchrad the main input total or bt is used
- ! switchrad == true bt is the input, brightness temperature
- ! switchrad == false total is the input, radiance
-
- !
- ! Copyright:
- ! This software was developed within the context of
- ! the EUMETSAT Satellite Application Facility on
- ! Numerical Weather Prediction (NWP SAF), under the
- ! Cooperation Agreement dated 25 November 1998, between
- ! EUMETSAT and the Met Office, UK, by one or more partners
- ! within the NWP SAF. The partners in the NWP SAF are
- ! the Met Office, ECMWF, KNMI and MeteoFrance.
- !
- ! Copyright 2002, EUMETSAT, All Rights Reserved.
- !
- ! Method:
- ! - Bauer, P., 2002: Microwave radiative transfer modeling in clouds and precipitation.
- ! Part I: Model description.
- ! NWP SAF Report No. NWPSAF-EC-TR-005, 21 pp.
- ! - Moreau, E., P. Bauer and F. Chevallier, 2002: Microwave radiative transfer modeling in clouds and precipitation.
- ! Part II: Model evaluation.
- ! NWP SAF Report No. NWPSAF-EC-TR-006, 27 pp.
- ! - Chevallier, F., and P. Bauer, 2003:
- ! Model rain and clouds over oceans:comparison with SSM/I observations. Mon. Wea. Rev., 131, 1240-1255.
- ! - Smith, E. A., P. Bauer, F. S. Marzano, C. D. Kummerow, D. McKague, A. Mugnai, G. Panegrossi, 2002:
- ! Intercomparison of microwave radiative transfer models for precipitating clouds.
- ! IEEE Trans. Geosci. Remote Sens. 40, 541-549.
- !
- ! Current Code Owner: SAF NWP
- !
- ! History:
- ! Version Date Comment
- ! ------- ---- -------
- ! 1.0 09/2002 Initial version (F. Chevallier)
- ! 1.1 05/2003 RTTOV7.3 compatible (F. Chevallier)
- ! 1.2 03/2004 Added polarimetry (R. Saunders)
- ! 1.3 08/2004 Polarimetry fixes (U. O'Keeffe)
- ! 1.4 11/2004 Clean-up (P. Bauer)
- ! 1.5 07/2005 Polarimetry fixes (U. O'Keeffe)
- ! 1.6 11/2005 Add errorstatus to iniscatt arguments and use a temporary
- ! radiance type for the calcpolarisation call (J Cameron)
- !
- ! Code Description:
- ! Language: Fortran 90.
- ! Software Standards: "European Standards for Writing and
- ! Documenting Exchangeable Fortran 90 Code".
- !
- ! Declarations:
- ! Modules used:
- ! Imported Parameters:
-
- Use rttov_const, Only : &
- & sensor_id_mw ,&
- & errorstatus_success ,&
- & errorstatus_fatal
-
- Use rttov_types, Only : &
- & rttov_coef ,&
- & rttov_scatt_coef ,&
- & geometry_Type ,&
- & profile_Type ,&
- & profile_cloud_Type ,&
- & profile_scatt_aux ,&
- & transmission_Type ,&
- & radiance_Type ,&
- & radiance_cloud_Type
-
- Use parkind1, Only : jpim ,jprb
-
- Implicit None
-
-#include "rttov_direct.interface"
-#include "rttov_iniscatt.interface"
-#include "rttov_eddington.interface"
-#include "rttov_ad.interface"
-#include "rttov_iniscatt_ad.interface"
-#include "rttov_eddington_ad.interface"
-#include "rttov_errorreport.interface"
-#include "rttov_calcpolarisation_ad.interface"
-
-!* Subroutine arguments:
- Integer (Kind=jpim), Intent (in) :: nwp_levels ! Number of levels
- Integer (Kind=jpim), Intent (in) :: nrt_levels ! Number of levels
- Integer (Kind=jpim), Intent (in) :: nprofiles ! Number of profiles
- Integer (Kind=jpim), Intent (in) :: nfrequencies ! Number of frequencies
- Integer (Kind=jpim), Intent (in) :: nchannels ! Number of channels*profiles=radiances
- Integer (Kind=jpim), Intent (in) :: nbtout ! Number of output radiances
- Integer (Kind=jpim), Intent (in) :: channels (nfrequencies) ! Channel indices
- Integer (Kind=jpim), Intent (in) :: frequencies (nchannels) ! Frequency indices
- Integer (Kind=jpim), Intent (in) :: polarisations (nchannels,3) ! Polarisation indices
- Integer (Kind=jpim), Intent (in) :: lprofiles (nfrequencies) ! Profile indices
- Integer (Kind=jpim), Intent (in) :: lsprofiles (nchannels) ! Profile indices
- Integer (Kind=jpim), Intent (out) :: errorstatus (nprofiles) ! Error return flag
-
- Logical, Intent (in) :: calcemiss (nchannels) ! Switch for emmissivity calculation
- Real (Kind=jprb), Intent (in) :: emissivity_in (nchannels) ! Surface emmissivity
- Real (Kind=jprb), Intent (inout) :: emissivity_in_ad (nchannels) ! Surface emmissivity
-
- Type (profile_Type), Intent (inout) :: profiles (nprofiles) ! Atmospheric profiles
- Type (profile_Type), Intent (inout) :: profiles_ad (nprofiles)
- Type (rttov_coef), Intent (in) :: coef_rttov ! RTTOV Coefficients
- Type (rttov_scatt_coef), Intent (in) :: coef_scatt ! RTTOV_SCATT Coefficients
- Type (profile_cloud_Type), Intent (in) :: cld_profiles (nprofiles) ! Cloud profiles with NWP levels
- Type (profile_cloud_Type), Intent (inout) :: cld_profiles_ad (nprofiles)
- Type (radiance_cloud_Type), Intent (inout) :: cld_radiance ! Radiances
- Type (radiance_cloud_Type), Intent (inout) :: cld_radiance_ad
-
- Integer (Kind=jpim), target :: sa__mclayer (nchannels)
- Integer (Kind=jpim), target :: sa_ad__mclayer (nchannels)
-
- Real (kind=jprb), target :: r__clear_out (nbtout)
- Real (kind=jprb), target :: r__out (nbtout)
- Real (kind=jprb), target :: r__out_clear (nbtout)
- Real (kind=jprb), target :: r__total_out (nbtout)
- Real (kind=jprb), target :: r__clear (nchannels)
- Real (kind=jprb), target :: r__cloudy (nchannels)
- Real (kind=jprb), target :: r__total (nchannels)
- Real (kind=jprb), target :: r__bt (nchannels)
- Real (kind=jprb), target :: r__bt_clear (nchannels)
- Real (kind=jprb), target :: r__upclear (nchannels)
- Real (kind=jprb), target :: r__dnclear (nchannels)
- Real (kind=jprb), target :: r__reflclear (nchannels)
- Real (Kind=jprb), target :: r__overcast (nrt_levels,nchannels)
- Real (Kind=jprb), target :: r__downcld (nrt_levels,nchannels)
-
- Real (kind=jprb), target :: rz__clear_out (nbtout)
- Real (kind=jprb), target :: rz__out (nbtout)
- Real (kind=jprb), target :: rz__out_clear (nbtout)
- Real (kind=jprb), target :: rz__total_out (nbtout)
- Real (kind=jprb), target :: rz__clear (nchannels)
- Real (kind=jprb), target :: rz__cloudy (nchannels)
- Real (kind=jprb), target :: rz__total (nchannels)
- Real (kind=jprb), target :: rz__bt (nchannels)
- Real (kind=jprb), target :: rz__bt_clear (nchannels)
- Real (kind=jprb), target :: rz__upclear (nchannels)
- Real (kind=jprb), target :: rz__dnclear (nchannels)
- Real (kind=jprb), target :: rz__reflclear (nchannels)
- Real (Kind=jprb), target :: rz__overcast (nrt_levels,nchannels)
- Real (Kind=jprb), target :: rz__downcld (nrt_levels,nchannels)
-
- Real (kind=jprb), target :: r_ad__clear_out (nbtout)
- Real (kind=jprb), target :: r_ad__out (nbtout)
- Real (kind=jprb), target :: r_ad__out_clear (nbtout)
- Real (kind=jprb), target :: r_ad__total_out (nbtout)
- Real (kind=jprb), target :: r_ad__clear (nchannels)
- Real (kind=jprb), target :: r_ad__cloudy (nchannels)
- Real (kind=jprb), target :: r_ad__total (nchannels)
- Real (kind=jprb), target :: r_ad__bt (nchannels)
- Real (kind=jprb), target :: r_ad__bt_clear (nchannels)
- Real (kind=jprb), target :: r_ad__upclear (nchannels)
- Real (kind=jprb), target :: r_ad__dnclear (nchannels)
- Real (kind=jprb), target :: r_ad__reflclear (nchannels)
- Real (Kind=jprb), target :: r_ad__overcast (nrt_levels,nchannels)
- Real (Kind=jprb), target :: r_ad__downcld (nrt_levels,nchannels)
-
- Real (Kind=jprb), target :: t__tau_surf (nchannels)
- Real (Kind=jprb), target :: t__tau_layer (nrt_levels,nchannels)
- Real (Kind=jprb), target :: t__od_singlelayer (nrt_levels,nchannels)
- Real (Kind=jprb), target :: t_ad__tau_surf (nchannels)
- Real (Kind=jprb), target :: t_ad__tau_layer (nrt_levels,nchannels)
- Real (Kind=jprb), target :: t_ad__od_singlelayer (nrt_levels,nchannels)
-
- Real (Kind=jprb), target :: sa__ccmax (nprofiles)
- Real (Kind=jprb), target :: sa__ems_bnd (nchannels)
- Real (Kind=jprb), target :: sa__ref_bnd (nchannels)
- Real (Kind=jprb), target :: sa__ems_cld (nchannels)
- Real (Kind=jprb), target :: sa__ref_cld (nchannels)
-
- Real (Kind=jprb), target :: sa__tbd (nprofiles,nwp_levels+1)
-
- Real (Kind=jprb), target :: sa__delta (nchannels,nwp_levels)
- Real (Kind=jprb), target :: sa__tau (nchannels,nwp_levels)
- Real (Kind=jprb), target :: sa__ext (nchannels,nwp_levels)
- Real (Kind=jprb), target :: sa__ssa (nchannels,nwp_levels)
- Real (Kind=jprb), target :: sa__asm (nchannels,nwp_levels)
- Real (Kind=jprb), target :: sa__lambda (nchannels,nwp_levels)
- Real (Kind=jprb), target :: sa__h (nchannels,nwp_levels)
-
- Real (Kind=jprb), target :: sa__b0 (nprofiles,nwp_levels)
- Real (Kind=jprb), target :: sa__b1 (nprofiles,nwp_levels)
- Real (Kind=jprb), target :: sa__bn (nprofiles,nwp_levels)
- Real (Kind=jprb), target :: sa__dz (nprofiles,nwp_levels)
- Real (Kind=jprb), target :: sa__clw (nprofiles,nwp_levels)
- Real (Kind=jprb), target :: sa__ciw (nprofiles,nwp_levels)
- Real (Kind=jprb), target :: sa__rain (nprofiles,nwp_levels)
- Real (Kind=jprb), target :: sa__sp (nprofiles,nwp_levels)
-
- Real (Kind=jprb), target :: sa_ad__ccmax (nprofiles)
- Real (Kind=jprb), target :: sa_ad__ems_bnd (nchannels)
- Real (Kind=jprb), target :: sa_ad__ref_bnd (nchannels)
- Real (Kind=jprb), target :: sa_ad__ems_cld (nchannels)
- Real (Kind=jprb), target :: sa_ad__ref_cld (nchannels)
-
- Real (Kind=jprb), target :: sa_ad__tbd (nprofiles,nwp_levels+1)
-
- Real (Kind=jprb), target :: sa_ad__delta (nchannels,nwp_levels)
- Real (Kind=jprb), target :: sa_ad__tau (nchannels,nwp_levels)
- Real (Kind=jprb), target :: sa_ad__ext (nchannels,nwp_levels)
- Real (Kind=jprb), target :: sa_ad__ssa (nchannels,nwp_levels)
- Real (Kind=jprb), target :: sa_ad__asm (nchannels,nwp_levels)
- Real (Kind=jprb), target :: sa_ad__lambda (nchannels,nwp_levels)
- Real (Kind=jprb), target :: sa_ad__h (nchannels,nwp_levels)
-
- Real (Kind=jprb), target :: sa_ad__b0 (nprofiles,nwp_levels)
- Real (Kind=jprb), target :: sa_ad__b1 (nprofiles,nwp_levels)
- Real (Kind=jprb), target :: sa_ad__bn (nprofiles,nwp_levels)
- Real (Kind=jprb), target :: sa_ad__dz (nprofiles,nwp_levels)
- Real (Kind=jprb), target :: sa_ad__clw (nprofiles,nwp_levels)
- Real (Kind=jprb), target :: sa_ad__ciw (nprofiles,nwp_levels)
- Real (Kind=jprb), target :: sa_ad__rain (nprofiles,nwp_levels)
- Real (Kind=jprb), target :: sa_ad__sp (nprofiles,nwp_levels)
-
-!* Local variables:
- Logical :: addcloud, switchrad
- Integer (Kind=jpim) :: iprof, ichan
- Real (Kind=jprb) :: emissivity (nchannels)
- Real (Kind=jprb) :: emissivity_ad (nchannels)
-
- Type (transmission_Type) :: transmission, transmission_ad
- Type (geometry_Type) :: angles (nprofiles)
- Type (profile_scatt_aux) :: scatt_aux, scatt_aux_ad
- Type (radiance_Type) :: radiance, radiance_ad
- Type (radiance_cloud_Type) :: zcld_radiance
- Type (radiance_Type) :: cld_radiance_tmp
-
- Character (len=80) :: errMessage
- Character (len=15) :: NameOfRoutine = 'rttov_scatt_ad '
-
- !- End of header --------------------------------------------------------
-
- errorstatus(:) = errorstatus_success
-
- radiance % clear_out => r__clear_out
- radiance % out => r__out
- radiance % out_clear => r__out_clear
- radiance % total_out => r__total_out
- radiance % clear => r__clear
- radiance % cloudy => r__cloudy
- radiance % total => r__total
- radiance % bt => r__bt
- radiance % bt_clear => r__bt_clear
- radiance % upclear => r__upclear
- radiance % dnclear => r__dnclear
- radiance % reflclear => r__reflclear
- radiance % overcast => r__overcast
- radiance % downcld => r__downcld
-
- radiance_ad % clear_out => r_ad__clear_out
- radiance_ad % out => r_ad__out
- radiance_ad % out_clear => r_ad__out_clear
- radiance_ad % total_out => r_ad__total_out
- radiance_ad % clear => r_ad__clear
- radiance_ad % cloudy => r_ad__cloudy
- radiance_ad % total => r_ad__total
- radiance_ad % bt => r_ad__bt
- radiance_ad % bt_clear => r_ad__bt_clear
- radiance_ad % upclear => r_ad__upclear
- radiance_ad % dnclear => r_ad__dnclear
- radiance_ad % reflclear => r_ad__reflclear
- radiance_ad % overcast => r_ad__overcast
- radiance_ad % downcld => r_ad__downcld
-
- zcld_radiance % clear_out => rz__clear_out
- zcld_radiance % out => rz__out
- zcld_radiance % out_clear => rz__out_clear
- zcld_radiance % total_out => rz__total_out
- zcld_radiance % clear => rz__clear
- zcld_radiance % cloudy => rz__cloudy
- zcld_radiance % total => rz__total
- zcld_radiance % bt => rz__bt
- zcld_radiance % bt_clear => rz__bt_clear
- zcld_radiance % upclear => rz__upclear
- zcld_radiance % dnclear => rz__dnclear
- zcld_radiance % reflclear => rz__reflclear
- zcld_radiance % overcast => rz__overcast
- zcld_radiance % downcld => rz__downcld
-
- transmission % tau_surf => t__tau_surf
- transmission % tau_layer => t__tau_layer
- transmission % od_singlelayer => t__od_singlelayer
-
- transmission_ad % tau_surf => t_ad__tau_surf
- transmission_ad % tau_layer => t_ad__tau_layer
- transmission_ad % od_singlelayer => t_ad__od_singlelayer
-
- scatt_aux % ccmax => sa__ccmax
- scatt_aux % ems_bnd => sa__ems_bnd
- scatt_aux % ref_bnd => sa__ref_bnd
- scatt_aux % ems_cld => sa__ems_cld
- scatt_aux % ref_cld => sa__ref_cld
- scatt_aux % tbd => sa__tbd
- scatt_aux % mclayer => sa__mclayer
- scatt_aux % delta => sa__delta
- scatt_aux % tau => sa__tau
- scatt_aux % ext => sa__ext
- scatt_aux % ssa => sa__ssa
- scatt_aux % asm => sa__asm
- scatt_aux % lambda => sa__lambda
- scatt_aux % h => sa__h
- scatt_aux % b0 => sa__b0
- scatt_aux % b1 => sa__b1
- scatt_aux % bn => sa__bn
- scatt_aux % dz => sa__dz
- scatt_aux % clw => sa__clw
- scatt_aux % ciw => sa__ciw
- scatt_aux % rain => sa__rain
- scatt_aux % sp => sa__sp
-
- scatt_aux_ad % ccmax => sa_ad__ccmax
- scatt_aux_ad % ems_bnd => sa_ad__ems_bnd
- scatt_aux_ad % ref_bnd => sa_ad__ref_bnd
- scatt_aux_ad % ems_cld => sa_ad__ems_cld
- scatt_aux_ad % ref_cld => sa_ad__ref_cld
- scatt_aux_ad % tbd => sa_ad__tbd
- scatt_aux_ad % mclayer => sa_ad__mclayer
- scatt_aux_ad % delta => sa_ad__delta
- scatt_aux_ad % tau => sa_ad__tau
- scatt_aux_ad % ext => sa_ad__ext
- scatt_aux_ad % ssa => sa_ad__ssa
- scatt_aux_ad % asm => sa_ad__asm
- scatt_aux_ad % lambda => sa_ad__lambda
- scatt_aux_ad % h => sa_ad__h
- scatt_aux_ad % b0 => sa_ad__b0
- scatt_aux_ad % b1 => sa_ad__b1
- scatt_aux_ad % bn => sa_ad__bn
- scatt_aux_ad % dz => sa_ad__dz
- scatt_aux_ad % clw => sa_ad__clw
- scatt_aux_ad % ciw => sa_ad__ciw
- scatt_aux_ad % rain => sa_ad__rain
- scatt_aux_ad % sp => sa_ad__sp
-
-!* 1. Gas absorption
- switchrad = .true. ! input to RTTOV is BT
- addcloud = .false.
-
- ! No calculation of CLW absorption inside "classical" RTTOV
- If ( Any(.Not. profiles (:) % clw_Data) ) Then
- ! warning message
- profiles (:) % clw_Data = .False.
- End If
-
- emissivity (:) = emissivity_in (:)
-
- Call rttov_direct( &
- & errorstatus, &! out
- & nfrequencies, &! in
- & nchannels, &! in
- & nbtout, &! in
- & nprofiles, &! in
- & channels, &! in
- & polarisations, &! in
- & lprofiles, &! in
- & profiles, &! in
- & coef_rttov, &! in
- & addcloud, &! in
- & calcemiss, &! in
- & emissivity, &! inout
- & transmission, &! inout
- & radiance ) ! inout
-
- If ( any( errorstatus(:) == errorstatus_fatal ) ) Then
- Write( errMessage, '( "error in rttov_direct")' )
- Call Rttov_ErrorReport (errorstatus_fatal, errMessage, NameOfRoutine)
- Return
- End If
-
- scatt_aux % ems_cld (:) = emissivity_in (:)
- scatt_aux % ref_cld (:) = 1.0_JPRB - emissivity_in (:)
-
-!* 2. Initialisations for Eddington
- Call rttov_iniscatt( &
- & errorstatus, &! out
- & nwp_levels, &! in
- & nrt_levels, &! in
- & nfrequencies, &! in
- & nchannels, &! in
- & nprofiles, &! in
- & polarisations, &! in
- & channels, &! in
- & frequencies, &! in
- & lprofiles, &! in
- & lsprofiles, &! in
- & profiles, &! in
- & cld_profiles, &! in
- & coef_rttov, &! in
- & coef_scatt, &! in
- & transmission, &! in
- & calcemiss, &! in
- & angles, &! out
- & scatt_aux ) ! inout
-
- If ( any( errorstatus(:) == errorstatus_fatal ) ) Then
- Write( errMessage, '( "error in rttov_iniscatt")' )
- Call Rttov_ErrorReport (errorstatus_fatal, errMessage, NameOfRoutine)
- Return
- End If
-
-!* 3. Eddington (in temperature space)
- Call rttov_eddington( &
- & nwp_levels, &! in
- & nchannels, &! in
- & nprofiles, &! in
- & lsprofiles, &! in
- & angles, &! in
- & profiles, &! in
- & cld_profiles, &! in
- & scatt_aux, &! in
- & cld_radiance) ! inout
-
- zcld_radiance % bt (:) = cld_radiance % bt (:)
-
-!* 4. Combine clear and cloudy parts
- Do ichan = 1, nchannels
- iprof = lsprofiles (ichan)
-
- cld_radiance % total (ichan) = radiance % total (ichan)
- cld_radiance % clear (ichan) = radiance % clear (ichan)
- cld_radiance % bt_clear (ichan) = radiance % bt (ichan)
- cld_radiance % bt (ichan) = cld_radiance % bt (ichan) * scatt_aux % ccmax (iprof) &
- & + radiance % bt (ichan) * (1.0_JPRB - scatt_aux % ccmax (iprof))
- End Do
-
-!* ADJOINT PART
- scatt_aux_ad % ccmax (:) = 0.0_JPRB
- scatt_aux_ad % ems_bnd (:) = 0.0_JPRB
- scatt_aux_ad % ref_bnd (:) = 0.0_JPRB
- scatt_aux_ad % ems_cld (:) = 0.0_JPRB
- scatt_aux_ad % ref_cld (:) = 0.0_JPRB
- scatt_aux_ad % tbd (:,:) = 0.0_JPRB
- scatt_aux_ad % delta (:,:) = 0.0_JPRB
- scatt_aux_ad % tau (:,:) = 0.0_JPRB
- scatt_aux_ad % ext (:,:) = 0.0_JPRB
- scatt_aux_ad % ssa (:,:) = 0.0_JPRB
- scatt_aux_ad % asm (:,:) = 0.0_JPRB
- scatt_aux_ad % lambda (:,:) = 0.0_JPRB
- scatt_aux_ad % h (:,:) = 0.0_JPRB
- scatt_aux_ad % b0 (:,:) = 0.0_JPRB
- scatt_aux_ad % b1 (:,:) = 0.0_JPRB
- scatt_aux_ad % bn (:,:) = 0.0_JPRB
- scatt_aux_ad % dz (:,:) = 0.0_JPRB
- scatt_aux_ad % clw (:,:) = 0.0_JPRB
- scatt_aux_ad % ciw (:,:) = 0.0_JPRB
- scatt_aux_ad % rain (:,:) = 0.0_JPRB
- scatt_aux_ad % sp (:,:) = 0.0_JPRB
-
- transmission_ad % tau_surf (:) = 0.0_JPRB
- transmission_ad % tau_layer (:,:) = 0.0_JPRB
- transmission_ad % od_singlelayer (:,:) = 0.0_JPRB
-
- radiance_ad % bt (:) = 0.0_JPRB
-
-
- !
- !* 5. Convert total polarisations length arrays to number of output channel length arrays
- !
- If (coef_rttov % id_sensor == sensor_id_mw) Then
-
- ! Point a temporary radiance type at cld_radiance_ad
- cld_radiance_tmp % clear => cld_radiance_ad % clear
- cld_radiance_tmp % clear_out => cld_radiance_ad % clear_out
- cld_radiance_tmp % cloudy => cld_radiance_ad % cloudy
- cld_radiance_tmp % total => cld_radiance_ad % total
- cld_radiance_tmp % total_out => cld_radiance_ad % total_out
- cld_radiance_tmp % out => cld_radiance_ad % out
- cld_radiance_tmp % out_clear => cld_radiance_ad % out_clear
- cld_radiance_tmp % bt => cld_radiance_ad % bt
- cld_radiance_tmp % bt_clear => cld_radiance_ad % bt_clear
- cld_radiance_tmp % upclear => cld_radiance_ad % upclear
- cld_radiance_tmp % dnclear => cld_radiance_ad % dnclear
- cld_radiance_tmp % reflclear => cld_radiance_ad % reflclear
- cld_radiance_tmp % overcast => cld_radiance_ad % overcast
- cld_radiance_tmp % downcld => cld_radiance_ad % downcld
-
- Call rttov_calcpolarisation_ad( &
- & nfrequencies, & ! in
- & nchannels, & ! in
- & nbtout, & ! in
- & profiles, & ! in
- & nprofiles, & ! in
- & angles, & ! in
- & channels, & ! in
- & polarisations,& ! in
- & lprofiles, & ! in
- & coef_rttov, & ! in
- & cld_radiance_tmp ) ! inout
- Else
- radiance_ad%bt = radiance_ad%out
- radiance_ad%bt_clear = radiance_ad%out_clear
- cld_radiance_ad%bt = cld_radiance_ad%out
- cld_radiance_ad%bt_clear = cld_radiance_ad%out_clear
- End If
-
-!* 4. Combine clear and cloudy parts
- Do ichan = 1, nchannels
- iprof = lsprofiles (ichan)
-
- scatt_aux_ad % ccmax (iprof) = scatt_aux_ad % ccmax (iprof) &
- & + (zcld_radiance % bt (ichan) - radiance % bt (ichan)) * cld_radiance_ad % bt (ichan)
- radiance_ad % bt (ichan) = radiance_ad % bt (ichan) &
- & + (1.0_JPRB - scatt_aux % ccmax (iprof)) * cld_radiance_ad % bt (ichan)
- cld_radiance_ad % bt (ichan) = scatt_aux % ccmax (iprof) * cld_radiance_ad % bt (ichan)
- End Do
-
-!* 3. Eddington (in temperature space)
- Call rttov_eddington_ad( &
- & nwp_levels, &! in
- & nchannels, &! in
- & nprofiles, &! in
- & lsprofiles, &! in
- & angles, &! in
- & profiles, &! in
- & profiles_ad, &! inout
- & cld_profiles, &! in
- & scatt_aux, &! in
- & scatt_aux_ad, &! inout
- & cld_radiance, &! inout
- & cld_radiance_ad) ! inout
-
-!* 2. Initialisations for Eddington
-
-
- Call rttov_iniscatt_ad( &
- & errorstatus, &! out
- & nwp_levels, &! in
- & nrt_levels, &! in
- & nfrequencies, &! in
- & nchannels, &! in
- & nprofiles, &! in
- & polarisations, &! in
- & channels, &! in
- & frequencies, &! in
- & lprofiles, &! in
- & lsprofiles, &! in
- & profiles, &! in
- & profiles_ad, &! inout
- & cld_profiles, &! in
- & cld_profiles_ad, &! inout
- & coef_rttov, &! in
- & coef_scatt, &! in
- & transmission, &! in
- & transmission_ad, &! inout
- & calcemiss, &! in
- & angles, &! out
- & scatt_aux, &! inout
- & scatt_aux_ad) ! inout
-
- If ( any( errorstatus(:) == errorstatus_fatal ) ) Then
- Write( errMessage, '( "error in rttov_iniscatt_ad")' )
- Call Rttov_ErrorReport (errorstatus_fatal, errMessage, NameOfRoutine)
- Return
- End If
-
- radiance_ad % clear (:) = 0.0_JPRB
- radiance_ad % clear_out (:) = 0.0_JPRB
- radiance_ad % cloudy (:) = 0.0_JPRB
- radiance_ad % total (:) = 0.0_JPRB
- radiance_ad % total_out (:) = 0.0_JPRB
- radiance_ad % out (:) = 0.0_JPRB
- radiance_ad % out_clear (:) = 0.0_JPRB
- radiance_ad % bt_clear (:) = 0.0_JPRB
- radiance_ad % upclear (:) = 0.0_JPRB
- radiance_ad % dnclear (:) = 0.0_JPRB
- radiance_ad % reflclear (:) = 0.0_JPRB
- radiance_ad % overcast (:,:) = 0.0_JPRB
- radiance_ad % downcld (:,:) = 0.0_JPRB
-
-!* 1. Gas absorption
- emissivity_ad (:) = 0.0_JPRB
-
- Call rttov_ad( &
- & errorstatus, &! out
- & nfrequencies, &! in
- & nchannels, &! in
- & nbtout, &! in
- & nprofiles, &! in
- & channels, &! in
- & polarisations, &! in
- & lprofiles, &! in
- & profiles, &! in
- & coef_rttov, &! in
- & addcloud, &! in
- & switchrad, &! in
- & calcemiss, &! in
- & emissivity, &! inout
- & profiles_ad, &! inout
- & emissivity_ad, &! inout
- & transmission, &! inout
- & transmission_ad, &! inout
- & radiance, &! inout
- & radiance_ad ) ! inout
-
- If ( any( errorstatus(:) == errorstatus_fatal ) ) Then
- Write( errMessage, '( "error in rttov_ad")' )
- Call Rttov_ErrorReport (errorstatus_fatal, errMessage, NameOfRoutine)
- Return
- End If
-
- emissivity_in_ad (:) = emissivity_in_ad (:) + emissivity_ad (:)
- emissivity_ad (:) = 0.0_JPRB
-
- cld_radiance % bt (:) = zcld_radiance % bt (:)
-
-End Subroutine rttov_scatt_ad
diff --git a/src/LIB/RTTOV/src/rttov_scatt_ad.interface b/src/LIB/RTTOV/src/rttov_scatt_ad.interface
deleted file mode 100644
index 7301ecd31b07d097394d3c2c95cd217fd7419aa6..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_scatt_ad.interface
+++ /dev/null
@@ -1,61 +0,0 @@
-INTERFACE
-Subroutine rttov_scatt_ad(&
- & errorstatus,&
- & nwp_levels,&
- & nrt_levels,&
- & nfrequencies,&
- & nchannels,&
- & nbtout,&
- & nprofiles,&
- & polarisations,&
- & channels,&
- & frequencies,&
- & lprofiles,&
- & lsprofiles,&
- & profiles,&
- & cld_profiles,&
- & coef_rttov,&
- & coef_scatt,&
- & calcemiss,&
- & emissivity_in,&
- & profiles_ad,&
- & cld_profiles_ad,&
- & emissivity_in_ad,&
- & cld_radiance,&
- & cld_radiance_ad)
- Use rttov_types, Only :&
- & rttov_coef ,&
- & rttov_scatt_coef ,&
- & geometry_Type ,&
- & profile_Type ,&
- & profile_cloud_Type ,&
- & profile_scatt_aux ,&
- & transmission_Type ,&
- & radiance_Type ,&
- & radiance_cloud_Type
- Use parkind1, Only : jpim ,jprb
- Integer (Kind=jpim), Intent (in) :: nwp_levels
- Integer (Kind=jpim), Intent (in) :: nrt_levels
- Integer (Kind=jpim), Intent (in) :: nprofiles
- Integer (Kind=jpim), Intent (in) :: nfrequencies
- Integer (Kind=jpim), Intent (in) :: nchannels
- Integer (Kind=jpim), Intent (in) :: nbtout
- Integer (Kind=jpim), Intent (in) :: channels (nfrequencies)
- Integer (Kind=jpim), Intent (in) :: frequencies (nchannels)
- Integer (Kind=jpim), Intent (in) :: polarisations (nchannels,3)
- Integer (Kind=jpim), Intent (in) :: lprofiles (nfrequencies)
- Integer (Kind=jpim), Intent (in) :: lsprofiles (nchannels)
- Integer (Kind=jpim), Intent (out) :: errorstatus (nprofiles)
- Logical, Intent (in) :: calcemiss (nchannels)
- Real (Kind=jprb), Intent (in) :: emissivity_in (nchannels)
- Real (Kind=jprb), Intent (inout) :: emissivity_in_ad (nchannels)
- Type (profile_Type), Intent (inout) :: profiles (nprofiles)
- Type (profile_Type), Intent (inout) :: profiles_ad (nprofiles)
- Type (rttov_coef), Intent (in) :: coef_rttov
- Type (rttov_scatt_coef), Intent (in) :: coef_scatt
- Type (profile_cloud_Type), Intent (in) :: cld_profiles (nprofiles)
- Type (profile_cloud_Type), Intent (inout) :: cld_profiles_ad (nprofiles)
- Type (radiance_cloud_Type), Intent (inout) :: cld_radiance
- Type (radiance_cloud_Type), Intent (inout) :: cld_radiance_ad
-End Subroutine rttov_scatt_ad
-END INTERFACE
diff --git a/src/LIB/RTTOV/src/rttov_scatt_k.F90 b/src/LIB/RTTOV/src/rttov_scatt_k.F90
deleted file mode 100644
index 2ebe7c678f79a2b646c7f6fcb17b4794cf3db0c8..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_scatt_k.F90
+++ /dev/null
@@ -1,852 +0,0 @@
-!
-Subroutine rttov_scatt_k( &
- & errorstatus, &! out
- & nwp_levels, &! in
- & nrt_levels, &! in
- & nfrequencies, &! in
- & nchannels, &! in
- & nbtout, &! in
- & nprofiles, &! in
- & polarisations, &! in
- & channels, &! in
- & frequencies, &! in
- & lprofiles, &! in
- & lsprofiles, &! in
- & profiles, &! inout
- & cld_profiles, &! in
- & coef_rttov, &! in
- & coef_scatt, &! in
- & calcemiss, &! in
- & emissivity_in, &! inout
- & profiles_k, &! inout
- & cld_profiles_k, &! inout
- & emissivity_in_k, &! inout
- & cld_radiance) ! inout
-
- ! Description:
- ! AD of subroutine
- ! to compute microwave multi-channel radiances and brightness
- ! temperatures for many profiles per call in a cloudy and/or rainy sky.
- !
- !
- ! Copyright:
- ! This software was developed within the context of
- ! the EUMETSAT Satellite Application Facility on
- ! Numerical Weather Prediction (NWP SAF), under the
- ! Cooperation Agreement dated 25 November 1998, between
- ! EUMETSAT and the Met Office, UK, by one or more partners
- ! within the NWP SAF. The partners in the NWP SAF are
- ! the Met Office, ECMWF, KNMI and MeteoFrance.
- !
- ! Copyright 2002, EUMETSAT, All Rights Reserved.
- !
- ! Method:
- ! - Bauer, P., 2002: Microwave radiative transfer modeling in clouds and precipitation.
- ! Part I: Model description.
- ! NWP SAF Report No. NWPSAF-EC-TR-005, 21 pp.
- ! - Moreau, E., P. Bauer and F. Chevallier, 2002: Microwave radiative transfer modeling in clouds and precipitation.
- ! Part II: Model evaluation.
- ! NWP SAF Report No. NWPSAF-EC-TR-006, 27 pp.
- ! - Chevallier, F., and P. Bauer, 2003:
- ! Model rain and clouds over oceans:comparison with SSM/I observations. Mon. Wea. Rev., 131, 1240-1255.
- ! - Smith, E. A., P. Bauer, F. S. Marzano, C. D. Kummerow, D. McKague, A. Mugnai, G. Panegrossi, 2002:
- ! Intercomparison of microwave radiative transfer models for precipitating clouds.
- ! IEEE Trans. Geosci. Remote Sens. 40, 541-549.
- !
- ! Current Code Owner: SAF NWP
- !
- ! History:
- ! Version Date Comment
- ! ------- ---- -------
- ! 1.0 09/2002 Initial version (F. Chevallier)
- ! 1.1 05/2003 RTTOV7.3 compatible (F. Chevallier)
- ! 1.2 03/2004 Added polarimetry (R. Saunders)
- ! 1.3 08/2004 Polarimetry fixes (U. O'Keefe)
- ! 1.4 11/2004 Clean-up (P. Bauer)
- ! 1.5 02/2005 K code (A. Collard)
- ! 1.6 07/2005 Polarimetry fixes (U. O'Keeffe)
- ! 1.7 11/2005 Add errorstatus to iniscatt arguments and use a temporary
- ! radiance type for the calcpolarisation call (J Cameron)
- !
- ! Code Description:
- ! Language: Fortran 90.
- ! Software Standards: "European Standards for Writing and
- ! Documenting Exchangeable Fortran 90 Code".
- !
- ! Declarations:
- ! Modules used:
- ! Imported Parameters:
-
- Use rttov_const, Only : &
- & errorstatus_success ,&
- & errorstatus_fatal ,&
- & sensor_id_mw
-
- Use rttov_types, Only : &
- & rttov_coef ,&
- & rttov_scatt_coef ,&
- & geometry_Type ,&
- & profile_Type ,&
- & profile_cloud_Type ,&
- & profile_scatt_aux ,&
- & transmission_Type ,&
- & radiance_Type ,&
- & radiance_cloud_Type
-
- Use parkind1, Only : jpim ,jprb
-
- Implicit None
-
-#include "rttov_direct.interface"
-#include "rttov_iniscatt.interface"
-#include "rttov_eddington.interface"
-#include "rttov_k.interface"
-#include "rttov_iniscatt_k.interface"
-#include "rttov_eddington_k.interface"
-#include "rttov_errorreport.interface"
-#include "rttov_calcpolarisation_ad.interface"
-#include "rttov_profout_k.interface"
-#include "rttov_cld_profout_k.interface"
-
-!* Subroutine arguments:
- Integer (Kind=jpim), Intent (in) :: nwp_levels ! Number of levels
- Integer (Kind=jpim), Intent (in) :: nrt_levels ! Number of levels
- Integer (Kind=jpim), Intent (in) :: nprofiles ! Number of profiles
- Integer (Kind=jpim), Intent (in) :: nfrequencies ! Number of frequencies
- Integer (Kind=jpim), Intent (in) :: nchannels ! Number of channels*profiles=radiances
- Integer (Kind=jpim), Intent (in) :: nbtout ! Number of output radiances
- Integer (Kind=jpim), Intent (in) :: channels (nfrequencies) ! Channel indices
- Integer (Kind=jpim), Intent (in) :: frequencies (nchannels) ! Frequency indices
- Integer (Kind=jpim), Intent (in) :: polarisations (nchannels,3) ! Polarisation indices
- Integer (Kind=jpim), Intent (in) :: lprofiles (nfrequencies) ! Profile indices
- Integer (Kind=jpim), Intent (in) :: lsprofiles (nchannels) ! Profile indices
- Integer (Kind=jpim), Intent (out) :: errorstatus (nprofiles) ! Error return flag
- Logical, Intent (in) :: calcemiss (nchannels) ! Surface emmissivity
- Real (Kind=jprb), Intent (in) :: emissivity_in (nchannels) ! Surface emmissivity
- Real (Kind=jprb), Intent (inout) :: emissivity_in_k (nchannels)
- Type (profile_Type), Intent (inout) :: profiles (nprofiles) ! Atmospheric profiles
- Type (profile_Type), Intent (inout) :: profiles_k (nbtout)
- Type (rttov_coef), Intent (in) :: coef_rttov ! RTTOV Coefficients
- Type (rttov_scatt_coef), Intent (in) :: coef_scatt ! RTTOV_SCATT Coefficients
- Type (profile_cloud_Type), Intent (in) :: cld_profiles (nprofiles) ! Cloud profiles with NWP levels
- Type (profile_cloud_Type), Intent (inout) :: cld_profiles_k (nbtout)
- Type (radiance_cloud_Type), Intent (inout) :: cld_radiance ! Radiances
-
- Integer (Kind=jpim), target :: sa__mclayer (nchannels)
- Integer (Kind=jpim), target :: sa_k__mclayer (nchannels)
-
- Real (kind=jprb), target :: cld_r_k__clear_out (nbtout)
- Real (kind=jprb), target :: cld_r_k__out (nbtout)
- Real (kind=jprb), target :: cld_r_k__out_clear (nbtout)
- Real (kind=jprb), target :: cld_r_k__total_out (nbtout)
- Real (kind=jprb), target :: cld_r_k__clear (nchannels)
- Real (kind=jprb), target :: cld_r_k__cloudy (nchannels)
- Real (kind=jprb), target :: cld_r_k__total (nchannels)
- Real (kind=jprb), target :: cld_r_k__bt (nchannels)
- Real (kind=jprb), target :: cld_r_k__bt_clear (nchannels)
- Real (kind=jprb), target :: cld_r_k__upclear (nchannels)
- Real (kind=jprb), target :: cld_r_k__dnclear (nchannels)
- Real (kind=jprb), target :: cld_r_k__reflclear (nchannels)
- Real (Kind=jprb), target :: cld_r_k__overcast (nrt_levels,nchannels)
- Real (Kind=jprb), target :: cld_r_k__downcld (nrt_levels,nchannels)
-
- Real (kind=jprb), target :: r__clear_out (nbtout)
- Real (kind=jprb), target :: r__out (nbtout)
- Real (kind=jprb), target :: r__out_clear (nbtout)
- Real (kind=jprb), target :: r__total_out (nbtout)
- Real (kind=jprb), target :: r__clear (nchannels)
- Real (kind=jprb), target :: r__cloudy (nchannels)
- Real (kind=jprb), target :: r__total (nchannels)
- Real (kind=jprb), target :: r__bt (nchannels)
- Real (kind=jprb), target :: r__bt_clear (nchannels)
- Real (kind=jprb), target :: r__upclear (nchannels)
- Real (kind=jprb), target :: r__dnclear (nchannels)
- Real (kind=jprb), target :: r__reflclear (nchannels)
- Real (Kind=jprb), target :: r__overcast (nrt_levels,nchannels)
- Real (Kind=jprb), target :: r__downcld (nrt_levels,nchannels)
-
- Real (kind=jprb), target :: rz__clear_out (nbtout)
- Real (kind=jprb), target :: rz__out (nbtout)
- Real (kind=jprb), target :: rz__out_clear (nbtout)
- Real (kind=jprb), target :: rz__total_out (nbtout)
- Real (kind=jprb), target :: rz__clear (nchannels)
- Real (kind=jprb), target :: rz__cloudy (nchannels)
- Real (kind=jprb), target :: rz__total (nchannels)
- Real (kind=jprb), target :: rz__bt (nchannels)
- Real (kind=jprb), target :: rz__bt_clear (nchannels)
- Real (kind=jprb), target :: rz__upclear (nchannels)
- Real (kind=jprb), target :: rz__dnclear (nchannels)
- Real (kind=jprb), target :: rz__reflclear (nchannels)
- Real (Kind=jprb), target :: rz__overcast (nrt_levels,nchannels)
- Real (Kind=jprb), target :: rz__downcld (nrt_levels,nchannels)
-
- Real (kind=jprb), target :: r_k__clear_out (nbtout)
- Real (kind=jprb), target :: r_k__out (nbtout)
- Real (kind=jprb), target :: r_k__out_clear (nbtout)
- Real (kind=jprb), target :: r_k__total_out (nbtout)
- Real (kind=jprb), target :: r_k__clear (nchannels)
- Real (kind=jprb), target :: r_k__cloudy (nchannels)
- Real (kind=jprb), target :: r_k__total (nchannels)
- Real (kind=jprb), target :: r_k__bt (nchannels)
- Real (kind=jprb), target :: r_k__bt_clear (nchannels)
- Real (kind=jprb), target :: r_k__upclear (nchannels)
- Real (kind=jprb), target :: r_k__dnclear (nchannels)
- Real (kind=jprb), target :: r_k__reflclear (nchannels)
- Real (Kind=jprb), target :: r_k__overcast (nrt_levels,nchannels)
- Real (Kind=jprb), target :: r_k__downcld (nrt_levels,nchannels)
-
- Real (Kind=jprb), target :: t__tau_surf (nchannels)
- Real (Kind=jprb), target :: t__tau_layer (nrt_levels,nchannels)
- Real (Kind=jprb), target :: t__od_singlelayer (nrt_levels,nchannels)
- Real (Kind=jprb), target :: t_k__tau_surf (nchannels)
- Real (Kind=jprb), target :: t_k__tau_layer (nrt_levels,nchannels)
- Real (Kind=jprb), target :: t_k__od_singlelayer (nrt_levels,nchannels)
-
- Real (Kind=jprb), target :: sa__ccmax (nprofiles)
- Real (Kind=jprb), target :: sa__ems_bnd (nchannels)
- Real (Kind=jprb), target :: sa__ref_bnd (nchannels)
- Real (Kind=jprb), target :: sa__ems_cld (nchannels)
- Real (Kind=jprb), target :: sa__ref_cld (nchannels)
-
- Real (Kind=jprb), target :: sa__tbd (nprofiles,nwp_levels+1)
-
- Real (Kind=jprb), target :: sa__delta (nchannels,nwp_levels)
- Real (Kind=jprb), target :: sa__tau (nchannels,nwp_levels)
- Real (Kind=jprb), target :: sa__ext (nchannels,nwp_levels)
- Real (Kind=jprb), target :: sa__ssa (nchannels,nwp_levels)
- Real (Kind=jprb), target :: sa__asm (nchannels,nwp_levels)
- Real (Kind=jprb), target :: sa__lambda (nchannels,nwp_levels)
- Real (Kind=jprb), target :: sa__h (nchannels,nwp_levels)
-
- Real (Kind=jprb), target :: sa__b0 (nprofiles,nwp_levels)
- Real (Kind=jprb), target :: sa__b1 (nprofiles,nwp_levels)
- Real (Kind=jprb), target :: sa__bn (nprofiles,nwp_levels)
- Real (Kind=jprb), target :: sa__dz (nprofiles,nwp_levels)
- Real (Kind=jprb), target :: sa__clw (nprofiles,nwp_levels)
- Real (Kind=jprb), target :: sa__ciw (nprofiles,nwp_levels)
- Real (Kind=jprb), target :: sa__rain (nprofiles,nwp_levels)
- Real (Kind=jprb), target :: sa__sp (nprofiles,nwp_levels)
-
- Real (Kind=jprb), target :: sa_k__ccmax (nchannels)
- Real (Kind=jprb), target :: sa_k__ems_bnd (nchannels)
- Real (Kind=jprb), target :: sa_k__ref_bnd (nchannels)
- Real (Kind=jprb), target :: sa_k__ems_cld (nchannels)
- Real (Kind=jprb), target :: sa_k__ref_cld (nchannels)
-
- Real (Kind=jprb), target :: sa_k__tbd (nchannels,nwp_levels+1)
-
- Real (Kind=jprb), target :: sa_k__delta (nchannels,nwp_levels)
- Real (Kind=jprb), target :: sa_k__tau (nchannels,nwp_levels)
- Real (Kind=jprb), target :: sa_k__ext (nchannels,nwp_levels)
- Real (Kind=jprb), target :: sa_k__ssa (nchannels,nwp_levels)
- Real (Kind=jprb), target :: sa_k__asm (nchannels,nwp_levels)
- Real (Kind=jprb), target :: sa_k__lambda (nchannels,nwp_levels)
- Real (Kind=jprb), target :: sa_k__h (nchannels,nwp_levels)
-
- Real (Kind=jprb), target :: sa_k__b0 (nchannels,nwp_levels)
- Real (Kind=jprb), target :: sa_k__b1 (nchannels,nwp_levels)
- Real (Kind=jprb), target :: sa_k__bn (nchannels,nwp_levels)
- Real (Kind=jprb), target :: sa_k__dz (nchannels,nwp_levels)
- Real (Kind=jprb), target :: sa_k__clw (nchannels,nwp_levels)
- Real (Kind=jprb), target :: sa_k__ciw (nchannels,nwp_levels)
- Real (Kind=jprb), target :: sa_k__rain (nchannels,nwp_levels)
- Real (Kind=jprb), target :: sa_k__sp (nchannels,nwp_levels)
-
-!* Local variables:
- Logical :: addcloud, switchrad
- Integer (Kind=jpim) :: iprof, ichan, ilev
- Real (Kind=jprb) :: emissivity (nchannels)
- Real (Kind=jprb) :: emissivity_k (nchannels)
-
- Type (radiance_cloud_Type) :: cld_radiance_k
- Type (transmission_Type) :: transmission, transmission_k
- Type (geometry_Type) :: angles (nprofiles)
- Type (profile_scatt_aux) :: scatt_aux, scatt_aux_k
- Type (radiance_Type) :: radiance, radiance_k
- Type (radiance_cloud_Type) :: zcld_radiance
- Type (profile_Type) :: profiles_k_all(nchannels)
- Type (profile_cloud_Type) :: cld_profiles_k_all(nchannels)
- Type (radiance_Type) :: cld_radiance_tmp
-
- Character (len=80) :: errMessage
- Character (len=15) :: NameOfRoutine = 'rttov_scatt_k '
-
- !- End of header --------------------------------------------------------
-
- errorstatus(:) = errorstatus_success
-
- cld_radiance_k % clear_out => cld_r_k__clear_out
- cld_radiance_k % out => cld_r_k__out
- cld_radiance_k % out_clear => cld_r_k__out_clear
- cld_radiance_k % total_out => cld_r_k__total_out
- cld_radiance_k % clear => cld_r_k__clear
- cld_radiance_k % cloudy => cld_r_k__cloudy
- cld_radiance_k % total => cld_r_k__total
- cld_radiance_k % bt => cld_r_k__bt
- cld_radiance_k % bt_clear => cld_r_k__bt_clear
- cld_radiance_k % upclear => cld_r_k__upclear
- cld_radiance_k % dnclear => cld_r_k__dnclear
- cld_radiance_k % reflclear => cld_r_k__reflclear
- cld_radiance_k % overcast => cld_r_k__overcast
- cld_radiance_k % downcld => cld_r_k__downcld
-
- radiance % clear_out => r__clear_out
- radiance % out => r__out
- radiance % out_clear => r__out_clear
- radiance % total_out => r__total_out
- radiance % clear => r__clear
- radiance % cloudy => r__cloudy
- radiance % total => r__total
- radiance % bt => r__bt
- radiance % bt_clear => r__bt_clear
- radiance % upclear => r__upclear
- radiance % dnclear => r__dnclear
- radiance % reflclear => r__reflclear
- radiance % overcast => r__overcast
- radiance % downcld => r__downcld
-
- radiance_k % clear_out => r_k__clear_out
- radiance_k % out => r_k__out
- radiance_k % out_clear => r_k__out_clear
- radiance_k % total_out => r_k__total_out
- radiance_k % clear => r_k__clear
- radiance_k % cloudy => r_k__cloudy
- radiance_k % total => r_k__total
- radiance_k % bt => r_k__bt
- radiance_k % bt_clear => r_k__bt_clear
- radiance_k % upclear => r_k__upclear
- radiance_k % dnclear => r_k__dnclear
- radiance_k % reflclear => r_k__reflclear
- radiance_k % overcast => r_k__overcast
- radiance_k % downcld => r_k__downcld
-
- zcld_radiance % clear_out => rz__clear_out
- zcld_radiance % out => rz__out
- zcld_radiance % out_clear => rz__out_clear
- zcld_radiance % total_out => rz__total_out
- zcld_radiance % clear => rz__clear
- zcld_radiance % cloudy => rz__cloudy
- zcld_radiance % total => rz__total
- zcld_radiance % bt => rz__bt
- zcld_radiance % bt_clear => rz__bt_clear
- zcld_radiance % upclear => rz__upclear
- zcld_radiance % dnclear => rz__dnclear
- zcld_radiance % reflclear => rz__reflclear
- zcld_radiance % overcast => rz__overcast
- zcld_radiance % downcld => rz__downcld
-
- transmission % tau_surf => t__tau_surf
- transmission % tau_layer => t__tau_layer
- transmission % od_singlelayer => t__od_singlelayer
-
- transmission_k % tau_surf => t_k__tau_surf
- transmission_k % tau_layer => t_k__tau_layer
- transmission_k % od_singlelayer => t_k__od_singlelayer
-
- scatt_aux % ccmax => sa__ccmax
- scatt_aux % ems_bnd => sa__ems_bnd
- scatt_aux % ref_bnd => sa__ref_bnd
- scatt_aux % ems_cld => sa__ems_cld
- scatt_aux % ref_cld => sa__ref_cld
- scatt_aux % tbd => sa__tbd
- scatt_aux % mclayer => sa__mclayer
- scatt_aux % delta => sa__delta
- scatt_aux % tau => sa__tau
- scatt_aux % ext => sa__ext
- scatt_aux % ssa => sa__ssa
- scatt_aux % asm => sa__asm
- scatt_aux % lambda => sa__lambda
- scatt_aux % h => sa__h
- scatt_aux % b0 => sa__b0
- scatt_aux % b1 => sa__b1
- scatt_aux % bn => sa__bn
- scatt_aux % dz => sa__dz
- scatt_aux % clw => sa__clw
- scatt_aux % ciw => sa__ciw
- scatt_aux % rain => sa__rain
- scatt_aux % sp => sa__sp
-
- scatt_aux_k % ccmax => sa_k__ccmax
- scatt_aux_k % ems_bnd => sa_k__ems_bnd
- scatt_aux_k % ref_bnd => sa_k__ref_bnd
- scatt_aux_k % ems_cld => sa_k__ems_cld
- scatt_aux_k % ref_cld => sa_k__ref_cld
- scatt_aux_k % tbd => sa_k__tbd
- scatt_aux_k % mclayer => sa_k__mclayer
- scatt_aux_k % delta => sa_k__delta
- scatt_aux_k % tau => sa_k__tau
- scatt_aux_k % ext => sa_k__ext
- scatt_aux_k % ssa => sa_k__ssa
- scatt_aux_k % asm => sa_k__asm
- scatt_aux_k % lambda => sa_k__lambda
- scatt_aux_k % h => sa_k__h
- scatt_aux_k % b0 => sa_k__b0
- scatt_aux_k % b1 => sa_k__b1
- scatt_aux_k % bn => sa_k__bn
- scatt_aux_k % dz => sa_k__dz
- scatt_aux_k % clw => sa_k__clw
- scatt_aux_k % ciw => sa_k__ciw
- scatt_aux_k % rain => sa_k__rain
- scatt_aux_k % sp => sa_k__sp
-
- Do ichan = 1, nchannels
- Allocate( profiles_k_all(ichan) % p(coef_rttov%nlevels ))
- Allocate( profiles_k_all(ichan) % t(coef_rttov%nlevels ))
- Allocate( profiles_k_all(ichan) % q(coef_rttov%nlevels ))
- Allocate( profiles_k_all(ichan) % o3(coef_rttov%nlevels ))
- Allocate( profiles_k_all(ichan) % co2(coef_rttov%nlevels ))
- Allocate( profiles_k_all(ichan) % clw(coef_rttov%nlevels ))
- Allocate( cld_profiles_k_all(ichan) % p(nwp_levels))
- Allocate( cld_profiles_k_all(ichan) % ph(nwp_levels+1))
- Allocate( cld_profiles_k_all(ichan) % t(nwp_levels))
- Allocate( cld_profiles_k_all(ichan) % q(nwp_levels))
- Allocate( cld_profiles_k_all(ichan) % cc(nwp_levels))
- Allocate( cld_profiles_k_all(ichan) % clw(nwp_levels))
- Allocate( cld_profiles_k_all(ichan) % ciw(nwp_levels))
- Allocate( cld_profiles_k_all(ichan) % rain(nwp_levels))
- Allocate( cld_profiles_k_all(ichan) % sp(nwp_levels))
- Do ilev = 1,coef_rttov%nlevels
- profiles_k_all(ichan) % clw (ilev) = 0.0_JPRB
- profiles_k_all(ichan) % co2 (ilev) = 0.0_JPRB
- profiles_k_all(ichan) % o3 (ilev) = 0.0_JPRB
- profiles_k_all(ichan) % t (ilev) = 0.0_JPRB
- profiles_k_all(ichan) % q (ilev) = 0.0_JPRB
- profiles_k_all(ichan) % p (ilev) = 0.0_JPRB
- Enddo
- profiles_k_all(ichan) % s2m % t =0.0_JPRB
- profiles_k_all(ichan) % s2m % u =0.0_JPRB
- profiles_k_all(ichan) % s2m % v =0.0_JPRB
- profiles_k_all(ichan) % s2m % q =0.0_JPRB
- profiles_k_all(ichan) % s2m % o =0.0_JPRB
- profiles_k_all(ichan) % s2m % p =0.0_JPRB
- profiles_k_all(ichan) % skin % t =0.0_JPRB
- profiles_k_all(ichan) % skin % fastem(1) =0.0_JPRB
- profiles_k_all(ichan) % skin % fastem(2) =0.0_JPRB
- profiles_k_all(ichan) % skin % fastem(3) =0.0_JPRB
- profiles_k_all(ichan) % skin % fastem(4) =0.0_JPRB
- profiles_k_all(ichan) % skin % fastem(5) =0.0_JPRB
- profiles_k_all(ichan) % ctp =0.0_JPRB
- profiles_k_all(ichan) % cfraction =0.0_JPRB
- profiles_k_all(ichan) % nlevels = coef_rttov % nlevels
- ! The next five are initialised for completeness - they are not used.
- profiles_k_all(ichan) % zenangle = 0.0_JPRB
- profiles_k_all(ichan) % azangle = 0.0_JPRB
- profiles_k_all(ichan) % skin % surftype = 0_JPIM
- profiles_k_all(ichan) % ozone_data = .true.
- profiles_k_all(ichan) % co2_data = .true.
- profiles_k_all(ichan) % clw_data = .true.
- Do ilev = 1,nwp_levels
- cld_profiles_k_all(ichan) % p(ilev)=0.0_JPRB
- cld_profiles_k_all(ichan) % ph(ilev)=0.0_JPRB
- cld_profiles_k_all(ichan) % t(ilev)=0.0_JPRB
- cld_profiles_k_all(ichan) % q(ilev)=0.0_JPRB
- cld_profiles_k_all(ichan) % cc(ilev)=0.0_JPRB
- cld_profiles_k_all(ichan) % clw(ilev)=0.0_JPRB
- cld_profiles_k_all(ichan) % ciw(ilev)=0.0_JPRB
- cld_profiles_k_all(ichan) % rain(ilev)=0.0_JPRB
- cld_profiles_k_all(ichan) % sp(ilev)=0.0_JPRB
- Enddo
- cld_profiles_k_all(ichan) % ph(nwp_levels+1) =0.0_JPRB
- cld_profiles_k_all(ichan) % nlevels = nwp_levels
- ! The next two are initialised for completeness - they are not used.
- cld_profiles_k_all(ichan) % kice = 0_JPIM
- cld_profiles_k_all(ichan) % kradip = 0_JPIM
- END Do
-
-!* 1. Gas absorption
- switchrad = .true. ! input to RTTOV is BT
- addcloud = .false.
-
- ! No calculation of CLW absorption inside "classical" RTTOV
- If ( Any(.Not. profiles (:) % clw_Data) ) Then
- ! warning message
- profiles (:) % clw_Data = .False.
- End If
-
- emissivity (:) = emissivity_in (:)
-
- Call rttov_direct( &
- & errorstatus, &! out
- & nfrequencies, &! in
- & nchannels, &! in
- & nbtout, &! in
- & nprofiles, &! in
- & channels, &! in
- & polarisations, &! in
- & lprofiles, &! in
- & profiles, &! in
- & coef_rttov, &! in
- & addcloud, &! in
- & calcemiss, &! in
- & emissivity, &! inout
- & transmission, &! inout
- & radiance ) ! inout
-
- If ( any( errorstatus(:) == errorstatus_fatal ) ) Then
- Write( errMessage, '( "error in rttov_direct")' )
- Call Rttov_ErrorReport (errorstatus_fatal, errMessage, NameOfRoutine)
- Return
- End If
-
- scatt_aux % ems_cld (:) = emissivity_in (:)
- scatt_aux % ref_cld (:) = 1.0_JPRB - emissivity_in (:)
-
-!* 2. Initialisations for Eddington
- Call rttov_iniscatt( &
- & errorstatus, &! out
- & nwp_levels, &! in
- & nrt_levels, &! in
- & nfrequencies, &! in
- & nchannels, &! in
- & nprofiles, &! in
- & polarisations, &! in
- & channels, &! in
- & frequencies, &! in
- & lprofiles, &! in
- & lsprofiles, &! in
- & profiles, &! in
- & cld_profiles, &! in
- & coef_rttov, &! in
- & coef_scatt, &! in
- & transmission, &! in
- & calcemiss, &! in
- & angles, &! out
- & scatt_aux ) ! inout
-
- If ( any( errorstatus(:) == errorstatus_fatal ) ) Then
- Write( errMessage, '( "error in rttov_iniscatt")' )
- Call Rttov_ErrorReport (errorstatus_fatal, errMessage, NameOfRoutine)
- Return
- End If
-
-!* 3. Eddington (in temperature space)
- Call rttov_eddington( &
- & nwp_levels, &! in
- & nchannels, &! in
- & nprofiles, &! in
- & lsprofiles, &! in
- & angles, &! in
- & profiles, &! in
- & cld_profiles, &! in
- & scatt_aux, &! in
- & cld_radiance) ! inout
-
- zcld_radiance % bt (:) = cld_radiance % bt (:)
-
-!* 4. Combine clear and cloudy parts
- Do ichan = 1, nchannels
- iprof = lsprofiles (ichan)
-
- cld_radiance % total (ichan) = radiance % total (ichan)
- cld_radiance % clear (ichan) = radiance % clear (ichan)
- cld_radiance % bt_clear (ichan) = radiance % bt (ichan)
- cld_radiance % bt (ichan) = cld_radiance % bt (ichan) * scatt_aux % ccmax (iprof) &
- & + radiance % bt (ichan) * (1.0_JPRB - scatt_aux % ccmax (iprof))
- End Do
-!* ADJOINT PART
-
-! Initialise cld_radiance_k
-
- cld_radiance_k % clear(:) = 0._JPRB
- cld_radiance_k % clear_out(:) = 0._JPRB
- cld_radiance_k % out_clear(:) = 0._JPRB
- cld_radiance_k % cloudy(:) = 0._JPRB
- cld_radiance_k % bt_clear(:) = 0._JPRB
- cld_radiance_k % upclear(:) = 0._JPRB
- cld_radiance_k % reflclear(:) = 0._JPRB
- cld_radiance_k % overcast(:,:) = 0._JPRB
- cld_radiance_k % downcld(:,:) = 0._JPRB
-
-! cld_radiance_k % bt(:) = 1._JPRB
- cld_radiance_k % bt(:) = 0._JPRB
- cld_radiance_k % total(:) = 0._JPRB
- cld_radiance_k % out(:) = 1._JPRB
- cld_radiance_k % total_out(:) = 0._JPRB
-
-
- scatt_aux_k % ccmax (:) = 0.0_JPRB
- scatt_aux_k % ems_bnd (:) = 0.0_JPRB
- scatt_aux_k % ref_bnd (:) = 0.0_JPRB
- scatt_aux_k % ems_cld (:) = 0.0_JPRB
- scatt_aux_k % ref_cld (:) = 0.0_JPRB
- scatt_aux_k % tbd (:,:) = 0.0_JPRB
- scatt_aux_k % delta (:,:) = 0.0_JPRB
- scatt_aux_k % tau (:,:) = 0.0_JPRB
- scatt_aux_k % ext (:,:) = 0.0_JPRB
- scatt_aux_k % ssa (:,:) = 0.0_JPRB
- scatt_aux_k % asm (:,:) = 0.0_JPRB
- scatt_aux_k % lambda (:,:) = 0.0_JPRB
- scatt_aux_k % h (:,:) = 0.0_JPRB
- scatt_aux_k % b0 (:,:) = 0.0_JPRB
- scatt_aux_k % b1 (:,:) = 0.0_JPRB
- scatt_aux_k % bn (:,:) = 0.0_JPRB
- scatt_aux_k % dz (:,:) = 0.0_JPRB
- scatt_aux_k % clw (:,:) = 0.0_JPRB
- scatt_aux_k % ciw (:,:) = 0.0_JPRB
- scatt_aux_k % rain (:,:) = 0.0_JPRB
- scatt_aux_k % sp (:,:) = 0.0_JPRB
-
- transmission_k % tau_surf (:) = 0.0_JPRB
- transmission_k % tau_layer (:,:) = 0.0_JPRB
- transmission_k % od_singlelayer (:,:) = 0.0_JPRB
-
- radiance_k % bt (:) = 0.0_JPRB
-
-
- !
- !* 5. Convert total polarisations length arrays to number of output channel length arrays
- !
- If (coef_rttov % id_sensor == sensor_id_mw) Then
-
- ! Point a temporary radiance type at cld_radiance_k
- cld_radiance_tmp % clear => cld_radiance_k % clear
- cld_radiance_tmp % clear_out => cld_radiance_k % clear_out
- cld_radiance_tmp % cloudy => cld_radiance_k % cloudy
- cld_radiance_tmp % total => cld_radiance_k % total
- cld_radiance_tmp % total_out => cld_radiance_k % total_out
- cld_radiance_tmp % out => cld_radiance_k % out
- cld_radiance_tmp % out_clear => cld_radiance_k % out_clear
- cld_radiance_tmp % bt => cld_radiance_k % bt
- cld_radiance_tmp % bt_clear => cld_radiance_k % bt_clear
- cld_radiance_tmp % upclear => cld_radiance_k % upclear
- cld_radiance_tmp % dnclear => cld_radiance_k % dnclear
- cld_radiance_tmp % reflclear => cld_radiance_k % reflclear
- cld_radiance_tmp % overcast => cld_radiance_k % overcast
- cld_radiance_tmp % downcld => cld_radiance_k % downcld
-
- Call rttov_calcpolarisation_ad( &
- & nfrequencies, & ! in
- & nchannels, & ! in
- & nbtout, & ! in
- & profiles, & ! in
- & nprofiles, & ! in
- & angles, & ! in
- & channels, & ! in
- & polarisations,& ! in
- & lprofiles, & ! in
- & coef_rttov, & ! in
- & cld_radiance_tmp ) ! inout
- Else
- radiance_k%bt = radiance_k%out
- radiance_k%bt_clear = radiance_k%out_clear
- cld_radiance_k%bt = cld_radiance_k%out
- cld_radiance_k%bt_clear = cld_radiance_k%out_clear
- End If
-
-!* 4. Combine clear and cloudy parts
- Do ichan = 1, nchannels
- iprof = lsprofiles (ichan)
-
- scatt_aux_k % ccmax (ichan) = scatt_aux_k % ccmax (ichan) + &
- (zcld_radiance % bt (ichan) - &
- radiance % bt (ichan)) * cld_radiance_k % bt (ichan)
- radiance_k % bt (ichan) = radiance_k % bt (ichan) + &
- (1.0_JPRB - scatt_aux % ccmax (iprof)) * cld_radiance_k % bt (ichan)
- cld_radiance_k % bt (ichan) = scatt_aux % ccmax (iprof) * &
- cld_radiance_k % bt (ichan)
- End Do
-
-!* 3. Eddington (in temperature space)
- Call rttov_eddington_k( &
- & nwp_levels, &! in
- & nchannels, &! in
- & nprofiles, &! in
- & lsprofiles, &! in
- & angles, &! in
- & profiles, &! in
- & profiles_k_all, &! inout
- & cld_profiles, &! in
- & scatt_aux, &! in
- & scatt_aux_k, &! inout
- & cld_radiance, &! inout
- & cld_radiance_k) ! inout
-
-!* 2. Initialisations for Eddington
- Call rttov_iniscatt_k( &
- & errorstatus, &! in
- & nwp_levels, &! in
- & nrt_levels, &! in
- & nfrequencies, &! in
- & nchannels, &! in
- & nprofiles, &! in
- & polarisations, &! in
- & channels, &! in
- & frequencies, &! in
- & lprofiles, &! in
- & lsprofiles, &! in
- & profiles, &! in
- & profiles_k_all, &! inout
- & cld_profiles, &! in
- & cld_profiles_k_all,&! inout
- & coef_rttov, &! in
- & coef_scatt, &! in
- & transmission, &! in
- & transmission_k, &! inout
- & calcemiss, &! in
- & angles, &! out
- & scatt_aux, &! inout
- & scatt_aux_k) ! inout
-
- If ( any( errorstatus(:) == errorstatus_fatal ) ) Then
- Write( errMessage, '( "error in rttov_iniscatt_k")' )
- Call Rttov_ErrorReport (errorstatus_fatal, errMessage, NameOfRoutine)
- Return
- End If
-
- emissivity_in_k (:) = emissivity_in_k (:) - scatt_aux_k % ref_cld (:)
- scatt_aux_k % ref_cld (:) = 0.0_JPRB
- emissivity_in_k (:) = emissivity_in_k (:) + scatt_aux_k % ems_cld (:)
- scatt_aux_k % ems_cld (:) = 0.0_JPRB
-
- radiance_k % clear (:) = 0.0_JPRB
- radiance_k % clear_out (:) = 0.0_JPRB
- radiance_k % cloudy (:) = 0.0_JPRB
- radiance_k % total (:) = 0.0_JPRB
- radiance_k % total_out (:) = 0.0_JPRB
- radiance_k % out (:) = 0.0_JPRB
- radiance_k % out_clear (:) = 0.0_JPRB
- radiance_k % bt_clear (:) = 0.0_JPRB
- radiance_k % upclear (:) = 0.0_JPRB
- radiance_k % dnclear (:) = 0.0_JPRB
- radiance_k % reflclear (:) = 0.0_JPRB
- radiance_k % overcast (:,:) = 0.0_JPRB
- radiance_k % downcld (:,:) = 0.0_JPRB
-
-
-!* 1. Gas absorption
- emissivity_k (:) = 0.0_JPRB
-
- Call rttov_k( &
- & errorstatus, &! out
- & nfrequencies, &! in
- & nchannels, &! in
- & nbtout, &! in
- & nprofiles, &! in
- & channels, &! in
- & polarisations, &! in
- & lprofiles, &! in
- & profiles, &! in
- & coef_rttov, &! in
- & addcloud, &! in
- & switchrad, &! in
- & calcemiss, &! in
- & emissivity, &! inout
- & profiles_k_all, &! inout
- & emissivity_k, &! inout
- & transmission, &! inout
- & transmission_k, &! inout
- & radiance, &! inout
- & radiance_k ) ! inout
-
- If ( any( errorstatus(:) == errorstatus_fatal ) ) Then
- Write( errMessage, '( "error in rttov_k")' )
- Call Rttov_ErrorReport (errorstatus_fatal, errMessage, NameOfRoutine)
- Return
- End If
-
- emissivity_in_k (:) = emissivity_in_k (:) + emissivity_k (:)
- emissivity_k (:) = 0.0_JPRB
-
- cld_radiance % bt (:) = zcld_radiance % bt (:)
-
-
- If (coef_rttov % id_sensor == sensor_id_mw) Then
- ! We have K wrt all calculated TBs - but user wants K for
- ! instrument channels, so K code only requires an extra routine to modify
- ! output. In AD code we simply exclude unused channels. Note only required
- ! for microwave calculations.
-
- Call rttov_profout_k( &
- & nfrequencies, &! in
- & nchannels, &! in
- & nbtout, &! in
- & nprofiles, &! in
- & channels, &! in
- & lprofiles, &! in
- & polarisations, &! in
- & coef_rttov, &! in
- & angles, &! in
- & profiles_k_all, &! in
- & profiles_k) ! Out
- Call rttov_cld_profout_k( &
- & nfrequencies, &! in
- & nchannels, &! in
- & nbtout, &! in
- & nprofiles, &! in
- & channels, &! in
- & lprofiles, &! in
- & polarisations, &! in
- & coef_rttov, &! in
- & angles, &! in
- & cld_profiles_k_all, &! in
- & cld_profiles_k) ! Out
- Else
- !profiles_k = profiles_k_all
- Do ichan = 1, nchannels
- profiles_k(ichan) % nlevels = profiles_k_all(ichan) % nlevels
- profiles_k(ichan) % s2m % t = profiles_k_all(ichan) % s2m % t
- profiles_k(ichan) % s2m % q = profiles_k_all(ichan) % s2m % q
- profiles_k(ichan) % s2m % p = profiles_k_all(ichan) % s2m % p
- profiles_k(ichan) % s2m % u = profiles_k_all(ichan) % s2m % u
- profiles_k(ichan) % s2m % v = profiles_k_all(ichan) % s2m % v
- profiles_k(ichan) % skin % t = profiles_k_all(ichan) % skin % t
- profiles_k(ichan) % skin % fastem(1) = profiles_k_all(ichan) % skin % fastem(1)
- profiles_k(ichan) % skin % fastem(2) = profiles_k_all(ichan) % skin % fastem(2)
- profiles_k(ichan) % skin % fastem(3) = profiles_k_all(ichan) % skin % fastem(3)
- profiles_k(ichan) % skin % fastem(4) = profiles_k_all(ichan) % skin % fastem(4)
- profiles_k(ichan) % skin % fastem(5) = profiles_k_all(ichan) % skin % fastem(5)
- profiles_k(ichan) % ctp = profiles_k_all(ichan) % ctp
- profiles_k(ichan) % cfraction = profiles_k_all(ichan) % cfraction
- Do ilev=1,coef_rttov%nlevels
- profiles_k(ichan) % t(ilev) = profiles_k_all(ichan) % t(ilev)
- profiles_k(ichan) % q(ilev) = profiles_k_all(ichan) % q(ilev)
- profiles_k(ichan) % o3(ilev) = profiles_k_all(ichan) % o3(ilev)
- profiles_k(ichan) % clw(ilev) = profiles_k_all(ichan) % clw(ilev)
- End Do
- cld_profiles_k(ichan) % nlevels = cld_profiles_k_all(ichan) % nlevels
- Do ilev=1,nwp_levels
- cld_profiles_k(ichan) % p(ilev) = cld_profiles_k_all(ichan) % p(ilev)
- cld_profiles_k(ichan) % ph(ilev) = cld_profiles_k_all(ichan) % ph(ilev)
- cld_profiles_k(ichan) % t(ilev) = cld_profiles_k_all(ichan) % t(ilev)
- cld_profiles_k(ichan) % q(ilev) = cld_profiles_k_all(ichan) % q(ilev)
- cld_profiles_k(ichan) % cc(ilev) = cld_profiles_k_all(ichan) % cc(ilev)
- cld_profiles_k(ichan) % clw(ilev) = cld_profiles_k_all(ichan) % clw(ilev)
- cld_profiles_k(ichan) % ciw(ilev) = cld_profiles_k_all(ichan) % ciw(ilev)
- cld_profiles_k(ichan) % rain(ilev) = cld_profiles_k_all(ichan) % rain(ilev)
- cld_profiles_k(ichan) % sp(ilev) = cld_profiles_k_all(ichan) % sp(ilev)
- enddo
- cld_profiles_k(ichan) % ph(nwp_levels+1) = cld_profiles_k_all(ichan) % ph(nwp_levels+1)
- End Do
- End If
-
-
-! Deallocate memory
-
- Do ichan = 1, nchannels
- If( Associated( profiles_k_all(ichan) % p )) Then
- Deallocate( profiles_k_all(ichan) % p)
- Deallocate( profiles_k_all(ichan) % t)
- Deallocate( profiles_k_all(ichan) % q)
- Deallocate( profiles_k_all(ichan) % o3)
- Deallocate( profiles_k_all(ichan) % co2)
- Deallocate( profiles_k_all(ichan) % clw)
- End If
- If( Associated( cld_profiles_k_all(ichan) % p )) Then
- Deallocate( cld_profiles_k_all(ichan) % p)
- Deallocate( cld_profiles_k_all(ichan) % ph)
- Deallocate( cld_profiles_k_all(ichan) % t)
- Deallocate( cld_profiles_k_all(ichan) % q)
- Deallocate( cld_profiles_k_all(ichan) % cc)
- Deallocate( cld_profiles_k_all(ichan) % clw)
- Deallocate( cld_profiles_k_all(ichan) % ciw)
- Deallocate( cld_profiles_k_all(ichan) % rain)
- Deallocate( cld_profiles_k_all(ichan) % sp)
- End If
- End do
-
-
-
-End Subroutine rttov_scatt_k
-
-
-
diff --git a/src/LIB/RTTOV/src/rttov_scatt_k.interface b/src/LIB/RTTOV/src/rttov_scatt_k.interface
deleted file mode 100644
index 5baad0e4f6a05d6cf48872968fafc5f1eb2461e9..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_scatt_k.interface
+++ /dev/null
@@ -1,70 +0,0 @@
-INTERFACE
-Subroutine rttov_scatt_k( &
- & errorstatus, &! out
- & nwp_levels, &! in
- & nrt_levels, &! in
- & nfrequencies, &! in
- & nchannels, &! in
- & nbtout, &! in
- & nprofiles, &! in
- & polarisations, &! in
- & channels, &! in
- & frequencies, &! in
- & lprofiles, &! in
- & lsprofiles, &! in
- & profiles, &! inout
- & cld_profiles, &! in
- & coef_rttov, &! in
- & coef_scatt, &! in
- & calcemiss, &! in
- & emissivity_in, &! inout
- & profiles_k, &! inout
- & cld_profiles_k, &! inout
- & emissivity_in_k, &! inout
- & cld_radiance) ! inout
-
- Use rttov_const, Only : &
- & errorstatus_success ,&
- & errorstatus_fatal ,&
- & sensor_id_mw
-
- Use rttov_types, Only : &
- & rttov_coef ,&
- & rttov_scatt_coef ,&
- & geometry_Type ,&
- & profile_Type ,&
- & profile_cloud_Type ,&
- & profile_scatt_aux ,&
- & transmission_Type ,&
- & radiance_Type ,&
- & radiance_cloud_Type
-
- Use parkind1, Only : jpim ,jprb
-
- Implicit None
-
- Integer (Kind=jpim), Intent (in) :: nwp_levels ! Number of levels
- Integer (Kind=jpim), Intent (in) :: nrt_levels ! Number of levels
- Integer (Kind=jpim), Intent (in) :: nprofiles ! Number of profiles
- Integer (Kind=jpim), Intent (in) :: nfrequencies ! Number of frequencies
- Integer (Kind=jpim), Intent (in) :: nchannels ! Number of channels*profiles=radiances
- Integer (Kind=jpim), Intent (in) :: nbtout ! Number of output radiances
- Integer (Kind=jpim), Intent (in) :: channels (nfrequencies) ! Channel indices
- Integer (Kind=jpim), Intent (in) :: frequencies (nchannels) ! Frequency indices
- Integer (Kind=jpim), Intent (in) :: polarisations (nchannels,3) ! Polarisation indices
- Integer (Kind=jpim), Intent (in) :: lprofiles (nfrequencies) ! Profile indices
- Integer (Kind=jpim), Intent (in) :: lsprofiles (nchannels) ! Profile indices
- Integer (Kind=jpim), Intent (out) :: errorstatus (nprofiles) ! Error return flag
- Logical, Intent (in) :: calcemiss (nchannels) ! Surface emmissivity
- Real (Kind=jprb), Intent (in) :: emissivity_in (nchannels) ! Surface emmissivity
- Real (Kind=jprb), Intent (inout) :: emissivity_in_k (nchannels)
- Type (profile_Type), Intent (inout) :: profiles (nprofiles) ! Atmospheric profiles
- Type (profile_Type), Intent (inout) :: profiles_k (nbtout)
- Type (rttov_coef), Intent (in) :: coef_rttov ! RTTOV Coefficients
- Type (rttov_scatt_coef), Intent (in) :: coef_scatt ! RTTOV_SCATT Coefficients
- Type (profile_cloud_Type), Intent (in) :: cld_profiles (nprofiles) ! Cloud profiles with NWP levels
- Type (profile_cloud_Type), Intent (inout) :: cld_profiles_k (nbtout)
- Type (radiance_cloud_Type), Intent (inout) :: cld_radiance ! Radiances
-
-End Subroutine rttov_scatt_k
-END INTERFACE
diff --git a/src/LIB/RTTOV/src/rttov_scatt_setupindex.F90 b/src/LIB/RTTOV/src/rttov_scatt_setupindex.F90
deleted file mode 100644
index 3df3565f81d750284290bf4222734a6705e4ed78..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_scatt_setupindex.F90
+++ /dev/null
@@ -1,73 +0,0 @@
-
- subroutine rttov_scatt_setupindex (nprofiles, n_chan, coef, nchannels, &
- & lsprofiles,lsprofiles2, frequencies, nbtout)
-
-!**** Set indices for frequencies, lsprofiles for RTTOV-8 (SCATT)
-
-! P. Bauer, P. Lopez, E. Moreau, D. Salmond ECMWF May 2004
-
-! 1. Set up indices for profiles/channels
-
-! RTTOV_SCATT_SETUPINDEX is called from ONEDVAR_OBSOP_RTTOV, ONEDVAR_OBSOP_RTTOV_GRAD
-
-! Modifications:
-!
-
-!* KIND
- use parkind1 , only: jpim, jprb
-
- use rttov_const, only : npolar_return, npolar_compute, &
- & inst_id_ssmi
- use rttov_types, only : rttov_coef
-
- implicit none
-
- integer (kind=jpim), intent ( in) :: nprofiles
- integer (kind=jpim), intent ( in) :: nchannels
- integer (kind=jpim), intent ( in) :: nbtout
- integer (kind=jpim), intent ( in) :: n_chan (nprofiles)
-
- type (rttov_coef), intent ( in) :: coef
-
- integer (kind=jpim), intent (out), dimension (nchannels) :: lsprofiles
- integer (kind=jpim), intent (out), dimension (nbtout) :: lsprofiles2
- integer (kind=jpim), intent (out), dimension (nchannels) :: frequencies
-
- integer (kind=jpim) :: i_prof, i_chan, j_chan, i_freq, i_polid, i_pol, nch
-
-!- End of header ------------------------------------------------------
-
-!* Set index arrays
- j_chan = 0
-
- do i_prof = 1, nprofiles
- do i_chan = 1, n_chan (i_prof)
- i_polid = coef % fastem_polar (i_chan) + 1
-
- do i_pol = 1, npolar_compute (i_polid)
- frequencies (j_chan + i_pol) = i_chan
- lsprofiles (j_chan + i_pol) = i_prof
-
- if (coef % id_comp_lvl < 8 .and. coef % id_inst == inst_id_ssmi) then
- if (i_chan == 1 .or. i_chan == 2) frequencies (j_chan + i_pol) = 1
- if (i_chan == 3 ) frequencies (j_chan + i_pol) = 2
- if (i_chan == 4 .or. i_chan == 5) frequencies (j_chan + i_pol) = 3
- if (i_chan == 6 .or. i_chan == 7) frequencies (j_chan + i_pol) = 4
- endif
- end do
- j_chan = j_chan + npolar_compute (i_polid)
- end do
- end do
-
-!* Set index arrays for output channels
-
- nch=0
- do i_prof = 1, nprofiles
- do i_chan = 1, nbtout/nprofiles
- nch=nch+1
- lsprofiles2 (nch) = i_prof
- end do
- end do
-
- end subroutine rttov_scatt_setupindex
-
diff --git a/src/LIB/RTTOV/src/rttov_scatt_setupindex.interface b/src/LIB/RTTOV/src/rttov_scatt_setupindex.interface
deleted file mode 100644
index ff4277401224d238a8798a1e059b00028d079245..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_scatt_setupindex.interface
+++ /dev/null
@@ -1,25 +0,0 @@
-INTERFACE
- subroutine rttov_scatt_setupindex (nprofiles, n_chan, coef, nchannels, &
- & lsprofiles,lsprofiles2, frequencies, nbtout)
-
- use parkind1 , only: jpim, jprb
-
- use rttov_const, only : npolar_return, npolar_compute, &
- & inst_id_ssmi
- use rttov_types, only : rttov_coef
-
- implicit none
-
- integer (kind=jpim), intent ( in) :: nprofiles
- integer (kind=jpim), intent ( in) :: nchannels
- integer (kind=jpim), intent ( in) :: nbtout
- integer (kind=jpim), intent ( in) :: n_chan (nprofiles)
-
- type (rttov_coef), intent ( in) :: coef
-
- integer (kind=jpim), intent (out), dimension (nchannels) :: lsprofiles
- integer (kind=jpim), intent (out), dimension (nbtout) :: lsprofiles2
- integer (kind=jpim), intent (out), dimension (nchannels) :: frequencies
-
- end subroutine rttov_scatt_setupindex
-END INTERFACE
diff --git a/src/LIB/RTTOV/src/rttov_scatt_test.F90 b/src/LIB/RTTOV/src/rttov_scatt_test.F90
deleted file mode 100644
index 129340e9954826736f892d65187fa3c2c1a3954d..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_scatt_test.F90
+++ /dev/null
@@ -1,1970 +0,0 @@
- subroutine rttov_scatt_test (nfrequencies, nchannels, nbtout, coef_rttov, coef_scatt, &
- & lprofiles , &
- & lsprofiles , &
- & lsprofiles2 , &
- & channels , &
- & frequencies , &
- & polarisations , &
- & emissivity)
-
- ! Current Code Owner: SAF NWP
- !
- ! History:
- ! Version Date Comment
- ! ------- ---- -------
- ! 1.1 28/09/2006 Fixed indexing problem in K tests for emissivity
- ! (A. Doherty)
-
- Use mod_rttov_scatt_test
-
- Use rttov_const, only : &
- & errorstatus_fatal, &
- & errorstatus_success, &
- & default_err_unit, &
- & sensor_id_mw, &
- & npolar_return, &
- & npolar_compute, &
- & fastem_sp ,&
- & inst_id_ssmi ,&
- & inst_id_amsua ,&
- & inst_id_amsub
-
- Use mod_cparam, only : &
- & q_mixratio_to_ppmv
-
- Use rttov_types, only : &
- & geometry_type ,&
- & rttov_coef ,&
- & rttov_scatt_coef ,&
- & profile_type ,&
- & profile_cloud_type ,&
- & transmission_type ,&
- & radiance_cloud_type ,&
- & profile_scatt_aux
-
-
- Use parkind1, only: jpim ,jprb
-
- IMPLICIT NONE
-
-#include "rttov_intex.interface"
-#include "rttov_setpressure.interface"
-#include "rttov_scatt.interface"
-#include "rttov_scatt_tl.interface"
-#include "rttov_scatt_ad.interface"
-#include "rttov_scatt_k.interface"
-
- integer (kind=jpim), intent (in) :: nfrequencies, nchannels, nbtout
- real (kind=jprb), intent (in) , dimension (nchannels) :: emissivity
- integer (kind=jpim), intent (in) , dimension (nchannels,3) :: polarisations
- integer (kind=jpim), intent (in) , dimension (nfrequencies) :: channels
- integer (kind=jpim), intent (in) , dimension (nchannels) :: frequencies
- integer (kind=jpim), intent (in) , dimension (nfrequencies) :: lprofiles
- integer (kind=jpim), intent (in) , dimension (nchannels) :: lsprofiles
- integer (kind=jpim), intent (in) , dimension (nbtout) :: lsprofiles2
-
- type (rttov_coef ), intent (inout) :: coef_rttov
- type (rttov_scatt_coef), intent (inout) :: coef_scatt
-
-!* FORWARD
- type (profile_type) :: profiles_d1 (kproma)
- type (profile_cloud_type) :: cld_profiles_d1 (kproma)
- type (radiance_cloud_type) :: radiance_d1
-
- real (kind=jprb), dimension (nchannels) :: emissivity_d1
-
- real (kind=jprb), target :: p1__p (coef_rttov%nlevels,kproma)
- real (kind=jprb), target :: p1__t (coef_rttov%nlevels,kproma)
- real (kind=jprb), target :: p1__q (coef_rttov%nlevels,kproma)
- real (kind=jprb), target :: p1__o3 (coef_rttov%nlevels,kproma)
- real (kind=jprb), target :: p1__clw (coef_rttov%nlevels,kproma)
-
- real (kind=jprb), target :: cp1__p (kflevg,kproma)
- real (kind=jprb), target :: cp1__ph (kflevg+1,kproma)
- real (kind=jprb), target :: cp1__t (kflevg,kproma)
- real (kind=jprb), target :: cp1__q (kflevg,kproma)
- real (kind=jprb), target :: cp1__cc (kflevg,kproma)
- real (kind=jprb), target :: cp1__clw (kflevg,kproma)
- real (kind=jprb), target :: cp1__ciw (kflevg,kproma)
- real (kind=jprb), target :: cp1__rain (kflevg,kproma)
- real (kind=jprb), target :: cp1__sp (kflevg,kproma)
-
- real (kind=jprb), target :: r1__clear_out (nbtout)
- real (kind=jprb), target :: r1__out (nbtout)
- real (kind=jprb), target :: r1__out_clear (nbtout)
- real (kind=jprb), target :: r1__total_out (nbtout)
- real (kind=jprb), target :: r1__clear (nchannels)
- real (kind=jprb), target :: r1__cloudy (nchannels)
- real (kind=jprb), target :: r1__total (nchannels)
- real (kind=jprb), target :: r1__bt (nchannels)
- real (kind=jprb), target :: r1__bt_clear (nchannels)
- real (kind=jprb), target :: r1__upclear (nchannels)
- real (kind=jprb), target :: r1__dnclear (nchannels)
- real (kind=jprb), target :: r1__reflclear (nchannels)
- real (kind=jprb), target :: r1__freq_used (nchannels)
- real (kind=jprb), target :: r1__overcast (kflevg,nchannels)
- real (Kind=jprb), target :: r1__downcld (kflevg,nchannels)
-
-!* TL
- type (profile_type) :: profiles_d2 (kproma)
- type (profile_type) :: profiles_tl (kproma)
- type (profile_type) :: profiles_tl2 (kproma)
- type (profile_cloud_type) :: cld_profiles_d2 (kproma)
- type (profile_cloud_type) :: cld_profiles_tl (kproma)
- type (profile_cloud_type) :: cld_profiles_tl2 (kproma)
- type (radiance_cloud_type) :: radiance_d2
- type (radiance_cloud_type) :: radiance_d3
- type (radiance_cloud_type) :: radiance_tl
- type (radiance_cloud_type) :: radiance_tl2
-
- real (kind=jprb), dimension (nchannels) :: emissivity_d2
- real (kind=jprb), dimension (nchannels) :: emissivity_tl
- real (kind=jprb), dimension (nchannels) :: emissivity_tl2
-
- real (kind=jprb), target :: p2__p (coef_rttov%nlevels,kproma)
- real (kind=jprb), target :: p2__t (coef_rttov%nlevels,kproma)
- real (kind=jprb), target :: p2__q (coef_rttov%nlevels,kproma)
- real (kind=jprb), target :: p2__o3 (coef_rttov%nlevels,kproma)
- real (kind=jprb), target :: p2__clw (coef_rttov%nlevels,kproma)
-
- real (kind=jprb), target :: cp2__p (kflevg,kproma)
- real (kind=jprb), target :: cp2__ph (kflevg+1,kproma)
- real (kind=jprb), target :: cp2__t (kflevg,kproma)
- real (kind=jprb), target :: cp2__q (kflevg,kproma)
- real (kind=jprb), target :: cp2__cc (kflevg,kproma)
- real (kind=jprb), target :: cp2__clw (kflevg,kproma)
- real (kind=jprb), target :: cp2__ciw (kflevg,kproma)
- real (kind=jprb), target :: cp2__rain (kflevg,kproma)
- real (kind=jprb), target :: cp2__sp (kflevg,kproma)
-
- real (kind=jprb), target :: ptl__p (coef_rttov%nlevels,kproma)
- real (kind=jprb), target :: ptl__t (coef_rttov%nlevels,kproma)
- real (kind=jprb), target :: ptl__q (coef_rttov%nlevels,kproma)
- real (kind=jprb), target :: ptl__o3 (coef_rttov%nlevels,kproma)
- real (kind=jprb), target :: ptl__clw (coef_rttov%nlevels,kproma)
-
- real (kind=jprb), target :: cptl__p (kflevg,kproma)
- real (kind=jprb), target :: cptl__ph (kflevg+1,kproma)
- real (kind=jprb), target :: cptl__t (kflevg,kproma)
- real (kind=jprb), target :: cptl__q (kflevg,kproma)
- real (kind=jprb), target :: cptl__cc (kflevg,kproma)
- real (kind=jprb), target :: cptl__clw (kflevg,kproma)
- real (kind=jprb), target :: cptl__ciw (kflevg,kproma)
- real (kind=jprb), target :: cptl__rain (kflevg,kproma)
- real (kind=jprb), target :: cptl__sp (kflevg,kproma)
-
- real (kind=jprb), target :: ptl2__p (coef_rttov%nlevels,kproma)
- real (kind=jprb), target :: ptl2__t (coef_rttov%nlevels,kproma)
- real (kind=jprb), target :: ptl2__q (coef_rttov%nlevels,kproma)
- real (kind=jprb), target :: ptl2__o3 (coef_rttov%nlevels,kproma)
- real (kind=jprb), target :: ptl2__clw (coef_rttov%nlevels,kproma)
-
- real (kind=jprb), target :: cptl2__p (kflevg,kproma)
- real (kind=jprb), target :: cptl2__ph (kflevg+1,kproma)
- real (kind=jprb), target :: cptl2__t (kflevg,kproma)
- real (kind=jprb), target :: cptl2__q (kflevg,kproma)
- real (kind=jprb), target :: cptl2__cc (kflevg,kproma)
- real (kind=jprb), target :: cptl2__clw (kflevg,kproma)
- real (kind=jprb), target :: cptl2__ciw (kflevg,kproma)
- real (kind=jprb), target :: cptl2__rain (kflevg,kproma)
- real (kind=jprb), target :: cptl2__sp (kflevg,kproma)
-
- real (kind=jprb), target :: r2__clear_out (nbtout)
- real (kind=jprb), target :: r2__out (nbtout)
- real (kind=jprb), target :: r2__out_clear (nbtout)
- real (kind=jprb), target :: r2__total_out (nbtout)
- real (kind=jprb), target :: r2__clear (nchannels)
- real (kind=jprb), target :: r2__cloudy (nchannels)
- real (kind=jprb), target :: r2__total (nchannels)
- real (kind=jprb), target :: r2__bt (nchannels)
- real (kind=jprb), target :: r2__bt_clear (nchannels)
- real (kind=jprb), target :: r2__upclear (nchannels)
- real (kind=jprb), target :: r2__dnclear (nchannels)
- real (kind=jprb), target :: r2__reflclear (nchannels)
- real (kind=jprb), target :: r2__freq_used (nchannels)
- real (kind=jprb), target :: r2__overcast (kflevg,nchannels)
- real (Kind=jprb), target :: r2__downcld (kflevg,nchannels)
-
- real (kind=jprb), target :: rtl__clear_out (nbtout)
- real (kind=jprb), target :: rtl__out (nbtout)
- real (kind=jprb), target :: rtl__out_clear (nbtout)
- real (kind=jprb), target :: rtl__total_out (nbtout)
- real (kind=jprb), target :: rtl__clear (nchannels)
- real (kind=jprb), target :: rtl__cloudy (nchannels)
- real (kind=jprb), target :: rtl__total (nchannels)
- real (kind=jprb), target :: rtl__bt (nchannels)
- real (kind=jprb), target :: rtl__bt_clear (nchannels)
- real (kind=jprb), target :: rtl__upclear (nchannels)
- real (kind=jprb), target :: rtl__dnclear (nchannels)
- real (kind=jprb), target :: rtl__reflclear (nchannels)
- real (kind=jprb), target :: rtl__freq_used (nchannels)
- real (kind=jprb), target :: rtl__overcast (kflevg,nchannels)
- real (Kind=jprb), target :: rtl__downcld (kflevg,nchannels)
-
- real (kind=jprb), target :: rtl2__clear_out (nbtout)
- real (kind=jprb), target :: rtl2__out (nbtout)
- real (kind=jprb), target :: rtl2__out_clear (nbtout)
- real (kind=jprb), target :: rtl2__total_out (nbtout)
- real (kind=jprb), target :: rtl2__clear (nchannels)
- real (kind=jprb), target :: rtl2__cloudy (nchannels)
- real (kind=jprb), target :: rtl2__total (nchannels)
- real (kind=jprb), target :: rtl2__bt (nchannels)
- real (kind=jprb), target :: rtl2__bt_clear (nchannels)
- real (kind=jprb), target :: rtl2__upclear (nchannels)
- real (kind=jprb), target :: rtl2__dnclear (nchannels)
- real (kind=jprb), target :: rtl2__reflclear (nchannels)
- real (kind=jprb), target :: rtl2__freq_used (nchannels)
- real (kind=jprb), target :: rtl2__overcast (kflevg,nchannels)
- real (Kind=jprb), target :: rtl2__downcld (kflevg,nchannels)
-
- real (kind=jprb), target :: r3__clear_out (nbtout)
- real (kind=jprb), target :: r3__out (nbtout)
- real (kind=jprb), target :: r3__out_clear (nbtout)
- real (kind=jprb), target :: r3__total_out (nbtout)
- real (kind=jprb), target :: r3__clear (nchannels)
- real (kind=jprb), target :: r3__cloudy (nchannels)
- real (kind=jprb), target :: r3__total (nchannels)
- real (kind=jprb), target :: r3__bt (nchannels)
- real (kind=jprb), target :: r3__bt_clear (nchannels)
- real (kind=jprb), target :: r3__upclear (nchannels)
- real (kind=jprb), target :: r3__dnclear (nchannels)
- real (kind=jprb), target :: r3__reflclear (nchannels)
- real (kind=jprb), target :: r3__freq_used (nchannels)
- real (kind=jprb), target :: r3__overcast (kflevg,nchannels)
- real (Kind=jprb), target :: r3__downcld (kflevg,nchannels)
-
-!* AD
- type (profile_type) :: profiles_ad (kproma)
- type (profile_cloud_type) :: cld_profiles_ad (kproma)
- type (radiance_cloud_type) :: radiance_ad
-
- type (profile_type) :: profiles_ad2 (kproma)
- type (profile_cloud_type) :: cld_profiles_ad2 (kproma)
- type (radiance_cloud_type) :: radiance_ad2
-
- real (kind=jprb), dimension (nchannels) :: emissivity_ad
-
- real (kind=jprb), target :: pad__p (coef_rttov%nlevels,kproma)
- real (kind=jprb), target :: pad__t (coef_rttov%nlevels,kproma)
- real (kind=jprb), target :: pad__q (coef_rttov%nlevels,kproma)
- real (kind=jprb), target :: pad__o3 (coef_rttov%nlevels,kproma)
- real (kind=jprb), target :: pad__clw (coef_rttov%nlevels,kproma)
-
- real (kind=jprb), target :: cpad__p (kflevg,kproma)
- real (kind=jprb), target :: cpad__ph (kflevg+1,kproma)
- real (kind=jprb), target :: cpad__t (kflevg,kproma)
- real (kind=jprb), target :: cpad__q (kflevg,kproma)
- real (kind=jprb), target :: cpad__cc (kflevg,kproma)
- real (kind=jprb), target :: cpad__clw (kflevg,kproma)
- real (kind=jprb), target :: cpad__ciw (kflevg,kproma)
- real (kind=jprb), target :: cpad__rain (kflevg,kproma)
- real (kind=jprb), target :: cpad__sp (kflevg,kproma)
-
- real (kind=jprb), target :: rad__clear_out (nbtout)
- real (kind=jprb), target :: rad__out (nbtout)
- real (kind=jprb), target :: rad__out_clear (nbtout)
- real (kind=jprb), target :: rad__total_out (nbtout)
- real (kind=jprb), target :: rad__clear (nchannels)
- real (kind=jprb), target :: rad__cloudy (nchannels)
- real (kind=jprb), target :: rad__total (nchannels)
- real (kind=jprb), target :: rad__bt (nchannels)
- real (kind=jprb), target :: rad__bt_clear (nchannels)
- real (kind=jprb), target :: rad__upclear (nchannels)
- real (kind=jprb), target :: rad__dnclear (nchannels)
- real (kind=jprb), target :: rad__reflclear (nchannels)
- real (kind=jprb), target :: rad__freq_used (nchannels)
- real (kind=jprb), target :: rad__overcast (kflevg,nchannels)
- real (Kind=jprb), target :: rad__downcld (kflevg,nchannels)
-
- real (kind=jprb), target :: pad2__p (coef_rttov%nlevels,kproma)
- real (kind=jprb), target :: pad2__t (coef_rttov%nlevels,kproma)
- real (kind=jprb), target :: pad2__q (coef_rttov%nlevels,kproma)
- real (kind=jprb), target :: pad2__o3 (coef_rttov%nlevels,kproma)
- real (kind=jprb), target :: pad2__clw (coef_rttov%nlevels,kproma)
-
- real (kind=jprb), target :: cpad2__p (kflevg,kproma)
- real (kind=jprb), target :: cpad2__ph (kflevg+1,kproma)
- real (kind=jprb), target :: cpad2__t (kflevg,kproma)
- real (kind=jprb), target :: cpad2__q (kflevg,kproma)
- real (kind=jprb), target :: cpad2__cc (kflevg,kproma)
- real (kind=jprb), target :: cpad2__clw (kflevg,kproma)
- real (kind=jprb), target :: cpad2__ciw (kflevg,kproma)
- real (kind=jprb), target :: cpad2__rain (kflevg,kproma)
- real (kind=jprb), target :: cpad2__sp (kflevg,kproma)
-
- real (kind=jprb), target :: rad2__clear_out (nbtout)
- real (kind=jprb), target :: rad2__out (nbtout)
- real (kind=jprb), target :: rad2__out_clear (nbtout)
- real (kind=jprb), target :: rad2__total_out (nbtout)
- real (kind=jprb), target :: rad2__clear (nchannels)
- real (kind=jprb), target :: rad2__cloudy (nchannels)
- real (kind=jprb), target :: rad2__total (nchannels)
- real (kind=jprb), target :: rad2__bt (nchannels)
- real (kind=jprb), target :: rad2__bt_clear (nchannels)
- real (kind=jprb), target :: rad2__upclear (nchannels)
- real (kind=jprb), target :: rad2__dnclear (nchannels)
- real (kind=jprb), target :: rad2__reflclear (nchannels)
- real (kind=jprb), target :: rad2__freq_used (nchannels)
- real (kind=jprb), target :: rad2__overcast (kflevg,nchannels)
- real (Kind=jprb), target :: rad2__downcld (kflevg,nchannels)
-
- real (kind=jprb), dimension (nchannels) :: emissivity_ad2
-
-
-!* K
- type (profile_type) :: profiles_k (nbtout)
- type (profile_cloud_type) :: cld_profiles_k (nbtout)
-
- real (kind=jprb), dimension (nchannels) :: emissivity_k
-
- real (kind=jprb), target :: pk__p (coef_rttov%nlevels,nbtout)
- real (kind=jprb), target :: pk__t (coef_rttov%nlevels,nbtout)
- real (kind=jprb), target :: pk__q (coef_rttov%nlevels,nbtout)
- real (kind=jprb), target :: pk__o3 (coef_rttov%nlevels,nbtout)
- real (kind=jprb), target :: pk__clw (coef_rttov%nlevels,nbtout)
-
- real (kind=jprb), target :: cpk__p (kflevg,nbtout)
- real (kind=jprb), target :: cpk__ph (kflevg+1,nbtout)
- real (kind=jprb), target :: cpk__t (kflevg,nbtout)
- real (kind=jprb), target :: cpk__q (kflevg,nbtout)
- real (kind=jprb), target :: cpk__cc (kflevg,nbtout)
- real (kind=jprb), target :: cpk__clw (kflevg,nbtout)
- real (kind=jprb), target :: cpk__ciw (kflevg,nbtout)
- real (kind=jprb), target :: cpk__rain (kflevg,nbtout)
- real (kind=jprb), target :: cpk__sp (kflevg,nbtout)
-
-!* OTHER
- logical :: calcemiss (nchannels)
-
- integer (kind=jpim) :: nchan_act, j, npol, i_pol
- integer (kind=jpim) :: errorstatus (kproma)
- integer (kind=jpim) :: i_lev, i_proma, i_chan, ibtout, i_btout, i_lambda, i_fast
-
- real (kind=jprb) :: t_2m, q_2m, td_2m, u_10m, v_10m, ls, p_sfc, t_sfc, rlat, rlon
- real (kind=jprb) :: lambda, epsilon, zdelta1, zdelta2, zdelta3, threshold, z
- real (kind=jprb), dimension (kflevg) :: q_ppmv_d1, q_ppmv_d2, q_ppmv_tl
- Real (Kind=jprb) :: ratio(2)
- Real(Kind=jprb), Allocatable :: radiance_total_ref (:)
-
- !- End of header ------------------------------------------------------
-
- threshold = 1.0E-09_JPRB
-
-!* FORWARD-MODEL TEST ***********************************************************************************
-!* Set-up
- errorstatus = errorstatus_success
- emissivity_d1 (1:nchannels) = emissivity (1:nchannels)
- calcemiss (1:nchannels) = emissivity_d1 (1:nchannels) < 0.01_JPRB
-
-!* RTTOV/RTTOVSCATT arrays
- do i_proma = 1, kproma
- profiles_d1 (i_proma) % nlevels = coef_rttov % nlevels
- profiles_d1 (i_proma) % p => p1__p (:,i_proma)
- profiles_d1 (i_proma) % t => p1__t (:,i_proma)
- profiles_d1 (i_proma) % q => p1__q (:,i_proma)
- profiles_d1 (i_proma) % o3 => p1__o3 (:,i_proma)
- profiles_d1 (i_proma) % clw => p1__clw (:,i_proma)
- enddo
-
- do i_proma = 1, kproma
- cld_profiles_d1 (i_proma) % nlevels = kflevg
- cld_profiles_d1 (i_proma) % p => cp1__p (:,i_proma)
- cld_profiles_d1 (i_proma) % ph => cp1__ph (:,i_proma)
- cld_profiles_d1 (i_proma) % t => cp1__t (:,i_proma)
- cld_profiles_d1 (i_proma) % q => cp1__q (:,i_proma)
- cld_profiles_d1 (i_proma) % cc => cp1__cc (:,i_proma)
- cld_profiles_d1 (i_proma) % clw => cp1__clw (:,i_proma)
- cld_profiles_d1 (i_proma) % ciw => cp1__ciw (:,i_proma)
- cld_profiles_d1 (i_proma) % rain=> cp1__rain (:,i_proma)
- cld_profiles_d1 (i_proma) % sp => cp1__sp (:,i_proma)
- enddo
-
- radiance_d1 % overcast => r1__overcast
- radiance_d1 % clear_out => r1__clear_out
- radiance_d1 % out => r1__out
- radiance_d1 % out_clear => r1__out_clear
- radiance_d1 % total_out => r1__total_out
- radiance_d1 % clear => r1__clear
- radiance_d1 % cloudy => r1__cloudy
- radiance_d1 % total => r1__total
- radiance_d1 % bt => r1__bt
- radiance_d1 % bt_clear => r1__bt_clear
- radiance_d1 % upclear => r1__upclear
- radiance_d1 % dnclear => r1__dnclear
- radiance_d1 % reflclear => r1__reflclear
- radiance_d1 % downcld => r1__downcld
-
- Allocate ( radiance_total_ref ( nchannels ) )
-
-!* Read profiles
- open (ioin, file = '../data/profiles2_fmt', status = 'old')
- open (ioout, file='outputscatt.ascii',form='formatted')
-
- do i_proma = 1, kproma
-!* Surface
- read (ioin,'(10e16.6)') rlon, & ! longitude (deg)
- & rlat, & ! latitude (deg)
- & ls, & ! land-sea mask (1=land)
- & t_sfc, & ! surface temperature (K)
- & p_sfc, & ! surface pressure (Pa)
- & t_2m, & ! 2-meter temperature (K)
- & q_2m, & ! 2-meter specific humidity (kg/kg)
- & u_10m, & ! 10-meter wind u (m/s)
- & v_10m ! 10-meter wind u (m/s)
-!* Profile
- read (ioin,'(10e16.6)') cld_profiles_d1 (i_proma) % t (1:kflevg) ! temperature (K)
- read (ioin,'(10e16.6)') cld_profiles_d1 (i_proma) % q (1:kflevg) ! specific humidity (kg/kg)
- read (ioin,'(10e16.6)') cld_profiles_d1 (i_proma) % cc (1:kflevg) ! cloud cover
- read (ioin,'(10e16.6)') cld_profiles_d1 (i_proma) % clw (1:kflevg) ! liquid water (kg/kg)
- read (ioin,'(10e16.6)') cld_profiles_d1 (i_proma) % ciw (1:kflevg) ! ice water (kg/kg)
- read (ioin,'(10e16.6)') cld_profiles_d1 (i_proma) % rain (1:kflevg) ! rain (kg/m2/s)
- read (ioin,'(10e16.6)') cld_profiles_d1 (i_proma) % sp (1:kflevg) ! solid precipitation (kg/m2/s)
-
- call rttov_setpressure (p_sfc, cld_profiles_d1 (i_proma) % p, cld_profiles_d1 (i_proma) % ph)
-
- cld_profiles_d1 (i_proma) % p (:) = cld_profiles_d1 (i_proma) % p (:) * 0.01_JPRB
- cld_profiles_d1 (i_proma) % ph (:) = cld_profiles_d1 (i_proma) % ph (:) * 0.01_JPRB
-
-!* Fill in RTTOV/RTTOVSCATT arrays once per profile
- q_2m = q_2m / (1.0_JPRB - q_2m)
-
- profiles_d1 (i_proma) % p (:) = coef_rttov % ref_prfl_p (:)
- profiles_d1 (i_proma) % clw (:) = 0.0_JPRB ! warning
- profiles_d1 (i_proma) % o3 (:) = 1.0e-7_JPRB ! warning
- profiles_d1 (i_proma) % s2m % p = p_sfc / 100.0_JPRB
- profiles_d1 (i_proma) % s2m % q = q_2m * q_mixratio_to_ppmv
- profiles_d1 (i_proma) % s2m % o = 0.0_JPRB
- profiles_d1 (i_proma) % s2m % t = t_2m
- profiles_d1 (i_proma) % s2m % u = u_10m
- profiles_d1 (i_proma) % s2m % v = v_10m
- profiles_d1 (i_proma) % skin % surftype = int (1.0_JPRB - ls)
- profiles_d1 (i_proma) % skin % t = t_sfc
- profiles_d1 (i_proma) % skin % fastem(:) = fastem_land_coeff (:)
-
- profiles_d1 (i_proma) % ozone_data = .false. ! warning
- profiles_d1 (i_proma) % co2_data = .false.
- profiles_d1 (i_proma) % clw_data = .false.
- profiles_d1 (i_proma) % zenangle = zenangle
- profiles_d1 (i_proma) % azangle = 0.0_JPRB ! default value
- profiles_d1 (i_proma) % ctp = 500.0_JPRB ! default value
- profiles_d1 (i_proma) % cfraction = 0.0_JPRB ! default value
-
-!* Convert kg/kg to ppmv
- q_ppmv_d1 (1:kflevg) = cld_profiles_d1 (i_proma) % q (1:kflevg) * q_mixratio_to_ppmv
-
-! Interpolate input profile to rttov pressure levels
- call rttov_intex (kflevg , &
- & coef_rttov%nlevels , &
- & cld_profiles_d1 (i_proma) % p , &
- & profiles_d1 (i_proma) % p , &
- & cld_profiles_d1 (i_proma) % t , &
- & profiles_d1 (i_proma) % t)
-
- call rttov_intex (kflevg , &
- & coef_rttov%nlevels , &
- & cld_profiles_d1 (i_proma) % p , &
- & profiles_d1 (i_proma) % p , &
- & q_ppmv_d1 (1:kflevg) , &
- & profiles_d1 (i_proma) % q)
- end do
- close (ioin)
-
-!* Reference forward model run
- call rttov_scatt (errorstatus, & ! out
- & kflevg, & ! in
- & coef_rttov%nlevels, & ! in
- & nfrequencies, & ! in
- & nchannels, & ! in
- & nbtout, & ! in
- & kproma, & ! in
- & polarisations, & ! in
- & channels, & ! in
- & frequencies, & ! in
- & lprofiles, & ! in
- & lsprofiles, & ! in
- & profiles_d1, & ! inout
- & cld_profiles_d1, & ! in
- & coef_rttov, & ! in
- & coef_scatt, & ! in
- & calcemiss, & ! in
- & emissivity_d1, & ! inout
- & radiance_d1 ) ! inout
-
- ! main output:
- ! radiance_d1%total_out = cloud-affected radiances
- ! radiance_d1%clear_out = clear-sky radiances
- ! radiance_d1%out = cloud-affected Tbs
- ! radiance_d1%out_clear = clear-sky Tbs
-
- write(*,*) 'nfreq ', nfrequencies, 'nchan ', nchannels, 'nbtout ', nbtout
-
- write(ioout,*) 'This dataset is made of ',kproma,' ECMWF model profiles'
- write(ioout,*)
- write(ioout,*) 'Call to RTTOV_SCATT'
- write(ioout,*) '-------------------'
- write(ioout,*)
- write(ioout,*) 'Channel cloudy Tb '
-
- do i_chan = 1, nbtout
- write (ioout,'(i4,3x,30e23.16)') i_chan, radiance_d1 % out (i_chan)
- enddo
-
-!* TANGENT-LINEAR TEST ***********************************************************************************
-
- write(ioout,*)
- write(ioout,*) 'Test TL'
- write(ioout,*) '-------'
- write(ioout,*)
-
- epsilon = 0.01_JPRB
-
-!* RTTOV/RTTOVSCATT arrays
- do i_proma = 1, kproma
- profiles_tl (i_proma) % nlevels = coef_rttov % nlevels
- profiles_tl (i_proma) % p => ptl__p (:,i_proma)
- profiles_tl (i_proma) % t => ptl__t (:,i_proma)
- profiles_tl (i_proma) % q => ptl__q (:,i_proma)
- profiles_tl (i_proma) % o3 => ptl__o3 (:,i_proma)
- profiles_tl (i_proma) % clw => ptl__clw (:,i_proma)
-
- cld_profiles_tl (i_proma) % nlevels = kflevg
- cld_profiles_tl (i_proma) % p => cptl__p (:,i_proma)
- cld_profiles_tl (i_proma) % ph => cptl__ph (:,i_proma)
- cld_profiles_tl (i_proma) % t => cptl__t (:,i_proma)
- cld_profiles_tl (i_proma) % q => cptl__q (:,i_proma)
- cld_profiles_tl (i_proma) % cc => cptl__cc (:,i_proma)
- cld_profiles_tl (i_proma) % clw => cptl__clw (:,i_proma)
- cld_profiles_tl (i_proma) % ciw => cptl__ciw (:,i_proma)
- cld_profiles_tl (i_proma) % rain=> cptl__rain (:,i_proma)
- cld_profiles_tl (i_proma) % sp => cptl__sp (:,i_proma)
- enddo
-
- radiance_d3 % overcast => r3__overcast
- radiance_d3 % clear_out => r3__clear_out
- radiance_d3 % out => r3__out
- radiance_d3 % out_clear => r3__out_clear
- radiance_d3 % total_out => r3__total_out
- radiance_d3 % clear => r3__clear
- radiance_d3 % cloudy => r3__cloudy
- radiance_d3 % total => r3__total
- radiance_d3 % bt => r3__bt
- radiance_d3 % bt_clear => r3__bt_clear
- radiance_d3 % upclear => r3__upclear
- radiance_d3 % dnclear => r3__dnclear
- radiance_d3 % reflclear => r3__reflclear
- radiance_d3 % downcld => r3__downcld
-
- radiance_tl % overcast => rtl__overcast
- radiance_tl % clear_out => rtl__clear_out
- radiance_tl % out => rtl__out
- radiance_tl % out_clear => rtl__out_clear
- radiance_tl % total_out => rtl__total_out
- radiance_tl % clear => rtl__clear
- radiance_tl % cloudy => rtl__cloudy
- radiance_tl % total => rtl__total
- radiance_tl % bt => rtl__bt
- radiance_tl % bt_clear => rtl__bt_clear
- radiance_tl % upclear => rtl__upclear
- radiance_tl % dnclear => rtl__dnclear
- radiance_tl % reflclear => rtl__reflclear
- radiance_tl % downcld => rtl__downcld
-
- do i_proma = 1, kproma
-!* Set perturbation
- cld_profiles_tl (i_proma) % p (:) = cld_profiles_d1 (i_proma) % p (:) * epsilon
- cld_profiles_tl (i_proma) % ph (:) = cld_profiles_d1 (i_proma) % ph (:) * epsilon
-
- cld_profiles_tl (i_proma) % t (1:kflevg) = cld_profiles_d1 (i_proma) % t (1:kflevg) * epsilon
- cld_profiles_tl (i_proma) % q (1:kflevg) = cld_profiles_d1 (i_proma) % q (1:kflevg) * epsilon
- cld_profiles_tl (i_proma) % cc (1:kflevg) = cld_profiles_d1 (i_proma) % cc (1:kflevg) * epsilon
- cld_profiles_tl (i_proma) % clw (1:kflevg) = cld_profiles_d1 (i_proma) % clw (1:kflevg) * epsilon
- cld_profiles_tl (i_proma) % ciw (1:kflevg) = cld_profiles_d1 (i_proma) % ciw (1:kflevg) * epsilon
- cld_profiles_tl (i_proma) % rain (1:kflevg) = cld_profiles_d1 (i_proma) % rain (1:kflevg) * epsilon
- cld_profiles_tl (i_proma) % sp (1:kflevg) = cld_profiles_d1 (i_proma) % sp (1:kflevg) * epsilon
-
- cld_profiles_tl (i_proma) % cc (1:kflevg) = 0.0_JPRB ! to avoid cc > 1
-
-!* Fill in RTTOV/RTTOVSCATT arrays once per profile
- profiles_tl (i_proma) % p (:) = 0.0_JPRB
- profiles_tl (i_proma) % clw (:) = profiles_d1 (i_proma) % clw (:) * epsilon
- profiles_tl (i_proma) % o3 (:) = profiles_d1 (i_proma) % o3 (:) * epsilon
- profiles_tl (i_proma) % s2m % p = profiles_d1 (i_proma) % s2m % p * epsilon
- profiles_tl (i_proma) % s2m % q = profiles_d1 (i_proma) % s2m % q * epsilon
- profiles_tl (i_proma) % s2m % o = profiles_d1 (i_proma) % s2m % o * epsilon
- profiles_tl (i_proma) % s2m % t = profiles_d1 (i_proma) % s2m % t * epsilon
- profiles_tl (i_proma) % s2m % u = profiles_d1 (i_proma) % s2m % u * epsilon
- profiles_tl (i_proma) % s2m % v = profiles_d1 (i_proma) % s2m % v * epsilon
- profiles_tl (i_proma) % skin % surftype = -1
- profiles_tl (i_proma) % skin % t = profiles_d1 (i_proma) % skin % t * epsilon
- profiles_tl (i_proma) % skin % fastem (:) = profiles_d1 (i_proma) % skin % fastem (:) * epsilon
-
- profiles_tl (i_proma) % ozone_data = .false.
- profiles_tl (i_proma) % co2_data = .false.
- profiles_tl (i_proma) % clw_data = .false.
- profiles_tl (i_proma) % zenangle = -1
- profiles_tl (i_proma) % azangle = -1
-
- profiles_tl (i_proma) % ctp = profiles_d1 (i_proma) % ctp * epsilon
- profiles_tl (i_proma) % cfraction = profiles_d1 (i_proma) % cfraction * epsilon
-
- profiles_tl (i_proma) % t (:) = profiles_d1 (i_proma) % t (:) * epsilon
- profiles_tl (i_proma) % q (:) = profiles_d1 (i_proma) % q (:) * epsilon
- enddo
-
- emissivity_tl (1:nchannels) = emissivity_d1 (1:nchannels) * epsilon
- calcemiss (1:nchannels) = emissivity_d1 (1:nchannels) < 0.01_JPRB
-
- call rttov_scatt_tl (errorstatus, &! out
- & kflevg, &! in
- & coef_rttov%nlevels, &! in
- & nfrequencies, &! in
- & nchannels, &! in
- & nbtout, &! in
- & kproma, &! in
- & polarisations, &! in
- & channels, &! in
- & frequencies, &! in
- & lprofiles, &! in
- & lsprofiles, &! in
- & profiles_d1, &! inout
- & cld_profiles_d1, &! in
- & coef_rttov, &! in
- & coef_scatt, &! in
- & calcemiss, &! in
- & emissivity_d1, &! inout
- & profiles_tl, &! in
- & cld_profiles_tl, &! in
- & emissivity_tl, &! inout
- & radiance_d3, &! inout
- & radiance_tl ) ! inout
-
-
- ! Save radiance as a reference for the trajectory
- ! TL is used instead of rttov_scatt because
- ! calcemis = F and reflectivities have not been saved
- radiance_total_ref(:) = radiance_d1%total(:)
-
-
- !---------------------------
- ! second run of TL
- !---------------------------
- lambda = 0.5_JPRB
-
-
- !* RTTOV/RTTOVSCATT arrays
- do i_proma = 1, kproma
- profiles_tl2 (i_proma) % nlevels = coef_rttov % nlevels
- profiles_tl2 (i_proma) % p => ptl2__p (:,i_proma)
- profiles_tl2 (i_proma) % t => ptl2__t (:,i_proma)
- profiles_tl2 (i_proma) % q => ptl2__q (:,i_proma)
- profiles_tl2 (i_proma) % o3 => ptl2__o3 (:,i_proma)
- profiles_tl2 (i_proma) % clw => ptl2__clw (:,i_proma)
-
- cld_profiles_tl2 (i_proma) % nlevels = kflevg
- cld_profiles_tl2 (i_proma) % p => cptl2__p (:,i_proma)
- cld_profiles_tl2 (i_proma) % ph => cptl2__ph (:,i_proma)
- cld_profiles_tl2 (i_proma) % t => cptl2__t (:,i_proma)
- cld_profiles_tl2 (i_proma) % q => cptl2__q (:,i_proma)
- cld_profiles_tl2 (i_proma) % cc => cptl2__cc (:,i_proma)
- cld_profiles_tl2 (i_proma) % clw => cptl2__clw (:,i_proma)
- cld_profiles_tl2 (i_proma) % ciw => cptl2__ciw (:,i_proma)
- cld_profiles_tl2 (i_proma) % rain=> cptl2__rain (:,i_proma)
- cld_profiles_tl2 (i_proma) % sp => cptl2__sp (:,i_proma)
- enddo
-
- radiance_d3 % overcast => r3__overcast
- radiance_d3 % clear_out => r3__clear_out
- radiance_d3 % out => r3__out
- radiance_d3 % out_clear => r3__out_clear
- radiance_d3 % total_out => r3__total_out
- radiance_d3 % clear => r3__clear
- radiance_d3 % cloudy => r3__cloudy
- radiance_d3 % total => r3__total
- radiance_d3 % bt => r3__bt
- radiance_d3 % bt_clear => r3__bt_clear
- radiance_d3 % upclear => r3__upclear
- radiance_d3 % dnclear => r3__dnclear
- radiance_d3 % reflclear => r3__reflclear
- radiance_d3 % downcld => r3__downcld
-
- radiance_tl2 % overcast => rtl2__overcast
- radiance_tl2 % clear_out => rtl2__clear_out
- radiance_tl2 % out => rtl2__out
- radiance_tl2 % out_clear => rtl2__out_clear
- radiance_tl2 % total_out => rtl2__total_out
- radiance_tl2 % clear => rtl2__clear
- radiance_tl2 % cloudy => rtl2__cloudy
- radiance_tl2 % total => rtl2__total
- radiance_tl2 % bt => rtl2__bt
- radiance_tl2 % bt_clear => rtl2__bt_clear
- radiance_tl2 % upclear => rtl2__upclear
- radiance_tl2 % dnclear => rtl2__dnclear
- radiance_tl2 % reflclear => rtl2__reflclear
- radiance_tl2 % downcld => rtl2__downcld
-
- do i_proma = 1, kproma
-!* Set perturbation
- cld_profiles_tl2 (i_proma) % p (:) = cld_profiles_tl (i_proma) % p (:) * lambda
- cld_profiles_tl2 (i_proma) % ph (:) = cld_profiles_tl (i_proma) % ph (:) * lambda
-
- cld_profiles_tl2 (i_proma) % t (1:kflevg) = cld_profiles_tl (i_proma) % t (1:kflevg) * lambda
- cld_profiles_tl2 (i_proma) % q (1:kflevg) = cld_profiles_tl (i_proma) % q (1:kflevg) * lambda
- cld_profiles_tl2 (i_proma) % cc (1:kflevg) = cld_profiles_tl (i_proma) % cc (1:kflevg) * lambda
- cld_profiles_tl2 (i_proma) % clw (1:kflevg) = cld_profiles_tl (i_proma) % clw (1:kflevg) * lambda
- cld_profiles_tl2 (i_proma) % ciw (1:kflevg) = cld_profiles_tl (i_proma) % ciw (1:kflevg) * lambda
- cld_profiles_tl2 (i_proma) % rain (1:kflevg) = cld_profiles_tl (i_proma) % rain (1:kflevg) * lambda
- cld_profiles_tl2 (i_proma) % sp (1:kflevg) = cld_profiles_tl (i_proma) % sp (1:kflevg) * lambda
-
- cld_profiles_tl (i_proma) % cc (1:kflevg) = 0.0_JPRB ! to avoid cc > 1
-
-!* Fill in RTTOV/RTTOVSCATT arrays once per profile
- profiles_tl2 (i_proma) % p (:) = 0.0_JPRB
- profiles_tl2 (i_proma) % clw (:) = profiles_tl (i_proma) % clw (:) * lambda
- profiles_tl2 (i_proma) % o3 (:) = profiles_tl (i_proma) % o3 (:) * lambda
- profiles_tl2 (i_proma) % s2m % p = profiles_tl (i_proma) % s2m % p * lambda
- profiles_tl2 (i_proma) % s2m % q = profiles_tl (i_proma) % s2m % q * lambda
- profiles_tl2 (i_proma) % s2m % o = profiles_tl (i_proma) % s2m % o * lambda
- profiles_tl2 (i_proma) % s2m % t = profiles_tl (i_proma) % s2m % t * lambda
- profiles_tl2 (i_proma) % s2m % u = profiles_tl (i_proma) % s2m % u * lambda
- profiles_tl2 (i_proma) % s2m % v = profiles_tl (i_proma) % s2m % v * lambda
- profiles_tl2 (i_proma) % skin % surftype = -1
- profiles_tl2 (i_proma) % skin % t = profiles_tl (i_proma) % skin % t * lambda
- profiles_tl2 (i_proma) % skin % fastem (:) = profiles_tl (i_proma) % skin % fastem (:) * lambda
-
- profiles_tl2 (i_proma) % ozone_data = .false.
- profiles_tl2 (i_proma) % co2_data = .false.
- profiles_tl2 (i_proma) % clw_data = .false.
- profiles_tl2 (i_proma) % zenangle = -1
- profiles_tl2 (i_proma) % azangle = -1
-
- profiles_tl2 (i_proma) % ctp = profiles_tl (i_proma) % ctp * lambda
- profiles_tl2 (i_proma) % cfraction = profiles_tl (i_proma) % cfraction * lambda
-
- profiles_tl2 (i_proma) % t (:) = profiles_tl (i_proma) % t (:) * lambda
- profiles_tl2 (i_proma) % q (:) = profiles_tl (i_proma) % q (:) * lambda
- enddo
-
- emissivity_tl2 (1:nchannels) = emissivity_tl (1:nchannels) * lambda
- calcemiss (1:nchannels) = emissivity_tl (1:nchannels) < 0.01_JPRB
-
-
-
- call rttov_scatt_tl (errorstatus, &! out
- & kflevg, &! in
- & coef_rttov%nlevels, &! in
- & nfrequencies, &! in
- & nchannels, &! in
- & nbtout, &! in
- & kproma, &! in
- & polarisations, &! in
- & channels, &! in
- & frequencies, &! in
- & lprofiles, &! in
- & lsprofiles, &! in
- & profiles_d1, &! inout
- & cld_profiles_d1, &! in
- & coef_rttov, &! in
- & coef_scatt, &! in
- & calcemiss, &! in
- & emissivity_d1, &! inout
- & profiles_tl2, &! in
- & cld_profiles_tl2, &! in
- & emissivity_tl2, &! inout
- & radiance_d1, &! inout
- & radiance_tl2 ) ! inout
-
-
-
-
- !---------------------------
-
- do i_chan = 1, kproma
- if( abs(lambda * radiance_tl%clear(i_chan) - radiance_tl2%clear(i_chan)) > threshold ) then
- write(ioout,*) 'TL test fails for radiance_tl%clear for channel ', i_chan
- stop
- endif
- if( abs(lambda * radiance_tl%bt_clear(i_chan) - radiance_tl2%bt_clear(i_chan)) > threshold ) then
- write(ioout,*) 'TL test fails for radiance_tl%bt_clear for channel ', i_chan
- stop
- endif
- if( abs(lambda * radiance_tl%bt(i_chan) - radiance_tl2%bt(i_chan)) > threshold ) then
- write(ioout,*) 'TL test fails for radiance_tl%bt for channel ', i_chan
- stop
- endif
- if( abs(lambda * radiance_tl%total(i_chan) - radiance_tl2%total(i_chan)) > threshold ) then
- write(ioout,*) 'TL test fails for radiance_tl%total for channel ', i_chan
- stop
- endif
- end do
-
-
-
-
- ! Now run the Taylor test
- !-------------------------
-
-
-
- do i_lambda = 10, 1, -1
- lambda = 10.0_JPRB ** (-1.0_JPRB * i_lambda)
-
- errorstatus = errorstatus_success
-
- emissivity_d2 (1:nchannels) = emissivity_d1 (1:nchannels) + emissivity_tl (1:nchannels) * lambda
- calcemiss (1:nchannels) = emissivity_d2 (1:nchannels) < 0.01_JPRB
-
-!* RTTOV/RTTOVSCATT arrays
- do i_proma = 1, kproma
- profiles_d2 (i_proma) % nlevels = coef_rttov % nlevels
- profiles_d2 (i_proma) % p => p2__p (:,i_proma)
- profiles_d2 (i_proma) % t => p2__t (:,i_proma)
- profiles_d2 (i_proma) % q => p2__q (:,i_proma)
- profiles_d2 (i_proma) % o3 => p2__o3 (:,i_proma)
- profiles_d2 (i_proma) % clw => p2__clw (:,i_proma)
-
- cld_profiles_d2 (i_proma) % nlevels = kflevg
- cld_profiles_d2 (i_proma) % p => cp2__p (:,i_proma)
- cld_profiles_d2 (i_proma) % ph => cp2__ph (:,i_proma)
- cld_profiles_d2 (i_proma) % t => cp2__t (:,i_proma)
- cld_profiles_d2 (i_proma) % q => cp2__q (:,i_proma)
- cld_profiles_d2 (i_proma) % cc => cp2__cc (:,i_proma)
- cld_profiles_d2 (i_proma) % clw => cp2__clw (:,i_proma)
- cld_profiles_d2 (i_proma) % ciw => cp2__ciw (:,i_proma)
- cld_profiles_d2 (i_proma) % rain=> cp2__rain (:,i_proma)
- cld_profiles_d2 (i_proma) % sp => cp2__sp (:,i_proma)
- enddo
-
- radiance_d2 % overcast => r2__overcast
- radiance_d2 % clear_out => r2__clear_out
- radiance_d2 % out => r2__out
- radiance_d2 % out_clear => r2__out_clear
- radiance_d2 % total_out => r2__total_out
- radiance_d2 % clear => r2__clear
- radiance_d2 % cloudy => r2__cloudy
- radiance_d2 % total => r2__total
- radiance_d2 % bt => r2__bt
- radiance_d2 % bt_clear => r2__bt_clear
- radiance_d2 % upclear => r2__upclear
- radiance_d2 % dnclear => r2__dnclear
- radiance_d2 % reflclear => r2__reflclear
- radiance_d2 % downcld => r2__downcld
-
- do i_proma = 1, kproma
-!* Add perturbations
- cld_profiles_d2 (i_proma) % p (:) = cld_profiles_d1 (i_proma) % p (:) + cld_profiles_tl (i_proma) % p (:) * lambda
- cld_profiles_d2 (i_proma) % ph (:) = cld_profiles_d1 (i_proma) % ph (:) + cld_profiles_tl (i_proma) % ph (:) * lambda
-
- cld_profiles_d2 (i_proma) % t (1:kflevg) = cld_profiles_d1 (i_proma) % t (1:kflevg) &
- & + cld_profiles_tl (i_proma) % t (1:kflevg) * lambda
- cld_profiles_d2 (i_proma) % q (1:kflevg) = cld_profiles_d1 (i_proma) % q (1:kflevg) &
- & + cld_profiles_tl (i_proma) % q (1:kflevg) * lambda
- cld_profiles_d2 (i_proma) % cc (1:kflevg) = cld_profiles_d1 (i_proma) % cc (1:kflevg) &
- & + cld_profiles_tl (i_proma) % cc (1:kflevg) * lambda
- cld_profiles_d2 (i_proma) % clw (1:kflevg) = cld_profiles_d1 (i_proma) % clw (1:kflevg) &
- & + cld_profiles_tl (i_proma) % clw (1:kflevg) * lambda
- cld_profiles_d2 (i_proma) % ciw (1:kflevg) = cld_profiles_d1 (i_proma) % ciw (1:kflevg) &
- & + cld_profiles_tl (i_proma) % ciw (1:kflevg) * lambda
- cld_profiles_d2 (i_proma) % rain (1:kflevg) = cld_profiles_d1 (i_proma) % rain (1:kflevg) &
- & + cld_profiles_tl (i_proma) % rain (1:kflevg) * lambda
- cld_profiles_d2 (i_proma) % sp (1:kflevg) = cld_profiles_d1 (i_proma) % sp (1:kflevg) &
- & + cld_profiles_tl (i_proma) % sp (1:kflevg) * lambda
-
-!* Fill in RTTOV/RTTOVSCATT arrays once per profile
- profiles_d2 (i_proma) % p (:) = profiles_d1 (i_proma) % p (:)
- profiles_d2 (i_proma) % clw (:) = profiles_d1 (i_proma) % clw (:) + profiles_tl (i_proma) % clw (:) * lambda
- profiles_d2 (i_proma) % o3 (:) = profiles_d1 (i_proma) % o3 (:) + profiles_tl (i_proma) % o3 (:) * lambda
- profiles_d2 (i_proma) % s2m % p = profiles_d1 (i_proma) % s2m % p + profiles_tl (i_proma) % s2m % p * lambda
- profiles_d2 (i_proma) % s2m % q = profiles_d1 (i_proma) % s2m % q + profiles_tl (i_proma) % s2m % q * lambda
- profiles_d2 (i_proma) % s2m % o = profiles_d1 (i_proma) % s2m % o + profiles_tl (i_proma) % s2m % o * lambda
- profiles_d2 (i_proma) % s2m % t = profiles_d1 (i_proma) % s2m % t + profiles_tl (i_proma) % s2m % t * lambda
- profiles_d2 (i_proma) % s2m % u = profiles_d1 (i_proma) % s2m % u + profiles_tl (i_proma) % s2m % u * lambda
- profiles_d2 (i_proma) % s2m % v = profiles_d1 (i_proma) % s2m % v + profiles_tl (i_proma) % s2m % v * lambda
- profiles_d2 (i_proma) % skin % surftype = profiles_d1 (i_proma) % skin % surftype
- profiles_d2 (i_proma) % skin % t = profiles_d1 (i_proma) % skin % t &
- & + profiles_tl (i_proma) % skin % t * lambda
- profiles_d2 (i_proma) % skin % fastem (:) = profiles_d1 (i_proma) % skin % fastem (:) &
- & + profiles_tl (i_proma) % skin % fastem (:) * lambda
-
- profiles_d2 (i_proma) % ozone_data = .false.
- profiles_d2 (i_proma) % co2_data = .false.
- profiles_d2 (i_proma) % clw_data = .false.
- profiles_d2 (i_proma) % zenangle = zenangle
- profiles_d2 (i_proma) % azangle = 0.0_JPRB ! default value
- profiles_d2 (i_proma) % ctp = 500.0_JPRB ! default value
- profiles_d2 (i_proma) % cfraction = 0.0_JPRB ! default value
-
- profiles_d2 (i_proma) % t (:) = profiles_d1 (i_proma) % t (:) + profiles_tl (i_proma) % t (:) * lambda
- profiles_d2 (i_proma) % q (:) = profiles_d1 (i_proma) % q (:) + profiles_tl (i_proma) % q (:) * lambda
- end do
-
-!* Reference forward model run
- call rttov_scatt (errorstatus, & ! out
- & kflevg, & ! in
- & coef_rttov%nlevels, & ! in
- & nfrequencies, & ! in
- & nchannels, & ! in
- & nbtout, & ! in
- & kproma, & ! in
- & polarisations, & ! in
- & channels, & ! in
- & frequencies, & ! in
- & lprofiles, & ! in
- & lsprofiles, & ! in
- & profiles_d2, & ! inout
- & cld_profiles_d2, & ! in
- & coef_rttov, & ! in
- & coef_scatt, & ! in
- & calcemiss, & ! in
- & emissivity_d2, & ! inout
- & radiance_d2 ) ! inout
-
-
- write(ioout,*)
- write(ioout,*) 'Chan Lambda Cloudy Tb'
-
- do i_chan = 1, nchannels
- ratio(1) = (radiance_d2 % bt(i_chan) - radiance_d1 % bt(i_chan)) / (lambda * radiance_tl % bt(i_chan))
- ratio(2) = (radiance_d2 % bt_clear(i_chan) - radiance_d1 % bt_clear(i_chan)) / (lambda * radiance_tl % bt_clear(i_chan))
- write (ioout,*) i_chan, lambda, ratio(1)
- enddo
- enddo
-
-!* ADJOINT TEST ***********************************************************************************
-
- write(ioout,*)
- write(ioout,*) 'Test AD'
- write(ioout,*) '-------'
- write(ioout,*)
-
- write(ioout,*) '1 - Test Linearity'
- write(ioout,*)
-
-!
- !Allocate new profiles for AD code
-!
-!* RTTOV/RTTOVSCATT arrays
- do i_proma = 1, kproma
- profiles_ad (i_proma) % nlevels = coef_rttov % nlevels
- profiles_ad (i_proma) % p => pad__p (:,i_proma)
- profiles_ad (i_proma) % t => pad__t (:,i_proma)
- profiles_ad (i_proma) % q => pad__q (:,i_proma)
- profiles_ad (i_proma) % o3 => pad__o3 (:,i_proma)
- profiles_ad (i_proma) % clw => pad__clw (:,i_proma)
-
- cld_profiles_ad (i_proma) % nlevels = kflevg
- cld_profiles_ad (i_proma) % p => cpad__p (:,i_proma)
- cld_profiles_ad (i_proma) % ph => cpad__ph (:,i_proma)
- cld_profiles_ad (i_proma) % t => cpad__t (:,i_proma)
- cld_profiles_ad (i_proma) % q => cpad__q (:,i_proma)
- cld_profiles_ad (i_proma) % cc => cpad__cc (:,i_proma)
- cld_profiles_ad (i_proma) % clw => cpad__clw (:,i_proma)
- cld_profiles_ad (i_proma) % ciw => cpad__ciw (:,i_proma)
- cld_profiles_ad (i_proma) % rain=> cpad__rain (:,i_proma)
- cld_profiles_ad (i_proma) % sp => cpad__sp (:,i_proma)
- enddo
-
- radiance_ad % overcast => rad__overcast
- radiance_ad % clear_out => rad__clear_out
- radiance_ad % out => rad__out
- radiance_ad % out_clear => rad__out_clear
- radiance_ad % total_out => rad__total_out
- radiance_ad % clear => rad__clear
- radiance_ad % cloudy => rad__cloudy
- radiance_ad % total => rad__total
- radiance_ad % bt => rad__bt
- radiance_ad % bt_clear => rad__bt_clear
- radiance_ad % upclear => rad__upclear
- radiance_ad % dnclear => rad__dnclear
- radiance_ad % reflclear => rad__reflclear
- radiance_ad % downcld => rad__downcld
-
- do i_proma = 1, kproma
-!* Set perturbation
- cld_profiles_ad (i_proma) % p (:) = 0.0_JPRB
- cld_profiles_ad (i_proma) % ph (:) = 0.0_JPRB
-
- cld_profiles_ad (i_proma) % t (:) = 0.0_JPRB
- cld_profiles_ad (i_proma) % q (:) = 0.0_JPRB
- cld_profiles_ad (i_proma) % cc (:) = 0.0_JPRB
- cld_profiles_ad (i_proma) % clw (:) = 0.0_JPRB
- cld_profiles_ad (i_proma) % ciw (:) = 0.0_JPRB
- cld_profiles_ad (i_proma) % rain (:) = 0.0_JPRB
- cld_profiles_ad (i_proma) % sp (:) = 0.0_JPRB
-
-!* Fill in RTTOV/RTTOVSCATT arrays once per profile
- profiles_ad (i_proma) % p (:) = 0.0_JPRB
- profiles_ad (i_proma) % t (:) = 0.0_JPRB
- profiles_ad (i_proma) % q (:) = 0.0_JPRB
- profiles_ad (i_proma) % clw (:) = 0.0_JPRB
- profiles_ad (i_proma) % o3 (:) = 0.0_JPRB
-
- profiles_ad (i_proma) % s2m % p = 0.0_JPRB
- profiles_ad (i_proma) % s2m % q = 0.0_JPRB
- profiles_ad (i_proma) % s2m % o = 0.0_JPRB
- profiles_ad (i_proma) % s2m % t = 0.0_JPRB
- profiles_ad (i_proma) % s2m % u = 0.0_JPRB
- profiles_ad (i_proma) % s2m % v = 0.0_JPRB
-
- profiles_ad (i_proma) % skin % surftype = -1
- profiles_ad (i_proma) % skin % t = 0.0_JPRB
- profiles_ad (i_proma) % skin % fastem (:) = 0.0_JPRB
-
- profiles_ad (i_proma) % ozone_data = .false.
- profiles_ad (i_proma) % co2_data = .false.
- profiles_ad (i_proma) % clw_data = .false.
- profiles_ad (i_proma) % zenangle = -1
- profiles_ad (i_proma) % azangle = -1
- profiles_ad (i_proma) % ctp = 0.0_JPRB
- profiles_ad (i_proma) % cfraction = 0.0_JPRB
-
- enddo
-
- emissivity_ad (1:nchannels) = 0.0_JPRB
-
-
- ! Set perturbations
- !
- radiance_ad % clear_out(:) = 0._JPRB
- radiance_ad % total_out(:) = 0._JPRB
- radiance_ad % out_clear(:) = 0.05_JPRB * radiance_d1 % out_clear(:)
- radiance_ad % out(:) = 0.05_JPRB * radiance_d1 % out(:)
- radiance_ad % clear(:) = 0._JPRB ! AD does not work for radiance_inc % clear(:) because of switchrad in RTTOV
- radiance_ad % cloudy (:) = 0._JPRB
- radiance_ad % upclear (:) = 0._JPRB
- radiance_ad % reflclear(:) = 0._JPRB
- radiance_ad % overcast (:,:) = 0._JPRB
- radiance_ad % bt (:) = 0._JPRB
- radiance_ad % bt_clear (:) = 0._JPRB
- radiance_ad % total (:) = 0._JPRB
-
-
- call rttov_scatt_ad (errorstatus, &! out
- & kflevg, &! in
- & coef_rttov%nlevels, &! in
- & nfrequencies, &! in
- & nchannels, &! in
- & nbtout, &! in
- & kproma, &! in
- & polarisations, &! in
- & channels, &! in
- & frequencies, &! in
- & lprofiles, &! in
- & lsprofiles, &! in
- & profiles_d1, &! inout
- & cld_profiles_d1, &! in
- & coef_rttov, &! in
- & coef_scatt, &! in
- & calcemiss, &! in
- & emissivity_d1, &! inout
- & profiles_ad, &! in
- & cld_profiles_ad, &! in
- & emissivity_ad, &! inout
- & radiance_d2, &! inout
- & radiance_ad ) ! inout
-
-
- If ( any( errorstatus(:) == errorstatus_fatal ) ) Then
- do i_proma = 1, kproma
- If ( errorstatus(i_proma) == errorstatus_fatal ) Then
- write ( ioout, * ) 'rttov_scatt_ad error for profile',i_proma
- End If
- End Do
- Stop
- End If
-
- If ( Any( abs(radiance_total_ref(:) - radiance_d2%total(:)) > threshold * radiance_total_ref(:) )) Then
- write(default_err_unit,*) 'wrong forward model in AD'
- write(default_err_unit,*) radiance_total_ref(:)
- write(default_err_unit,*) abs(radiance_total_ref(:)-radiance_d2%total(:)) / (threshold * radiance_total_ref(:))
- Stop
- Endif
-
-
- !---------------------------
- ! Second run of AD
-
- !Allocate new profiles for AD code
- ! Profiles on RTTOV pressure levels
-
- do i_proma = 1, kproma
- profiles_ad2 (i_proma) % nlevels = coef_rttov % nlevels
- profiles_ad2 (i_proma) % p => pad2__p (:,i_proma)
- profiles_ad2 (i_proma) % t => pad2__t (:,i_proma)
- profiles_ad2 (i_proma) % q => pad2__q (:,i_proma)
- profiles_ad2 (i_proma) % o3 => pad2__o3 (:,i_proma)
- profiles_ad2 (i_proma) % clw => pad2__clw (:,i_proma)
-
- cld_profiles_ad2 (i_proma) % nlevels = kflevg
- cld_profiles_ad2 (i_proma) % p => cpad2__p (:,i_proma)
- cld_profiles_ad2 (i_proma) % ph => cpad2__ph (:,i_proma)
- cld_profiles_ad2 (i_proma) % t => cpad2__t (:,i_proma)
- cld_profiles_ad2 (i_proma) % q => cpad2__q (:,i_proma)
- cld_profiles_ad2 (i_proma) % cc => cpad2__cc (:,i_proma)
- cld_profiles_ad2 (i_proma) % clw => cpad2__clw (:,i_proma)
- cld_profiles_ad2 (i_proma) % ciw => cpad2__ciw (:,i_proma)
- cld_profiles_ad2 (i_proma) % rain=> cpad2__rain (:,i_proma)
- cld_profiles_ad2 (i_proma) % sp => cpad2__sp (:,i_proma)
- enddo
-
- radiance_ad2 % overcast => rad2__overcast
- radiance_ad2 % clear_out => rad2__clear_out
- radiance_ad2 % out => rad2__out
- radiance_ad2 % out_clear => rad2__out_clear
- radiance_ad2 % total_out => rad2__total_out
- radiance_ad2 % clear => rad2__clear
- radiance_ad2 % cloudy => rad2__cloudy
- radiance_ad2 % total => rad2__total
- radiance_ad2 % bt => rad2__bt
- radiance_ad2 % bt_clear => rad2__bt_clear
- radiance_ad2 % upclear => rad2__upclear
- radiance_ad2 % dnclear => rad2__dnclear
- radiance_ad2 % reflclear => rad2__reflclear
- radiance_ad2 % downcld => rad2__downcld
-
- do i_proma = 1, kproma
-!* Set perturbation
- cld_profiles_ad2 (i_proma) % p (:) = 0.0_JPRB
- cld_profiles_ad2 (i_proma) % ph (:) = 0.0_JPRB
-
- cld_profiles_ad2 (i_proma) % t (:) = 0.0_JPRB
- cld_profiles_ad2 (i_proma) % q (:) = 0.0_JPRB
- cld_profiles_ad2 (i_proma) % cc (:) = 0.0_JPRB
- cld_profiles_ad2 (i_proma) % clw (:) = 0.0_JPRB
- cld_profiles_ad2 (i_proma) % ciw (:) = 0.0_JPRB
- cld_profiles_ad2 (i_proma) % rain (:) = 0.0_JPRB
- cld_profiles_ad2 (i_proma) % sp (:) = 0.0_JPRB
-
-!* Fill in RTTOV/RTTOVSCATT arrays once per profile
- profiles_ad2 (i_proma) % p (:) = 0.0_JPRB
- profiles_ad2 (i_proma) % t (:) = 0.0_JPRB
- profiles_ad2 (i_proma) % q (:) = 0.0_JPRB
- profiles_ad2 (i_proma) % clw (:) = 0.0_JPRB
- profiles_ad2 (i_proma) % o3 (:) = 0.0_JPRB
-
- profiles_ad2 (i_proma) % s2m % p = 0.0_JPRB
- profiles_ad2 (i_proma) % s2m % q = 0.0_JPRB
- profiles_ad2 (i_proma) % s2m % o = 0.0_JPRB
- profiles_ad2 (i_proma) % s2m % t = 0.0_JPRB
- profiles_ad2 (i_proma) % s2m % u = 0.0_JPRB
- profiles_ad2 (i_proma) % s2m % v = 0.0_JPRB
-
- profiles_ad2 (i_proma) % skin % surftype = -1
- profiles_ad2 (i_proma) % skin % t = 0.0_JPRB
- profiles_ad2 (i_proma) % skin % fastem (:) = 0.0_JPRB
-
- profiles_ad2 (i_proma) % ozone_data = .false.
- profiles_ad2 (i_proma) % co2_data = .false.
- profiles_ad2 (i_proma) % clw_data = .false.
- profiles_ad2 (i_proma) % zenangle = -1
- profiles_ad2 (i_proma) % azangle = -1
- profiles_ad2 (i_proma) % ctp = 0.0_JPRB
- profiles_ad2 (i_proma) % cfraction = 0.0_JPRB
-
- enddo
-
- emissivity_ad2 (1:nchannels) = 0.0_JPRB
-
-
- ! Set perturbations
- !
- lambda = 0.5_JPRB
- radiance_ad2 % clear_out(:) = 0._JPRB
- radiance_ad2 % total_out(:) = 0._JPRB
- radiance_ad2 % out_clear(:) = 0.05_JPRB * radiance_d1 % out_clear(:)* lambda
- radiance_ad2 % out(:) = 0.05_JPRB * radiance_d1 % out(:)* lambda
-
- radiance_ad2 % clear(:) = 0._JPRB ! AD does not work for radiance_inc % clear(:) because of switchrad in RTTOV
- radiance_ad2 % cloudy (:) = 0._JPRB
- radiance_ad2 % upclear (:) = 0._JPRB
- radiance_ad2 % reflclear(:) = 0._JPRB
- radiance_ad2 % overcast (:,:) = 0._JPRB
- radiance_ad2 % bt (:) = 0._JPRB
- radiance_ad2 % bt_clear (:) = 0._JPRB
- radiance_ad2 % total (:) = 0._JPRB
-
- call rttov_scatt_ad (errorstatus, &! out
- & kflevg, &! in
- & coef_rttov%nlevels, &! in
- & nfrequencies, &! in
- & nchannels, &! in
- & nbtout, &! in
- & kproma, &! in
- & polarisations, &! in
- & channels, &! in
- & frequencies, &! in
- & lprofiles, &! in
- & lsprofiles, &! in
- & profiles_d1, &! inout
- & cld_profiles_d1, &! in
- & coef_rttov, &! in
- & coef_scatt, &! in
- & calcemiss, &! in
- & emissivity_d1, &! inout
- & profiles_ad2, &! in
- & cld_profiles_ad2, &! in
- & emissivity_ad2, &! inout
- & radiance_d2, &! inout
- & radiance_ad2 ) ! inout
-
-
- If ( any( errorstatus(:) == errorstatus_fatal ) ) Then
- do i_proma = 1, kproma
- If ( errorstatus(i_proma) == errorstatus_fatal ) Then
- write ( ioout, * ) 'rttov_scatt_ad error for profile',i_proma
- End If
- End Do
- Stop
- End If
-
-
- do i_proma = 1, kproma
- do i_lev = 1, profiles_ad (i_proma) % nlevels
- if ( abs(lambda * profiles_ad (i_proma) % t (i_lev) - profiles_ad2 (i_proma) % t (i_lev)) > threshold ) then
- write(default_err_unit,*) 'test AD 1 fails', i_lev
- stop
- End If
- if ( abs(lambda * profiles_ad (i_proma) % q (i_lev) - profiles_ad2 (i_proma) % q (i_lev)) > threshold ) then
- write(default_err_unit,*) 'test AD 2 fails', i_lev
- stop
- End If
- if ( abs(lambda * profiles_ad (i_proma) % o3 (i_lev) - profiles_ad2 (i_proma) % o3 (i_lev)) > threshold ) then
- write(default_err_unit,*) 'test AD 3 fails', i_lev
- stop
- End If
- enddo
- enddo
-
-
- do i_proma = 1, kproma
- do i_lev = 1, cld_profiles_ad (i_proma) % nlevels
-
-
- if ( abs(lambda * cld_profiles_ad (i_proma) % p (i_lev) - cld_profiles_ad2 (i_proma) % p (i_lev)) > threshold ) then
- write(default_err_unit,*) 'test AD 4 fails', i_lev
- stop
- End If
- if ( abs(lambda * cld_profiles_ad (i_proma) % ph (i_lev) - cld_profiles_ad2 (i_proma) % ph (i_lev)) > threshold ) then
- write(default_err_unit,*) 'test AD 5 fails', i_lev
- stop
- End If
- if ( abs(lambda * cld_profiles_ad (i_proma) % t (i_lev) - cld_profiles_ad2 (i_proma) % t (i_lev)) > threshold ) then
- write(default_err_unit,*) 'test AD 6 fails', i_lev
- stop
- End If
- if ( abs(lambda * cld_profiles_ad (i_proma) % cc (i_lev) - cld_profiles_ad2 (i_proma) % cc (i_lev)) > threshold ) then
- write(default_err_unit,*) 'test AD 7 fails', i_lev
- stop
- End If
- if ( abs(lambda * cld_profiles_ad (i_proma) % clw (i_lev) - cld_profiles_ad2 (i_proma) % clw (i_lev)) > threshold ) then
- write(default_err_unit,*) 'test AD 8 fails', i_lev
- stop
- End If
-
- if ( abs(lambda * cld_profiles_ad (i_proma) % ciw (i_lev) - cld_profiles_ad2 (i_proma) % ciw (i_lev)) > threshold ) then
- write(default_err_unit,*) 'test AD 9 fails', i_lev
- stop
- End If
- if ( abs(lambda * cld_profiles_ad (i_proma) % rain (i_lev) - cld_profiles_ad2 (i_proma) % rain (i_lev)) > threshold ) then
- write(default_err_unit,*) 'test AD 10 fails', i_lev
- stop
- End If
- if ( abs(lambda * cld_profiles_ad (i_proma) % sp (i_lev) - cld_profiles_ad2 (i_proma) % sp (i_lev)) > threshold ) then
- write(default_err_unit,*) 'test AD 11 fails', i_lev
- stop
- End If
- enddo
- enddo
-
- do i_proma = 1, kproma
- if ( abs(lambda * profiles_ad (i_proma) % s2m % t - profiles_ad2 (i_proma) % s2m % t) > threshold ) Then
- write(default_err_unit,*) 'test AD 12 fails', i_proma
- stop
- End If
- if ( abs(lambda * profiles_ad (i_proma) % s2m % q - profiles_ad2 (i_proma) % s2m % q) > threshold ) Then
- write(default_err_unit,*) 'test AD 13 fails', i_proma
- stop
- End If
- if ( abs(lambda * profiles_ad (i_proma) % s2m % p - profiles_ad2 (i_proma) % s2m % p) > threshold ) Then
- write(default_err_unit,*) 'test AD 14 fails', i_proma
- stop
- End If
- if ( abs(lambda * profiles_ad (i_proma) % s2m % u - profiles_ad2 (i_proma) % s2m % u) > threshold ) Then
- write(default_err_unit,*) 'test AD 15 fails', i_proma
- stop
- End If
- if ( abs(lambda * profiles_ad (i_proma) % s2m % v - profiles_ad2 (i_proma) % s2m % v) > threshold ) Then
- write(default_err_unit,*) 'test AD 16 fails', i_proma
- stop
- End If
- if ( abs(lambda * profiles_ad (i_proma) % skin % t - profiles_ad2 (i_proma) % skin % t) > threshold ) Then
- write(default_err_unit,*) 'test AD 17 fails', i_proma
- stop
- End If
- enddo
-
- do i_chan = 1, nchannels
- if ( abs(lambda * emissivity_ad (i_chan) - emissivity_ad2 (i_chan) ) > threshold ) Then
- write(default_err_unit,*) 'test AD 18 fails', i_chan
- stop
- End If
- enddo
-
-
-
- write(ioout,*) '2 - Test Equality of Norms'
- write(ioout,*)
-
- do i_proma = 1, kproma
- enddo
-
-
- do i_proma = 1, kproma
-!* Set perturbation
- cld_profiles_tl (i_proma) % p (:) = cld_profiles_d1 (i_proma) % p (:) * epsilon
- cld_profiles_tl (i_proma) % ph (:) = cld_profiles_d1 (i_proma) % ph (:) * epsilon
-
- cld_profiles_tl (i_proma) % t (:) = cld_profiles_d1 (i_proma) % t (:) * epsilon
- cld_profiles_tl (i_proma) % q (:) = cld_profiles_d1 (i_proma) % q (:) * epsilon
- cld_profiles_tl (i_proma) % cc (:) = cld_profiles_d1 (i_proma) % cc (:) * epsilon
- cld_profiles_tl (i_proma) % clw (:) = cld_profiles_d1 (i_proma) % clw (:) * epsilon
- cld_profiles_tl (i_proma) % ciw (:) = cld_profiles_d1 (i_proma) % ciw (:) * epsilon
- cld_profiles_tl (i_proma) % rain (:) = cld_profiles_d1 (i_proma) % rain (:) * epsilon
- cld_profiles_tl (i_proma) % sp (:) = cld_profiles_d1 (i_proma) % sp (:) * epsilon
-
-!* Fill in RTTOV/RTTOVSCATT arrays once per profile
- profiles_tl (i_proma) % clw (:) = profiles_d1 (i_proma) % clw (:) * epsilon
- profiles_tl (i_proma) % o3 (:) = profiles_d1 (i_proma) % o3 (:) * epsilon
- profiles_tl (i_proma) % t (:) = profiles_d1 (i_proma) % t (:) * epsilon
- profiles_tl (i_proma) % q (:) = profiles_d1 (i_proma) % q (:) * epsilon
-
- profiles_tl (i_proma) % s2m % p = profiles_d1 (i_proma) % s2m % p * epsilon
- profiles_tl (i_proma) % s2m % q = profiles_d1 (i_proma) % s2m % q * epsilon
- profiles_tl (i_proma) % s2m % o = profiles_d1 (i_proma) % s2m % o * epsilon
- profiles_tl (i_proma) % s2m % t = profiles_d1 (i_proma) % s2m % t * epsilon
- profiles_tl (i_proma) % s2m % u = profiles_d1 (i_proma) % s2m % u * epsilon
- profiles_tl (i_proma) % s2m % v = profiles_d1 (i_proma) % s2m % v * epsilon
-
- profiles_tl (i_proma) % skin % surftype = -1
- profiles_tl (i_proma) % skin % t = profiles_d1 (i_proma) % skin % t * epsilon
- profiles_tl (i_proma) % skin % fastem (:) = profiles_d1 (i_proma) % skin % fastem (:) * epsilon
-
- profiles_tl (i_proma) % ozone_data = .false.
- profiles_tl (i_proma) % co2_data = .false.
- profiles_tl (i_proma) % clw_data = .false.
- profiles_tl (i_proma) % zenangle = -1
- profiles_tl (i_proma) % azangle = -1
-
- profiles_tl (i_proma) % ctp = profiles_d1 (i_proma) % ctp * epsilon
- profiles_tl (i_proma) % cfraction = profiles_d1 (i_proma) % cfraction * epsilon
-
-!* Set perturbation
- cld_profiles_ad (i_proma) % p (:) = 0.0_JPRB
- cld_profiles_ad (i_proma) % ph (:) = 0.0_JPRB
-
- cld_profiles_ad (i_proma) % t (:) = 0.0_JPRB
- cld_profiles_ad (i_proma) % q (:) = 0.0_JPRB
- cld_profiles_ad (i_proma) % cc (:) = 0.0_JPRB
- cld_profiles_ad (i_proma) % clw (:) = 0.0_JPRB
- cld_profiles_ad (i_proma) % ciw (:) = 0.0_JPRB
- cld_profiles_ad (i_proma) % rain (:) = 0.0_JPRB
- cld_profiles_ad (i_proma) % sp (:) = 0.0_JPRB
-
-!* Fill in RTTOV/RTTOVSCATT arrays once per profile
- profiles_ad (i_proma) % p (:) = 0.0_JPRB
- profiles_ad (i_proma) % t (:) = 0.0_JPRB
- profiles_ad (i_proma) % q (:) = 0.0_JPRB
- profiles_ad (i_proma) % clw (:) = 0.0_JPRB
- profiles_ad (i_proma) % o3 (:) = 0.0_JPRB
-
- profiles_ad (i_proma) % s2m % p = 0.0_JPRB
- profiles_ad (i_proma) % s2m % q = 0.0_JPRB
- profiles_ad (i_proma) % s2m % o = 0.0_JPRB
- profiles_ad (i_proma) % s2m % t = 0.0_JPRB
- profiles_ad (i_proma) % s2m % u = 0.0_JPRB
- profiles_ad (i_proma) % s2m % v = 0.0_JPRB
-
- profiles_ad (i_proma) % skin % surftype = -1
- profiles_ad (i_proma) % skin % t = 0.0_JPRB
- profiles_ad (i_proma) % skin % fastem (:) = 0.0_JPRB
-
- profiles_ad (i_proma) % ozone_data = .false.
- profiles_ad (i_proma) % co2_data = .false.
- profiles_ad (i_proma) % clw_data = .false.
- profiles_ad (i_proma) % zenangle = -1
- profiles_ad (i_proma) % azangle = -1
- profiles_ad (i_proma) % ctp = 0.0_JPRB
- profiles_ad (i_proma) % cfraction = 0.0_JPRB
-
- enddo
-
- emissivity_d1 (1:nchannels) = 0.0_JPRB
- calcemiss (1:nchannels) = emissivity_d1 (1:nchannels) < 0.01_JPRB
-
- emissivity_tl (1:nchannels) = emissivity_d1 (1:nchannels) * epsilon
- emissivity_ad (1:nchannels) = 0.0_JPRB
-
- radiance_tl % total(:) = 0._JPRB
- radiance_tl % bt_clear(:) = 0._JPRB
- radiance_tl % bt(:) = 0._JPRB
-
-
- call rttov_scatt_tl (errorstatus, &! out
- & kflevg, &! in
- & coef_rttov%nlevels, &! in
- & nfrequencies, &! in
- & nchannels, &! in
- & nbtout, &! in
- & kproma, &! in
- & polarisations, &! in
- & channels, &! in
- & frequencies, &! in
- & lprofiles, &! in
- & lsprofiles, &! in
- & profiles_d1, &! inout
- & cld_profiles_d1, &! in
- & coef_rttov, &! in
- & coef_scatt, &! in
- & calcemiss, &! in
- & emissivity_d1, &! inout
- & profiles_tl, &! in
- & cld_profiles_tl, &! in
- & emissivity_tl, &! inout
- & radiance_d3, &! inout
- & radiance_tl ) ! inout
-
- If ( any( errorstatus(:) == errorstatus_fatal ) ) Then
- Do i_proma = 1, kproma
- If ( errorstatus(i_proma) == errorstatus_fatal ) Then
- write (ioout, * ) 'rttov_scatt_tl error for profile',i_proma
- End If
- End Do
- Stop
- End If
-
-
- radiance_tl % clear_out(:) = 0._JPRB
- radiance_tl % total_out(:) = 0._JPRB
-
- !* compute <subtl(delta_x),delta_z>
-
- zdelta1 = 0.0_JPRB
-
- do i_chan = 1, nbtout
- zdelta1 = zdelta1 + (radiance_tl % out (i_chan)) ** 2.0_JPRB
- enddo
-
-!* Initialize
- radiance_ad % overcast = 0.0_JPRB
- radiance_ad % clear_out = 0.0_JPRB
- radiance_ad % out = 0.0_JPRB
- radiance_ad % out_clear = 0.0_JPRB
- radiance_ad % total_out = 0.0_JPRB
- radiance_ad % clear = 0.0_JPRB
- radiance_ad % cloudy = 0.0_JPRB
- radiance_ad % total = 0.0_JPRB
-! radiance_ad % bt = radiance_tl % bt
- radiance_ad % out = radiance_tl % out
- radiance_ad % bt_clear = 0.0_JPRB
- radiance_ad % upclear = 0.0_JPRB
- radiance_ad % dnclear = 0.0_JPRB
- radiance_ad % reflclear = 0.0_JPRB
- radiance_ad % downcld = 0.0_JPRB
-
- radiance_d1 % overcast = 0.0_JPRB
- radiance_d1 % clear_out = 0.0_JPRB
- radiance_d1 % out = 0.0_JPRB
- radiance_d1 % out_clear = 0.0_JPRB
- radiance_d1 % total_out = 0.0_JPRB
- radiance_d1 % clear = 0.0_JPRB
- radiance_d1 % cloudy = 0.0_JPRB
- radiance_d1 % total = 0.0_JPRB
- radiance_d1 % bt = 0.0_JPRB
- radiance_d1 % bt_clear = 0.0_JPRB
- radiance_d1 % upclear = 0.0_JPRB
- radiance_d1 % dnclear = 0.0_JPRB
- radiance_d1 % reflclear = 0.0_JPRB
- radiance_d1 % downcld = 0.0_JPRB
-
-
- !---------------------------
- ! Now run AD code with TL radiances in input
- ! move TL results to AD radiance increments
-
- do i_proma = 1, kproma
-!* Set perturbation
- cld_profiles_ad (i_proma) % p (:) = 0.0_JPRB
- cld_profiles_ad (i_proma) % ph (:) = 0.0_JPRB
-
- cld_profiles_ad (i_proma) % t (:) = 0.0_JPRB
- cld_profiles_ad (i_proma) % q (:) = 0.0_JPRB
- cld_profiles_ad (i_proma) % cc (:) = 0.0_JPRB
- cld_profiles_ad (i_proma) % clw (:) = 0.0_JPRB
- cld_profiles_ad (i_proma) % ciw (:) = 0.0_JPRB
- cld_profiles_ad (i_proma) % rain (:) = 0.0_JPRB
- cld_profiles_ad (i_proma) % sp (:) = 0.0_JPRB
-
-!* Fill in RTTOV/RTTOVSCATT arrays once per profile
- profiles_ad (i_proma) % p (:) = 0.0_JPRB
- profiles_ad (i_proma) % t (:) = 0.0_JPRB
- profiles_ad (i_proma) % q (:) = 0.0_JPRB
- profiles_ad (i_proma) % clw (:) = 0.0_JPRB
- profiles_ad (i_proma) % o3 (:) = 0.0_JPRB
-
- profiles_ad (i_proma) % s2m % p = 0.0_JPRB
- profiles_ad (i_proma) % s2m % q = 0.0_JPRB
- profiles_ad (i_proma) % s2m % o = 0.0_JPRB
- profiles_ad (i_proma) % s2m % t = 0.0_JPRB
- profiles_ad (i_proma) % s2m % u = 0.0_JPRB
- profiles_ad (i_proma) % s2m % v = 0.0_JPRB
-
- profiles_ad (i_proma) % skin % surftype = -1
- profiles_ad (i_proma) % skin % t = 0.0_JPRB
- profiles_ad (i_proma) % skin % fastem (:) = 0.0_JPRB
-
- profiles_ad (i_proma) % ozone_data = .false.
- profiles_ad (i_proma) % co2_data = .false.
- profiles_ad (i_proma) % clw_data = .false.
- profiles_ad (i_proma) % zenangle = -1
- profiles_ad (i_proma) % azangle = -1
- profiles_ad (i_proma) % ctp = 0.0_JPRB
- profiles_ad (i_proma) % cfraction = 0.0_JPRB
-
- enddo!* Initialize
- emissivity_ad(:) = 0._JPRB
-
- radiance_ad % overcast = 0.0_JPRB
- radiance_ad % clear_out = 0.0_JPRB
- radiance_ad % out = 0.0_JPRB
- radiance_ad % out_clear = 0.0_JPRB
- radiance_ad % total_out = 0.0_JPRB
- radiance_ad % clear = 0.0_JPRB
- radiance_ad % cloudy = 0.0_JPRB
- radiance_ad % total = 0.0_JPRB
- radiance_ad % bt = 0.0_JPRB
- radiance_ad % bt_clear = 0.0_JPRB
- radiance_ad % upclear = 0.0_JPRB
- radiance_ad % dnclear = 0.0_JPRB
- radiance_ad % reflclear = 0.0_JPRB
- radiance_ad % downcld = 0.0_JPRB
-
- radiance_ad % out_clear(:) = radiance_tl % out_clear(:)
- radiance_ad % out(:) = radiance_tl % out(:)
-
-
- call rttov_scatt_ad (errorstatus, &! out
- & kflevg, &! in
- & coef_rttov%nlevels, &! in
- & nfrequencies, &! in
- & nchannels, &! in
- & nbtout, &! in
- & kproma, &! in
- & polarisations, &! in
- & channels, &! in
- & frequencies, &! in
- & lprofiles, &! in
- & lsprofiles, &! in
- & profiles_d1, &! inout
- & cld_profiles_d1, &! in
- & coef_rttov, &! in
- & coef_scatt, &! in
- & calcemiss, &! in
- & emissivity_d1, &! inout
- & profiles_ad, &! in
- & cld_profiles_ad, &! in
- & emissivity_ad, &! inout
- & radiance_d2, &! inout
- & radiance_ad ) ! inout
-
- If ( any( errorstatus(:) == errorstatus_fatal ) ) Then
- Do i_proma = 1, kproma
- If ( errorstatus(i_proma) == errorstatus_fatal ) Then
- write ( ioout, * ) 'rttov_scatt_ad error for profile',i_proma
- End If
- End Do
- Stop
- End If
-
- !* compute <delta_x,subad(delta_z)>
-
- zdelta2 = 0.0_JPRB
-
- do i_proma = 1, kproma
- do i_lev = 1, kflevg
- zdelta2 = zdelta2 &
- & + cld_profiles_tl (i_proma) % p (i_lev) * cld_profiles_ad (i_proma) % p (i_lev) &
- & + cld_profiles_tl (i_proma) % t (i_lev) * cld_profiles_ad (i_proma) % t (i_lev) &
- & + cld_profiles_tl (i_proma) % q (i_lev) * cld_profiles_ad (i_proma) % q (i_lev) &
- & + cld_profiles_tl (i_proma) % cc (i_lev) * cld_profiles_ad (i_proma) % cc (i_lev) &
- & + cld_profiles_tl (i_proma) % clw (i_lev) * cld_profiles_ad (i_proma) % clw (i_lev) &
- & + cld_profiles_tl (i_proma) % ciw (i_lev) * cld_profiles_ad (i_proma) % ciw (i_lev) &
- & + cld_profiles_tl (i_proma) % rain (i_lev) * cld_profiles_ad (i_proma) % rain (i_lev) &
- & + cld_profiles_tl (i_proma) % sp (i_lev) * cld_profiles_ad (i_proma) % sp (i_lev)
- enddo
-
- do i_lev = 1, kflevg + 1
- zdelta2 = zdelta2 &
- & + cld_profiles_tl (i_proma) % ph (i_lev) * cld_profiles_ad (i_proma) % ph (i_lev)
- enddo
-
- do i_lev = 1, coef_rttov % nlevels
- zdelta2 = zdelta2 &
- & + profiles_tl (i_proma) % p (i_lev) * profiles_ad (i_proma) % p (i_lev) &
- & + profiles_tl (i_proma) % t (i_lev) * profiles_ad (i_proma) % t (i_lev) &
- & + profiles_tl (i_proma) % q (i_lev) * profiles_ad (i_proma) % q (i_lev) &
- & + profiles_tl (i_proma) % clw (i_lev) * profiles_ad (i_proma) % clw (i_lev) &
- & + profiles_tl (i_proma) % o3 (i_lev) * profiles_ad (i_proma) % o3 (i_lev)
- enddo
-
- zdelta2 = zdelta2 + profiles_tl (i_proma) % s2m % p * profiles_ad (i_proma) % s2m % p
- zdelta2 = zdelta2 + profiles_tl (i_proma) % s2m % q * profiles_ad (i_proma) % s2m % q
- zdelta2 = zdelta2 + profiles_tl (i_proma) % s2m % o * profiles_ad (i_proma) % s2m % o
- zdelta2 = zdelta2 + profiles_tl (i_proma) % s2m % t * profiles_ad (i_proma) % s2m % t
- zdelta2 = zdelta2 + profiles_tl (i_proma) % s2m % u * profiles_ad (i_proma) % s2m % u
- zdelta2 = zdelta2 + profiles_tl (i_proma) % s2m % v * profiles_ad (i_proma) % s2m % v
-
- zdelta2 = zdelta2 + profiles_tl (i_proma) % skin % t * profiles_ad (i_proma) % skin % t
-
- do i_fast = 1, fastem_sp
- zdelta2 = zdelta2 + profiles_tl (i_proma) % skin % fastem (i_fast) * profiles_ad (i_proma) % skin % fastem (i_fast)
- enddo
-
- zdelta2 = zdelta2 + profiles_tl (i_proma) % ctp * profiles_ad (i_proma) % ctp
- zdelta2 = zdelta2 + profiles_tl (i_proma) % cfraction * profiles_ad (i_proma) % cfraction
-
- do i_chan = 1, nchannels
- zdelta2 = zdelta2 + emissivity_tl (i_chan) * emissivity_ad (i_chan)
- enddo
- enddo
-
- if (zdelta2 == 0._JPRB) then
- z = 1._JPRB
- else
- z = zdelta2
- endif
-
-
- write (ioout,*) 'delta1 = ', zdelta1
- write (ioout,*) 'delta1 = ', zdelta2
-
- write (ioout,fmt= &
- & '('' The difference is '',f9.3, '' times the zero of the machine '')') &
- & abs(zdelta2-zdelta1)/threshold/z
-
-!* K-TEST ***********************************************************************************
-
- write(ioout,*)
- write(ioout,*) 'Test K'
- write(ioout,*) '------'
- write(ioout,*)
-
-
- do i_btout = 1, nbtout
- profiles_k (i_btout) % nlevels = coef_rttov % nlevels
- profiles_k (i_btout) % p => pk__p (:,i_btout)
- profiles_k (i_btout) % t => pk__t (:,i_btout)
- profiles_k (i_btout) % q => pk__q (:,i_btout)
- profiles_k (i_btout) % o3 => pk__o3 (:,i_btout)
- profiles_k (i_btout) % clw => pk__clw (:,i_btout)
-
- cld_profiles_k (i_btout) % nlevels = kflevg
- cld_profiles_k (i_btout) % p => cpk__p (:,i_btout)
- cld_profiles_k (i_btout) % ph => cpk__ph (:,i_btout)
- cld_profiles_k (i_btout) % t => cpk__t (:,i_btout)
- cld_profiles_k (i_btout) % q => cpk__q (:,i_btout)
- cld_profiles_k (i_btout) % cc => cpk__cc (:,i_btout)
- cld_profiles_k (i_btout) % clw => cpk__clw (:,i_btout)
- cld_profiles_k (i_btout) % ciw => cpk__ciw (:,i_btout)
- cld_profiles_k (i_btout) % rain=> cpk__rain (:,i_btout)
- cld_profiles_k (i_btout) % sp => cpk__sp (:,i_btout)
-
- cld_profiles_k (i_btout) % p (:) = 0.0_JPRB
- cld_profiles_k (i_btout) % ph (:) = 0.0_JPRB
-
- cld_profiles_k (i_btout) % t (1:kflevg) = 0.0_JPRB
- cld_profiles_k (i_btout) % q (1:kflevg) = 0.0_JPRB
- cld_profiles_k (i_btout) % cc (1:kflevg) = 0.0_JPRB
- cld_profiles_k (i_btout) % clw (1:kflevg) = 0.0_JPRB
- cld_profiles_k (i_btout) % ciw (1:kflevg) = 0.0_JPRB
- cld_profiles_k (i_btout) % rain (1:kflevg) = 0.0_JPRB
- cld_profiles_k (i_btout) % sp (1:kflevg) = 0.0_JPRB
-
- cld_profiles_k (i_btout) % cc (1:kflevg) = 0.0_JPRB
-
- profiles_k (i_btout) % p (:) = 0.0_JPRB
- profiles_k (i_btout) % clw (:) = 0.0_JPRB
- profiles_k (i_btout) % o3 (:) = 0.0_JPRB
- profiles_k (i_btout) % s2m % p = 0.0_JPRB
- profiles_k (i_btout) % s2m % q = 0.0_JPRB
- profiles_k (i_btout) % s2m % o = 0.0_JPRB
- profiles_k (i_btout) % s2m % t = 0.0_JPRB
- profiles_k (i_btout) % s2m % u = 0.0_JPRB
- profiles_k (i_btout) % s2m % v = 0.0_JPRB
- profiles_k (i_btout) % skin % surftype = -1
- profiles_k (i_btout) % skin % t = 0.0_JPRB
- profiles_k (i_btout) % skin % fastem (:) = 0.0_JPRB
-
- profiles_k (i_btout) % ozone_data = .false.
- profiles_k (i_btout) % co2_data = .false.
- profiles_k (i_btout) % clw_data = .false.
- profiles_k (i_btout) % zenangle = -1
- profiles_k (i_btout) % azangle = -1
- profiles_k (i_btout) % ctp = 0.0_JPRB
- profiles_k (i_btout) % cfraction = 0.0_JPRB
-
- profiles_k (i_btout) % t (:) = 0.0_JPRB
- profiles_k (i_btout) % q (:) = 0.0_JPRB
- enddo
-
- emissivity_d1 (1:nchannels) = 0.0_JPRB
- calcemiss (1:nchannels) = emissivity_d1 (1:nchannels) < 0.01_JPRB
- emissivity_k (1:nchannels) = 0.0_JPRB
-
- call rttov_scatt_k (errorstatus, &! out
- & kflevg, &! in
- & coef_rttov%nlevels, &! in
- & nfrequencies, &! in
- & nchannels, &! in
- & nbtout, &! in
- & kproma, &! in
- & polarisations, &! in
- & channels, &! in
- & frequencies, &! in
- & lprofiles, &! in
- & lsprofiles, &! in
- & profiles_d1, &! inout
- & cld_profiles_d1, &! in
- & coef_rttov, &! in
- & coef_scatt, &! in
- & calcemiss, &! in
- & emissivity_d1, &! inout
- & profiles_k, &! in
- & cld_profiles_k, &! in
- & emissivity_k, &! inout
- & radiance_d1) ! inout
-
- If ( Any( abs(radiance_total_ref(:) - radiance_d1 % total(:)) > threshold * radiance_total_ref(:) )) Then
- write(ioout,*) 'wrong forward model in K'
- write(ioout,*) radiance_total_ref(:)
- write(ioout,*) radiance_d1 % total(:)
- write(ioout,*) abs(radiance_total_ref(:)-radiance_d1 %total(:)) / ( threshold * radiance_total_ref(:))
- Stop
- Endif
-
- !---------------------------
- ! Compares K to AD
-
-!* Write out Jacobian matrices
- do i_btout = 1, nchannels
- radiance_ad % overcast = 0.0_JPRB
- radiance_ad % clear = 0.0_JPRB
- radiance_ad % cloudy = 0.0_JPRB
- radiance_ad % total = 0.0_JPRB
- radiance_ad % bt = 0.0_JPRB
- radiance_ad % bt_clear = 0.0_JPRB
- radiance_ad % upclear = 0.0_JPRB
- radiance_ad % dnclear = 0.0_JPRB
- radiance_ad % reflclear = 0.0_JPRB
- radiance_ad % downcld = 0.0_JPRB
- enddo
-
- do i_btout = 1, nbtout
- radiance_ad % clear_out = 0.0_JPRB
- radiance_ad % out = 0.0_JPRB
- radiance_ad % out_clear = 0.0_JPRB
- radiance_ad % total_out = 0.0_JPRB
-
-! radiance_ad % bt (i_btout) = 1.0_JPRB
- radiance_ad % out (i_btout) = 1.0_JPRB
-
- do i_proma = 1, kproma
-!* Reset perturbations
- cld_profiles_ad (i_proma) % p (:) = 0.0_JPRB
- cld_profiles_ad (i_proma) % ph (:) = 0.0_JPRB
-
- cld_profiles_ad (i_proma) % t (:) = 0.0_JPRB
- cld_profiles_ad (i_proma) % q (:) = 0.0_JPRB
- cld_profiles_ad (i_proma) % cc (:) = 0.0_JPRB
- cld_profiles_ad (i_proma) % clw (:) = 0.0_JPRB
- cld_profiles_ad (i_proma) % ciw (:) = 0.0_JPRB
- cld_profiles_ad (i_proma) % rain (:) = 0.0_JPRB
- cld_profiles_ad (i_proma) % sp (:) = 0.0_JPRB
-
-!* Fill in RTTOV/RTTOVSCATT arrays once per profile
- profiles_ad (i_proma) % p (:) = 0.0_JPRB
- profiles_ad (i_proma) % t (:) = 0.0_JPRB
- profiles_ad (i_proma) % q (:) = 0.0_JPRB
- profiles_ad (i_proma) % clw (:) = 0.0_JPRB
- profiles_ad (i_proma) % o3 (:) = 0.0_JPRB
-
- profiles_ad (i_proma) % s2m % p = 0.0_JPRB
- profiles_ad (i_proma) % s2m % q = 0.0_JPRB
- profiles_ad (i_proma) % s2m % o = 0.0_JPRB
- profiles_ad (i_proma) % s2m % t = 0.0_JPRB
- profiles_ad (i_proma) % s2m % u = 0.0_JPRB
- profiles_ad (i_proma) % s2m % v = 0.0_JPRB
-
- profiles_ad (i_proma) % skin % surftype = -1
- profiles_ad (i_proma) % skin % t = 0.0_JPRB
- profiles_ad (i_proma) % skin % fastem (:) = 0.0_JPRB
-
- profiles_ad (i_proma) % ozone_data = .false.
- profiles_ad (i_proma) % co2_data = .false.
- profiles_ad (i_proma) % clw_data = .false.
- profiles_ad (i_proma) % zenangle = -1
- profiles_ad (i_proma) % azangle = -1
- profiles_ad (i_proma) % ctp = 0.0_JPRB
- profiles_ad (i_proma) % cfraction = 0.0_JPRB
- enddo
-
-! emissivity_d1 (1:nchannels) = 0.0_JPRB
-! calcemiss (1:nchannels) = emissivity_d1 (1:nchannels) < 0.01_JPRB
- emissivity_ad (1:nchannels) = 0.0_JPRB
-
-
- call rttov_scatt_ad (errorstatus, &! out
- & kflevg, &! in
- & coef_rttov%nlevels, &! in
- & nfrequencies, &! in
- & nchannels, &! in
- & nbtout, &! in
- & kproma, &! in
- & polarisations, &! in
- & channels, &! in
- & frequencies, &! in
- & lprofiles, &! in
- & lsprofiles, &! in
- & profiles_d1, &! inout
- & cld_profiles_d1, &! in
- & coef_rttov, &! in
- & coef_scatt, &! in
- & calcemiss, &! in
- & emissivity_d1, &! inout
- & profiles_ad, &! in
- & cld_profiles_ad, &! in
- & emissivity_ad, &! inout
- & radiance_d2, &! inout
- & radiance_ad ) ! inout
-
-
-
-
- i_proma = lsprofiles2 (i_btout)
-
-
- do i_lev = 1, profiles_ad(i_proma) % nlevels
-
- if ( abs (profiles_ad (i_proma) % p (i_lev) - profiles_k (i_btout) % p (i_lev)) > threshold ) then
- write(ioout,*) 'test K 1 fails',i_lev
- Stop
- End If
- if ( abs (profiles_ad (i_proma) % t (i_lev) - profiles_k (i_btout) % t (i_lev)) > threshold ) then
- write(ioout,*) 'test K 2 fails',i_lev
- Stop
- End If
- if ( abs (profiles_ad (i_proma) % q (i_lev) - profiles_k (i_btout) % q (i_lev)) > threshold ) then
- write(ioout,*) 'test K 3 fails',i_lev
- Stop
- End If
- if ( abs (profiles_ad (i_proma) % o3 (i_lev) - profiles_k (i_btout) % o3 (i_lev)) > threshold ) then
- write(ioout,*) 'test K 4 fails',i_lev
- Stop
- End If
- End Do
-
- do i_lev = 1, cld_profiles_ad(i_proma) % nlevels
- if ( abs (cld_profiles_ad (i_proma) % p (i_lev) - cld_profiles_k (i_btout) % p (i_lev)) > threshold ) then
- write(ioout,*) 'test K 5 fails',' prof ', i_proma, 'level ',i_lev
- Stop
- End If
- if ( abs (cld_profiles_ad (i_proma) % ph (i_lev) - cld_profiles_k (i_btout) % ph (i_lev)) > threshold ) then
- write(ioout,*) 'test K 6 fails',i_lev
- Stop
- End If
- if ( abs (cld_profiles_ad (i_proma) % t (i_lev) - cld_profiles_k (i_btout) % t (i_lev)) > threshold ) then
- write(ioout,*) 'test K 7 fails',i_lev
- Stop
- End If
- if ( abs (cld_profiles_ad (i_proma) % cc (i_lev) - cld_profiles_k (i_btout) % cc (i_lev)) > threshold ) then
- write(ioout,*) 'test K 8 fails',i_lev
- Stop
- End If
- if ( abs (cld_profiles_ad (i_proma) % clw (i_lev) - cld_profiles_k (i_btout) % clw (i_lev)) > threshold ) then
- write(ioout,*) 'test K 9 fails', i_lev
- Stop
- End If
- if ( abs (cld_profiles_ad (i_proma) % ciw (i_lev) - cld_profiles_k (i_btout) % ciw (i_lev)) > threshold ) then
- write(ioout,*) 'test K 10 fails',i_lev
- Stop
- End If
- if ( abs (cld_profiles_ad (i_proma) % rain (i_lev) - cld_profiles_k (i_btout) % rain (i_lev)) > threshold ) then
- write(ioout,*) 'test K 11 fails',i_lev
- Stop
- End If
- if ( abs (cld_profiles_ad (i_proma) % sp (i_lev) - cld_profiles_k (i_btout) % sp (i_lev)) > threshold ) then
- write(ioout,*) 'test K 12 fails',i_lev
- Stop
- End If
- End Do
-
- if ( abs (profiles_ad (i_proma) % s2m % p - profiles_k (i_btout) % s2m % p) > threshold ) then
- write(ioout,*) 'test K 13 fails',i_lev
- Stop
- End If
- if ( abs (profiles_ad (i_proma) % s2m % q - profiles_k (i_btout) % s2m % q) > threshold ) then
- write(ioout,*) 'test K 14 fails',i_lev
- Stop
- End If
- if ( abs (profiles_ad (i_proma) % s2m % o - profiles_k (i_btout) % s2m % o) > threshold ) then
- write(ioout,*) 'test K 15 fails',i_lev
- Stop
- End If
- if ( abs (profiles_ad (i_proma) % s2m % t - profiles_k (i_btout) % s2m % t) > threshold ) then
- write(ioout,*) 'test K 16 fails',i_lev
- Stop
- End If
- if ( abs (profiles_ad (i_proma) % s2m % u - profiles_k (i_btout) % s2m % u) > threshold ) then
- write(ioout,*) 'test K 17 fails',i_lev
- Stop
- End If
- if ( abs (profiles_ad (i_proma) % s2m % v - profiles_k (i_btout) % s2m % v) > threshold ) then
- write(ioout,*) 'test K 18 fails',i_lev
- Stop
- End If
- if ( abs (profiles_ad (i_proma) % skin % t - profiles_k (i_btout) % skin % t) > threshold ) then
- write(ioout,*) 'test K 19 fails',i_lev
- Stop
- End If
-
- if ( abs (profiles_ad (i_proma) % ctp - profiles_k (i_btout) % ctp) > threshold ) then
- write(ioout,*) 'test K 21 fails',i_lev
- Stop
- End If
- if ( abs (profiles_ad (i_proma) % cfraction - profiles_k (i_btout) % cfraction) > threshold ) then
- write(ioout,*) 'test K 22 fails',i_lev
- Stop
- End If
-
- npol=polarisations(i_btout,3)
- j=-1
- do i_pol = 1, npol
- i_chan=polarisations(i_btout,1)+(1+j)
- if ( abs (emissivity_ad (i_chan) - emissivity_k (i_chan) ) > threshold ) then
- write(ioout,*) 'test K 23 fails',i_lev
- Stop
- End If
- j=j+1
- enddo
- enddo
-
- write(ioout,*) 'K is ok'
- write(ioout,*)
- write(ioout,*) 'End of RTTOVSCATT tests'
- close (ioout)
-
-
-1111 format (a6,1x,100(1x,E12.6))
-
-End subroutine rttov_scatt_test
-
-!*******
-
diff --git a/src/LIB/RTTOV/src/rttov_scatt_test.interface b/src/LIB/RTTOV/src/rttov_scatt_test.interface
deleted file mode 100644
index f3179c6deeac8a8b623ff899f53e9939f870ca12..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_scatt_test.interface
+++ /dev/null
@@ -1,57 +0,0 @@
-INTERFACE
- subroutine rttov_scatt_test (nfrequencies, nchannels, nbtout, coef_rttov, coef_scatt, &
- & lprofiles , &
- & lsprofiles , &
- & lsprofiles2 , &
- & channels , &
- & frequencies , &
- & polarisations , &
- & emissivity)
-
- Use mod_rttov_scatt_test
-
- Use rttov_const, only : &
- & errorstatus_fatal, &
- & errorstatus_success, &
- & default_err_unit, &
- & sensor_id_mw, &
- & npolar_return, &
- & npolar_compute, &
- & fastem_sp ,&
- & inst_id_ssmi ,&
- & inst_id_amsua ,&
- & inst_id_amsub
-
- Use mod_cparam, only : &
- & q_mixratio_to_ppmv
-
- Use rttov_types, only : &
- & geometry_type ,&
- & rttov_coef ,&
- & rttov_scatt_coef ,&
- & profile_type ,&
- & profile_cloud_type ,&
- & transmission_type ,&
- & radiance_cloud_type ,&
- & profile_scatt_aux
-
-
- Use parkind1, only: jpim ,jprb
-
- IMPLICIT NONE
-
- integer (kind=jpim), intent (in) :: nfrequencies, nchannels, nbtout
- real (kind=jprb), intent (in) , dimension (nchannels) :: emissivity
- integer (kind=jpim), intent (in) , dimension (nchannels,3) :: polarisations
- integer (kind=jpim), intent (in) , dimension (nfrequencies) :: channels
- integer (kind=jpim), intent (in) , dimension (nchannels) :: frequencies
- integer (kind=jpim), intent (in) , dimension (nfrequencies) :: lprofiles
- integer (kind=jpim), intent (in) , dimension (nchannels) :: lsprofiles
- integer (kind=jpim), intent (in) , dimension (nbtout) :: lsprofiles2
-
- type (rttov_coef ), intent (inout) :: coef_rttov
- type (rttov_scatt_coef), intent (inout) :: coef_scatt
-
-End subroutine rttov_scatt_test
-END INTERFACE
-
diff --git a/src/LIB/RTTOV/src/rttov_scatt_tl.F90 b/src/LIB/RTTOV/src/rttov_scatt_tl.F90
deleted file mode 100644
index b67a801426b7ee41d465da22e3867c3186bb5b07..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_scatt_tl.F90
+++ /dev/null
@@ -1,507 +0,0 @@
-!
-Subroutine rttov_scatt_tl( &
- & errorstatus, &! out
- & nwp_levels, &! in
- & nrt_levels, &! in
- & nfrequencies, &! in
- & nchannels, &! in
- & nbtout, &! in
- & nprofiles, &! in
- & polarisations, &! in
- & channels, &! in
- & frequencies, &! in
- & lprofiles, &! in
- & lsprofiles, &! in
- & profiles, &! inout
- & cld_profiles, &! in
- & coef_rttov, &! in
- & coef_scatt, &! in
- & calcemiss, &! in
- & emissivity_in, &! inout
- & profiles_tl, &! in
- & cld_profiles_tl, &! in
- & emissivity_in_tl, &! inout
- & cld_radiance, &! inout
- & cld_radiance_tl) ! inout
-
- ! Description:
- ! TL of subroutine
- ! to compute microwave multi-channel radiances and brightness
- ! temperatures for many profiles per call in a cloudy and/or rainy sky.
- !
- ! Copyright:
- ! This software was developed within the context of
- ! the EUMETSAT Satellite Application Facility on
- ! Numerical Weather Prediction (NWP SAF), under the
- ! Cooperation Agreement dated 25 November 1998, between
- ! EUMETSAT and the Met Office, UK, by one or more partners
- ! within the NWP SAF. The partners in the NWP SAF are
- ! the Met Office, ECMWF, KNMI and MeteoFrance.
- !
- ! Copyright 2002, EUMETSAT, All Rights Reserved.
- !
- ! Method:
- ! - Bauer, P., 2002: Microwave radiative transfer modeling in clouds and precipitation.
- ! Part I: Model description.
- ! NWP SAF Report No. NWPSAF-EC-TR-005, 21 pp.
- ! - Moreau, E., P. Bauer and F. Chevallier, 2002: Microwave radiative transfer modeling in clouds and precipitation.
- ! Part II: Model evaluation.
- ! NWP SAF Report No. NWPSAF-EC-TR-006, 27 pp.
- ! - Chevallier, F., and P. Bauer, 2003:
- ! Model rain and clouds over oceans:comparison with SSM/I observations. Mon. Wea. Rev., 131, 1240-1255.
- ! - Smith, E. A., P. Bauer, F. S. Marzano, C. D. Kummerow, D. McKague, A. Mugnai, G. Panegrossi, 2002:
- ! Intercomparison of microwave radiative transfer models for precipitating clouds.
- ! IEEE Trans. Geosci. Remote Sens. 40, 541-549.
- !
- ! Current Code Owner: SAF NWP
- !
- ! History:
- ! Version Date Comment
- ! ------- ---- -------
- ! 1.0 09/2002 Initial version (F. Chevallier)
- ! 1.1 05/2003 RTTOV7.3 compatible (F. Chevallier)
- ! 1.2 03/2004 Added polarimetry (R. Saunders)
- ! 1.3 08/2004 Polarimetry fixes (U. O'Keeffe)
- ! 1.4 11/2004 Clean-up (P. Bauer)
- ! 1.5 07/2005 Polarimetry fixes (U. O'Keeffe)
- ! 1.6 11/2005 Add errorstatus to iniscatt arguments and use a temporary
- ! radiance type for the calcpolarisation call (J Cameron)
- !
- ! Code Description:
- ! Language: Fortran 90.
- ! Software Standards: "European Standards for Writing and
- ! Documenting Exchangeable Fortran 90 Code".
- !
- ! Declarations:
- ! Modules used:
- ! Imported Parameters:
-
- Use rttov_const, Only : &
- & sensor_id_mw ,&
- & errorstatus_success ,&
- & errorstatus_fatal
-
- Use rttov_types, Only : &
- & rttov_coef ,&
- & rttov_scatt_coef ,&
- & geometry_Type ,&
- & profile_Type ,&
- & profile_cloud_Type ,&
- & profile_scatt_aux ,&
- & transmission_Type ,&
- & radiance_Type ,&
- & radiance_cloud_Type
-
- Use parkind1, Only : jpim ,jprb
-
- Implicit None
-
-#include "rttov_tl.interface"
-#include "rttov_iniscatt_tl.interface"
-#include "rttov_eddington_tl.interface"
-#include "rttov_errorreport.interface"
-#include "rttov_calcpolarisation.interface"
-#include "rttov_calcpolarisation_tl.interface"
-
-!* Subroutine arguments:
- Integer (Kind=jpim), Intent (in) :: nwp_levels ! Number of levels
- Integer (Kind=jpim), Intent (in) :: nrt_levels ! Number of levels
- Integer (Kind=jpim), Intent (in) :: nprofiles ! Number of profiles
- Integer (Kind=jpim), Intent (in) :: nfrequencies ! Number of frequencies
- Integer (Kind=jpim), Intent (in) :: nchannels ! Number of channels*profiles=radiances
- Integer (Kind=jpim), Intent (in) :: nbtout ! Number of output radiances
- Integer (Kind=jpim), Intent (in) :: channels (nfrequencies) ! Channel indices
- Integer (Kind=jpim), Intent (in) :: frequencies (nchannels) ! Frequency indices
- Integer (Kind=jpim), Intent (in) :: polarisations (nchannels,3) ! Polarisation indices
- Integer (Kind=jpim), Intent (in) :: lprofiles (nfrequencies) ! Profile indices
- Integer (Kind=jpim), Intent (in) :: lsprofiles (nchannels) ! Profile indices
- Integer (Kind=jpim), Intent (out) :: errorstatus (nprofiles) ! Error return flag
-
- Logical, Intent (in) :: calcemiss (nchannels) ! Switch for emmissivity calculation
- Real (Kind=jprb), Intent (in) :: emissivity_in (nchannels) ! Surface emmissivity
- Real (Kind=jprb), Intent (in) :: emissivity_in_tl (nchannels) ! Surface emmissivity
-
- Type (profile_Type), Intent (inout) :: profiles (nprofiles) ! Atmospheric profiles
- Type (profile_Type), Intent (inout) :: profiles_tl (nprofiles)
- Type (rttov_coef), Intent (in) :: coef_rttov ! RTTOV Coefficients
- Type (rttov_scatt_coef), Intent (in) :: coef_scatt ! RTTOV_SCATT Coefficients
- Type (profile_cloud_Type), Intent (in) :: cld_profiles (nprofiles) ! Cloud profiles with NWP levels
- Type (profile_cloud_Type), Intent (in) :: cld_profiles_tl (nprofiles)
- Type (radiance_cloud_Type), Intent (inout) :: cld_radiance ! Radiances
- Type (radiance_cloud_Type), Intent (inout) :: cld_radiance_tl
-
- Integer (Kind=jpim), target :: sa__mclayer (nchannels)
- Integer (Kind=jpim), target :: sa_tl__mclayer (nchannels)
-
- Real (kind=jprb), target :: r__clear_out (nbtout)
- Real (kind=jprb), target :: r__out (nbtout)
- Real (kind=jprb), target :: r__out_clear (nbtout)
- Real (kind=jprb), target :: r__total_out (nbtout)
- Real (kind=jprb), target :: r__clear (nchannels)
- Real (kind=jprb), target :: r__cloudy (nchannels)
- Real (kind=jprb), target :: r__total (nchannels)
- Real (kind=jprb), target :: r__bt (nchannels)
- Real (kind=jprb), target :: r__bt_clear (nchannels)
- Real (kind=jprb), target :: r__upclear (nchannels)
- Real (kind=jprb), target :: r__dnclear (nchannels)
- Real (kind=jprb), target :: r__reflclear (nchannels)
- Real (Kind=jprb), target :: r__overcast (nrt_levels,nchannels)
- Real (Kind=jprb), target :: r__downcld (nrt_levels,nchannels)
-
- Real (kind=jprb), target :: r_tl__clear_out (nbtout)
- Real (kind=jprb), target :: r_tl__out (nbtout)
- Real (kind=jprb), target :: r_tl__out_clear (nbtout)
- Real (kind=jprb), target :: r_tl__total_out (nbtout)
- Real (kind=jprb), target :: r_tl__clear (nchannels)
- Real (kind=jprb), target :: r_tl__cloudy (nchannels)
- Real (kind=jprb), target :: r_tl__total (nchannels)
- Real (kind=jprb), target :: r_tl__bt (nchannels)
- Real (kind=jprb), target :: r_tl__bt_clear (nchannels)
- Real (kind=jprb), target :: r_tl__upclear (nchannels)
- Real (kind=jprb), target :: r_tl__dnclear (nchannels)
- Real (kind=jprb), target :: r_tl__reflclear (nchannels)
- Real (Kind=jprb), target :: r_tl__overcast (nrt_levels,nchannels)
- Real (Kind=jprb), target :: r_tl__downcld (nrt_levels,nchannels)
-
- Real (Kind=jprb), target :: t__tau_surf (nchannels)
- Real (Kind=jprb), target :: t__tau_layer (nrt_levels,nchannels)
- Real (Kind=jprb), target :: t__od_singlelayer (nrt_levels,nchannels)
- Real (Kind=jprb), target :: t_tl__tau_surf (nchannels)
- Real (Kind=jprb), target :: t_tl__tau_layer (nrt_levels,nchannels)
- Real (Kind=jprb), target :: t_tl__od_singlelayer (nrt_levels,nchannels)
-
- Real (Kind=jprb), target :: sa__ccmax (nprofiles)
- Real (Kind=jprb), target :: sa__ems_bnd (nchannels)
- Real (Kind=jprb), target :: sa__ref_bnd (nchannels)
- Real (Kind=jprb), target :: sa__ems_cld (nchannels)
- Real (Kind=jprb), target :: sa__ref_cld (nchannels)
-
- Real (Kind=jprb), target :: sa__tbd (nprofiles,nwp_levels+1)
-
- Real (Kind=jprb), target :: sa__delta (nchannels,nwp_levels)
- Real (Kind=jprb), target :: sa__tau (nchannels,nwp_levels)
- Real (Kind=jprb), target :: sa__ext (nchannels,nwp_levels)
- Real (Kind=jprb), target :: sa__ssa (nchannels,nwp_levels)
- Real (Kind=jprb), target :: sa__asm (nchannels,nwp_levels)
- Real (Kind=jprb), target :: sa__lambda (nchannels,nwp_levels)
- Real (Kind=jprb), target :: sa__h (nchannels,nwp_levels)
-
- Real (Kind=jprb), target :: sa__b0 (nprofiles,nwp_levels)
- Real (Kind=jprb), target :: sa__b1 (nprofiles,nwp_levels)
- Real (Kind=jprb), target :: sa__bn (nprofiles,nwp_levels)
- Real (Kind=jprb), target :: sa__dz (nprofiles,nwp_levels)
- Real (Kind=jprb), target :: sa__clw (nprofiles,nwp_levels)
- Real (Kind=jprb), target :: sa__ciw (nprofiles,nwp_levels)
- Real (Kind=jprb), target :: sa__rain (nprofiles,nwp_levels)
- Real (Kind=jprb), target :: sa__sp (nprofiles,nwp_levels)
-
- Real (Kind=jprb), target :: sa_tl__ccmax (nprofiles)
- Real (Kind=jprb), target :: sa_tl__ems_bnd (nchannels)
- Real (Kind=jprb), target :: sa_tl__ref_bnd (nchannels)
- Real (Kind=jprb), target :: sa_tl__ems_cld (nchannels)
- Real (Kind=jprb), target :: sa_tl__ref_cld (nchannels)
-
- Real (Kind=jprb), target :: sa_tl__tbd (nprofiles,nwp_levels+1)
-
- Real (Kind=jprb), target :: sa_tl__delta (nchannels,nwp_levels)
- Real (Kind=jprb), target :: sa_tl__tau (nchannels,nwp_levels)
- Real (Kind=jprb), target :: sa_tl__ext (nchannels,nwp_levels)
- Real (Kind=jprb), target :: sa_tl__ssa (nchannels,nwp_levels)
- Real (Kind=jprb), target :: sa_tl__asm (nchannels,nwp_levels)
- Real (Kind=jprb), target :: sa_tl__lambda (nchannels,nwp_levels)
- Real (Kind=jprb), target :: sa_tl__h (nchannels,nwp_levels)
-
- Real (Kind=jprb), target :: sa_tl__b0 (nprofiles,nwp_levels)
- Real (Kind=jprb), target :: sa_tl__b1 (nprofiles,nwp_levels)
- Real (Kind=jprb), target :: sa_tl__bn (nprofiles,nwp_levels)
- Real (Kind=jprb), target :: sa_tl__dz (nprofiles,nwp_levels)
- Real (Kind=jprb), target :: sa_tl__clw (nprofiles,nwp_levels)
- Real (Kind=jprb), target :: sa_tl__ciw (nprofiles,nwp_levels)
- Real (Kind=jprb), target :: sa_tl__rain (nprofiles,nwp_levels)
- Real (Kind=jprb), target :: sa_tl__sp (nprofiles,nwp_levels)
-
-!* Local variables:
- Logical :: addcloud, switchrad
- Integer (Kind=jpim) :: iprof, ichan
- Real (Kind=jprb) :: emissivity (nchannels)
- Real (Kind=jprb) :: emissivity_tl (nchannels)
-
- Type (transmission_Type) :: transmission, transmission_tl
- Type (geometry_Type) :: angles (nprofiles)
- Type (profile_scatt_aux) :: scatt_aux, scatt_aux_tl
- Type (radiance_Type) :: radiance, radiance_tl
- Type (radiance_Type) :: cld_radiance_tmp
-
- Character (len=80) :: errMessage
- Character (len=15) :: NameOfRoutine = 'rttov_scatt_tl '
-
- !- End of header --------------------------------------------------------
-
- errorstatus (:) = errorstatus_success
-
- radiance % clear_out => r__clear_out
- radiance % out => r__out
- radiance % out_clear => r__out_clear
- radiance % total_out => r__total_out
- radiance % clear => r__clear
- radiance % cloudy => r__cloudy
- radiance % total => r__total
- radiance % bt => r__bt
- radiance % bt_clear => r__bt_clear
- radiance % upclear => r__upclear
- radiance % dnclear => r__dnclear
- radiance % reflclear => r__reflclear
- radiance % overcast => r__overcast
- radiance % downcld => r__downcld
-
- radiance_tl % clear_out => r_tl__clear_out
- radiance_tl % out => r_tl__out
- radiance_tl % out_clear => r_tl__out_clear
- radiance_tl % total_out => r_tl__total_out
- radiance_tl % clear => r_tl__clear
- radiance_tl % cloudy => r_tl__cloudy
- radiance_tl % total => r_tl__total
- radiance_tl % bt => r_tl__bt
- radiance_tl % bt_clear => r_tl__bt_clear
- radiance_tl % upclear => r_tl__upclear
- radiance_tl % dnclear => r_tl__dnclear
- radiance_tl % reflclear => r_tl__reflclear
- radiance_tl % overcast => r_tl__overcast
- radiance_tl % downcld => r_tl__downcld
-
- transmission % tau_surf => t__tau_surf
- transmission % tau_layer => t__tau_layer
- transmission % od_singlelayer => t__od_singlelayer
-
- transmission_tl % tau_surf => t_tl__tau_surf
- transmission_tl % tau_layer => t_tl__tau_layer
- transmission_tl % od_singlelayer => t_tl__od_singlelayer
-
- scatt_aux % ccmax => sa__ccmax
- scatt_aux % ems_bnd => sa__ems_bnd
- scatt_aux % ref_bnd => sa__ref_bnd
- scatt_aux % ems_cld => sa__ems_cld
- scatt_aux % ref_cld => sa__ref_cld
- scatt_aux % tbd => sa__tbd
- scatt_aux % mclayer => sa__mclayer
- scatt_aux % delta => sa__delta
- scatt_aux % tau => sa__tau
- scatt_aux % ext => sa__ext
- scatt_aux % ssa => sa__ssa
- scatt_aux % asm => sa__asm
- scatt_aux % lambda => sa__lambda
- scatt_aux % h => sa__h
- scatt_aux % b0 => sa__b0
- scatt_aux % b1 => sa__b1
- scatt_aux % bn => sa__bn
- scatt_aux % dz => sa__dz
- scatt_aux % clw => sa__clw
- scatt_aux % ciw => sa__ciw
- scatt_aux % rain => sa__rain
- scatt_aux % sp => sa__sp
-
- scatt_aux_tl % ccmax => sa_tl__ccmax
- scatt_aux_tl % ems_bnd => sa_tl__ems_bnd
- scatt_aux_tl % ref_bnd => sa_tl__ref_bnd
- scatt_aux_tl % ems_cld => sa_tl__ems_cld
- scatt_aux_tl % ref_cld => sa_tl__ref_cld
- scatt_aux_tl % tbd => sa_tl__tbd
- scatt_aux_tl % mclayer => sa_tl__mclayer
- scatt_aux_tl % delta => sa_tl__delta
- scatt_aux_tl % tau => sa_tl__tau
- scatt_aux_tl % ext => sa_tl__ext
- scatt_aux_tl % ssa => sa_tl__ssa
- scatt_aux_tl % asm => sa_tl__asm
- scatt_aux_tl % lambda => sa_tl__lambda
- scatt_aux_tl % h => sa_tl__h
- scatt_aux_tl % b0 => sa_tl__b0
- scatt_aux_tl % b1 => sa_tl__b1
- scatt_aux_tl % bn => sa_tl__bn
- scatt_aux_tl % dz => sa_tl__dz
- scatt_aux_tl % clw => sa_tl__clw
- scatt_aux_tl % ciw => sa_tl__ciw
- scatt_aux_tl % rain => sa_tl__rain
- scatt_aux_tl % sp => sa_tl__sp
-
-!* 1. Gas absorption
- switchrad = .true. ! input to RTTOV is BT
- addcloud = .false.
-
- ! No calculation of CLW absorption inside "classical" RTTOV
- If ( Any(.Not.profiles(:) % clw_Data) ) Then
- ! warning message
- profiles (:) % clw_Data = .False.
- End If
-
- emissivity (:) = emissivity_in (:)
- emissivity_tl (:) = emissivity_in_tl (:)
-
- Call rttov_tl( &
- & errorstatus, &! out
- & nfrequencies, &! in
- & nchannels, &! in
- & nbtout, &! in
- & nprofiles, &! in
- & channels, &! in
- & polarisations, &! in
- & lprofiles, &! in
- & profiles, &! in
- & coef_rttov, &! in
- & addcloud, &! in
- & calcemiss, &! in
- & emissivity, &! inout
- & profiles_tl, &! in
- & emissivity_tl, &! inout
- & transmission, &! inout
- & transmission_tl, &! inout
- & radiance, &! inout
- & radiance_tl ) ! inout
-
- If ( any( errorstatus(:) == errorstatus_fatal ) ) Then
- Write( errMessage, '( "error in rttov_tl")' )
- Call Rttov_ErrorReport (errorstatus_fatal, errMessage, NameOfRoutine)
- Return
- End If
-
- scatt_aux_tl % ems_cld (:) = emissivity_in_tl (:)
- scatt_aux % ems_cld (:) = emissivity_in (:)
- scatt_aux_tl % ref_cld (:) = -1.0_JPRB * emissivity_in_tl (:)
- scatt_aux % ref_cld (:) = 1.0_JPRB - emissivity_in (:)
-
-!* 2. Initialisations for Eddington
- Call rttov_iniscatt_tl( &
- & errorstatus, &! in
- & nwp_levels, &! in
- & nrt_levels, &! in
- & nfrequencies, &! in
- & nchannels, &! in
- & nprofiles, &! in
- & polarisations, &! in
- & channels, &! in
- & frequencies, &! in
- & lprofiles, &! in
- & lsprofiles, &! in
- & profiles, &! in
- & profiles_tl, &! in
- & cld_profiles, &! in
- & cld_profiles_tl, &! in
- & coef_rttov, &! in
- & coef_scatt, &! in
- & transmission, &! in
- & transmission_tl, &! in
- & calcemiss, &! in
- & angles, &! out
- & scatt_aux, &! inout
- & scatt_aux_tl) ! inout
-
- If ( any( errorstatus(:) == errorstatus_fatal ) ) Then
- Write( errMessage, '( "error in rttov_iniscatt_tl")' )
- Call Rttov_ErrorReport (errorstatus_fatal, errMessage, NameOfRoutine)
- Return
- End If
-
-!* 3. Eddington (in temperature space)
- Call rttov_eddington_tl( &
- & nwp_levels, &! in
- & nchannels, &! in
- & nprofiles, &! in
- & lsprofiles, &! in
- & angles, &! in
- & profiles, &! in
- & profiles_tl, &! in
- & cld_profiles, &! in
- & scatt_aux, &! in
- & scatt_aux_tl, &! in
- & cld_radiance, &! inout
- & cld_radiance_tl) ! inout
-
-!* 4. Combine clear and cloudy parts
- Do ichan = 1, nchannels
- iprof = lsprofiles (ichan)
-
- cld_radiance_tl % total (ichan) = radiance_tl % total (ichan)
- cld_radiance % total (ichan) = radiance % total (ichan)
- cld_radiance_tl % clear (ichan) = radiance_tl % clear (ichan)
- cld_radiance % clear (ichan) = radiance % clear (ichan)
- cld_radiance_tl % bt_clear (ichan) = radiance_tl % bt (ichan)
- cld_radiance % bt_clear (ichan) = radiance % bt (ichan)
- cld_radiance_tl % bt (ichan) = cld_radiance_tl % bt (ichan) * scatt_aux % ccmax (iprof) &
- & + cld_radiance % bt (ichan) * scatt_aux_tl % ccmax (iprof) &
- & + radiance_tl % bt (ichan) * (1.0_JPRB - scatt_aux % ccmax (iprof)) &
- & - radiance % bt (ichan) * scatt_aux_tl % ccmax (iprof)
-
- cld_radiance % bt (ichan) = cld_radiance % bt (ichan) * scatt_aux % ccmax (iprof) &
- & + radiance % bt (ichan) * (1.0_JPRB - scatt_aux % ccmax (iprof))
- End Do
-
-
-
- !
- !* 5. Convert total polarisations length arrays to number of output channel length arrays
- !
- If (coef_rttov % id_sensor == sensor_id_mw) Then
-
- ! Point a temporary radiance type at cld_radiance
- cld_radiance_tmp % clear => cld_radiance % clear
- cld_radiance_tmp % clear_out => cld_radiance % clear_out
- cld_radiance_tmp % cloudy => cld_radiance % cloudy
- cld_radiance_tmp % total => cld_radiance % total
- cld_radiance_tmp % total_out => cld_radiance % total_out
- cld_radiance_tmp % out => cld_radiance % out
- cld_radiance_tmp % out_clear => cld_radiance % out_clear
- cld_radiance_tmp % bt => cld_radiance % bt
- cld_radiance_tmp % bt_clear => cld_radiance % bt_clear
- cld_radiance_tmp % upclear => cld_radiance % upclear
- cld_radiance_tmp % dnclear => cld_radiance % dnclear
- cld_radiance_tmp % reflclear => cld_radiance % reflclear
- cld_radiance_tmp % overcast => cld_radiance % overcast
- cld_radiance_tmp % downcld => cld_radiance % downcld
-
- Call rttov_calcpolarisation( &
- & nfrequencies, &! in
- & nchannels, &! in
- & nprofiles, &! in
- & angles, &! in
- & channels, &! in
- & polarisations, &! in
- & lprofiles, &! in
- & coef_rttov, &! in
- & cld_radiance_tmp )! inout
-
- ! Point a temporary radiance type at cld_radiance_tl
- cld_radiance_tmp % clear => cld_radiance_tl % clear
- cld_radiance_tmp % clear_out => cld_radiance_tl % clear_out
- cld_radiance_tmp % cloudy => cld_radiance_tl % cloudy
- cld_radiance_tmp % total => cld_radiance_tl % total
- cld_radiance_tmp % total_out => cld_radiance_tl % total_out
- cld_radiance_tmp % out => cld_radiance_tl % out
- cld_radiance_tmp % out_clear => cld_radiance_tl % out_clear
- cld_radiance_tmp % bt => cld_radiance_tl % bt
- cld_radiance_tmp % bt_clear => cld_radiance_tl % bt_clear
- cld_radiance_tmp % upclear => cld_radiance_tl % upclear
- cld_radiance_tmp % dnclear => cld_radiance_tl % dnclear
- cld_radiance_tmp % reflclear => cld_radiance_tl % reflclear
- cld_radiance_tmp % overcast => cld_radiance_tl % overcast
- cld_radiance_tmp % downcld => cld_radiance_tl % downcld
-
- Call rttov_calcpolarisation_tl( &
- & nfrequencies, & ! in
- & nchannels, & ! in
- & nprofiles, & ! in
- & angles, & ! in
- & channels, & ! in
- & polarisations, & ! in
- & lprofiles, & ! in
- & coef_rttov, & ! in
- & cld_radiance_tmp ) ! inout
- Else
- radiance%out = radiance%bt
- radiance%out_clear = radiance%bt_clear
- cld_radiance%out = cld_radiance%bt
- cld_radiance%out_clear = cld_radiance%bt_clear
- radiance_tl%out = radiance_tl%bt
- radiance_tl%out_clear = radiance_tl%bt_clear
- cld_radiance_tl%out = cld_radiance_tl%bt
- cld_radiance_tl%out_clear = cld_radiance_tl%bt_clear
- End If
-End Subroutine rttov_scatt_tl
diff --git a/src/LIB/RTTOV/src/rttov_scatt_tl.interface b/src/LIB/RTTOV/src/rttov_scatt_tl.interface
deleted file mode 100644
index 7eef2c366d095a5a8da22d3ed952738f7389c5de..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_scatt_tl.interface
+++ /dev/null
@@ -1,61 +0,0 @@
-INTERFACE
-Subroutine rttov_scatt_tl(&
- & errorstatus,&
- & nwp_levels,&
- & nrt_levels,&
- & nfrequencies,&
- & nchannels,&
- & nbtout,&
- & nprofiles,&
- & polarisations,&
- & channels,&
- & frequencies,&
- & lprofiles,&
- & lsprofiles,&
- & profiles,&
- & cld_profiles,&
- & coef_rttov,&
- & coef_scatt,&
- & calcemiss,&
- & emissivity_in,&
- & profiles_tl,&
- & cld_profiles_tl,&
- & emissivity_in_tl,&
- & cld_radiance,&
- & cld_radiance_tl)
- Use rttov_types, Only :&
- & rttov_coef ,&
- & rttov_scatt_coef ,&
- & geometry_Type ,&
- & profile_Type ,&
- & profile_cloud_Type ,&
- & profile_scatt_aux ,&
- & transmission_Type ,&
- & radiance_Type ,&
- & radiance_cloud_Type
- Use parkind1, Only : jpim ,jprb
- Integer (Kind=jpim), Intent (in) :: nwp_levels
- Integer (Kind=jpim), Intent (in) :: nrt_levels
- Integer (Kind=jpim), Intent (in) :: nprofiles
- Integer (Kind=jpim), Intent (in) :: nfrequencies
- Integer (Kind=jpim), Intent (in) :: nchannels
- Integer (Kind=jpim), Intent (in) :: nbtout
- Integer (Kind=jpim), Intent (in) :: channels (nfrequencies)
- Integer (Kind=jpim), Intent (in) :: frequencies (nchannels)
- Integer (Kind=jpim), Intent (in) :: polarisations (nchannels,3)
- Integer (Kind=jpim), Intent (in) :: lprofiles (nfrequencies)
- Integer (Kind=jpim), Intent (in) :: lsprofiles (nchannels)
- Integer (Kind=jpim), Intent (out) :: errorstatus (nprofiles)
- Logical, Intent (in) :: calcemiss (nchannels)
- Real (Kind=jprb), Intent (in) :: emissivity_in (nchannels)
- Real (Kind=jprb), Intent (in) :: emissivity_in_tl (nchannels)
- Type (profile_Type), Intent (inout) :: profiles (nprofiles)
- Type (profile_Type), Intent (inout) :: profiles_tl (nprofiles)
- Type (rttov_coef), Intent (in) :: coef_rttov
- Type (rttov_scatt_coef), Intent (in) :: coef_scatt
- Type (profile_cloud_Type), Intent (in) :: cld_profiles (nprofiles)
- Type (profile_cloud_Type), Intent (in) :: cld_profiles_tl (nprofiles)
- Type (radiance_cloud_Type), Intent (inout) :: cld_radiance
- Type (radiance_cloud_Type), Intent (inout) :: cld_radiance_tl
-End Subroutine rttov_scatt_tl
-END INTERFACE
diff --git a/src/LIB/RTTOV/src/rttov_setgeometry.F90 b/src/LIB/RTTOV/src/rttov_setgeometry.F90
deleted file mode 100644
index ea674c96bd988bfa323bab878aad565cd45509e6..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_setgeometry.F90
+++ /dev/null
@@ -1,89 +0,0 @@
-!
-Subroutine rttov_setgeometry( &
- & prof, &! in
- & coef, &! in
- & angles ) ! out
- ! Description:
- ! compute all profile related viewing geometry
- ! The only profile input value is profile%zenangle (zenith angle)
- !
- ! Copyright:
- ! This software was developed within the context of
- ! the EUMETSAT Satellite Application Facility on
- ! Numerical Weather Prediction (NWP SAF), under the
- ! Cooperation Agreement dated 25 November 1998, between
- ! EUMETSAT and the Met Office, UK, by one or more partners
- ! within the NWP SAF. The partners in the NWP SAF are
- ! the Met Office, ECMWF, KNMI and MeteoFrance.
- !
- ! Copyright 2002, EUMETSAT, All Rights Reserved.
- !
- ! Method:
- !
- ! Current Code Owner: SAF NWP
- !
- ! History:
- ! Version Date Comment
- ! ------- ---- -------
- ! 1.0 01/12/2002 New F90 code with structures (P Brunel A Smith)
- ! 1.1 02/01/2003 Added more comments (R Saunders)
- ! 1.2 29/03/2005 Add end of header comment (J. Cameron)
- !
- ! Code Description:
- ! Language: Fortran 90.
- ! Software Standards: "European Standards for Writing and
- ! Documenting Exchangeable Fortran 90 Code".
- !
- ! Declarations:
- ! Modules used:
- ! Imported Parameters:
- Use rttov_const, Only : &
- & deg2rad
-
- ! Imported Type Definitions:
- Use rttov_types, Only : &
- & rttov_coef ,&
- & profile_Type ,&
- & geometry_Type
-
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
- !subroutine arguments:
- Type(profile_Type), Intent(in) :: prof ! profile
- Type(rttov_coef) , Intent(in) :: coef ! coefficient
- Type(geometry_Type), Intent(out) :: angles ! angles
-
-
- ! local
-
- !- End of header --------------------------------------------------------
-
- !Notes on notation:
- ! zen => zenith angle
- ! (definition: angle at surface between view path to satellite and zenith)
- ! view => view angle
- ! (definition: angle at the satellite between view path and nadir)
- ! _sq = square of given value
- ! _sqrt = square root of given value
- ! _minus1 = given value - 1
- ! trigonometric function abbreviations have their usual meanings
-
- angles % sinzen = Sin( prof%zenangle * deg2rad )
- angles % sinzen_sq = angles%sinzen * angles%sinzen
- angles % coszen = Cos( prof%zenangle * deg2rad )
- angles % coszen_sq = angles%coszen * angles%coszen
- angles % seczen = 1.0_JPRB/Abs(angles%coszen)
- angles % seczen_sq = angles%seczen * angles%seczen
- angles % seczen_sqrt = Sqrt(angles%seczen)
- angles % seczen_minus1 = angles%seczen - 1.0_JPRB
- angles % seczen_minus1_sq = angles%seczen_minus1 * angles%seczen_minus1
- angles % sinview = angles%sinzen / coef % ratoe
- angles % sinview_sq = angles%sinview * angles%sinview
- angles % cosview_sq = 1.0_JPRB - angles%sinview_sq
- angles % normzen = prof%zenangle / 60.0_JPRB !normalized zenith angle
-
-
-
-End Subroutine rttov_setgeometry
diff --git a/src/LIB/RTTOV/src/rttov_setgeometry.interface b/src/LIB/RTTOV/src/rttov_setgeometry.interface
deleted file mode 100644
index 31805fbbb7f330b193c572106db12d24a2f3e96b..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_setgeometry.interface
+++ /dev/null
@@ -1,25 +0,0 @@
-Interface
-!
-Subroutine rttov_setgeometry( &
- prof, & ! in
- coef, & ! in
- angles ) ! out
- Use rttov_const, Only : &
- deg2rad
-
- Use rttov_types, Only : &
- rttov_coef ,&
- profile_Type ,&
- geometry_Type
-
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
- Type(profile_Type), Intent(in) :: prof ! profile
- Type(rttov_coef) , Intent(in) :: coef ! coefficient
- Type(geometry_Type), Intent(out) :: angles ! angles
-
-
-End Subroutine rttov_setgeometry
-End Interface
diff --git a/src/LIB/RTTOV/src/rttov_setpredictors.F90 b/src/LIB/RTTOV/src/rttov_setpredictors.F90
deleted file mode 100644
index b3773ab134b61158664e70874882cc8f80577198..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_setpredictors.F90
+++ /dev/null
@@ -1,243 +0,0 @@
-!
-Subroutine rttov_setpredictors( &
- & prof, &! in
- & geom, &! in
- & coef, &! in
- & predictors ) ! out
- ! Description
- ! To calculate and store the profile variables (predictors) required
- ! in subsequent transmittance calculations.
- ! Code based on PRFTAU from previous versions of RTTOV
- ! Only one profile per call
- !
- ! Copyright:
- ! This software was developed within the context of
- ! the EUMETSAT Satellite Application Facility on
- ! Numerical Weather Prediction (NWP SAF), under the
- ! Cooperation Agreement dated 25 November 1998, between
- ! EUMETSAT and the Met Office, UK, by one or more partners
- ! within the NWP SAF. The partners in the NWP SAF are
- ! the Met Office, ECMWF, KNMI and MeteoFrance.
- !
- ! Copyright 2002, EUMETSAT, All Rights Reserved.
- !
- ! Method:
- ! see RTTOV7 science and validation report pages 18/19
- ! variable names are close to the documentation
- !
- ! Current Code Owner: SAF NWP
- !
- ! History:
- ! Version Date Comment
- ! ------- ---- -------
- ! 1.0 01/12/2002 New F90 code with structures (P Brunel A Smith)
- ! 1.1 04/12/2003 Optimisation (J Hague and D Salmond ECMWF)
- ! 1.2 29/03/2005 Add end of header comment (J. Cameron)
- !
- ! Code Description:
- ! Language: Fortran 90.
- ! Software Standards: "European Standards for Writing and
- ! Documenting Exchangeable Fortran 90 Code".
- !
- ! Declarations:
- ! Modules used:
- ! Imported Parameters:
- Use rttov_const, Only : &
- & gravity ,&
- & sensor_id_mw
-
- ! Imported Type Definitions:
- Use rttov_types, Only : &
- & rttov_coef ,&
- & profile_Type ,&
- & geometry_Type ,&
- & predictors_Type
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
- !subroutine arguments:
- Type(profile_Type), Intent(in) :: prof ! profile
- Type(rttov_coef), Intent(in) :: coef ! coefficients
- Type(geometry_Type), Intent(in) :: geom ! geometry
- Type(predictors_Type), Intent(inout) :: predictors ! predictors
-
-
- !local variables:
- Integer(Kind=jpim) :: level
-
- ! user profile
- Real(Kind=jprb) :: t(prof % nlevels)
- Real(Kind=jprb) :: w(prof % nlevels)
- Real(Kind=jprb) :: o(prof % nlevels)
-
- ! reference profile
- Real(Kind=jprb) :: tr(prof % nlevels)
- Real(Kind=jprb) :: wr(prof % nlevels)
- Real(Kind=jprb) :: or(prof % nlevels)
-
- ! user - reference
- Real(Kind=jprb) :: dt(prof % nlevels)
- Real(Kind=jprb) :: dto(prof % nlevels)
-
- ! pressure weighted
- Real(Kind=jprb) :: tw(prof % nlevels)
- Real(Kind=jprb) :: ww(prof % nlevels)
- Real(Kind=jprb) :: ow(prof % nlevels)
-
- ! intermediate variables
- Real(Kind=jprb) :: sum1,sum2
- Real(Kind=jprb) :: deltac(prof %nlevels)
- Real(Kind=jprb) :: sec_or(prof %nlevels)
- Real(Kind=jprb) :: sec_wr(prof %nlevels)
-
- !- End of header --------------------------------------------------------
-
- ! 1 profile layer quantities
- t(1) = prof % t(1)
- t(2 : prof % nlevels ) = ( prof % t(1 : prof % nlevels-1) + &
- & prof % t(2 : prof % nlevels ) ) / 2
-
- w(1) = prof % q(1)
- w(2 : prof % nlevels ) = ( prof % q(1 : prof % nlevels-1) + &
- & prof % q(2 : prof % nlevels ) ) / 2
-
- If ( prof % ozone_Data .And. coef % nozone > 0 ) Then
- o(1) = prof % o3(1)
- o(2 : prof % nlevels ) = ( prof % o3(1 : prof % nlevels-1) + &
- & prof % o3(2 : prof % nlevels ) ) / 2
- Endif
-
- ! 2 calculate deviations from reference profile (layers)
- ! if no input O3 profile, set to reference value (dto =0)
- dt(:) = t(:) - coef % tstar(:)
- If ( prof % ozone_Data .And. coef % nozone > 0 ) Then
- dto(:) = t(:) - coef % to3star(:)
- Else
- dto(:) = 0._JPRB
- Endif
-
- ! 3 calculate (profile / reference profile) ratios; tr wr or
- tr(:) = t(:) / coef % tstar(:)
- wr(:) = w(:) / coef % wstar(:)
- ! if no input O3 profile, set to reference value (or =1)
- If ( prof % ozone_Data .And. coef % nozone > 0 ) Then
- or(:) = o(:) / coef % ostar(:)
-
- Else
- or(:) = 1._JPRB
- Endif
-
- ! 4 calculate profile / reference profile sums: tw ww ow
- tw(1) = 0._JPRB
- Do level = 2 , prof % nlevels
- tw( level ) = tw( level-1 ) + coef % dpp( level ) * tr ( level -1 )
- End Do
-
- sum1 = 0._JPRB
- sum2 = 0._JPRB
- Do level = 1, prof % nlevels
- sum1 = sum1 + coef % dpp( level ) * w ( level )
- sum2 = sum2 + coef % dpp( level ) * coef % wstar ( level )
- ww ( level ) = sum1 / sum2
- End Do
-
- ! if no input O3 profile, set to reference value (ow =1)
- If ( prof % ozone_Data .And. coef % nozone > 0 ) Then
- sum1 = 0._JPRB
- sum2 = 0._JPRB
- Do level = 1, prof % nlevels
- sum1 = sum1 + coef % dpp( level ) * o ( level )
- sum2 = sum2 + coef % dpp( level ) * coef % ostar ( level )
- ow ( level ) = sum1 / sum2
- End Do
- Else
- ow(:) = 1._JPRB
- Endif
-
- ! for other minor gases do as for O3 for testing presence of
- ! coefficients and profile values
- !
-
- !5) set predictors
- !--
-
- !5.1 mixed gases
- !---
-
- Do level = 1, prof % nlevels
- predictors % mixedgas(1,level) = geom % seczen
- predictors % mixedgas(2,level) = geom % seczen_sq
- predictors % mixedgas(3,level) = geom % seczen * tr(level)
- predictors % mixedgas(4,level) = geom % seczen * tr(level) * tr(level)
- predictors % mixedgas(5,level) = tr(level)
- predictors % mixedgas(6,level) = tr(level) * tr(level)
- predictors % mixedgas(7,level) = geom % seczen * tw(level)
- predictors % mixedgas(8,level) = geom % seczen * tw(level) / tr(level)
- predictors % mixedgas(9,level) = geom % seczen_sqrt
- predictors % mixedgas(10,level) = geom % seczen_sqrt * tw(level)**0.25_JPRB
- End Do
-
- !5.2 water vapour ( numbers in right hand are predictor numbers
- ! in the reference document for RTTOV7 (science and validation report)
- !----------------
-
- Do level = 1, prof % nlevels
- sec_wr(level) = geom%seczen * wr(level)
- predictors % watervapour(1,level) = sec_wr(level) ! 7
- predictors % watervapour(2,level) = Sqrt( sec_wr(level) ) ! 5
- predictors % watervapour(3,level) = sec_wr(level) * wr(level) / ww(level) ! 12
- predictors % watervapour(4,level) = sec_wr(level) * dt(level) ! 4
- predictors % watervapour(5,level) = sec_wr(level) * sec_wr(level) ! 1
- predictors % watervapour(6,level) = predictors % watervapour(2,level) * dt (level) ! 11
- predictors % watervapour(7,level) = Sqrt( predictors % watervapour(2,level) ) ! 6
- predictors % watervapour(8,level) = predictors % watervapour(2,level) * wr(level) / ww(level) ! 13
- predictors % watervapour(9,level) = predictors % watervapour(5,level) * sec_wr(level) ! 8
- predictors % watervapour(10,level) = predictors % watervapour(9,level) * sec_wr(level) ! 9
- predictors % watervapour(11,level) = sec_wr(level) * dt(level) * Abs(dt(level)) ! 10
- predictors % watervapour(12,level) = ( geom%seczen * ww(level) )**4 ! 3
- predictors % watervapour(13,level) = ( geom%seczen * ww(level) )**2 ! 2
- predictors % watervapour(14,level) = sec_wr(level) * wr(level) / tr(level) ! 14
- predictors % watervapour(15,level) = sec_wr(level) * wr(level) / tr(level)**4 ! 15
- End Do
-
-
- !5.3 ozone
- !---------
-
- ! if no input O3 profile, variables or, ow and dto have been set
- ! to the reference profile values (1, 1, 0)
-
- If ( coef % nozone > 0 ) Then
- Do level = 1, prof % nlevels
- sec_or(level) = geom%seczen * or(level)
- predictors % ozone(1,level) = sec_or(level)
- predictors % ozone(2,level) = Sqrt( sec_or(level) )
- predictors % ozone(3,level) = sec_or(level) * dto(level)
- predictors % ozone(4,level) = sec_or(level) * sec_or(level)
- predictors % ozone(5,level) = predictors % ozone(2,level) * dto(level)
- predictors % ozone(6,level) = sec_or(level) * or(level) * ow (level)
- predictors % ozone(7,level) = predictors % ozone(2,level) * or(level) / ow(level)
- predictors % ozone(8,level) = sec_or(level) * ow(level)
- predictors % ozone(9,level) = sec_or(level) * Sqrt( geom%seczen * ow(level) )
- predictors % ozone(10,level) = geom%seczen * ow(level)
- predictors % ozone(11,level) = geom%seczen * ow(level) * geom%seczen * ow(level)
- End Do
- Endif
-
-
- !5.4 cloud
- !---------
- If ( prof % clw_Data .And. coef % id_sensor == sensor_id_mw ) Then
- deltac(:) = 0.1820_JPRB * 100.0_JPRB * coef % dp(:) / (4.3429_JPRB * gravity)
- predictors % clw(:) = deltac(:) * prof%clw(:) * geom%seczen
- predictors % clw(2:prof % nlevels) = &
- & 0.5_JPRB * &
- & ( predictors % clw(2:prof % nlevels) + &
- & deltac(2:prof % nlevels) * prof%clw(1:prof % nlevels-1) * &
- & geom%seczen )
- predictors % ncloud = 1
- Endif
-
-
-End Subroutine rttov_setpredictors
diff --git a/src/LIB/RTTOV/src/rttov_setpredictors.interface b/src/LIB/RTTOV/src/rttov_setpredictors.interface
deleted file mode 100644
index b3c4371b32c82b2401b2181f0990dcb4caa564ca..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_setpredictors.interface
+++ /dev/null
@@ -1,29 +0,0 @@
-Interface
-!
-Subroutine rttov_setpredictors( &
- prof, & ! in
- geom, & ! in
- coef, & ! in
- predictors ) ! out
- Use rttov_const, Only : &
- gravity ,&
- sensor_id_mw
-
- Use rttov_types, Only : &
- rttov_coef ,&
- profile_Type ,&
- geometry_Type ,&
- predictors_Type
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
- Type(profile_Type), Intent(in) :: prof ! profile
- Type(rttov_coef), Intent(in) :: coef ! coefficients
- Type(geometry_Type), Intent(in) :: geom ! geometry
- Type(predictors_Type), Intent(inout) :: predictors ! predictors
-
-
-
-End Subroutine rttov_setpredictors
-End Interface
diff --git a/src/LIB/RTTOV/src/rttov_setpredictors_8.F90 b/src/LIB/RTTOV/src/rttov_setpredictors_8.F90
deleted file mode 100644
index 44828a064ab3fbe95a832e591ad6babb539d45ab..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_setpredictors_8.F90
+++ /dev/null
@@ -1,327 +0,0 @@
-!
-Subroutine rttov_setpredictors_8( &
- prof, & ! in
- geom, & ! in
- coef, & ! in
- aux, & ! in
- predictors ) ! out
- ! Description
- ! RTTOV-8 Model
- ! To calculate and store the profile variables (predictors) required
- ! in subsequent transmittance calculations.
- !
- ! Copyright:
- ! This software was developed within the context of
- ! the EUMETSAT Satellite Application Facility on
- ! Numerical Weather Prediction (NWP SAF), under the
- ! Cooperation Agreement dated 25 November 1998, between
- ! EUMETSAT and the Met Office, UK, by one or more partners
- ! within the NWP SAF. The partners in the NWP SAF are
- ! the Met Office, ECMWF, KNMI and MeteoFrance.
- !
- ! Copyright 2002, EUMETSAT, All Rights Reserved.
- !
- ! Method:
- ! see RTTOV7 science and validation report pages 18/19
- ! variable names are close to the documentation
- !
- ! Current Code Owner: SAF NWP
- !
- ! History:
- ! Version Date Comment
- ! ------- ---- -------
- ! 1.0 29/01/2003 Original - copy of RTTOV7 model (P Brunel)
- ! 1.1 11/09/2003 Added predictors for wv line and continuum and CO2 (R Saunders)
- ! 1.2 03/06/2004 Parkind parametrisation (P. Brunel)
- ! 1.3 23/02/2005 Correction of Twr definition (P. Brunel)
- ! 1.4 29/03/2005 Add end of header comment (J. Cameron)
- ! 1.5 07/12/2005 Add surface humidity (R. Saunders)
- ! 1.6 13/10/2006 Corrected CO2 profile logic (R Saunders)
- !
- ! Code Description:
- ! Language: Fortran 90.
- ! Software Standards: "European Standards for Writing and
- ! Documenting Exchangeable Fortran 90 Code".
- !
- ! Declarations:
- ! Modules used:
- ! Imported Parameters:
- Use rttov_const, Only : &
- & gravity ,&
- & sensor_id_mw ,&
- & use_q2m
-
- ! Imported Type Definitions:
- Use rttov_types, Only : &
- & rttov_coef ,&
- & profile_Type ,&
- & geometry_Type ,&
- & profile_aux ,&
- & predictors_Type
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
- !subroutine arguments:
- Type(profile_Type), Intent(in) :: prof ! profile
- Type(rttov_coef), Intent(in) :: coef ! coefficients
- Type(geometry_Type), Intent(in) :: geom ! geometry
- Type(predictors_Type), Intent(inout) :: predictors ! predictors
- Type(profile_aux) , Intent(in) :: aux ! auxillary profiles info.
-
- !local variables:
- Integer(Kind=jpim) :: level
- Integer(Kind=jpim) :: iv2, iv3
-
- ! user profile
- Real(Kind=jprb) :: t(prof % nlevels)
- Real(Kind=jprb) :: w(prof % nlevels)
- Real(Kind=jprb) :: o(prof % nlevels)
- Real(Kind=jprb) :: co2(prof % nlevels)
-
- ! reference profile
- Real(Kind=Jprb) :: tr(prof % nlevels)
- Real(Kind=Jprb) :: wr(prof % nlevels)
- Real(Kind=Jprb) :: wwr(prof % nlevels)
- Real(Kind=Jprb) :: or(prof % nlevels)
- Real(Kind=Jprb) :: co2r(prof % nlevels)
- Real(Kind=Jprb) :: twr(prof % nlevels)
-
- ! user - reference
- Real(Kind=Jprb) :: dt(prof % nlevels)
- Real(Kind=Jprb) :: dto(prof % nlevels)
- Real(Kind=Jprb) :: dtabs(prof % nlevels)
-
- ! pressure weighted
- Real(Kind=Jprb) :: tw(prof % nlevels)
- Real(Kind=Jprb) :: ww(prof % nlevels)
- Real(Kind=Jprb) :: ow(prof % nlevels)
- Real(Kind=Jprb) :: co2w(prof % nlevels)
-
- ! intermediate variables
- Real(Kind=Jprb) :: sum1,sum2
- Real(Kind=Jprb) :: deltac(prof %nlevels)
- Real(Kind=Jprb) :: sec_or(prof %nlevels)
- Real(Kind=Jprb) :: sec_wr(prof %nlevels)
- Real(Kind=Jprb) :: sec_wrwr(prof %nlevels)
- Real(Kind=Jprb) :: tr_sq(prof %nlevels)
-
- !- End of header --------------------------------------------------------
-
- !-------------------------------------------------------------------------------
- ! 1 profile layer quantities
- !-------------------------------------------------------------------------------
- t(1) = prof % t(1)
- t(2 : prof % nlevels ) = ( prof % t(1 : prof % nlevels-1) + &
- & prof % t(2 : prof % nlevels ) ) / 2._JPRB
-
- w(1) = prof % q(1)
- w(2 : prof % nlevels ) = ( prof % q(1 : prof % nlevels-1) + &
- & prof % q(2 : prof % nlevels ) ) / 2._JPRB
- !
- If ( use_q2m )Then
- ! include surface humidity
- iv3 = aux % nearestlev_surf - 1
- iv2 = aux % nearestlev_surf
- If ( iv2 <= coef % nlevels) Then
- w(iv2) = (prof % s2m % q + prof % q(iv3)) / 2._JPRB
- Endif
- Endif
- !
- If ( prof % ozone_Data .And. coef % nozone > 0 ) Then
- o(1) = prof % o3(1)
- o(2 : prof % nlevels ) = ( prof % o3(1 : prof % nlevels-1) + &
- & prof % o3(2 : prof % nlevels ) ) / 2._JPRB
- Endif
-
- If ( prof % co2_Data .And. coef % nco2 > 0 ) Then
- co2(1) = prof % co2(1)
- co2(2 : prof % nlevels ) = ( prof % co2(1 : prof % nlevels-1) + &
- & prof % co2(2 : prof % nlevels ) ) / 2._JPRB
- Endif
-
- !------------------------------------------------------------------------------
- ! 2 calculate deviations from reference profile (layers)
- ! if no input O3 profile, set to reference value (dto =0)
- !-----------------------------------------------------------------------------
- dt(:) = t(:) - coef % tstar(:)
- dtabs(:) = Abs(dt(:))
- If ( prof % ozone_Data .And. coef % nozone > 0 ) Then
- dto(:) = t(:) - coef % to3star(:)
- Else
- dto(:) = 0._JPRB
- Endif
- !------------------------------------------------------------------------------
- ! 3 calculate (profile / reference profile) ratios; tr wr or co2r
- !------------------------------------------------------------------------------
- tr(:) = t(:) / coef % tstar(:)
- wr(:) = w(:) / coef % wstar(:)
- ! if no input O3 profile, set to reference value (or =1)
- If ( prof % ozone_Data .And. coef % nozone > 0 ) Then
- or(:) = o(:) / coef % ostar(:)
- Else
- or(:) = 1._JPRB
- Endif
- ! if no input CO2 profile, set to reference value (co2r=1)
- If ( prof % co2_Data .And. coef % nco2 > 0 ) Then
- co2r(:) = co2(:) / coef % co2star(:)
- Else
- co2r(:) = 1._JPRB
- Endif
- !------------------------------------------------------------------------------
- ! 4 calculate profile / reference profile sums: tw ww ow co2w twr
- !------------------------------------------------------------------------------
- tw(1) = 0._JPRB
- Do level = 2 , prof % nlevels
- tw( level ) = tw( level-1 ) + coef % dpp( level ) * tr ( level -1 )
- End Do
-
- sum1 = 0._JPRB
- sum2 = 0._JPRB
- Do level = 1, prof % nlevels
- sum1 = sum1 + coef % dpp( level ) * w ( level )
- sum2 = sum2 + coef % dpp( level ) * coef % wstar ( level )
- ww ( level ) = sum1 / sum2
- End Do
- sum1 = 0._JPRB
- sum2 = 0._JPRB
- Do level = 1, prof % nlevels
- sum1 = sum1 + coef % dpp( level ) * w ( level ) * t ( level )
- sum2 = sum2 + coef % dpp( level ) * coef % wstar ( level ) * coef % tstar ( level )
- wwr ( level ) = sum1 / sum2
- End Do
-
- ! if no input O3 profile, set to reference value (ow =1)
- If ( prof % ozone_Data .And. coef % nozone > 0 ) Then
- sum1 = 0._JPRB
- sum2 = 0._JPRB
- Do level = 1, prof % nlevels
- sum1 = sum1 + coef % dpp( level ) * o ( level )
- sum2 = sum2 + coef % dpp( level ) * coef % ostar ( level )
- ow ( level ) = sum1 / sum2
- End Do
- Else
- ow(:) = 1._JPRB
- Endif
-
- ! if no input co2 profile, set to reference value (co2w=1 and twr=1)
- If ( prof % co2_Data .And. coef % nco2 > 0 ) Then
- sum1 = 0._JPRB
- sum2 = 0._JPRB
- Do level = 1, prof % nlevels
- sum1 = sum1 + coef % dpp( level ) * co2 ( level )
- sum2 = sum2 + coef % dpp( level ) * coef % co2star ( level )
- co2w ( level ) = sum1 / sum2
- End Do
- sum1 = 0._JPRB
- sum2 = 0._JPRB
- twr ( 1 ) = 0._JPRB
- Do level = 2, prof % nlevels
- sum1 = sum1 + coef % dpp( level ) * t ( level-1 )
- sum2 = sum2 + coef % dpp( level ) * coef % tstar ( level-1 )
- twr ( level ) = sum1 / sum2
- End Do
- Else
- co2w(:) = 1._JPRB
- twr(:) = 1._JPRB
- Endif
-
- !5) set predictors for RTTOV-8 options
- !--
-
- !5.1 mixed gases
- !---
- tr_sq(:) = tr(:) * tr(:)
- predictors % mixedgas(1,:) = geom % seczen
- predictors % mixedgas(2,:) = geom % seczen_sq
- predictors % mixedgas(3,:) = geom % seczen * tr(:)
- predictors % mixedgas(4,:) = geom % seczen * tr_sq(:)
- predictors % mixedgas(5,:) = tr(:)
- predictors % mixedgas(6,:) = tr_sq(:)
- predictors % mixedgas(7,:) = geom % seczen * tw(:)
- predictors % mixedgas(8,:) = geom % seczen * tw(:) / tr(:)
- ! these latter 2 predictors may be removed after testing
- predictors % mixedgas(9,:) = geom % seczen_sqrt
- predictors % mixedgas(10,:) = geom % seczen_sqrt * tw(:)**0.25_JPRB
-
- !5.2 water vapour line transmittance based on RTIASI but with pred 9 removed
- !----------------
-
- sec_wr(:) = geom%seczen * wr(:)
- sec_wrwr(:) = sec_wr(:) * wr(:)
- !predictors % watervapour(:,:) = 0._JPRB
- predictors % watervapour(1,:) = sec_wr(:) * sec_wr(:)
- predictors % watervapour(2,:) = geom%seczen * ww(:)
- predictors % watervapour(3,:) = ( geom%seczen * ww(:) )**2
- predictors % watervapour(4,:) = sec_wr(:) * dt(:)
- predictors % watervapour(5,:) = Sqrt( sec_wr(:) )
- predictors % watervapour(6,:) = sec_wr(:)**0.25_JPRB
- predictors % watervapour(7,:) = sec_wr(:)
- predictors % watervapour(8,:) = sec_wr(:)**3
- predictors % watervapour(9,:) = sec_wr(:) * dt(:) * dtabs(:)
- predictors % watervapour(10,:) = Sqrt(sec_wr(:)) * dt(:)
- predictors % watervapour(11,:) = sec_wrwr(:) / wwr(:)
- predictors % watervapour(12,:) = Sqrt(geom%seczen) * wr(:)**1.5_JPRB / wwr(:)
-
- !5.3 water vapour continuum transmittance based on RTIASI
- !----------------
- !
- If ( coef % nwvcont > 0 ) Then
- !predictors % wvcont(:,:) = 0._JPRB
- predictors % wvcont(1,:) = sec_wrwr(:) / tr(:)
- predictors % wvcont(2,:) = sec_wrwr(:) / (tr_sq(:)*tr_sq(:))
- predictors % wvcont(3,:) = sec_wr(:) / tr(:)
- predictors % wvcont(4,:) = sec_wr(:) / tr_sq(:)
- Endif
-
- !5.4 ozone
- !---------
-
- ! if no input O3 profile, variables or, ow and dto have been set
- ! to the reference profile values (1, 1, 0)
- If ( coef % nozone > 0 ) Then
- sec_or(:) = geom%seczen * or(:)
- predictors % ozone(1,:) = sec_or(:)
- predictors % ozone(2,:) = Sqrt( sec_or(:) )
- predictors % ozone(3,:) = sec_or(:) * dto(:)
- predictors % ozone(4,:) = sec_or(:) * sec_or(:)
- predictors % ozone(5,:) = Sqrt(sec_or(:)) * dto(:)
- predictors % ozone(6,:) = sec_or(:) * or(:) * ow (:)
- predictors % ozone(7,:) = Sqrt( sec_or(:) ) * or(:) / ow(:)
- predictors % ozone(8,:) = sec_or(:) * ow(:)
- predictors % ozone(9,:) = sec_or(:) * Sqrt( geom%seczen * ow(:) )
- predictors % ozone(10,:) = geom%seczen * ow(:)
- predictors % ozone(11,:) = geom%seczen * ow(:) * geom%seczen * ow(:)
- Endif
-
-
- !5.5 cloud
- !---------
- If ( prof % clw_Data .And. coef % id_sensor == sensor_id_mw ) Then
- deltac(:) = 0.1820_JPRB * 100.0_JPRB * coef % dp(:) / (4.3429_JPRB * gravity)
- predictors % clw(:) = deltac(:) * prof%clw(:) * geom%seczen
- predictors % clw(2:prof % nlevels) = &
- & 0.5_JPRB * &
- & ( predictors % clw(2:prof % nlevels) + &
- & deltac(2:prof % nlevels) * prof%clw(1:prof % nlevels-1) * &
- & geom%seczen )
- predictors % ncloud = 1
- Endif
-
- !5.6 carbon diooxide transmittance based on RTIASI
- !-------------------------------------------------
- !
- If ( coef % nco2 > 0 ) Then
- predictors % co2(1,:) = geom%seczen * co2r(:)
- predictors % co2(2,:) = tr_sq(:)
- predictors % co2(3,:) = geom%seczen * tr(:)
- predictors % co2(4,:) = geom%seczen * tr_sq(:)
- predictors % co2(5,:) = tr(:)
- predictors % co2(6,:) = geom%seczen
- predictors % co2(7,:) = geom%seczen * twr(:)
- predictors % co2(8,:) = (geom%seczen * co2w(:))**2
- predictors % co2(9,:) = twr(:) * twr(:) * twr(:)
- predictors % co2(10,:) = geom%seczen * twr(:) * Sqrt(tr(:))
- Endif
-
-End Subroutine rttov_setpredictors_8
diff --git a/src/LIB/RTTOV/src/rttov_setpredictors_8.interface b/src/LIB/RTTOV/src/rttov_setpredictors_8.interface
deleted file mode 100644
index e35e951bb3feec988a011a8948a23f3bde99d3bd..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_setpredictors_8.interface
+++ /dev/null
@@ -1,29 +0,0 @@
-Interface
-!
-Subroutine rttov_setpredictors_8( &
- prof, & ! in
- geom, & ! in
- coef, & ! in
- predictors ) ! out
- Use rttov_const, Only : &
- gravity ,&
- sensor_id_mw
-
- Use rttov_types, Only : &
- rttov_coef ,&
- profile_Type ,&
- geometry_Type ,&
- predictors_Type
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
- Type(profile_Type), Intent(in) :: prof ! profile
- Type(rttov_coef), Intent(in) :: coef ! coefficients
- Type(geometry_Type), Intent(in) :: geom ! geometry
- Type(predictors_Type), Intent(inout) :: predictors ! predictors
-
-
-
-End Subroutine rttov_setpredictors_8
-End Interface
diff --git a/src/LIB/RTTOV/src/rttov_setpredictors_8_ad.F90 b/src/LIB/RTTOV/src/rttov_setpredictors_8_ad.F90
deleted file mode 100644
index e8148ab953a5f5ecbb1f98978d08a354f0684323..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_setpredictors_8_ad.F90
+++ /dev/null
@@ -1,560 +0,0 @@
-!
-Subroutine rttov_setpredictors_8_ad( &
- prof, & ! in
- prof_ad, & ! inout
- geom, & ! in
- coef, & ! in
- aux, &! in
- predictors, & ! in
- predictors_ad ) ! inout
- ! Description
- ! RTTOV-8 Model
- ! AD of rttov_setpredictors_8
- ! To calculate and store the profile variables (predictors) required
- ! in subsequent transmittance calculations.
- !
- ! Copyright:
- ! This software was developed within the context of
- ! the EUMETSAT Satellite Application Facility on
- ! Numerical Weather Prediction (NWP SAF), under the
- ! Cooperation Agreement dated 25 November 1998, between
- ! EUMETSAT and the Met Office, UK, by one or more partners
- ! within the NWP SAF. The partners in the NWP SAF are
- ! the Met Office, ECMWF, KNMI and MeteoFrance.
- !
- ! Copyright 2002, EUMETSAT, All Rights Reserved.
- !
- ! Method:
- ! see RTTOV7 science and validation report pages 18/19
- ! variable names are close to the documentation
- !
- ! Current Code Owner: SAF NWP
- !
- ! History:
- ! Version Date Comment
- ! ------- ---- -------
- ! 1.0 29/01/2003 Original - copy of RTTOV7 model (P Brunel)
- ! as a template for RTTOV-8
- ! 1.1 30/09/2003 Added predictors for wv line and continuum and CO2 (R Saunders)
- ! 1.2 03/06/2004 Parkind parametrisation, correction of w_ad, t_ad calculation
- ! simplify AD relatted to predictor 9 for WVL (P. Brunel)
- ! 1.3 23/02/2005 Correction of Twr definition (P. Brunel)
- ! 1.4 29/03/2005 Add end of header comment (J. Cameron)
- ! 1.5 07/12/2005 Add surface humidity (R. Saunders)
-! ! 1.6 13/10/2006 Corrected CO2 profile logic (R Saunders)
- !
- ! Code Description:
- ! Language: Fortran 90.
- ! Software Standards: "European Standards for Writing and
- ! Documenting Exchangeable Fortran 90 Code".
- !
- ! Declarations:
- ! Modules used:
- ! Imported Parameters:
- Use rttov_const, Only : &
- & gravity ,&
- & sensor_id_mw ,&
- & use_q2m
-
- ! Imported Type Definitions:
- Use rttov_types, Only : &
- & rttov_coef ,&
- & profile_Type ,&
- & geometry_Type ,&
- & profile_aux ,&
- & predictors_Type
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
- !subroutine arguments:
- Type(profile_Type), Intent(in) :: prof
- Type(profile_Type), Intent(inout) :: prof_ad
- Type(rttov_coef), Intent(in) :: coef
- Type(geometry_Type), Intent(in) :: geom
- Type(predictors_Type), Intent(in) :: predictors
- Type(predictors_Type), Intent(inout) :: predictors_ad
- Type(profile_aux) , Intent(in) :: aux ! auxillary profiles info.
-
- !local variables:
- Integer(Kind=jpim) :: level
- Integer(Kind=jpim) :: iv2, iv3
-
- ! user profile
- Real(Kind=Jprb) :: t(prof % nlevels)
- Real(Kind=Jprb) :: w(prof % nlevels)
- Real(Kind=Jprb) :: o(prof % nlevels)
- Real(Kind=Jprb) :: co2(prof % nlevels)
-
- ! reference profile
- Real(Kind=Jprb) :: tr(prof % nlevels)
- Real(Kind=Jprb) :: wr(prof % nlevels)
- Real(Kind=Jprb) :: wwr(prof % nlevels)
-
- ! user - reference
- Real(Kind=Jprb) :: dt(prof % nlevels)
- Real(Kind=Jprb) :: dtabs(prof % nlevels)
-
- ! pressure weighted
- Real(Kind=Jprb) :: tw(prof % nlevels)
-
- ! intermediate variables
- Real(Kind=Jprb) :: sum1,sum2
- Real(Kind=Jprb) :: deltac(prof %nlevels)
- Real(Kind=Jprb) :: sum2_ww(prof %nlevels)
- Real(Kind=Jprb) :: sum2_wwr(prof %nlevels)
- Real(Kind=Jprb) :: sum2_ow(prof %nlevels)
- Real(Kind=Jprb) :: sum2_twr(prof %nlevels)
- Real(Kind=Jprb) :: sum2_co2w(prof %nlevels)
- Real(Kind=Jprb) :: tr_sq(prof % nlevels)
- Real(Kind=Jprb) :: tr_sqrt(prof % nlevels)
- Real(Kind=Jprb) :: tr_4(prof % nlevels)
-
- ! AD variables
- Real(Kind=Jprb) :: t_ad(prof % nlevels)
- Real(Kind=Jprb) :: w_ad(prof % nlevels)
- Real(Kind=Jprb) :: o_ad(prof % nlevels)
- Real(Kind=Jprb) :: co2_ad(prof % nlevels)
-
- Real(Kind=Jprb) :: tr_ad(prof % nlevels)
- Real(Kind=Jprb) :: wr_ad(prof % nlevels)
- Real(Kind=Jprb) :: or_ad(prof % nlevels)
- Real(Kind=Jprb) :: wwr_ad(prof % nlevels)
- Real(Kind=Jprb) :: co2r_ad(prof % nlevels)
- Real(Kind=Jprb) :: twr_ad(prof % nlevels)
-
- Real(Kind=Jprb) :: dt_ad(prof % nlevels)
- Real(Kind=Jprb) :: dto_ad(prof % nlevels)
-
- Real(Kind=Jprb) :: tw_ad(prof % nlevels)
- Real(Kind=Jprb) :: ww_ad(prof % nlevels)
- Real(Kind=Jprb) :: ow_ad(prof % nlevels)
- Real(Kind=Jprb) :: co2w_ad(prof % nlevels)
-
- Real(Kind=Jprb) :: sec_or_ad(prof %nlevels)
- Real(Kind=Jprb) :: sec_wr_ad(prof %nlevels)
- Real(Kind=Jprb) :: sec_wrwr_ad(prof %nlevels)
-
- !- End of header --------------------------------------------------------
-
- !-------------------------------------------------------------------------------
- ! Recompute Direct variables
- !-------------------------------------------------------------------------------
- !1) Profile layer quantities
- !-------------------------------------------------------------------------------
- t(1) = prof % t(1)
- t(2 : prof % nlevels ) = ( prof % t(1 : prof % nlevels-1) + &
- & prof % t(2 : prof % nlevels ) ) / 2._JPRB
-
- w(1) = prof % q(1)
- w(2 : prof % nlevels ) = ( prof % q(1 : prof % nlevels-1) + &
- & prof % q(2 : prof % nlevels ) ) / 2._JPRB
- !
- If ( use_q2m )Then
- ! include surface humidity
- iv3 = aux % nearestlev_surf - 1
- iv2 = aux % nearestlev_surf
- If ( iv2 <= coef % nlevels) Then
- w(iv2) = (prof % s2m % q + prof % q(iv3)) / 2._jprb
- Endif
- Endif
- !
- If ( prof % ozone_Data .And. coef % nozone > 0 ) Then
- o(1) = prof % o3(1)
- o(2 : prof % nlevels ) = ( prof % o3(1 : prof % nlevels-1) + &
- & prof % o3(2 : prof % nlevels ) ) / 2._JPRB
- Endif
-
- If ( prof % co2_Data .And. coef % nco2 > 0 ) Then
- co2(1) = prof % co2(1)
- co2(2 : prof % nlevels ) = ( prof % co2(1 : prof % nlevels-1) + &
- & prof % co2(2 : prof % nlevels ) ) / 2._JPRB
- Endif
- !------------------------------------------------------------------------------
- !2) calculate deviations from reference profile (layers)
- !------------------------------------------------------------------------------
- dt(:) = t(:) - coef % tstar(:)
- dtabs(:) = Abs(dt(:))
- !------------------------------------------------------------------------------
- !3) calculate (profile / reference profile) ratios; tr wr or
- ! if no input O3 profile, set to reference value (or =1)
- !------------------------------------------------------------------------------
- tr(:) = t(:) / coef % tstar(:)
- tr_sq(:) = tr(:) * tr(:)
- tr_4(:) = tr_sq(:) * tr_sq(:)
- tr_sqrt(:) = Sqrt(tr(:))
- wr(:) = w(:) / coef % wstar(:)
- !-------------------------------------------------------------------
- ! 4. calculate profile / reference profile sums: tw wwr
- !--------------------------------------------------------------------
- tw(1) = 0.
- Do level = 2 , prof % nlevels
- tw( level ) = tw( level-1 ) + coef % dpp( level ) * tr ( level -1 )
- End Do
- sum1 = 0._JPRB
- sum2 = 0._JPRB
- Do level = 1, prof % nlevels
- sum1 = sum1 + coef % dpp( level ) * w ( level ) * t ( level )
- sum2 = sum2 + coef % dpp( level ) * coef % wstar ( level ) * coef % tstar ( level )
- sum2_wwr ( level ) = sum2
- wwr(level) = sum1 / sum2
- End Do
- sum1 = 0._JPRB
- sum2 = 0._JPRB
- Do level = 1, prof % nlevels
- sum1 = sum1 + coef % dpp( level ) * w ( level )
- sum2 = sum2 + coef % dpp( level ) * coef % wstar ( level )
- sum2_ww( level ) = sum2
- End Do
-
- If ( prof % ozone_Data .And. coef % nozone > 0 ) Then
- sum1 = 0._JPRB
- sum2 = 0._JPRB
- Do level = 1, prof % nlevels
- sum1 = sum1 + coef % dpp( level ) * o ( level )
- sum2 = sum2 + coef % dpp( level ) * coef % ostar ( level )
- sum2_ow( level ) = sum2
- End Do
- Endif
-
- If ( prof % co2_Data .And. coef % nco2 > 0 ) Then
- sum1 = 0._JPRB
- sum2 = 0._JPRB
- Do level = 1, prof % nlevels
- sum1 = sum1 + coef % dpp( level ) * co2 ( level )
- sum2 = sum2 + coef % dpp( level ) * coef % co2star ( level )
- sum2_co2w ( level ) = sum2
- End Do
- sum1 = 0._JPRB
- sum2 = 0._JPRB
- sum2_twr ( 1 ) = 0._JPRB
- Do level = 2, prof % nlevels
- sum1 = sum1 + coef % dpp( level ) * t ( level-1 )
- sum2 = sum2 + coef % dpp( level ) * coef % tstar ( level-1 )
- sum2_twr ( level ) = sum2
- End Do
- Endif
- !-------------------------------------------------------------------------
- ! Ajoint code
- !-------------------------------------------------------------------------
- w_ad(:) = 0._JPRB
- wr_ad(:) = 0._JPRB
- ww_ad(:) = 0._JPRB
- wwr_ad(:) = 0._JPRB
- sec_wr_ad(:) = 0._JPRB
- sec_wrwr_ad(:)= 0._JPRB
- dt_ad(:) = 0._JPRB
- t_ad(:) = 0._JPRB
- tr_ad(:) = 0._JPRB
- tw_ad(:) = 0._JPRB
-
- !5.6 CO2
- !-------
- If ( coef % nco2 > 0 ) Then
- co2r_ad(:) = 0._JPRB
- co2w_ad(:) = 0._JPRB
- twr_ad(:) = 0._JPRB
- co2_ad(:) = 0._JPRB
- !
- twr_ad(:) = twr_ad(:) + predictors_ad % co2(10,:) * geom%seczen * tr_sqrt(:)
- tr_ad(:) = tr_ad(:) + predictors_ad % co2(10,:) * 0.5_JPRB * predictors % co2(7,:) / tr_sqrt(:)
- twr_ad(:) = twr_ad(:) + predictors_ad % co2(9,:) * 3 * geom%seczen * predictors % co2(9,:) &
- & / predictors % co2(7,:)
- co2w_ad(:) = co2w_ad(:) + 2 * geom%seczen * predictors_ad % co2(8,:) * Sqrt(predictors % co2(8,:))
- twr_ad(:) = twr_ad(:) + predictors_ad % co2(7,:) * geom%seczen
- predictors_ad % co2(6,:) = 0._JPRB
- tr_ad(:) = tr_ad(:) + predictors_ad % co2(5,:)
- tr_ad(:) = tr_ad(:) + 2 * predictors_ad % co2(4,:) * predictors % co2(3,:)
- tr_ad(:) = tr_ad(:) + predictors_ad % co2(3,:) * geom%seczen
- tr_ad(:) = tr_ad(:) + 2 * predictors_ad % co2(2,:) * predictors % co2(5,:)
- co2r_ad(:) = co2r_ad(:) + predictors_ad % co2(1,:) * geom%seczen
- Endif
-
- !5.5 cloud
- !---------
- If ( prof % clw_Data .And. coef % id_sensor == sensor_id_mw ) Then
- deltac(:) = 0.1820_JPRB * 100.0_JPRB * coef % dp(:) / (4.3429_JPRB * gravity)
-
- prof_ad%clw(1:prof_ad % nlevels-1) = prof_ad%clw(1:prof_ad % nlevels-1) +&
- & 0.5_JPRB * predictors_ad % clw(2:prof_ad % nlevels) *&
- & deltac(2:prof_ad % nlevels) * geom%seczen
-
- predictors_ad % clw(2:prof_ad % nlevels) = 0.5_JPRB * predictors_ad % clw(2:prof_ad % nlevels)
-
- prof_ad%clw(:) = prof_ad%clw(:) + predictors_ad % clw(:) *&
- & deltac(:) * geom%seczen
-
- Endif
-
- !5.4 ozone
- !---------
- If ( coef % nozone > 0 ) Then
- o_ad(:) = 0._JPRB
- or_ad(:) = 0._JPRB
- wr_ad(:) = 0._JPRB
- ow_ad(:) = 0._JPRB
- dto_ad(:) = 0._JPRB
- sec_or_ad(:) = 0._JPRB
-
- ! One can pack all ow_ad lines in one longer statement
- ! same for sec_or_ad and dto_ad
- ow_ad(:) = ow_ad(:) + predictors_ad % ozone(11,:) *&
- & 2 * geom%seczen * predictors % ozone(10,:)
-
- ow_ad(:) = ow_ad(:) + predictors_ad % ozone(10,:) * geom%seczen
-
- sec_or_ad(:) = sec_or_ad(:) + predictors_ad % ozone(9,:) *&
- & Sqrt(predictors % ozone(10,:))
- ow_ad(:) = ow_ad(:) + predictors_ad % ozone(9,:) *&
- & 0.5_JPRB * geom%seczen * predictors % ozone(1,:) &
- & / Sqrt(predictors % ozone(10,:))
-
- ow_ad(:) = ow_ad(:) + predictors_ad % ozone(8,:) *&
- & predictors % ozone(1,:)
- or_ad(:) = or_ad(:) + predictors_ad % ozone(8,:) *&
- & predictors % ozone(10,:)
-
- sec_or_ad(:) = sec_or_ad(:) + predictors_ad % ozone(7,:) *&
- & 1.5_JPRB * predictors % ozone(2,:) / predictors % ozone(10,:)
- ow_ad(:) = ow_ad(:) - predictors_ad % ozone(7,:) *&
- & geom%seczen * predictors % ozone(2,:)**3 / predictors % ozone(10,:)**2
-
-
- or_ad(:) = or_ad(:) + predictors_ad % ozone(6,:) *&
- & 2 * predictors % ozone(8,:)
- ow_ad(:) = ow_ad(:) + predictors_ad % ozone(6,:) *&
- & predictors % ozone(4,:) / geom%seczen
-
- sec_or_ad(:) = sec_or_ad(:) + predictors_ad % ozone(5,:) *&
- & 0.5_JPRB * predictors % ozone(3,:) /&
- & ( predictors % ozone(1,:) *predictors % ozone(2,:))
- dto_ad(:) = dto_ad(:) + predictors_ad % ozone(5,:) *&
- & predictors % ozone(2,:)
-
- sec_or_ad(:) = sec_or_ad(:) + predictors_ad % ozone(4,:) *&
- & 2 * predictors % ozone(1,:)
-
- sec_or_ad(:) = sec_or_ad(:) + predictors_ad % ozone(3,:) *&
- & predictors % ozone(3,:) / predictors % ozone(1,:)
- dto_ad(:) = dto_ad(:) + predictors_ad % ozone(3,:) *&
- & predictors % ozone(1,:)
-
- sec_or_ad(:) = sec_or_ad(:) + predictors_ad % ozone(2,:) *&
- & 0.5_JPRB / predictors % ozone(2,:)
-
- sec_or_ad(:) = sec_or_ad(:) + predictors_ad % ozone(1,:)
-
- or_ad(:) = or_ad(:) + sec_or_ad(:) * geom%seczen
-
- Endif
-
- !5.3 Water Vapour Continuum based on RTIASI
- !------------------------------------------
- If ( coef % nwvcont > 0 ) Then
- sec_wr_ad(:) = sec_wr_ad(:) + predictors_ad % wvcont(4,:) / tr_sq(:)
- tr_ad(:) = tr_ad(:) - 2 * predictors_ad % wvcont(4,:)* &
- & predictors % watervapour(7,:) / (tr_sq(:) * tr(:))
- sec_wr_ad(:) = sec_wr_ad(:) + predictors_ad % wvcont(3,:) / tr(:)
- tr_ad(:) = tr_ad(:) - predictors_ad % wvcont(3,:) * &
- & predictors % watervapour(7,:) / tr_sq(:)
- sec_wrwr_ad(:) = sec_wrwr_ad(:) + predictors_ad % wvcont(2,:) / tr_4(:)
- tr_ad(:) = tr_ad(:) - 4 * predictors_ad % wvcont(2,:) * &
- & predictors % wvcont(1,:) / tr_4(:)
- sec_wrwr_ad(:) = sec_wrwr_ad(:) + predictors_ad % wvcont(1,:) / tr(:)
- tr_ad(:) = tr_ad(:) - predictors_ad % wvcont(1,:) * &
- & predictors % wvcont(1,:) / tr(:)
- Endif
- !
- !5.2 water vapour based on RTIASI
- !--------------------------------
- wr_ad(:) = wr_ad(:) + 1.5_JPRB * predictors_ad % watervapour(12,:) *&
- & predictors % watervapour(5,:) / wwr(:)
-
- wwr_ad(:) = wwr_ad(:) - predictors_ad % watervapour(12,:) *&
- & predictors % watervapour(5,:) * wr / (wwr(:) * wwr(:))
-
- wr_ad(:) = wr_ad(:) + 2 * predictors_ad % watervapour(11,:) *&
- & predictors % watervapour(7,:) / wwr(:)
-
- wwr_ad(:) = wwr_ad(:) - predictors_ad % watervapour(11,:) *&
- & predictors % watervapour(1,:) / (geom%seczen * wwr(:) * wwr(:))
-
- dt_ad(:) = dt_ad(:) + predictors_ad % watervapour(10,:) *&
- & predictors % watervapour(5,:)
-
- sec_wr_ad(:) = sec_wr_ad(:) + 0.5_JPRB * predictors_ad % watervapour(10,:) *&
- & dt(:) / predictors % watervapour(5,:)
-
- sec_wr_ad(:) = sec_wr_ad(:) + predictors_ad % watervapour(9,:) * dtabs(:) * dt(:)
- dt_ad(:) = dt_ad(:) + 2 * predictors_ad % watervapour(9,:) *&
- & predictors % watervapour(7,:) * dtabs(:)
-
- sec_wr_ad(:) = sec_wr_ad(:) + 3 * predictors_ad % watervapour(8,:) *&
- & predictors % watervapour(1,:)
-
- sec_wr_ad(:) = sec_wr_ad(:) + predictors_ad % watervapour(7,:)
-
- sec_wr_ad(:) = sec_wr_ad(:) + 0.25_JPRB * predictors_ad % watervapour(6,:) /&
- & predictors % watervapour(6,:)**3
-
- sec_wr_ad(:) = sec_wr_ad(:) + 0.5_JPRB * predictors_ad % watervapour(5,:) /&
- & predictors % watervapour(5,:)
-
- dt_ad(:) = dt_ad(:) + predictors_ad % watervapour(4,:) *&
- & predictors % watervapour(7,:)
-
- sec_wr_ad(:) = sec_wr_ad(:) + predictors_ad % watervapour(4,:) * dt(:)
-
- ww_ad(:) = ww_ad(:) + 2 * predictors_ad % watervapour(3,:) * &
- & geom%seczen * predictors % watervapour(2,:)
-
- ww_ad(:) = ww_ad(:) + predictors_ad % watervapour(2,:) * geom%seczen
-
- sec_wr_ad(:) = sec_wr_ad(:) + 2 * predictors_ad % watervapour(1,:) * &
- & predictors % watervapour(7,:)
-
- sec_wr_ad(:) = sec_wr_ad(:) + sec_wrwr_ad(:)* wr(:)
- wr_ad(:) = wr_ad(:) + sec_wrwr_ad(:) * predictors % watervapour(7,:)
- wr_ad(:) = wr_ad(:) + sec_wr_ad(:) * geom % seczen
-
- !5.1 mixed gases
- !---------------
-
-
- ! X10
- tw_ad(2:prof_ad % nlevels) = tw_ad(2:prof_ad % nlevels) +&
- & predictors_ad % mixedgas(10,2:prof_ad % nlevels) *&
- & 0.25_JPRB * geom % seczen_sq &
- & / predictors % mixedgas(10,2:prof_ad % nlevels)**3
- ! X9
- ! X8
- tw_ad(:) = tw_ad(:) + predictors_ad % mixedgas(8,:) *&
- & geom % seczen / predictors % mixedgas(5,:)
- tr_ad(:) = tr_ad(:) - predictors_ad % mixedgas(8,:) *&
- & predictors % mixedgas(7,:) / predictors % mixedgas(6,:)
- ! X7
- tw_ad(:) = tw_ad(:) + predictors_ad % mixedgas(7,:) *&
- & geom % seczen
- ! X6
- tr_ad(:) = tr_ad(:) + predictors_ad % mixedgas(6,:) *&
- & 2._JPRB * tr(:)
- ! X5
- tr_ad(:) = tr_ad(:) + predictors_ad % mixedgas(5,:)
- ! X4
- tr_ad(:) = tr_ad(:) + predictors_ad % mixedgas(4,:) *&
- & 2._JPRB * predictors % mixedgas(3,:)
- ! X3
- tr_ad(:) = tr_ad(:) + predictors_ad % mixedgas(3,:) *&
- & geom % seczen
- ! X2
- ! X1
- !-------------------------------------------------------------------
- ! calc adjoint of profile/reference sums
- !-------------------------------------------------------------------
- If ( prof % co2_Data .And. coef % nco2 > 0 ) Then
- sum1 = 0._JPRB
- Do level = prof_ad % nlevels, 1 , -1
- sum1 = sum1 + co2w_ad(level) / sum2_co2w(level)
- co2_ad( level ) = co2_ad( level ) + sum1 * coef % dpp( level )
- End Do
- sum1 = 0._JPRB
- Do level = prof_ad % nlevels , 2, -1
- sum1 = sum1 + twr_ad(level) / sum2_twr(level)
- t_ad( level-1 ) = t_ad( level-1 ) + sum1 * coef % dpp( level )
- End Do
- Else
- t_ad(:) = 0._JPRB
- co2_ad(:) = 0._JPRB
- Endif
- !
- sum1 = 0._JPRB
- If ( prof % ozone_Data .And. coef % nozone > 0 ) Then
- Do level = prof_ad % nlevels, 1, -1
- sum1 = sum1 + ow_ad ( level ) / sum2_ow(level)
- o_ad( level ) = o_ad( level ) + sum1 * coef % dpp( level )
- End Do
- Else
- o_ad(:) = 0._JPRB
- Endif
- !
- sum1 = 0._JPRB
- Do level = prof_ad % nlevels, 1, -1
- sum1 = sum1 + wwr_ad ( level ) / sum2_wwr(level)
- w_ad( level ) = w_ad( level ) + sum1 * coef % dpp( level ) * t( level )
- t_ad( level ) = t_ad( level ) + sum1 * coef % dpp( level ) * w( level )
- End Do
- !
- sum1 = 0._JPRB
- Do level = prof_ad % nlevels, 1, -1
- sum1 = sum1 + ww_ad ( level ) / sum2_ww(level)
- w_ad( level ) = w_ad( level ) + sum1 * coef % dpp( level )
- End Do
-
- Do level = prof_ad % nlevels, 2, -1
- tw_ad( level-1 ) = tw_ad( level-1 ) + tw_ad( level )
- tr_ad( level-1 ) = tr_ad( level-1 ) + tw_ad( level ) *&
- & coef % dpp( level )
- End Do
- !-------------------------------------------------------------------
- ! calc adjoint of profile deviations
- !-------------------------------------------------------------------
- If ( prof % co2_Data .And. coef % nco2 > 0 ) Then
- co2_ad(:) = co2_ad(:) + co2r_ad(:) / coef % co2star(:)
- Endif
-
- If ( prof % ozone_Data .And. coef % nozone > 0 ) Then
- o_ad(:) = o_ad(:) + or_ad(:) / coef % ostar(:)
- Endif
-
- w_ad(:) = w_ad(:) + wr_ad(:) / coef % wstar(:)
-
- t_ad(:) = t_ad(:) + tr_ad(:) / coef % tstar(:)
-
-
- If ( prof % ozone_Data .And. coef % nozone > 0 ) Then
- t_ad(:) = t_ad(:) + dto_ad(:)
- Endif
-
- t_ad(:) = t_ad(:) + dt_ad(:)
- !-------------------------------------------------------------------
- ! calc adjoint of profile layer means
- !-------------------------------------------------------------------
- If ( prof % co2_Data .And. coef % nco2 > 0 ) Then
- prof_ad % co2(1 : prof_ad % nlevels-1) = prof_ad % co2(1 : prof_ad % nlevels-1) +&
- & 0.5_JPRB *co2_ad(2 : prof_ad % nlevels )
- prof_ad % co2(2 : prof_ad % nlevels) = prof_ad % co2(2 : prof_ad % nlevels) +&
- & 0.5_JPRB *co2_ad(2 : prof_ad % nlevels )
- prof_ad % co2(1) = prof_ad % co2(1) + co2_ad(1)
- Endif
-
- If ( prof % ozone_Data .And. coef % nozone > 0 ) Then
- prof_ad % o3(1 : prof_ad % nlevels-1) = prof_ad % o3(1 : prof_ad % nlevels-1) +&
- & 0.5_JPRB *o_ad(2 : prof_ad % nlevels )
- prof_ad % o3(2 : prof_ad % nlevels) = prof_ad % o3(2 : prof_ad % nlevels) +&
- & 0.5_JPRB *o_ad(2 : prof_ad % nlevels )
- prof_ad % o3(1) = prof_ad % o3(1) + o_ad(1)
- Endif
-
- ! include adjoint surface humidity
- If ( use_q2m )Then
- prof_ad % s2m % q = prof_ad % s2m % q + 0.5_JPRB *w_ad(iv2)
- prof_ad % q(iv3) = prof_ad % q(iv3) + 0.5_JPRB *w_ad(iv2)
- prof_ad % q(1 : iv3-1) = prof_ad % q(1 : iv3-1) +&
- & 0.5_JPRB *w_ad(2 : iv3 )
- prof_ad % q(2 : iv3) = prof_ad % q(2 : iv3) +&
- & 0.5_JPRB *w_ad(2 : iv3 )
- Else
- prof_ad % q(1 : prof_ad % nlevels-1) = prof_ad % q(1 : prof_ad % nlevels-1) +&
- & 0.5_JPRB *w_ad(2 : prof_ad % nlevels )
- prof_ad % q(2 : prof_ad % nlevels) = prof_ad % q(2 : prof_ad % nlevels) +&
- & 0.5_JPRB *w_ad(2 : prof_ad % nlevels )
- Endif
- prof_ad % q(1) = prof_ad % q(1) + w_ad(1)
-
- prof_ad % t(1 : prof_ad % nlevels-1) = prof_ad % t(1 : prof_ad % nlevels-1) +&
- & 0.5_JPRB *t_ad(2 : prof_ad % nlevels )
- prof_ad % t(2 : prof_ad % nlevels) = prof_ad % t(2 : prof_ad % nlevels) +&
- & 0.5_JPRB *t_ad(2 : prof_ad % nlevels )
- prof_ad % t(1) = prof_ad % t(1) + t_ad(1)
-
-End Subroutine rttov_setpredictors_8_ad
diff --git a/src/LIB/RTTOV/src/rttov_setpredictors_8_ad.interface b/src/LIB/RTTOV/src/rttov_setpredictors_8_ad.interface
deleted file mode 100644
index b10c6b74f808942109ab41c7cdc0c81ec769db12..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_setpredictors_8_ad.interface
+++ /dev/null
@@ -1,32 +0,0 @@
-Interface
-!
-Subroutine rttov_setpredictors_8_ad( &
- prof, & ! in
- prof_ad, & ! inout
- geom, & ! in
- coef, & ! in
- predictors, & ! in
- predictors_ad ) ! inout
- Use rttov_const, Only : &
- gravity
-
- Use rttov_types, Only : &
- rttov_coef ,&
- profile_Type ,&
- geometry_Type ,&
- predictors_Type
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
- Type(profile_Type), Intent(in) :: prof
- Type(profile_Type), Intent(inout) :: prof_ad
- Type(rttov_coef), Intent(in) :: coef
- Type(geometry_Type), Intent(in) :: geom
- Type(predictors_Type), Intent(in) :: predictors
- Type(predictors_Type), Intent(inout) :: predictors_ad
-
-
-
-End Subroutine rttov_setpredictors_8_ad
-End Interface
diff --git a/src/LIB/RTTOV/src/rttov_setpredictors_8_k.F90 b/src/LIB/RTTOV/src/rttov_setpredictors_8_k.F90
deleted file mode 100644
index 66652484ad6acd5bfde5a669b4a5d09815011484..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_setpredictors_8_k.F90
+++ /dev/null
@@ -1,677 +0,0 @@
-!
-Subroutine rttov_setpredictors_8_k( &
- & nfrequencies, &! in
- & nchannels, &! in
- & nprofiles, &! in
- & nlevels, &! in
- & angles, &! in
- & polarisations, &! in
- & lprofiles, &! in
- & profiles, &! in
- & profiles_k, &! inout
- & coef, &! in
- & aux_prof, &! in
- & predictors, &! in
- & predictors_k ) ! inout
- ! Description
- ! RTTOV-8 Model
- !
- ! Copyright:
- ! This software was developed within the context of
- ! the EUMETSAT Satellite Application Facility on
- ! Numerical Weather Prediction (NWP SAF), under the
- ! Cooperation Agreement dated 25 November 1998, between
- ! EUMETSAT and the Met Office, UK, by one or more partners
- ! within the NWP SAF. The partners in the NWP SAF are
- ! the Met Office, ECMWF, KNMI and MeteoFrance.
- !
- ! Copyright 2005, EUMETSAT, All Rights Reserved.
- !
- !
- ! Current Code Owner: SAF NWP
- !
- ! History:
- ! Version Date Comment
- ! ------- ---- -------
- ! 1.0 22/06/2005 initial (P Brunel)
- ! based on version 1.4 (29/03/05) of AD code
- ! 1.1 07/12/2005 Add surface humidity (R. Saunders)
-! ! 1.2 13/10/2006 Corrected CO2 logic (R Saunders)
- !
- ! Code Description:
- ! Language: Fortran 90.
- ! Software Standards: "European Standards for Writing and
- ! Documenting Exchangeable Fortran 90 Code".
- !
- ! Declarations:
- ! Modules used:
- ! Imported Parameters:
- Use rttov_const, Only : &
- & gravity ,&
- & sensor_id_mw ,&
- & use_q2m
-
- ! Imported Type Definitions:
- Use rttov_types, Only : &
- & rttov_coef ,&
- & profile_Type ,&
- & geometry_Type ,&
- & profile_aux ,&
- & predictors_Type
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
- !subroutine arguments:
- Integer(Kind=jpim), Intent(in) :: nfrequencies ! Number of frequencies
- Integer(Kind=jpim), Intent(in) :: nchannels ! Number of output radiances
- Integer(Kind=jpim), Intent(in) :: nprofiles ! Number of profiles
- Integer(Kind=jpim), Intent(in) :: nlevels ! Number of levels
- Integer(Kind=jpim), Intent(in) :: polarisations(nchannels,3) ! polarisation indices
- Integer(Kind=jpim), Intent(in) :: lprofiles(nfrequencies) ! Profiles indices
-
- Type(profile_Type), Target, Intent(in) :: profiles(nprofiles)
- Type(profile_Type), Target, Intent(inout) :: profiles_k(nchannels)
- Type(geometry_Type), Target, Intent(in) :: angles(nprofiles)
- Type(predictors_Type), Target, Intent(in) :: predictors(nprofiles)
- Type(predictors_Type), Target, Intent(inout) :: predictors_k(nchannels)
- Type(rttov_coef), Intent(in) :: coef
- Type(profile_aux) , Target, Intent(in) :: aux_prof(nprofiles) ! auxillary profiles info.
-
- !local variables:
-
- Type(geometry_Type), Pointer :: geom
- Type(profile_Type), Pointer :: prof
- Type(profile_Type), Pointer :: prof_k
- Type(profile_aux), Pointer :: prof_aux
- Type(predictors_Type), Pointer :: pred
- Type(predictors_Type), Pointer :: pred_k
-
- Integer(Kind=jpim) :: level
- Integer(Kind=jpim) :: freq
- Integer(Kind=jpim) :: i ! channel indice
- Integer(Kind=jpim) :: j ! profile indice
- Integer(Kind=jpim) :: iv2, iv3
-
- ! user profile
- Real(Kind=Jprb) :: t(nlevels, nprofiles)
- Real(Kind=Jprb) :: w(nlevels, nprofiles)
- Real(Kind=Jprb) :: o(nlevels, nprofiles)
- Real(Kind=Jprb) :: co2(nlevels, nprofiles)
-
- ! reference profile
- Real(Kind=Jprb) :: tr(nlevels, nprofiles)
- Real(Kind=Jprb) :: wr(nlevels, nprofiles)
- Real(Kind=Jprb) :: wwr(nlevels, nprofiles)
-
- ! user - reference
- Real(Kind=Jprb) :: dt(nlevels, nprofiles)
- Real(Kind=Jprb) :: dtabs(nlevels, nprofiles)
-
- ! pressure weighted
- Real(Kind=Jprb) :: tw(nlevels, nprofiles)
-
- ! intermediate variables
- Real(Kind=Jprb) :: sum1,sum2
- Real(Kind=Jprb) :: deltac(nlevels)
- Real(Kind=Jprb) :: sum2_ww(nlevels, nprofiles)
- Real(Kind=Jprb) :: sum2_wwr(nlevels, nprofiles)
- Real(Kind=Jprb) :: sum2_ow(nlevels, nprofiles)
- Real(Kind=Jprb) :: sum2_twr(nlevels, nprofiles)
- Real(Kind=Jprb) :: sum2_co2w(nlevels, nprofiles)
- Real(Kind=Jprb) :: tr_sq(nlevels, nprofiles)
- Real(Kind=Jprb) :: tr_sqrt(nlevels, nprofiles)
- Real(Kind=Jprb) :: tr_4(nlevels, nprofiles)
-
- ! K variables
- Real(Kind=Jprb) :: t_k(nlevels, nchannels)
- Real(Kind=Jprb) :: w_k(nlevels, nchannels)
- Real(Kind=Jprb) :: o_k(nlevels, nchannels)
- Real(Kind=Jprb) :: co2_k(nlevels, nchannels)
-
- Real(Kind=Jprb) :: tr_k(nlevels, nchannels)
- Real(Kind=Jprb) :: wr_k(nlevels, nchannels)
- Real(Kind=Jprb) :: or_k(nlevels, nchannels)
- Real(Kind=Jprb) :: wwr_k(nlevels, nchannels)
- Real(Kind=Jprb) :: co2r_k(nlevels, nchannels)
- Real(Kind=Jprb) :: twr_k(nlevels, nchannels)
-
- Real(Kind=Jprb) :: dt_k(nlevels, nchannels)
- Real(Kind=Jprb) :: dto_k(nlevels, nchannels)
-
- Real(Kind=Jprb) :: tw_k(nlevels, nchannels)
- Real(Kind=Jprb) :: ww_k(nlevels, nchannels)
- Real(Kind=Jprb) :: ow_k(nlevels, nchannels)
- Real(Kind=Jprb) :: co2w_k(nlevels, nchannels)
-
- Real(Kind=Jprb) :: sec_or_k(nlevels, nchannels)
- Real(Kind=Jprb) :: sec_wr_k(nlevels, nchannels)
- Real(Kind=Jprb) :: sec_wrwr_k(nlevels, nchannels)
-
- !- End of header --------------------------------------------------------
-
- nullify ( geom )
- nullify ( prof )
- nullify ( prof_k )
- nullify ( prof_aux )
- nullify ( pred )
- nullify ( pred_k )
-
- !-------------------------------------------------------------------------------
- ! Recompute Direct variables
- !-------------------------------------------------------------------------------
- Do j = 1, nprofiles
-
- prof => profiles(j)
- prof_aux => aux_prof(j)
-
- !1) Profile layer quantities
- !-------------------------------------------------------------------------------
- t(1, j) = prof % t(1)
- t(2 : prof % nlevels, j) = ( prof % t(1 : prof % nlevels-1) + &
- & prof % t(2 : prof % nlevels ) ) / 2._JPRB
-
- w(1, j) = prof % q(1)
- w(2 : prof % nlevels, j) = ( prof % q(1 : prof % nlevels-1) + &
- & prof % q(2 : prof % nlevels ) ) / 2._JPRB
- ! include surface humidity
- If( use_q2m )Then
- iv3 = prof_aux % nearestlev_surf - 1
- iv2 = prof_aux % nearestlev_surf
- If ( iv2 <= coef % nlevels) Then
- w(iv2,j) = (prof % s2m % q + prof % q(iv3)) / 2._jprb
- Endif
- Endif
- !
- If ( prof % ozone_Data .And. coef % nozone > 0 ) Then
- o(1, j) = prof % o3(1)
- o(2 : prof % nlevels, j) = ( prof % o3(1 : prof % nlevels-1) + &
- & prof % o3(2 : prof % nlevels ) ) / 2._JPRB
- Else
- o( : , j ) = 0._JPRB
- Endif
-
- If ( prof % co2_Data .And. coef % nco2 > 0 ) Then
- co2(1, j) = prof % co2(1)
- co2(2 : prof % nlevels, j) = ( prof % co2(1 : prof % nlevels-1) + &
- & prof % co2(2 : prof % nlevels ) ) / 2._JPRB
- Endif
- !------------------------------------------------------------------------------
- !2) calculate deviations from reference profile (layers)
- !------------------------------------------------------------------------------
- dt(:, j) = t(:,j) - coef % tstar(:)
- dtabs(:,j) = Abs(dt(:,j))
- !------------------------------------------------------------------------------
- !3) calculate (profile / reference profile) ratios; tr wr or
- ! if no input O3 profile, set to reference value (or =1)
- !------------------------------------------------------------------------------
- tr(:,j) = t(:,j) / coef % tstar(:)
- tr_sq(:,j) = tr(:,j) * tr(:,j)
- tr_4(:,j) = tr_sq(:,j) * tr_sq(:,j)
- tr_sqrt(:,j) = Sqrt(tr(:,j))
- wr(:,j) = w(:,j) / coef % wstar(:)
- !-------------------------------------------------------------------
- ! 4. calculate profile / reference profile sums: tw wwr
- !--------------------------------------------------------------------
- tw(1,j) = 0._JPRB
- Do level = 2 , prof % nlevels
- tw( level, j) = tw( level-1, j) + coef % dpp( level ) * tr ( level -1, j)
- End Do
- sum1 = 0._JPRB
- sum2 = 0._JPRB
- Do level = 1, prof % nlevels
- sum1 = sum1 + coef % dpp( level ) * w ( level, j) * t ( level, j)
- sum2 = sum2 + coef % dpp( level ) * coef % wstar ( level ) * coef % tstar ( level )
- sum2_wwr ( level, j) = sum2
- wwr(level, j) = sum1 / sum2
- End Do
- sum1 = 0._JPRB
- sum2 = 0._JPRB
- Do level = 1, prof % nlevels
- sum1 = sum1 + coef % dpp( level ) * w ( level, j)
- sum2 = sum2 + coef % dpp( level ) * coef % wstar ( level )
- sum2_ww( level, j) = sum2
- End Do
-
- If ( prof % ozone_Data .And. coef % nozone > 0 ) Then
- sum1 = 0._JPRB
- sum2 = 0._JPRB
- Do level = 1, prof % nlevels
- sum1 = sum1 + coef % dpp( level ) * o ( level, j)
- sum2 = sum2 + coef % dpp( level ) * coef % ostar ( level )
- sum2_ow( level, j) = sum2
- End Do
- Endif
-
- If ( prof % co2_Data .And. coef % nco2 > 0 ) Then
- sum1 = 0._JPRB
- sum2 = 0._JPRB
- Do level = 1, prof % nlevels
- sum1 = sum1 + coef % dpp( level ) * co2 ( level, j)
- sum2 = sum2 + coef % dpp( level ) * coef % co2star ( level )
- sum2_co2w ( level, j) = sum2
- End Do
- sum1 = 0._JPRB
- sum2 = 0._JPRB
- sum2_twr ( 1, j) = 0._JPRB
- Do level = 2, prof % nlevels
- sum1 = sum1 + coef % dpp( level ) * t ( level-1, j)
- sum2 = sum2 + coef % dpp( level ) * coef % tstar ( level-1 )
- sum2_twr ( level, j) = sum2
- End Do
- Endif
-
- End Do
-
- !-------------------------------------------------------------------------
- ! Ajoint code
- !-------------------------------------------------------------------------
- w_k(:,:) = 0._JPRB
- wr_k(:,:) = 0._JPRB
- ww_k(:,:) = 0._JPRB
- wwr_k(:,:) = 0._JPRB
- sec_wr_k(:,:) = 0._JPRB
- sec_wrwr_k(:,:)= 0._JPRB
- dt_k(:,:) = 0._JPRB
- t_k(:,:) = 0._JPRB
- tr_k(:,:) = 0._JPRB
- tw_k(:,:) = 0._JPRB
-
- !5.6 CO2
- !-------
- If ( coef % nco2 > 0 ) Then
- co2r_k(:,:) = 0._JPRB
- co2w_k(:,:) = 0._JPRB
- twr_k(:,:) = 0._JPRB
- co2_k(:,:) = 0._JPRB
-
- Do i = 1, nchannels
- freq=polarisations(i,2)
- j = lprofiles( freq )
-
- prof => profiles(j) ! for test on CO2 data
- geom => angles(j)
- pred => predictors(j)
- ! prof_k => profiles_k(i)
- pred_k => predictors_k(i)
- !
- twr_k(:,i) = twr_k(:,i) + pred_k % co2(10,:) * geom%seczen * tr_sqrt(:,j)
- tr_k(:,i) = tr_k(:,i) + pred_k % co2(10,:) * 0.5_JPRB * pred % co2(7,:) / tr_sqrt(:,j)
- twr_k(:,i) = twr_k(:,i) + pred_k % co2(9,:) * 3 * geom%seczen * pred % co2(9,:) &
- & / pred % co2(7,:)
- co2w_k(:,i) = co2w_k(:,i) + 2 * geom%seczen * pred_k % co2(8,:) * Sqrt(pred % co2(8,:))
- twr_k(:,i) = twr_k(:,i) + pred_k % co2(7,:) * geom%seczen
- pred_k % co2(6,:) = 0._JPRB
- tr_k(:,i) = tr_k(:,i) + pred_k % co2(5,:)
- tr_k(:,i) = tr_k(:,i) + 2 * pred_k % co2(4,:) * pred % co2(3,:)
- tr_k(:,i) = tr_k(:,i) + pred_k % co2(3,:) * geom%seczen
- tr_k(:,i) = tr_k(:,i) + 2 * pred_k % co2(2,:) * pred % co2(5,:)
- co2r_k(:,i) = co2r_k(:,i) + pred_k % co2(1,:) * geom%seczen
- End Do ! channels
- End If ! coefs CO2
-
- !5.5 cloud
- !---------
- If ( coef % id_sensor == sensor_id_mw ) Then
- deltac(:) = 0.1820_JPRB * 100.0_JPRB * coef % dp(:) / (4.3429_JPRB * gravity)
-
- Do i = 1, nchannels
- freq=polarisations(i,2)
- j = lprofiles( freq )
-
- prof => profiles(j)
-
- If ( prof % clw_Data ) Then
-
- geom => angles(j)
- prof_k => profiles_k(i)
- pred_k => predictors_k(i)
-
- prof_k%clw(1:prof_k % nlevels-1) = prof_k%clw(1:prof_k % nlevels-1) +&
- & 0.5_JPRB * pred_k % clw(2:prof_k % nlevels) *&
- & deltac(2:prof_k % nlevels) * geom%seczen
-
- pred_k % clw(2:prof_k % nlevels) = 0.5_JPRB * pred_k % clw(2:prof_k % nlevels)
-
- prof_k%clw(:) = prof_k%clw(:) + pred_k % clw(:) *&
- & deltac(:) * geom%seczen
-
- End If
- End Do
- End If
-
- !5.4 ozone
- !---------
- If ( coef % nozone > 0 ) Then
- o_k(:,:) = 0._JPRB
- or_k(:,:) = 0._JPRB
- wr_k(:,:) = 0._JPRB
- ow_k(:,:) = 0._JPRB
- dto_k(:,:) = 0._JPRB
- sec_or_k(:,:) = 0._JPRB
-
- Do i = 1, nchannels
- freq=polarisations(i,2)
- j = lprofiles( freq )
-
- ! prof => profiles(j) (use of variables derived from prof )
- geom => angles(j)
- pred => predictors(j)
- ! prof_k => profiles_k(i) (not used for O3 )
- pred_k => predictors_k(i)
-
- ! One can pack all ow_k lines in one longer statement
- ! same for sec_or_k and dto_k
- ow_k(:,i) = ow_k(:,i) + pred_k % ozone(11,:) *&
- & 2 * geom%seczen * pred % ozone(10,:)
-
- ow_k(:,i) = ow_k(:,i) + pred_k % ozone(10,:) * geom%seczen
-
- sec_or_k(:,i) = sec_or_k(:,i) + pred_k % ozone(9,:) *&
- & Sqrt(pred % ozone(10,:))
- ow_k(:,i) = ow_k(:,i) + pred_k % ozone(9,:) *&
- & 0.5_JPRB * geom%seczen * pred % ozone(1,:) &
- & / Sqrt(pred % ozone(10,:))
-
- ow_k(:,i) = ow_k(:,i) + pred_k % ozone(8,:) *&
- & pred % ozone(1,:)
- or_k(:,i) = or_k(:,i) + pred_k % ozone(8,:) *&
- & pred % ozone(10,:)
-
- sec_or_k(:,i) = sec_or_k(:,i) + pred_k % ozone(7,:) *&
- & 1.5_JPRB * pred % ozone(2,:) / pred % ozone(10,:)
- ow_k(:,i) = ow_k(:,i) - pred_k % ozone(7,:) *&
- & geom%seczen * pred % ozone(2,:)**3 / pred % ozone(10,:)**2
-
-
- or_k(:,i) = or_k(:,i) + pred_k % ozone(6,:) *&
- & 2 * pred % ozone(8,:)
- ow_k(:,i) = ow_k(:,i) + pred_k % ozone(6,:) *&
- & pred % ozone(4,:) / geom%seczen
-
- sec_or_k(:,i) = sec_or_k(:,i) + pred_k % ozone(5,:) *&
- & 0.5_JPRB * pred % ozone(3,:) /&
- & ( pred % ozone(1,:) *pred % ozone(2,:))
- dto_k(:,i) = dto_k(:,i) + pred_k % ozone(5,:) *&
- & pred % ozone(2,:)
-
- sec_or_k(:,i) = sec_or_k(:,i) + pred_k % ozone(4,:) *&
- & 2 * pred % ozone(1,:)
-
- sec_or_k(:,i) = sec_or_k(:,i) + pred_k % ozone(3,:) *&
- & pred % ozone(3,:) / pred % ozone(1,:)
- dto_k(:,i) = dto_k(:,i) + pred_k % ozone(3,:) *&
- & pred % ozone(1,:)
-
- sec_or_k(:,i) = sec_or_k(:,i) + pred_k % ozone(2,:) *&
- & 0.5_JPRB / pred % ozone(2,:)
-
- sec_or_k(:,i) = sec_or_k(:,i) + pred_k % ozone(1,:)
-
- or_k(:,i) = or_k(:,i) + sec_or_k(:,i) * geom%seczen
-
- End Do ! channels
- Endif ! Coef O3
-
- !5.3 Water Vapour Continuum based on RTIASI
- !------------------------------------------
- If ( coef % nwvcont > 0 ) Then
-
- Do i = 1, nchannels
- freq=polarisations(i,2)
- j = lprofiles( freq )
-
- ! prof => profiles(j) (use of variables derived from prof )
- ! geom => angles(j)
- pred => predictors(j)
- ! prof_k => profiles_k(i)
- pred_k => predictors_k(i)
-
- sec_wr_k(:,i) = sec_wr_k(:,i) + pred_k % wvcont(4,:) / tr_sq(:,j)
- tr_k(:,i) = tr_k(:,i) - 2 * pred_k % wvcont(4,:)* &
- & pred % watervapour(7,:) / (tr_sq(:,j) * tr(:,j))
- sec_wr_k(:,i) = sec_wr_k(:,i) + pred_k % wvcont(3,:) / tr(:,j)
- tr_k(:,i) = tr_k(:,i) - pred_k % wvcont(3,:) * &
- & pred % watervapour(7,:) / tr_sq(:,j)
- sec_wrwr_k(:,i) = sec_wrwr_k(:,i) + pred_k % wvcont(2,:) / tr_4(:,j)
- tr_k(:,i) = tr_k(:,i) - 4 * pred_k % wvcont(2,:) * &
- & pred % wvcont(1,:) / tr_4(:,j)
- sec_wrwr_k(:,i) = sec_wrwr_k(:,i) + pred_k % wvcont(1,:) / tr(:,j)
- tr_k(:,i) = tr_k(:,i) - pred_k % wvcont(1,:) * &
- & pred % wvcont(1,:) / tr(:,j)
- End Do ! channels
- Endif ! Coefs WV Cont
- !
- !5.2 water vapour based on RTIASI
- !--------------------------------
- Do i = 1, nchannels
- freq=polarisations(i,2)
- j = lprofiles( freq )
-
- ! prof => profiles(j) (use of variables derived from prof )
- geom => angles(j)
- pred => predictors(j)
- ! prof_k => profiles_k(i)
- pred_k => predictors_k(i)
-
-
- wr_k(:,i) = wr_k(:,i) + 1.5_JPRB * pred_k % watervapour(12,:) *&
- & pred % watervapour(5,:) / wwr(:,j)
-
- wwr_k(:,i) = wwr_k(:,i) - pred_k % watervapour(12,:) *&
- & pred % watervapour(5,:) * wr(:,j) / (wwr(:,j) * wwr(:,j))
-
- wr_k(:,i) = wr_k(:,i) + 2 * pred_k % watervapour(11,:) *&
- & pred % watervapour(7,:) / wwr(:,j)
-
- wwr_k(:,i) = wwr_k(:,i) - pred_k % watervapour(11,:) *&
- & pred % watervapour(1,:) / (geom%seczen * wwr(:,j) * wwr(:,j))
-
- dt_k(:,i) = dt_k(:,i) + pred_k % watervapour(10,:) *&
- & pred % watervapour(5,:)
-
- sec_wr_k(:,i) = sec_wr_k(:,i) + 0.5_JPRB * pred_k % watervapour(10,:) *&
- & dt(:,j) / pred % watervapour(5,:)
-
- sec_wr_k(:,i) = sec_wr_k(:,i) + pred_k % watervapour(9,:) * dtabs(:,j) * dt(:,j)
- dt_k(:,i) = dt_k(:,i) + 2 * pred_k % watervapour(9,:) *&
- & pred % watervapour(7,:) * dtabs(:,j)
-
- sec_wr_k(:,i) = sec_wr_k(:,i) + 3 * pred_k % watervapour(8,:) *&
- & pred % watervapour(1,:)
-
- sec_wr_k(:,i) = sec_wr_k(:,i) + pred_k % watervapour(7,:)
-
- sec_wr_k(:,i) = sec_wr_k(:,i) + 0.25_JPRB * pred_k % watervapour(6,:) /&
- & pred % watervapour(6,:)**3
-
- sec_wr_k(:,i) = sec_wr_k(:,i) + 0.5_JPRB * pred_k % watervapour(5,:) /&
- & pred % watervapour(5,:)
-
- dt_k(:,i) = dt_k(:,i) + pred_k % watervapour(4,:) *&
- & pred % watervapour(7,:)
-
- sec_wr_k(:,i) = sec_wr_k(:,i) + pred_k % watervapour(4,:) * dt(:,j)
-
- ww_k(:,i) = ww_k(:,i) + 2 * pred_k % watervapour(3,:) * &
- & geom%seczen * pred % watervapour(2,:)
-
- ww_k(:,i) = ww_k(:,i) + pred_k % watervapour(2,:) * geom%seczen
-
- sec_wr_k(:,i) = sec_wr_k(:,i) + 2 * pred_k % watervapour(1,:) * &
- & pred % watervapour(7,:)
-
- sec_wr_k(:,i) = sec_wr_k(:,i) + sec_wrwr_k(:,i)* wr(:,j)
- wr_k(:,i) = wr_k(:,i) + sec_wrwr_k(:,i) * pred % watervapour(7,:)
- wr_k(:,i) = wr_k(:,i) + sec_wr_k(:,i) * geom % seczen
- End Do ! channels
-
- !5.1 mixed gases
- !---------------
-
- Do i = 1, nchannels
- freq=polarisations(i,2)
- j = lprofiles( freq )
-
- ! prof => profiles(j) (use of variables derived from prof )
- geom => angles(j)
- pred => predictors(j)
- prof_k => profiles_k(i)
- pred_k => predictors_k(i)
-
- ! X10
- tw_k(2:prof_k % nlevels,i) = tw_k(2:prof_k % nlevels,i) +&
- & pred_k % mixedgas(10,2:prof_k % nlevels) *&
- & 0.25_JPRB * geom % seczen_sq &
- & / pred % mixedgas(10,2:prof_k % nlevels)**3
- ! X9
- ! X8
- tw_k(:,i) = tw_k(:,i) + pred_k % mixedgas(8,:) *&
- & geom % seczen / pred % mixedgas(5,:)
- tr_k(:,i) = tr_k(:,i) - pred_k % mixedgas(8,:) *&
- & pred % mixedgas(7,:) / pred % mixedgas(6,:)
- ! X7
- tw_k(:,i) = tw_k(:,i) + pred_k % mixedgas(7,:) *&
- & geom % seczen
- ! X6
- tr_k(:,i) = tr_k(:,i) + pred_k % mixedgas(6,:) *&
- & 2._JPRB * tr(:,j)
- ! X5
- tr_k(:,i) = tr_k(:,i) + pred_k % mixedgas(5,:)
- ! X4
- tr_k(:,i) = tr_k(:,i) + pred_k % mixedgas(4,:) *&
- & 2._JPRB * pred % mixedgas(3,:)
- ! X3
- tr_k(:,i) = tr_k(:,i) + pred_k % mixedgas(3,:) *&
- & geom % seczen
- ! X2
- ! X1
- End Do ! channels
-
- Do i = 1, nchannels
- freq=polarisations(i,2)
- j = lprofiles( freq )
-
- prof => profiles(j)
- geom => angles(j)
- pred => predictors(j)
- prof_k => profiles_k(i)
- pred_k => predictors_k(i)
- !-------------------------------------------------------------------
- ! calc adjoint of profile/reference sums
- !-------------------------------------------------------------------
- If ( prof % co2_Data .And. coef % nco2 > 0 ) Then
- sum1 = 0._JPRB
- Do level = prof_k % nlevels, 1 , -1
- sum1 = sum1 + co2w_k(level, i) / sum2_co2w(level, j)
- co2_k( level, i) = co2_k( level, i) + sum1 * coef % dpp( level )
- End Do
- sum1 = 0._JPRB
- Do level = prof_k % nlevels , 2, -1
- sum1 = sum1 + twr_k(level,i) / sum2_twr(level,j)
- t_k( level-1, i) = t_k( level-1, i) + sum1 * coef % dpp( level )
- End Do
- Else
- t_k(:,i) = 0._JPRB
- co2_k(:,i) = 0._JPRB
- Endif
- !
- sum1 = 0._JPRB
- If ( prof % ozone_Data .And. coef % nozone > 0 ) Then
- Do level = prof_k % nlevels, 1, -1
- sum1 = sum1 + ow_k ( level, i) / sum2_ow(level, j)
- o_k( level, i) = o_k( level, i) + sum1 * coef % dpp( level )
- End Do
- Else
- o_k(:,i) = 0._JPRB
- Endif
- !
- sum1 = 0._JPRB
- Do level = prof_k % nlevels, 1, -1
- sum1 = sum1 + wwr_k ( level, i) / sum2_wwr(level, j)
- w_k( level, i) = w_k( level, i) + sum1 * coef % dpp( level ) * t( level, j)
- t_k( level, i) = t_k( level, i) + sum1 * coef % dpp( level ) * w( level, j)
- End Do
- !
- sum1 = 0._JPRB
- Do level = prof_k % nlevels, 1, -1
- sum1 = sum1 + ww_k ( level, i) / sum2_ww(level, j)
- w_k( level, i) = w_k( level, i) + sum1 * coef % dpp( level )
- End Do
-
- Do level = prof_k % nlevels, 2, -1
- tw_k( level-1, i) = tw_k( level-1, i) + tw_k( level, i)
- tr_k( level-1, i) = tr_k( level-1, i) + tw_k( level, i) *&
- & coef % dpp( level )
- End Do
- !-------------------------------------------------------------------
- ! calc adjoint of profile deviations
- !-------------------------------------------------------------------
- If ( prof % co2_Data .And. coef % nco2 > 0 ) Then
- co2_k(:,i) = co2_k(:,i) + co2r_k(:,i) / coef % co2star(:)
- Endif
-
- If ( prof % ozone_Data .And. coef % nozone > 0 ) Then
- o_k(:,i) = o_k(:,i) + or_k(:,i) / coef % ostar(:)
- Endif
-
- w_k(:,i) = w_k(:,i) + wr_k(:,i) / coef % wstar(:)
-
- t_k(:,i) = t_k(:,i) + tr_k(:,i) / coef % tstar(:)
-
-
- If ( prof % ozone_Data .And. coef % nozone > 0 ) Then
- t_k(:,i) = t_k(:,i) + dto_k(:,i)
- Endif
-
- t_k(:,i) = t_k(:,i) + dt_k(:,i)
- !-------------------------------------------------------------------
- ! calc adjoint of profile layer means
- !-------------------------------------------------------------------
- If ( prof % co2_Data .And. coef % nco2 > 0 ) Then
- prof_k % co2(1 : prof_k % nlevels-1) = prof_k % co2(1 : prof_k % nlevels-1) +&
- & 0.5_JPRB *co2_k(2 : prof_k % nlevels, i)
- prof_k % co2(2 : prof_k % nlevels) = prof_k % co2(2 : prof_k % nlevels) +&
- & 0.5_JPRB *co2_k(2 : prof_k % nlevels, i)
- prof_k % co2(1) = prof_k % co2(1) + co2_k(1,i)
- Endif
-
- If ( prof % ozone_Data .And. coef % nozone > 0 ) Then
- prof_k % o3(1 : prof_k % nlevels-1) = prof_k % o3(1 : prof_k % nlevels-1) +&
- & 0.5_JPRB *o_k(2 : prof_k % nlevels, i)
- prof_k % o3(2 : prof_k % nlevels) = prof_k % o3(2 : prof_k % nlevels) +&
- & 0.5_JPRB *o_k(2 : prof_k % nlevels, i)
- prof_k % o3(1) = prof_k % o3(1) + o_k(1,i)
- Endif
-
- ! include K surface humidity
- If ( use_q2m )Then
- prof_k % s2m % q = prof_k % s2m % q + 0.5_JPRB *w_k(iv2,i)
- prof_k % q(iv3) = prof_k % q(iv3) + 0.5_JPRB *w_k(iv2,i)
- prof_k % q(1 : iv3-1) = prof_k % q(1 : iv3-1) +&
- & 0.5_JPRB *w_k(2 : iv3, i)
- prof_k % q(2 : iv3) = prof_k % q(2 : iv3) +&
- & 0.5_JPRB *w_k(2 : iv3, i)
- Else
- prof_k % q(1 : prof_k % nlevels-1) = prof_k % q(1 : prof_k % nlevels-1) +&
- & 0.5_JPRB *w_k(2 : prof_k % nlevels, i)
- prof_k % q(2 : prof_k % nlevels) = prof_k % q(2 : prof_k % nlevels) +&
- & 0.5_JPRB *w_k(2 : prof_k % nlevels, i)
- Endif
- prof_k % q(1) = prof_k % q(1) + w_k(1,i)
-
- prof_k % t(1 : prof_k % nlevels-1) = prof_k % t(1 : prof_k % nlevels-1) +&
- & 0.5_JPRB *t_k(2 : prof_k % nlevels, i)
- prof_k % t(2 : prof_k % nlevels) = prof_k % t(2 : prof_k % nlevels) +&
- & 0.5_JPRB *t_k(2 : prof_k % nlevels, i)
- prof_k % t(1) = prof_k % t(1) + t_k(1,i)
-
- End Do ! channels
-
- nullify ( geom )
- nullify ( prof )
- nullify ( prof_k )
- nullify ( pred )
- nullify ( pred_k )
-
-End Subroutine rttov_setpredictors_8_k
diff --git a/src/LIB/RTTOV/src/rttov_setpredictors_8_k.interface b/src/LIB/RTTOV/src/rttov_setpredictors_8_k.interface
deleted file mode 100644
index 9ae8eac52cbb4eab019e4288fa2003b152c55928..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_setpredictors_8_k.interface
+++ /dev/null
@@ -1,46 +0,0 @@
-Interface
-!
-Subroutine rttov_setpredictors_8_k( &
- & nfrequencies, &! in
- & nchannels, &! in
- & nprofiles, &! in
- & nlevels, &! in
- & angles, &! in
- & polarisations, &! in
- & lprofiles, &! in
- & profiles, &! in
- & profiles_k, &! inout
- & coef, &! in
- & predictors, &! in
- & predictors_k ) ! inout
-
- Use rttov_const, Only : &
- & gravity ,&
- & sensor_id_mw
-
- Use rttov_types, Only : &
- & rttov_coef ,&
- & profile_Type ,&
- & geometry_Type ,&
- & predictors_Type
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
- Integer(Kind=jpim), Intent(in) :: nfrequencies ! Number of frequencies
- Integer(Kind=jpim), Intent(in) :: nchannels ! Number of output radiances
- Integer(Kind=jpim), Intent(in) :: nprofiles ! Number of profiles
- Integer(Kind=jpim), Intent(in) :: nlevels ! Number of levels
- Integer(Kind=jpim), Intent(in) :: polarisations(nchannels,3) ! polarisation indices
- Integer(Kind=jpim), Intent(in) :: lprofiles(nfrequencies) ! Profiles indices
-
-
- Type(profile_Type), Intent(in) :: profiles(nprofiles)
- Type(profile_Type), Intent(inout) :: profiles_k(nchannels)
- Type(geometry_Type), Intent(in) :: angles(nprofiles)
- Type(rttov_coef), Intent(in) :: coef
- Type(predictors_Type), Intent(in) :: predictors(nprofiles)
- Type(predictors_Type), Intent(inout) :: predictors_k(nchannels)
-
-End Subroutine rttov_setpredictors_8_k
-End Interface
diff --git a/src/LIB/RTTOV/src/rttov_setpredictors_8_tl.F90 b/src/LIB/RTTOV/src/rttov_setpredictors_8_tl.F90
deleted file mode 100644
index 1566251d373db4e31d2c630e512378be0c92244e..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_setpredictors_8_tl.F90
+++ /dev/null
@@ -1,485 +0,0 @@
-!
-Subroutine rttov_setpredictors_8_tl( &
- prof, & ! in
- prof_tl, & ! in
- geom, & ! in
- coef, & ! in
- aux, & ! in
- predictors, & ! in
- predictors_tl ) ! inout
- ! Description
- ! RTTOV-8 Model
- ! TL of rttov_setpredictors_8
- ! To calculate and store the profile variables (predictors) required
- ! in subsequent transmittance calculations.
- !
- ! Copyright:
- ! This software was developed within the context of
- ! the EUMETSAT Satellite Application Facility on
- ! Numerical Weather Prediction (NWP SAF), under the
- ! Cooperation Agreement dated 25 November 1998, between
- ! EUMETSAT and the Met Office, UK, by one or more partners
- ! within the NWP SAF. The partners in the NWP SAF are
- ! the Met Office, ECMWF, KNMI and MeteoFrance.
- !
- ! Copyright 2002, EUMETSAT, All Rights Reserved.
- !
- ! Method:
- ! see RTTOV7 science and validation report pages 18/19
- ! variable names are close to the documentation
- !
- ! Current Code Owner: SAF NWP
- !
- ! History:
- ! Version Date Comment
- ! ------- ---- -------
- ! 1.0 29/01/2003 Original - copy of RTTOV7 model (P Brunel)
- ! as a template for RTTOV-8
- ! 1.1 17/09/2003 Added predictors for wv line and continuum and CO2 (R Saunders)
- ! 1.2 03/06/2004 Parkind parametrisation, correction of wwr_tl calculation
- ! simplify TL of predictor 9 for WVL (P. Brunel)
- ! 1.3 23/02/2005 Correction of Twr definition (P. Brunel)
- ! 1.4 29/03/2005 Add end of header comment (J. Cameron)
- ! 1.5 07/12/2005 Add surface humidity (R. Saunders)
-! ! 1.6 13/10/2006 Corrected CO2 profile logic (R Saunders)
- !
- ! Code Description:
- ! Language: Fortran 90.
- ! Software Standards: "European Standards for Writing and
- ! Documenting Exchangeable Fortran 90 Code".
- !
- ! Declarations:
- ! Modules used:
- ! Imported Parameters:
- Use rttov_const, Only : &
- & gravity ,&
- & sensor_id_mw ,&
- & use_q2m
-
- ! Imported Type Definitions:
- Use rttov_types, Only : &
- & rttov_coef ,&
- & profile_Type ,&
- & geometry_Type ,&
- & profile_aux ,&
- & predictors_Type
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
- !subroutine arguments:
- Type(profile_Type), Intent(in) :: prof
- Type(profile_Type), Intent(in) :: prof_tl
- Type(rttov_coef), Intent(in) :: coef
- Type(geometry_Type), Intent(in) :: geom
- Type(predictors_Type), Intent(in) :: predictors
- Type(predictors_Type), Intent(inout) :: predictors_tl ! in because of mem allocation
- Type(profile_aux) , Intent(in) :: aux ! auxillary profiles info.
-
- !local variables:
- Integer(Kind=jpim) :: level
- Integer(Kind=jpim) :: iv2, iv3
-
- ! user profile
- Real(Kind=Jprb) :: t(prof % nlevels)
- Real(Kind=Jprb) :: w(prof % nlevels)
-
- ! reference profile
- Real(Kind=Jprb) :: tr(prof % nlevels)
- Real(Kind=Jprb) :: wr(prof % nlevels)
- Real(Kind=Jprb) :: wwr(prof % nlevels)
- Real(Kind=Jprb) :: twr(prof % nlevels)
-
- ! user - reference
- Real(Kind=Jprb) :: dt(prof % nlevels)
- Real(Kind=Jprb) :: dtabs(prof % nlevels)
-
- ! pressure weighted
- Real(Kind=Jprb) :: tw(prof % nlevels)
-
- ! intermediate variables
- Real(Kind=Jprb) :: sum1,sum2
- Real(Kind=Jprb) :: deltac(prof %nlevels)
- Real(Kind=Jprb) :: tr_sq(prof % nlevels)
- Real(Kind=Jprb) :: tr_sqrt(prof % nlevels)
- Real(Kind=Jprb) :: tr_4(prof % nlevels)
-
- ! TL variables
- Real(Kind=Jprb) :: t_tl(prof % nlevels)
- Real(Kind=Jprb) :: w_tl(prof % nlevels)
- Real(Kind=Jprb) :: o_tl(prof % nlevels)
- Real(Kind=Jprb) :: co2_tl(prof % nlevels)
-
- Real(Kind=Jprb) :: tr_tl(prof % nlevels)
- Real(Kind=Jprb) :: wr_tl(prof % nlevels)
- Real(Kind=Jprb) :: wwr_tl(prof % nlevels)
- Real(Kind=Jprb) :: or_tl(prof % nlevels)
- Real(Kind=Jprb) :: co2r_tl(prof % nlevels)
- Real(Kind=Jprb) :: twr_tl(prof % nlevels)
-
- Real(Kind=Jprb) :: dt_tl(prof % nlevels)
- Real(Kind=Jprb) :: dto_tl(prof % nlevels)
-
- Real(Kind=Jprb) :: tw_tl(prof % nlevels)
- Real(Kind=Jprb) :: ww_tl(prof % nlevels)
- Real(Kind=Jprb) :: ow_tl(prof % nlevels)
- Real(Kind=Jprb) :: co2w_tl(prof % nlevels)
-
- Real(Kind=Jprb) :: sec_or_tl(prof %nlevels)
- Real(Kind=Jprb) :: sec_wr_tl(prof %nlevels)
- Real(Kind=Jprb) :: sec_wrwr_tl(prof %nlevels)
-
- !- End of header --------------------------------------------------------
-
- !-------------------------------------------------------------------------------
- ! Recompute direct variables
- !-------------------------------------------------------------------------------
- ! 1) profile layer mean quantities
- !------------------------------------------------------------------------------
- t(1) = prof % t(1)
- t(2 : prof % nlevels ) = ( prof % t(1 : prof % nlevels-1) + &
- & prof % t(2 : prof % nlevels ) ) / 2._JPRB
-
- w(1) = prof % q(1)
- w(2 : prof % nlevels ) = ( prof % q(1 : prof % nlevels-1) + &
- & prof % q(2 : prof % nlevels ) ) / 2._JPRB
- !
- If ( use_q2m )Then
- ! include surface humidity
- iv3 = aux % nearestlev_surf - 1
- iv2 = aux % nearestlev_surf
- If ( iv2 <= coef % nlevels) Then
- w(iv2) = (prof % s2m % q + prof % q(iv3)) / 2._JPRB
- Endif
- Endif
- ! Direct value of o and co2 NOT needed for TL
-
- !------------------------------------------------------------------------------
- !2) calculate deviations from reference profile (layers)
- !------------------------------------------------------------------------------
- dt(:) = t(:) - coef % tstar(:)
- dtabs(:) = Abs(dt(:))
- !------------------------------------------------------------------------------
- !3) calculate (profile / reference profile) ratios; tr wr or
- ! if no input O3 profile, set to reference value (or =1)
- !------------------------------------------------------------------------------
- tr(:) = t(:) / coef % tstar(:)
- wr(:) = w(:) / coef % wstar(:)
- !-------------------------------------------------------------------
- ! 4. calculate profile / reference profile sums: tw wwr twr
- !--------------------------------------------------------------------
- tw(1) = 0.
- Do level = 2 , prof % nlevels
- tw( level ) = tw( level-1 ) + coef % dpp( level ) * tr ( level -1 )
- End Do
- sum1 = 0._JPRB
- sum2 = 0._JPRB
- Do level = 1, prof % nlevels
- sum1 = sum1 + coef % dpp( level ) * w ( level ) * t ( level )
- sum2 = sum2 + coef % dpp( level ) * coef % wstar ( level ) * coef % tstar ( level )
- wwr ( level ) = sum1 / sum2
- End Do
- ! Direct value of ww NOT needed for TL
- ! Direct value of ow NOT needed for TL
- ! Direct value of co2w NOT needed for TL
- If ( prof % co2_Data .And. coef % nco2 > 0 ) Then
- sum1 = 0._JPRB
- sum2 = 0._JPRB
- twr (1 ) = 0._JPRB
- Do level = 2, prof % nlevels
- sum1 = sum1 + coef % dpp( level ) * t ( level-1 )
- sum2 = sum2 + coef % dpp( level ) * coef % tstar ( level-1 )
- twr ( level ) = sum1 / sum2
- End Do
- Else
- twr(:) = 1._JPRB
- Endif
- !-------------------------------------------------------------------------------
- ! Now compute TL variables
- !-------------------------------------------------------------------------------
- ! 1) profile layer mean quantities
- !------------------------------------------------------------------------------
- t_tl(1) = prof_tl % t(1)
- t_tl(2 : prof_tl % nlevels ) = ( prof_tl % t(1 : prof_tl % nlevels-1) + &
- & prof_tl % t(2 : prof_tl % nlevels ) ) / 2._JPRB
- w_tl(1) = prof_tl % q(1)
- w_tl(2 : prof_tl % nlevels ) = ( prof_tl % q(1 : prof_tl % nlevels-1) + &
- & prof_tl % q(2 : prof_tl % nlevels ) ) / 2._JPRB
- ! include tl surface humidity
- If ( use_q2m )Then
- If ( iv2 <= coef % nlevels) Then
- w_tl(iv2) = (prof_tl % s2m % q + prof_tl % q(iv3)) / 2._JPRB
- Endif
- Endif
- If ( prof % ozone_Data .And. coef % nozone > 0 ) Then
- o_tl(1) = prof_tl % o3(1)
- o_tl(2 : prof_tl % nlevels ) = ( prof_tl % o3(1 : prof_tl % nlevels-1) + &
- & prof_tl % o3(2 : prof_tl % nlevels ) ) / 2._JPRB
- Endif
- If ( prof % co2_Data .And. coef % nco2 > 0 ) Then
- co2_tl(1) = prof_tl % co2(1)
- co2_tl(2 : prof_tl % nlevels ) = ( prof_tl % co2(1 : prof_tl % nlevels-1) + &
- & prof_tl % co2(2 : prof_tl % nlevels ) ) / 2._JPRB
- Endif
- !------------------------------------------------------------------------------
- !2) calculate deviations from reference profile (layers)
- !------------------------------------------------------------------------------
- dt_tl(:) = t_tl(:)
- If ( prof % ozone_Data .And. coef % nozone > 0 ) Then
- dto_tl(:) = t_tl(:)
- Else
- dto_tl(:) = 0._JPRB
- Endif
- !------------------------------------------------------------------------------
- !3) calculate (profile / reference profile) ratios; tr_tl wr_tl or_tl
- !------------------------------------------------------------------------------
- tr_tl(:) = t_tl(:) / coef % tstar(:)
- wr_tl(:) = w_tl(:) / coef % wstar(:)
- If ( prof % ozone_Data .And. coef % nozone > 0 ) Then
- or_tl(:) = o_tl(:) / coef % ostar(:)
- Else
- or_tl(:) = 0._JPRB
- Endif
- If ( prof % co2_Data .And. coef % nco2 > 0 ) Then
- co2r_tl(:) = co2_tl(:) / coef % co2star(:)
- Else
- co2r_tl(:) = 0._JPRB
- Endif
- !-------------------------------------------------------------------------
- ! 4. calculate profile / reference profile sums: tw_tl ww_tl ow_tl co2w_tl
- !-------------------------------------------------------------------------
- tw_tl(1) = 0._JPRB
- Do level = 2 , prof_tl % nlevels
- tw_tl( level ) = tw_tl( level-1 ) + coef % dpp( level ) * tr_tl ( level -1 )
- End Do
-
- sum1 = 0._JPRB
- sum2 = 0._JPRB
- Do level = 1, prof_tl % nlevels
- sum1 = sum1 + coef % dpp( level ) * w_tl ( level )
- sum2 = sum2 + coef % dpp( level ) * coef % wstar ( level )
- ww_tl ( level ) = sum1 / sum2
- End Do
- sum1 = 0._JPRB
- sum2 = 0._JPRB
- Do level = 1, prof_tl % nlevels
- sum1 = sum1 + coef % dpp( level ) * ( w_tl ( level ) * t ( level ) + &
- & w ( level ) * t_tl ( level ) )
- sum2 = sum2 + coef % dpp( level ) * coef % wstar ( level ) * coef % tstar ( level )
- wwr_tl ( level ) = sum1 / sum2
- End Do
-
- If ( prof % ozone_Data .And. coef % nozone > 0 ) Then
- sum1 = 0._JPRB
- sum2 = 0._JPRB
- Do level = 1, prof_tl % nlevels
- sum1 = sum1 + coef % dpp( level ) * o_tl ( level )
- sum2 = sum2 + coef % dpp( level ) * coef % ostar ( level )
- ow_tl ( level ) = sum1 / sum2
- End Do
- Else
- ow_tl(:) = 0._JPRB
- Endif
-
- If ( prof % co2_Data .And. coef % nco2 > 0 ) Then
- sum1 = 0._JPRB
- sum2 = 0._JPRB
- Do level = 1, prof_tl % nlevels
- sum1 = sum1 + coef % dpp( level ) * co2_tl ( level )
- sum2 = sum2 + coef % dpp( level ) * coef % co2star ( level )
- co2w_tl ( level ) = sum1 / sum2
- End Do
- sum1 = 0._JPRB
- sum2 = 0._JPRB
- twr_tl (1 ) = 0._JPRB
- Do level = 2, prof_tl % nlevels
- sum1 = sum1 + coef % dpp( level ) * t_tl ( level-1 )
- sum2 = sum2 + coef % dpp( level ) * coef % tstar ( level-1 )
- twr_tl ( level ) = sum1 / sum2
- End Do
- Else
- co2w_tl(:) = 0._JPRB
- twr_tl(:) = 0._JPRB
- Endif
- ! End of TL profile calcs
- ! ATTENTION
- ! w_tl(:) = prof_tl % q(:)
-
- !5) set predictors for RTTOV-8 options
- !--
-
- !5.1 mixed gases
- !---
-
- predictors_tl % mixedgas(1,:) = 0._JPRB
- predictors_tl % mixedgas(2,:) = 0._JPRB
- predictors_tl % mixedgas(3,:) = geom % seczen * tr_tl(:)
- predictors_tl % mixedgas(4,:) = 2._JPRB * predictors % mixedgas(3,:) * tr_tl(:)
- ! or predictors_tl % mixedgas(4,:) = 2. * geom % seczen * tr_tl(:) * tr(:)
- predictors_tl % mixedgas(5,:) = tr_tl(:)
- predictors_tl % mixedgas(6,:) = 2._JPRB * tr_tl(:) * tr(:)
- ! or predictors_tl % mixedgas(6,:) = 2. * tr_tl(:) * predictors % mixedgas(5,:)
- predictors_tl % mixedgas(7,:) = geom % seczen * tw_tl(:)
- predictors_tl % mixedgas(8,:) =&
- & geom % seczen * tw_tl(:) / predictors % mixedgas(5,:) &
- & - predictors % mixedgas(7,:) * tr_tl(:) / predictors % mixedgas(6,:)
- ! or predictors_tl % mixedgas(8,:) = geom % seczen *&
- ! & ( tw_tl(:) / tr(:) - tw(:) * tr_tl(:) / tr(:)**2 )
- ! 9 and 10 may be removed after testing
- predictors_tl % mixedgas(9,:) = 0._JPRB
- ! predictor 10 is always 0 for the first level
- predictors_tl % mixedgas(10,1) = 0._JPRB
- predictors_tl % mixedgas(10,2:prof_tl % nlevels) =&
- & 0.25_JPRB * geom % seczen_sq * tw_tl(2:prof_tl % nlevels)&
- & / predictors % mixedgas(10,2:prof_tl % nlevels)**3
- ! or predictors_tl % mixedgas(10,:) = 0.25 * geom % seczen_sqrt * tw_tl(:) / tw(:)**0.75
-
-
- !5.2 water vapour lines based on RTIASI
- !--------------------------------------
-
- sec_wr_tl(:) = geom%seczen * wr_tl(:)
- sec_wrwr_tl(:) = sec_wr_tl(:) * wr(:) + predictors % watervapour(7,:) * wr_tl(:)
- predictors_tl % watervapour(:,:) = 0._JPRB
-
- predictors_tl % watervapour(1,:) = 2 * predictors % watervapour(7,:) * sec_wr_tl(:)
-
- predictors_tl % watervapour(2,:) = geom%seczen * ww_tl(:)
-
- predictors_tl % watervapour(3,:) = 2 * predictors % watervapour(2,:) * predictors_tl % watervapour(2,:)
-
- predictors_tl % watervapour(4,:) = predictors % watervapour(7,:) * dt_tl(:) + sec_wr_tl(:) * dt(:)
-
- predictors_tl % watervapour(5,:) = 0.5_JPRB * sec_wr_tl(:) / predictors % watervapour(5,:)
-
- predictors_tl % watervapour(6,:) = 0.25_JPRB * sec_wr_tl(:) / predictors % watervapour(6,:)**3
-
- predictors_tl % watervapour(7,:) = sec_wr_tl(:)
-
- predictors_tl % watervapour(8,:) = 3 * predictors % watervapour(1,:) * sec_wr_tl(:)
- ! NB can we sort this next one out?
- predictors_tl % watervapour(9,:) = &
- & dtabs(:) * &
- & (sec_wr_tl(:) * dt(:) + 2 * predictors % watervapour(7,:) * dt_tl(:) )
-! Do level = 1, prof_tl % nlevels
-! predictors_tl % watervapour(9,level) = &
-! & Abs(dt(level)) * &
-! & (sec_wr_tl(level) * dt(level) + 2 * predictors % watervapour(7,level) * dt_tl(level) )
-!!$ If ( dt(level) >= 0. )Then
-!!$ predictors_tl % watervapour(9,level) = sec_wr_tl(level) * dt(level) * dt(level) + &
-!!$ & 2 * predictors % watervapour(7,level) * dt(level) * dt_tl(level)
-!!$ Else
-!!$ predictors_tl % watervapour(9,level) = sec_wr_tl(level) * dt(level) * dtabs(level) + &
-!!$ & predictors % watervapour(7,level) * dtabs(level) * dt_tl(level) - &
-!!$ & predictors % watervapour(7,level) * dt(level) * dt_tl(level)
-!!$ Endif
-! End Do
- predictors_tl % watervapour(10,:) = predictors % watervapour(5,:) * dt_tl(:) + 0.5_JPRB * dt(:) * sec_wr_tl(:)/ &
- & predictors % watervapour(5,:)
- predictors_tl % watervapour(11,:) = 2 * predictors % watervapour(7,:) * wr_tl(:)/wwr(:) - &
- & predictors % watervapour(1,:) * wwr_tl(:) / (geom%seczen*wwr(:)*wwr(:))
-
- predictors_tl % watervapour(12,:) = 1.5_JPRB * predictors % watervapour(5,:) * wr_tl(:) / wwr(:) - &
- & predictors % watervapour(5,:) * wr * wwr_tl(:) / (wwr(:)*wwr(:))
-
- !predictors_tl % watervapour(12,:) = 1.5 * sec_wr(:)**0.5 * wr_tl(:) / wwr(:) - &
- ! & * wr * sec_wr(:)**0.5 * wwr_tl(:) / (wwr(:) * wwr(:))
- !
- !5.3 water vapour continuum transmittance based on RTIASI
- !--------------------------------------------------------
- !
- If ( coef % nwvcont > 0 ) Then
- tr_sq(:) = tr(:) * tr(:)
- tr_4(:) = tr_sq(:) * tr_sq(:)
- !predictors_tl % wvcont(:,:) = 0._JPRB
- predictors_tl % wvcont(1,:) = sec_wrwr_tl(:) / tr(:) - predictors % wvcont(1,:) * tr_tl(:) / tr(:)
- predictors_tl % wvcont(2,:) = sec_wrwr_tl(:) / tr_4(:) - 4 * predictors % wvcont(1,:) * tr_tl(:) / &
- & tr_4(:)
- predictors_tl % wvcont(3,:) = sec_wr_tl(:) / tr(:) - predictors % watervapour(7,:) * tr_tl(:) / tr_sq(:)
- predictors_tl % wvcont(4,:) = sec_wr_tl(:) / tr_sq(:) - 2 * predictors % watervapour(7,:) * tr_tl(:) / &
- & (tr_sq(:)*tr(:))
- Endif
- !
- !5.4 ozone
- !---------
-
- If ( coef % nozone > 0 ) Then
- sec_or_tl(:) = geom%seczen * or_tl(:)
-
- predictors_tl % ozone(1,:) = &
- & sec_or_tl(:)
-
- predictors_tl % ozone(2,:) = &
- & 0.5_JPRB * sec_or_tl(:) / predictors % ozone(2,:)
-
- predictors_tl % ozone(3,:) = &
- & sec_or_tl(:) * predictors % ozone(3,:) / predictors % ozone(1,:)&
- & + predictors % ozone(1,:) * dto_tl(:)
-
- predictors_tl % ozone(4,:) = &
- & 2 * sec_or_tl(:) * predictors % ozone(1,:)
-
- predictors_tl % ozone(5,:) = &
- & 0.5_JPRB * sec_or_tl(:) * predictors % ozone(3,:) /&
- & ( predictors % ozone(1,:) *predictors % ozone(2,:))&
- & + predictors % ozone(2,:) * dto_tl(:)
-
- predictors_tl % ozone(6,:) = &
- & 2 * predictors % ozone(8,:) * or_tl(:)&
- & + predictors % ozone(4,:) * ow_tl(:) / geom%seczen
-
- predictors_tl % ozone(7,:) = &
- & 1.5_JPRB * sec_or_tl(:) * predictors % ozone(2,:) / predictors % ozone(10,:)&
- & - geom%seczen * ow_tl(:) * predictors % ozone(2,:)**3 / predictors % ozone(10,:)**2
-
- predictors_tl % ozone(8,:) = &
- & predictors % ozone(10,:) * or_tl(:)&
- & + predictors % ozone(1,:) * ow_tl(:)
-
- predictors_tl % ozone(9,:) = &
- & sec_or_tl(:) * Sqrt(predictors % ozone(10,:))&
- & + 0.5_JPRB * geom%seczen * ow_tl(:) * predictors % ozone(1,:)&
- & / Sqrt(predictors % ozone(10,:))
-
- predictors_tl % ozone(10,:) = &
- & geom%seczen * ow_tl(:)
-
- predictors_tl % ozone(11,:) = &
- & 2 * geom%seczen * ow_tl(:) * predictors % ozone(10,:)
-
- Endif
- !
- !5.5 cloud
- !---------
- If ( prof % clw_Data .And. coef % id_sensor == sensor_id_mw ) Then
- deltac(:) = 0.1820_JPRB * 100.0_JPRB * coef % dp(:) / (4.3429_JPRB * gravity)
-
- predictors_tl % clw(:) = deltac(:) * prof_tl%clw(:) * geom%seczen
-
- predictors_tl % clw(2:prof_tl % nlevels) = &
- & 0.5_JPRB * &
- & ( predictors_tl % clw(2:prof_tl % nlevels) + &
- & deltac(2:prof_tl % nlevels) * prof_tl%clw(1:prof_tl % nlevels-1) * &
- & geom%seczen )
- Else
- predictors_tl % ncloud = 0
- Endif
- !
- !5.6 carbon dioxide transmittance based on RTIASI
- !-------------------------------------------------
- !
- If ( coef % nco2 > 0 ) Then
- tr_sqrt(:) = Sqrt(tr(:))
- predictors_tl % co2(1,:) = geom%seczen * co2r_tl(:)
- predictors_tl % co2(2,:) = 2 * tr_tl(:) * predictors % co2(5,:)
- predictors_tl % co2(3,:) = geom%seczen * tr_tl(:)
- predictors_tl % co2(4,:) = 2 * tr_tl(:) * predictors % co2(3,:)
- predictors_tl % co2(5,:) = tr_tl(:)
- predictors_tl % co2(6,:) = 0._JPRB
- predictors_tl % co2(7,:) = geom%seczen * twr_tl(:)
- predictors_tl % co2(8,:) = 2 * geom%seczen * Sqrt( predictors % co2(8,:)) * co2w_tl(:)
- predictors_tl % co2(9,:) = 3 * twr(:) * twr(:) * twr_tl(:)
- predictors_tl % co2(10,:) = geom%seczen * tr_sqrt(:) * twr_tl(:) + &
- & 0.5_JPRB * predictors % co2(7,:) * tr_tl(:) / tr_sqrt(:)
- Endif
-End Subroutine rttov_setpredictors_8_tl
diff --git a/src/LIB/RTTOV/src/rttov_setpredictors_8_tl.interface b/src/LIB/RTTOV/src/rttov_setpredictors_8_tl.interface
deleted file mode 100644
index 1841f1c71aa1ae1afa259b2e14b4c4f699072e62..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_setpredictors_8_tl.interface
+++ /dev/null
@@ -1,32 +0,0 @@
-Interface
-!
-Subroutine rttov_setpredictors_8_tl( &
- prof, & ! in
- prof_tl, & ! in
- geom, & ! in
- coef, & ! in
- predictors, & ! in
- predictors_tl ) ! inout
- Use rttov_const, Only : &
- gravity
-
- Use rttov_types, Only : &
- rttov_coef ,&
- profile_Type ,&
- geometry_Type ,&
- predictors_Type
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
- Type(profile_Type), Intent(in) :: prof
- Type(profile_Type), Intent(in) :: prof_tl
- Type(rttov_coef), Intent(in) :: coef
- Type(geometry_Type), Intent(in) :: geom
- Type(predictors_Type), Intent(in) :: predictors
- Type(predictors_Type), Intent(inout) :: predictors_tl ! in because of mem allocation
-
-
-
-End Subroutine rttov_setpredictors_8_tl
-End Interface
diff --git a/src/LIB/RTTOV/src/rttov_setpredictors_ad.F90 b/src/LIB/RTTOV/src/rttov_setpredictors_ad.F90
deleted file mode 100644
index b4c33f1df9c41816a5005811d72a8b5901d07aa3..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_setpredictors_ad.F90
+++ /dev/null
@@ -1,453 +0,0 @@
-!
-Subroutine rttov_setpredictors_ad( &
- & prof, &! in
- & prof_ad, &! inout
- & geom, &! in
- & coef, &! in
- & predictors, &! in
- & predictors_ad ) ! inout
- ! Description
- ! RTTOV-7 Model
- ! AD of rttov_setpredictors
- ! To calculate and store the profile variables (predictors) required
- ! in subsequent transmittance calculations.
- ! Code based on PRFTAU from previous versions of RTTOV
- ! Only one profile per call
- !
- ! Copyright:
- ! This software was developed within the context of
- ! the EUMETSAT Satellite Application Facility on
- ! Numerical Weather Prediction (NWP SAF), under the
- ! Cooperation Agreement dated 25 November 1998, between
- ! EUMETSAT and the Met Office, UK, by one or more partners
- ! within the NWP SAF. The partners in the NWP SAF are
- ! the Met Office, ECMWF, KNMI and MeteoFrance.
- !
- ! Copyright 2002, EUMETSAT, All Rights Reserved.
- !
- ! Method:
- ! see RTTOV7 science and validation report pages 18/19
- ! variable names are close to the documentation
- !
- ! Current Code Owner: SAF NWP
- !
- ! History:
- ! Version Date Comment
- ! ------- ---- -------
- ! 1.0 01/12/2002 New F90 code with structures (P Brunel A Smith)
- ! 1.1 04/12/2003 Optimisation (J Hague and D Salmond ECMWF)
- ! 1.2 29/03/2005 Add end of header comment (J. Cameron)
- !
- ! Code Description:
- ! Language: Fortran 90.
- ! Software Standards: "European Standards for Writing and
- ! Documenting Exchangeable Fortran 90 Code".
- !
- ! Declarations:
- ! Modules used:
- Use rttov_const, Only : &
- & gravity
-
- ! Imported Type Definitions:
- Use rttov_types, Only : &
- & rttov_coef ,&
- & profile_Type ,&
- & geometry_Type ,&
- & predictors_Type
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
- !subroutine arguments:
- Type(profile_Type), Intent(in) :: prof
- Type(profile_Type), Intent(inout) :: prof_ad
- Type(rttov_coef), Intent(in) :: coef
- Type(geometry_Type), Intent(in) :: geom
- Type(predictors_Type), Intent(in) :: predictors
- Type(predictors_Type), Intent(inout) :: predictors_ad
-
-
- !local variables:
- Integer(Kind=jpim) :: level
-
- ! user profile
- Real(Kind=jprb) :: t(prof % nlevels)
- Real(Kind=jprb) :: w(prof % nlevels)
- Real(Kind=jprb) :: o(prof % nlevels)
-
- ! reference profile
- Real(Kind=jprb) :: tr(prof % nlevels)
- Real(Kind=jprb) :: wr(prof % nlevels)
-
- ! user - reference
- Real(Kind=jprb) :: dt(prof % nlevels)
-
- ! pressure weighted
- Real(Kind=jprb) :: tw(prof % nlevels)
-
-
- Real(Kind=jprb) :: sum1,sum2
- Real(Kind=jprb) :: deltac(prof %nlevels)
- Real(Kind=jprb) :: sec_wr(prof %nlevels)
- Real(Kind=jprb) :: sum2_ww(prof %nlevels)
- Real(Kind=jprb) :: sum2_ow(prof %nlevels)
-
- ! TL variables
- Real(Kind=jprb) :: t_ad(prof % nlevels)
- Real(Kind=jprb) :: w_ad(prof % nlevels)
- Real(Kind=jprb) :: o_ad(prof % nlevels)
-
- Real(Kind=jprb) :: tr_ad(prof % nlevels)
- Real(Kind=jprb) :: wr_ad(prof % nlevels)
- Real(Kind=jprb) :: or_ad(prof % nlevels)
-
- Real(Kind=jprb) :: dt_ad(prof % nlevels)
- Real(Kind=jprb) :: dto_ad(prof % nlevels)
-
- Real(Kind=jprb) :: tw_ad(prof % nlevels)
- Real(Kind=jprb) :: ww_ad(prof % nlevels)
- Real(Kind=jprb) :: ow_ad(prof % nlevels)
-
-
- Real(Kind=jprb) :: sec_or_ad(prof %nlevels)
- Real(Kind=jprb) :: sec_wr_ad(prof %nlevels)
- Real(Kind=jprb) :: zsqrt
-
- !- End of header --------------------------------------------------------
-
- ! profile layer quantities
- ! Direct variables
- t(1) = prof % t(1)
- t(2 : prof % nlevels ) = ( prof % t(1 : prof % nlevels-1) + &
- & prof % t(2 : prof % nlevels ) ) / 2
-
- w(1) = prof % q(1)
- w(2 : prof % nlevels ) = ( prof % q(1 : prof % nlevels-1) + &
- & prof % q(2 : prof % nlevels ) ) / 2
-
- If ( prof % ozone_Data .And. coef % nozone > 0 ) Then
- o(1) = prof % o3(1)
- o(2 : prof % nlevels ) = ( prof % o3(1 : prof % nlevels-1) + &
- & prof % o3(2 : prof % nlevels ) ) / 2
- Endif
-
-
- !3) calculate deviations from reference profile (layers)
- ! if no input O3 profile, set to reference value (dto =0)
- ! Direct variables
- dt(:) = t(:) - coef % tstar(:)
-
- !2) calculate (profile / reference profile) ratios; tr wr or
- ! if no input O3 profile, set to reference value (or =1)
- ! Direct variables
- tr(:) = t(:) / coef % tstar(:)
- wr(:) = w(:) / coef % wstar(:)
-
- ! calculate profile / reference profile sums: tw ww ow
- ! if no input O3 profile, set to reference value (ow =1)
- ! Direct variables
- tw(1) = 0._JPRB
- Do level = 2 , prof % nlevels
- tw( level ) = tw( level-1 ) + coef % dpp( level ) * tr ( level -1 )
- End Do
-
- sum1 = 0._JPRB
- sum2 = 0._JPRB
- Do level = 1, prof % nlevels
- sum1 = sum1 + coef % dpp( level ) * w ( level )
- sum2 = sum2 + coef % dpp( level ) * coef % wstar ( level )
- sum2_ww( level ) = sum2
- End Do
-
- If ( prof % ozone_Data .And. coef % nozone > 0 ) Then
- sum1 = 0._JPRB
- sum2 = 0._JPRB
- Do level = 1, prof % nlevels
- sum1 = sum1 + coef % dpp( level ) * o ( level )
- sum2 = sum2 + coef % dpp( level ) * coef % ostar ( level )
- sum2_ow( level ) = sum2
- End Do
- Endif
-
-
- ! Ajoint code
- !-------------
- w_ad(:) = 0._JPRB
- wr_ad(:) = 0._JPRB
- ww_ad(:) = 0._JPRB
- sec_wr_ad(:) = 0._JPRB
- dt_ad(:) = 0._JPRB
-
- t_ad(:) = 0._JPRB
- tr_ad(:) = 0._JPRB
- tw_ad(:) = 0._JPRB
-
- !5.4 cloud
- !---------
- If ( prof % clw_Data ) Then
- deltac(:) = 0.1820_JPRB * 100.0_JPRB * coef % dp(:) / (4.3429_JPRB * gravity)
-
- prof_ad%clw(1:prof_ad % nlevels-1) = prof_ad%clw(1:prof_ad % nlevels-1) +&
- & 0.5_JPRB * predictors_ad % clw(2:prof_ad % nlevels) *&
- & deltac(2:prof_ad % nlevels) * geom%seczen
-
- predictors_ad % clw(2:prof_ad % nlevels) = 0.5_JPRB * predictors_ad % clw(2:prof_ad % nlevels)
-
- prof_ad%clw(:) = prof_ad%clw(:) + predictors_ad % clw(:) *&
- & deltac(:) * geom%seczen
-
- Endif
-
- !5.3 ozone
- !---------
- If ( coef % nozone > 0 ) Then
- Do level = 1,prof_ad % nlevels
- o_ad(level) = 0._JPRB
- or_ad(level) = 0._JPRB
- ow_ad(level) = 0._JPRB
- dto_ad(level) = 0._JPRB
- sec_or_ad(level) = 0._JPRB
-
- ! One can pack all ow_ad lines in one longer statement
- ! same for sec_or_ad and dto_ad
- ow_ad(level) = ow_ad(level) + predictors_ad % ozone(11,level) *&
- & 2 * geom%seczen * predictors % ozone(10,level)
-
- ow_ad(level) = ow_ad(level) + predictors_ad % ozone(10,level) * geom%seczen
-
- zsqrt=Sqrt(predictors % ozone(10,level))
- sec_or_ad(level) = sec_or_ad(level) + predictors_ad % ozone(9,level) *&
- & zsqrt
- ow_ad(level) = ow_ad(level) + predictors_ad % ozone(9,level) *&
- & 0.5_JPRB * geom%seczen * predictors % ozone(1,level) &
- & / zsqrt
-
- ow_ad(level) = ow_ad(level) + predictors_ad % ozone(8,level) *&
- & predictors % ozone(1,level)
- or_ad(level) = or_ad(level) + predictors_ad % ozone(8,level) *&
- & predictors % ozone(10,level)
-
- sec_or_ad(level) = sec_or_ad(level) + predictors_ad % ozone(7,level) *&
- & 1.5_JPRB * predictors % ozone(2,level) / predictors % ozone(10,level)
- ow_ad(level) = ow_ad(level) - predictors_ad % ozone(7,level) *&
- & geom%seczen * predictors % ozone(2,level)**3 / predictors % ozone(10,level)**2
-
- or_ad(level) = or_ad(level) + predictors_ad % ozone(6,level) *&
- & 2 * predictors % ozone(8,level)
- ow_ad(level) = ow_ad(level) + predictors_ad % ozone(6,level) *&
- & predictors % ozone(4,level) / geom%seczen
-
- sec_or_ad(level) = sec_or_ad(level) + predictors_ad % ozone(5,level) *&
- & 0.5_JPRB * predictors % ozone(3,level) /&
- & ( predictors % ozone(1,level) *predictors % ozone(2,level))
- dto_ad(level) = dto_ad(level) + predictors_ad % ozone(5,level) *&
- & predictors % ozone(2,level)
-
- sec_or_ad(level) = sec_or_ad(level) + predictors_ad % ozone(4,level) *&
- & 2 * predictors % ozone(1,level)
-
- sec_or_ad(level) = sec_or_ad(level) + predictors_ad % ozone(3,level) *&
- & predictors % ozone(3,level) / predictors % ozone(1,level)
- dto_ad(level) = dto_ad(level) + predictors_ad % ozone(3,level) *&
- & predictors % ozone(1,level)
-
- sec_or_ad(level) = sec_or_ad(level) + predictors_ad % ozone(2,level) *&
- & 0.5_JPRB / predictors % ozone(2,level)
-
- sec_or_ad(level) = sec_or_ad(level) + predictors_ad % ozone(1,level)
-
- or_ad(level) = or_ad(level) + sec_or_ad(level) * geom%seczen
- End Do
- Endif
-
- !5.2 water vapour ( numbers in right hand are predictor numbers
- ! in the reference document for RTTOV7 (science and validation report)
- !----------------
-
- Do level = 1,prof_ad % nlevels
- sec_wr(level) = geom%seczen * wr(level)
-
- ! X15 (15)
- wr_ad(level) = wr_ad(level) + predictors_ad % watervapour(15,level) *&
- & predictors % watervapour(15,level) * geom%seczen * &
- & 2 / predictors % watervapour(1,level)
- tr_ad(level) = tr_ad(level) - predictors_ad % watervapour(15,level) *&
- & predictors % watervapour(15,level) * geom%seczen * &
- & 4 * predictors % watervapour(14,level) / &
- & predictors % watervapour(5,level)
-
- ! X14 (14)
- sec_wr_ad(level) = sec_wr_ad(level) + predictors_ad % watervapour(14,level) *&
- & 2 * predictors % watervapour(14,level) / predictors % watervapour(1,level)
- tr_ad(level) = tr_ad(level) - predictors_ad % watervapour(14,level) *&
- & predictors % watervapour(14,level)**2 / (geom%seczen * wr(level) * wr(level))
-
- ! X13 (2)
- zsqrt=Sqrt( predictors % watervapour(13,level))
- ww_ad(level) = ww_ad(level) + predictors_ad % watervapour(13,level) *&
- & 2 * geom%seczen * zsqrt
-
- ! X12 (3)
- ww_ad(level) = ww_ad(level) + predictors_ad % watervapour(12,level) *&
- & 4 * geom%seczen * predictors % watervapour(12,level) &
- & / zsqrt
-
- ! X11 (10)
- sec_wr_ad(level) = sec_wr_ad(level) + predictors_ad % watervapour(11,level) *&
- & Abs(dt(level)) * dt(level)
- dt_ad(level) = dt_ad(level) + predictors_ad % watervapour(11,level) *&
- & 2 * sec_wr(level) * Abs(dt(level))
-
- ! X10 (9)
- sec_wr_ad(level) = sec_wr_ad(level) + predictors_ad % watervapour(10,level) *&
- & 4 * predictors % watervapour(9,level)
-
- ! X9 (8)
- sec_wr_ad(level) = sec_wr_ad(level) + predictors_ad % watervapour(9,level) *&
- & 3 * predictors % watervapour(5,level)
-
- ! X8 (13)
- wr_ad(level) = wr_ad(level) + predictors_ad % watervapour(8,level) *&
- & geom%seczen * predictors % watervapour(8,level) * &
- & 1.5_JPRB / predictors % watervapour(1,level)
- ww_ad(level) = ww_ad(level) - predictors_ad % watervapour(8,level) *&
- & geom%seczen * predictors % watervapour(8,level) / &
- & predictors % watervapour(13,level)**0.5_JPRB
-
- ! X7 (6)
- sec_wr_ad(level) = sec_wr_ad(level) + predictors_ad % watervapour(7,level) *&
- & 0.25_JPRB / predictors % watervapour(7,level)**3
-
- ! X6 (11)
- dt_ad(level) = dt_ad(level) + predictors_ad % watervapour(6,level) *&
- & predictors % watervapour(2,level)
- sec_wr_ad(level) = sec_wr_ad(level) + predictors_ad % watervapour(6,level) *&
- & 0.5_JPRB * predictors % watervapour(6,level) / predictors % watervapour(1,level)
-
- ! X5 (1)
- sec_wr_ad(level) = sec_wr_ad(level) + predictors_ad % watervapour(5,level) *&
- & 2 * predictors % watervapour(1,level)
-
- ! X4 (4)
- sec_wr_ad(level) = sec_wr_ad(level) + predictors_ad % watervapour(4,level) *&
- & predictors % watervapour(4,level) / predictors % watervapour(1,level)
- dt_ad(level) = dt_ad(level) + predictors_ad % watervapour(4,level) *&
- & predictors % watervapour(1,level)
-
- ! X3 (12)
- sec_wr_ad(level) = sec_wr_ad(level) + predictors_ad % watervapour(3,level) *&
- & 2 * predictors % watervapour(3,level) / predictors % watervapour(1,level)
- ww_ad(level) = ww_ad(level) - predictors_ad % watervapour(3,level) *&
- & predictors % watervapour(3,level)**2 * geom%seczen &
- & / predictors % watervapour(5,level)
-
- ! X2 (5)
- sec_wr_ad(level) = sec_wr_ad(level) + predictors_ad % watervapour(2,level) *&
- & 0.5_JPRB / predictors % watervapour(2,level)
-
- ! X1 (7)
- sec_wr_ad(level) = sec_wr_ad(level) + predictors_ad % watervapour(1,level)
-
- wr_ad(level) = wr_ad(level) + sec_wr_ad(level) * geom%seczen
- End Do
-
- !5.1 mixed gases
- !---------------
-
- ! X10
- tw_ad(2:prof_ad % nlevels) = tw_ad(2:prof_ad % nlevels) +&
- & predictors_ad % mixedgas(10,2:prof_ad % nlevels) *&
- & 0.25_JPRB * geom % seczen_sq &
- & / predictors % mixedgas(10,2:prof_ad % nlevels)**3
-
- ! X9
- ! X8
- Do level = 1,prof_ad % nlevels
- tw_ad(level) = tw_ad(level) + predictors_ad % mixedgas(8,level) *&
- & geom % seczen / predictors % mixedgas(5,level)
- tr_ad(level) = tr_ad(level) - predictors_ad % mixedgas(8,level) *&
- & predictors % mixedgas(7,level) / predictors % mixedgas(6,level)
-
- ! X7
- tw_ad(level) = tw_ad(level) + predictors_ad % mixedgas(7,level) *&
- & geom % seczen
-
- ! X6
- tr_ad(level) = tr_ad(level) + predictors_ad % mixedgas(6,level) *&
- & 2._JPRB * tr(level)
-
- ! X5
- tr_ad(level) = tr_ad(level) + predictors_ad % mixedgas(5,level)
-
- ! X4
- tr_ad(level) = tr_ad(level) + predictors_ad % mixedgas(4,level) *&
- & 2._JPRB * predictors % mixedgas(3,level)
-
- ! X3
- tr_ad(level) = tr_ad(level) + predictors_ad % mixedgas(3,level) *&
- & geom % seczen
-
- ! X2
- ! X1
- End Do
-
- sum1 = 0._JPRB
- If ( prof % ozone_Data .And. coef % nozone > 0 ) Then
- Do level = prof_ad % nlevels, 1, -1
- sum1 = sum1 + ow_ad ( level ) / sum2_ow(level)
- o_ad( level ) = o_ad( level ) + sum1 * coef % dpp( level )
- End Do
- Else
- o_ad(:) = 0._JPRB
- Endif
-
- sum1 = 0._JPRB
- Do level = prof_ad % nlevels, 1, -1
- sum1 = sum1 + ww_ad ( level ) / sum2_ww(level)
- w_ad( level ) = w_ad( level ) + sum1 * coef % dpp( level )
- End Do
-
- Do level = prof_ad % nlevels, 2, -1
- tw_ad( level-1 ) = tw_ad( level-1 ) + tw_ad( level )
- tr_ad( level-1 ) = tr_ad( level-1 ) + tw_ad( level ) *&
- & coef % dpp( level )
- End Do
-
-
- If ( prof % ozone_Data .And. coef % nozone > 0 ) Then
- o_ad(:) = o_ad(:) + or_ad(:) / coef % ostar(:)
- Endif
-
- w_ad(:) = w_ad(:) + wr_ad(:) / coef % wstar(:)
-
- t_ad(:) = t_ad(:) + tr_ad(:) / coef % tstar(:)
-
-
- If ( prof % ozone_Data .And. coef % nozone > 0 ) Then
- t_ad(:) = t_ad(:) + dto_ad(:)
- Endif
-
- t_ad(:) = t_ad(:) + dt_ad(:)
-
- If ( prof % ozone_Data .And. coef % nozone > 0 ) Then
- prof_ad % o3(1 : prof_ad % nlevels-1) = prof_ad % o3(1 : prof_ad % nlevels-1) +&
- & 0.5_JPRB *o_ad(2 : prof_ad % nlevels )
- prof_ad % o3(2 : prof_ad % nlevels) = prof_ad % o3(2 : prof_ad % nlevels) +&
- & 0.5_JPRB *o_ad(2 : prof_ad % nlevels )
- prof_ad % o3(1) = prof_ad % o3(1) + o_ad(1)
- Endif
-
- prof_ad % q(1 : prof_ad % nlevels-1) = prof_ad % q(1 : prof_ad % nlevels-1) +&
- & 0.5_JPRB *w_ad(2 : prof_ad % nlevels )
- prof_ad % q(2 : prof_ad % nlevels) = prof_ad % q(2 : prof_ad % nlevels) +&
- & 0.5_JPRB *w_ad(2 : prof_ad % nlevels )
- prof_ad % q(1) = prof_ad % q(1) + w_ad(1)
-
- prof_ad % t(1 : prof_ad % nlevels-1) = prof_ad % t(1 : prof_ad % nlevels-1) +&
- & 0.5_JPRB *t_ad(2 : prof_ad % nlevels )
- prof_ad % t(2 : prof_ad % nlevels) = prof_ad % t(2 : prof_ad % nlevels) +&
- & 0.5_JPRB *t_ad(2 : prof_ad % nlevels )
- prof_ad % t(1) = prof_ad % t(1) + t_ad(1)
-
-
-End Subroutine rttov_setpredictors_ad
diff --git a/src/LIB/RTTOV/src/rttov_setpredictors_ad.interface b/src/LIB/RTTOV/src/rttov_setpredictors_ad.interface
deleted file mode 100644
index cce3d45d8b7411f628ddf9627815fb87eb4f59f8..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_setpredictors_ad.interface
+++ /dev/null
@@ -1,32 +0,0 @@
-Interface
-!
-Subroutine rttov_setpredictors_ad( &
- prof, & ! in
- prof_ad, & ! inout
- geom, & ! in
- coef, & ! in
- predictors, & ! in
- predictors_ad ) ! inout
- Use rttov_const, Only : &
- gravity
-
- Use rttov_types, Only : &
- rttov_coef ,&
- profile_Type ,&
- geometry_Type ,&
- predictors_Type
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
- Type(profile_Type), Intent(in) :: prof
- Type(profile_Type), Intent(inout) :: prof_ad
- Type(rttov_coef), Intent(in) :: coef
- Type(geometry_Type), Intent(in) :: geom
- Type(predictors_Type), Intent(in) :: predictors
- Type(predictors_Type), Intent(inout) :: predictors_ad
-
-
-
-End Subroutine rttov_setpredictors_ad
-End Interface
diff --git a/src/LIB/RTTOV/src/rttov_setpredictors_k.F90 b/src/LIB/RTTOV/src/rttov_setpredictors_k.F90
deleted file mode 100644
index d9ede6e8dd288e7bdc1df18bec4deb6c4a3f64da..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_setpredictors_k.F90
+++ /dev/null
@@ -1,569 +0,0 @@
-!
-Subroutine rttov_setpredictors_k( &
- & nfrequencies, &! in
- & nchannels, &! in
- & nprofiles, &! in
- & nlevels, &! in
- & angles, &! in
- & polarisations, &! in
- & lprofiles, &! in
- & profiles, &! in
- & profiles_k, &! inout
- & coef, &! in
- & predictors, &! in
- & predictors_k ) ! inout
- ! Description
- ! RTTOV-7 Model
- !
- ! Copyright:
- ! This software was developed within the context of
- ! the EUMETSAT Satellite Application Facility on
- ! Numerical Weather Prediction (NWP SAF), under the
- ! Cooperation Agreement dated 25 November 1998, between
- ! EUMETSAT and the Met Office, UK, by one or more partners
- ! within the NWP SAF. The partners in the NWP SAF are
- ! the Met Office, ECMWF, KNMI and MeteoFrance.
- !
- ! Copyright 2005, EUMETSAT, All Rights Reserved.
- !
- ! Method:
- ! see RTTOV7 science and validation report pages 18/19
- ! variable names are close to the documentation
- !
- ! Current Code Owner: SAF NWP
- !
- ! History:
- ! Version Date Comment
- ! ------- ---- -------
- ! 1.0 22/06/2005 initial (P Brunel)
- ! based on version 1.2 (29/03/05) of AD code
- !
- ! Code Description:
- ! Language: Fortran 90.
- ! Software Standards: "European Standards for Writing and
- ! Documenting Exchangeable Fortran 90 Code".
- !
- ! Declarations:
- ! Modules used:
- ! Imported Parameters:
- Use rttov_const, Only : &
- & gravity ,&
- & sensor_id_mw
-
- ! Imported Type Definitions:
- Use rttov_types, Only : &
- & rttov_coef ,&
- & profile_Type ,&
- & geometry_Type ,&
- & predictors_Type
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
- !subroutine arguments:
- Integer(Kind=jpim), Intent(in) :: nfrequencies ! Number of frequencies
- Integer(Kind=jpim), Intent(in) :: nchannels ! Number of output radiances
- Integer(Kind=jpim), Intent(in) :: nprofiles ! Number of profiles
- Integer(Kind=jpim), Intent(in) :: nlevels ! Number of levels
- Integer(Kind=jpim), Intent(in) :: polarisations(nchannels,3) ! polarisation indices
- Integer(Kind=jpim), Intent(in) :: lprofiles(nfrequencies) ! Profiles indices
-
- Type(profile_Type), Target, Intent(in) :: profiles(nprofiles)
- Type(profile_Type), Target, Intent(inout) :: profiles_k(nchannels)
- Type(geometry_Type), Target, Intent(in) :: angles(nprofiles)
- Type(predictors_Type), Target, Intent(in) :: predictors(nprofiles)
- Type(predictors_Type), Target, Intent(inout) :: predictors_k(nchannels)
- Type(rttov_coef), Intent(in) :: coef
-
- !local variables:
-
- Type(geometry_Type), Pointer :: geom
- Type(profile_Type), Pointer :: prof
- Type(profile_Type), Pointer :: prof_k
- Type(predictors_Type), Pointer :: pred
- Type(predictors_Type), Pointer :: pred_k
-
- Integer(Kind=jpim) :: level
- Integer(Kind=jpim) :: freq
- Integer(Kind=jpim) :: i ! channel indice
- Integer(Kind=jpim) :: j ! profile indice
-
- ! user profile
- Real(Kind=jprb) :: t(nlevels, nprofiles)
- Real(Kind=jprb) :: w(nlevels, nprofiles)
- Real(Kind=jprb) :: o(nlevels, nprofiles)
-
- ! reference profile
- Real(Kind=jprb) :: tr(nlevels, nprofiles)
- Real(Kind=jprb) :: wr(nlevels, nprofiles)
-
- ! user - reference
- Real(Kind=jprb) :: dt(nlevels, nprofiles)
-
- ! pressure weighted
- Real(Kind=jprb) :: tw(nlevels, nprofiles)
-
-
- Real(Kind=jprb) :: sum1,sum2
- Real(Kind=jprb) :: deltac(nlevels)
- Real(Kind=jprb) :: sec_wr(nlevels, nprofiles)
- Real(Kind=jprb) :: sum2_ww(nlevels, nprofiles)
- Real(Kind=jprb) :: sum2_ow(nlevels, nprofiles)
-
- ! K variables
- Real(Kind=jprb) :: t_k(nlevels, nchannels)
- Real(Kind=jprb) :: w_k(nlevels, nchannels)
- Real(Kind=jprb) :: o_k(nlevels, nchannels)
-
- Real(Kind=jprb) :: tr_k(nlevels, nchannels)
- Real(Kind=jprb) :: wr_k(nlevels, nchannels)
- Real(Kind=jprb) :: or_k(nlevels, nchannels)
-
- Real(Kind=jprb) :: dt_k(nlevels, nchannels)
- Real(Kind=jprb) :: dto_k(nlevels, nchannels)
-
- Real(Kind=jprb) :: tw_k(nlevels, nchannels)
- Real(Kind=jprb) :: ww_k(nlevels, nchannels)
- Real(Kind=jprb) :: ow_k(nlevels, nchannels)
-
-
- Real(Kind=jprb) :: sec_or_k(nlevels, nchannels)
- Real(Kind=jprb) :: sec_wr_k(nlevels, nchannels)
- Real(Kind=jprb) :: zsqrt
-
- !- End of header --------------------------------------------------------
-
- nullify ( geom )
- nullify ( prof )
- nullify ( prof_k )
- nullify ( pred )
- nullify ( pred_k )
-
- !
- ! Keep use of prof%nlevels in the code instead of input argument nlevels
- ! This is to allow profiles on variable levels, for future version.
- !
-
- ! profile layer quantities
- ! Direct variables
- Do j = 1, nprofiles
-
- prof => profiles(j)
-
- t(1, j) = prof % t(1)
- t(2 : prof % nlevels, j ) = ( prof % t(1 : prof % nlevels-1) + &
- & prof % t(2 : prof % nlevels) ) / 2._JPRB
-
- w(1, j) = prof % q(1)
- w(2 : prof % nlevels, j ) = ( prof % q(1 : prof % nlevels-1) + &
- & prof % q(2 : prof % nlevels) ) / 2._JPRB
-
- If ( prof % ozone_Data .And. coef % nozone > 0 ) Then
- o(1, j) = prof % o3(1)
- o(2 : prof % nlevels, j ) = ( prof % o3(1 : prof % nlevels-1) + &
- & prof % o3(2 : prof % nlevels) ) / 2._JPRB
- Else
- o( : , j ) = 0._JPRB
- Endif
-
-
- !3) calculate deviations from reference profile (layers)
- ! if no input O3 profile, set to reference value (dto =0)
- ! Direct variables
- dt(:, j) = t(:, j) - coef % tstar(:)
-
- !2) calculate (profile / reference profile) ratios; tr wr or
- ! if no input O3 profile, set to reference value (or =1)
- ! Direct variables
- tr(:, j) = t(:, j) / coef % tstar(:)
- wr(:, j) = w(:, j) / coef % wstar(:)
-
- ! calculate profile / reference profile sums: tw ww ow
- ! if no input O3 profile, set to reference value (ow =1)
- ! Direct variables
- tw(1, j) = 0._JPRB
- Do level = 2 , prof % nlevels
- tw( level, j ) = tw( level-1, j ) + coef % dpp( level ) * tr ( level -1, j )
- End Do
-
- sum1 = 0._JPRB
- sum2 = 0._JPRB
- Do level = 1, prof % nlevels
- sum1 = sum1 + coef % dpp( level ) * w ( level, j )
- sum2 = sum2 + coef % dpp( level ) * coef % wstar ( level )
- sum2_ww( level, j ) = sum2
- End Do
-
- If ( prof % ozone_Data .And. coef % nozone > 0 ) Then
- sum1 = 0._JPRB
- sum2 = 0._JPRB
- Do level = 1, prof % nlevels
- sum1 = sum1 + coef % dpp( level ) * o ( level, j )
- sum2 = sum2 + coef % dpp( level ) * coef % ostar ( level )
- sum2_ow( level, j ) = sum2
- End Do
- Else
- sum2_ow( :, j ) = 0._JPRB
- Endif
-
- End Do ! loop on profiles
-
-
-
- ! Ajoint code
- !-------------
- w_k(:,:) = 0._JPRB
- wr_k(:,:) = 0._JPRB
- ww_k(:,:) = 0._JPRB
- sec_wr_k(:,:) = 0._JPRB
- dt_k(:,:) = 0._JPRB
-
- t_k(:,:) = 0._JPRB
- tr_k(:,:) = 0._JPRB
- tw_k(:,:) = 0._JPRB
-
- !5.4 cloud
- !---------
- If ( coef % id_sensor == sensor_id_mw ) Then
- deltac(:) = 0.1820_JPRB * 100.0_JPRB * coef % dp(:) / (4.3429_JPRB * gravity)
-
- Do i = 1, nchannels
- freq=polarisations(i,2)
- j = lprofiles( freq )
-
- prof => profiles(j)
-
- If ( prof % clw_Data ) Then
-
- geom => angles(j)
- prof_k => profiles_k(i)
- pred_k => predictors_k(i)
-
- prof_k%clw(1:prof_k % nlevels-1) = prof_k%clw(1:prof_k % nlevels-1) +&
- & 0.5_JPRB * pred_k % clw(2:prof_k % nlevels) *&
- & deltac(2:prof_k % nlevels) * geom%seczen
-
- pred_k % clw(2:prof_k % nlevels) = 0.5_JPRB * pred_k % clw(2:prof_k % nlevels)
-
- prof_k%clw(:) = prof_k%clw(:) + pred_k % clw(:) *&
- & deltac(:) * geom%seczen
-
- Endif
- End Do
- End If
-
- !5.3 ozone
- !---------
- If ( coef % nozone > 0 ) Then
- Do i = 1, nchannels
- freq=polarisations(i,2)
- j = lprofiles( freq )
-
- ! prof => profiles(j) (use of variables derived from prof )
- geom => angles(j)
- pred => predictors(j)
- prof_k => profiles_k(i) ! only for loop on levels
- pred_k => predictors_k(i)
-
- Do level = 1,prof_k % nlevels
-
- o_k(level,i) = 0._JPRB
- or_k(level,i) = 0._JPRB
- ow_k(level,i) = 0._JPRB
- dto_k(level,i) = 0._JPRB
- sec_or_k(level,i) = 0._JPRB
-
- ! One can pack all ow_k lines in one longer statement
- ! same for sec_or_k and dto_k
- ow_k(level,i) = ow_k(level,i) + pred_k % ozone(11,level) *&
- & 2 * geom%seczen * pred % ozone(10,level)
-
- ow_k(level,i) = ow_k(level,i) + pred_k % ozone(10,level) * geom%seczen
-
- zsqrt=Sqrt(pred % ozone(10,level))
- sec_or_k(level,i) = sec_or_k(level,i) + pred_k % ozone(9,level) *&
- & zsqrt
- ow_k(level,i) = ow_k(level,i) + pred_k % ozone(9,level) *&
- & 0.5_JPRB * geom%seczen * pred % ozone(1,level) &
- & / zsqrt
-
- ow_k(level,i) = ow_k(level,i) + pred_k % ozone(8,level) *&
- & pred % ozone(1,level)
- or_k(level,i) = or_k(level,i) + pred_k % ozone(8,level) *&
- & pred % ozone(10,level)
-
- sec_or_k(level,i) = sec_or_k(level,i) + pred_k % ozone(7,level) *&
- & 1.5_JPRB * pred % ozone(2,level) / pred % ozone(10,level)
- ow_k(level,i) = ow_k(level,i) - pred_k % ozone(7,level) *&
- & geom%seczen * pred % ozone(2,level)**3 / pred % ozone(10,level)**2
-
- or_k(level,i) = or_k(level,i) + pred_k % ozone(6,level) *&
- & 2 * pred % ozone(8,level)
- ow_k(level,i) = ow_k(level,i) + pred_k % ozone(6,level) *&
- & pred % ozone(4,level) / geom%seczen
-
- sec_or_k(level,i) = sec_or_k(level,i) + pred_k % ozone(5,level) *&
- & 0.5_JPRB * pred % ozone(3,level) /&
- & ( pred % ozone(1,level) *pred % ozone(2,level))
- dto_k(level,i) = dto_k(level,i) + pred_k % ozone(5,level) *&
- & pred % ozone(2,level)
-
- sec_or_k(level,i) = sec_or_k(level,i) + pred_k % ozone(4,level) *&
- & 2 * pred % ozone(1,level)
-
- sec_or_k(level,i) = sec_or_k(level,i) + pred_k % ozone(3,level) *&
- & pred % ozone(3,level) / pred % ozone(1,level)
- dto_k(level,i) = dto_k(level,i) + pred_k % ozone(3,level) *&
- & pred % ozone(1,level)
-
- sec_or_k(level,i) = sec_or_k(level,i) + pred_k % ozone(2,level) *&
- & 0.5_JPRB / pred % ozone(2,level)
-
- sec_or_k(level,i) = sec_or_k(level,i) + pred_k % ozone(1,level)
-
- or_k(level,i) = or_k(level,i) + sec_or_k(level,i) * geom%seczen
- End Do
- End Do
- Endif
-
- !5.2 water vapour ( numbers in right hand are predictor numbers
- ! in the reference document for RTTOV7 (science and validation report)
- !----------------
-
- Do i = 1, nchannels
- freq=polarisations(i,2)
- j = lprofiles( freq )
-
- ! prof => profiles(j) (use of variables derived from prof )
- geom => angles(j)
- pred => predictors(j)
- prof_k => profiles_k(i) ! only for loop on levels
- pred_k => predictors_k(i)
-
- Do level = 1,prof_k % nlevels
-
- sec_wr(level, j) = geom%seczen * wr(level, j)
-
- ! X15 (15)
- wr_k(level,i) = wr_k(level,i) + pred_k % watervapour(15,level) *&
- & pred % watervapour(15,level) * geom%seczen * &
- & 2 / pred % watervapour(1,level)
- tr_k(level,i) = tr_k(level,i) - pred_k % watervapour(15,level) *&
- & pred % watervapour(15,level) * geom%seczen * &
- & 4 * pred % watervapour(14,level) / &
- & pred % watervapour(5,level)
-
- ! X14 (14)
- sec_wr_k(level,i) = sec_wr_k(level,i) + pred_k % watervapour(14,level) *&
- & 2 * pred % watervapour(14,level) / pred % watervapour(1,level)
- tr_k(level,i) = tr_k(level,i) - pred_k % watervapour(14,level) *&
- & pred % watervapour(14,level)**2 / (geom%seczen * wr(level,j) * wr(level,j))
-
- ! X13 (2)
- zsqrt=Sqrt( pred % watervapour(13,level))
- ww_k(level,i) = ww_k(level,i) + pred_k % watervapour(13,level) *&
- & 2 * geom%seczen * zsqrt
-
- ! X12 (3)
- ww_k(level,i) = ww_k(level,i) + pred_k % watervapour(12,level) *&
- & 4 * geom%seczen * pred % watervapour(12,level) &
- & / zsqrt
-
- ! X11 (10)
- sec_wr_k(level,i) = sec_wr_k(level,i) + pred_k % watervapour(11,level) *&
- & Abs(dt(level,j)) * dt(level,j)
- dt_k(level,i) = dt_k(level,i) + pred_k % watervapour(11,level) *&
- & 2 * sec_wr(level,j) * Abs(dt(level,j))
-
- ! X10 (9)
- sec_wr_k(level,i) = sec_wr_k(level,i) + pred_k % watervapour(10,level) *&
- & 4 * pred % watervapour(9,level)
-
- ! X9 (8)
- sec_wr_k(level,i) = sec_wr_k(level,i) + pred_k % watervapour(9,level) *&
- & 3 * pred % watervapour(5,level)
-
- ! X8 (13)
- wr_k(level,i) = wr_k(level,i) + pred_k % watervapour(8,level) *&
- & geom%seczen * pred % watervapour(8,level) * &
- & 1.5_JPRB / pred % watervapour(1,level)
- ww_k(level,i) = ww_k(level,i) - pred_k % watervapour(8,level) *&
- & geom%seczen * pred % watervapour(8,level) / &
- & pred % watervapour(13,level)**0.5_JPRB
-
- ! X7 (6)
- sec_wr_k(level,i) = sec_wr_k(level,i) + pred_k % watervapour(7,level) *&
- & 0.25_JPRB / pred % watervapour(7,level)**3
-
- ! X6 (11)
- dt_k(level,i) = dt_k(level,i) + pred_k % watervapour(6,level) *&
- & pred % watervapour(2,level)
- sec_wr_k(level,i) = sec_wr_k(level,i) + pred_k % watervapour(6,level) *&
- & 0.5_JPRB * pred % watervapour(6,level) / pred % watervapour(1,level)
-
- ! X5 (1)
- sec_wr_k(level,i) = sec_wr_k(level,i) + pred_k % watervapour(5,level) *&
- & 2 * pred % watervapour(1,level)
-
- ! X4 (4)
- sec_wr_k(level,i) = sec_wr_k(level,i) + pred_k % watervapour(4,level) *&
- & pred % watervapour(4,level) / pred % watervapour(1,level)
- dt_k(level,i) = dt_k(level,i) + pred_k % watervapour(4,level) *&
- & pred % watervapour(1,level)
-
- ! X3 (12)
- sec_wr_k(level,i) = sec_wr_k(level,i) + pred_k % watervapour(3,level) *&
- & 2 * pred % watervapour(3,level) / pred % watervapour(1,level)
- ww_k(level,i) = ww_k(level,i) - pred_k % watervapour(3,level) *&
- & pred % watervapour(3,level)**2 * geom%seczen &
- & / pred % watervapour(5,level)
-
- ! X2 (5)
- sec_wr_k(level,i) = sec_wr_k(level,i) + pred_k % watervapour(2,level) *&
- & 0.5_JPRB / pred % watervapour(2,level)
-
- ! X1 (7)
- sec_wr_k(level,i) = sec_wr_k(level,i) + pred_k % watervapour(1,level)
-
- wr_k(level,i) = wr_k(level,i) + sec_wr_k(level,i) * geom%seczen
- End Do
- End Do
-
- !5.1 mixed gases
- !---------------
-
- ! X10
- Do i = 1, nchannels
- freq=polarisations(i,2)
- j = lprofiles( freq )
-
- geom => angles(j)
- pred => predictors(j)
- prof_k => profiles_k(i)
- pred_k => predictors_k(i)
-
- tw_k(2:prof_k % nlevels,i) = tw_k(2:prof_k % nlevels,i) +&
- & pred_k % mixedgas(10,2:prof_k % nlevels) *&
- & 0.25_JPRB * geom % seczen_sq &
- & / pred % mixedgas(10,2:prof_k % nlevels)**3
- End Do
-
- ! X9
- ! X8
- Do i = 1, nchannels
- freq=polarisations(i,2)
- j = lprofiles( freq )
-
- ! prof => profiles(j) (use of variables derived from prof )
- geom => angles(j)
- pred => predictors(j)
- prof_k => profiles_k(i)
- pred_k => predictors_k(i)
-
- Do level = 1,prof_k % nlevels
-
- tw_k(level,i) = tw_k(level,i) + pred_k % mixedgas(8,level) *&
- & geom % seczen / pred % mixedgas(5,level)
- tr_k(level,i) = tr_k(level,i) - pred_k % mixedgas(8,level) *&
- & pred % mixedgas(7,level) / pred % mixedgas(6,level)
-
- ! X7
- tw_k(level,i) = tw_k(level,i) + pred_k % mixedgas(7,level) *&
- & geom % seczen
-
- ! X6
- tr_k(level,i) = tr_k(level,i) + pred_k % mixedgas(6,level) *&
- & 2._JPRB * tr(level,j)
-
- ! X5
- tr_k(level,i) = tr_k(level,i) + pred_k % mixedgas(5,level)
-
- ! X4
- tr_k(level,i) = tr_k(level,i) + pred_k % mixedgas(4,level) *&
- & 2._JPRB * pred % mixedgas(3,level)
-
- ! X3
- tr_k(level,i) = tr_k(level,i) + pred_k % mixedgas(3,level) *&
- & geom % seczen
-
- ! X2
- ! X1
- End Do
- End Do
-
- Do i = 1, nchannels
- freq=polarisations(i,2)
- j = lprofiles( freq )
-
- prof => profiles(j)
- geom => angles(j)
- pred => predictors(j)
- prof_k => profiles_k(i)
- pred_k => predictors_k(i)
-
- sum1 = 0._JPRB
- If ( prof % ozone_Data .And. coef % nozone > 0 ) Then
- Do level = prof_k % nlevels, 1, -1
- sum1 = sum1 + ow_k ( level, i ) / sum2_ow(level, j)
- o_k( level, i) = o_k( level, i) + sum1 * coef % dpp( level )
- End Do
- Else
- o_k(:,i) = 0._JPRB
- Endif
-
- sum1 = 0._JPRB
- Do level = prof_k % nlevels, 1, -1
- sum1 = sum1 + ww_k ( level, i) / sum2_ww(level, j)
- w_k( level, i) = w_k( level, i) + sum1 * coef % dpp( level )
- End Do
-
- Do level = prof_k % nlevels, 2, -1
- tw_k( level-1, i) = tw_k( level-1, i) + tw_k( level, i)
- tr_k( level-1, i) = tr_k( level-1, i) + tw_k( level, i) *&
- & coef % dpp( level )
- End Do
-
-
- If ( prof % ozone_Data .And. coef % nozone > 0 ) Then
- o_k(:,i) = o_k(:,i) + or_k(:,i) / coef % ostar(:)
- Endif
-
- w_k(:,i) = w_k(:,i) + wr_k(:,i) / coef % wstar(:)
-
- t_k(:,i) = t_k(:,i) + tr_k(:,i) / coef % tstar(:)
-
-
- If ( prof % ozone_Data .And. coef % nozone > 0 ) Then
- t_k(:,i) = t_k(:,i) + dto_k(:,i)
- Endif
-
- t_k(:,i) = t_k(:,i) + dt_k(:,i)
-
- If ( prof % ozone_Data .And. coef % nozone > 0 ) Then
- prof_k % o3(1 : prof_k % nlevels-1) = prof_k % o3(1 : prof_k % nlevels-1) +&
- & 0.5_JPRB *o_k(2 : prof_k % nlevels, i)
- prof_k % o3(2 : prof_k % nlevels) = prof_k % o3(2 : prof_k % nlevels) +&
- & 0.5_JPRB *o_k(2 : prof_k % nlevels, i)
- prof_k % o3(1) = prof_k % o3(1) + o_k(1,i)
- Endif
-
- prof_k % q(1 : prof_k % nlevels-1) = prof_k % q(1 : prof_k % nlevels-1) +&
- & 0.5_JPRB *w_k(2 : prof_k % nlevels, i)
- prof_k % q(2 : prof_k % nlevels) = prof_k % q(2 : prof_k % nlevels) +&
- & 0.5_JPRB *w_k(2 : prof_k % nlevels, i)
- prof_k % q(1) = prof_k % q(1) + w_k(1,i)
-
- prof_k % t(1 : prof_k % nlevels-1) = prof_k % t(1 : prof_k % nlevels-1) +&
- & 0.5_JPRB *t_k(2 : prof_k % nlevels, i)
- prof_k % t(2 : prof_k % nlevels) = prof_k % t(2 : prof_k % nlevels) +&
- & 0.5_JPRB *t_k(2 : prof_k % nlevels, i)
- prof_k % t(1) = prof_k % t(1) + t_k(1,i)
- End Do
-
- nullify ( geom )
- nullify ( prof )
- nullify ( prof_k )
- nullify ( pred )
- nullify ( pred_k )
-
-End Subroutine rttov_setpredictors_k
diff --git a/src/LIB/RTTOV/src/rttov_setpredictors_k.interface b/src/LIB/RTTOV/src/rttov_setpredictors_k.interface
deleted file mode 100644
index 8dc6a82b200a0280067bf3db860420d11fb872ac..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_setpredictors_k.interface
+++ /dev/null
@@ -1,46 +0,0 @@
-Interface
-!
-Subroutine rttov_setpredictors_k( &
- & nfrequencies, &! in
- & nchannels, &! in
- & nprofiles, &! in
- & nlevels, &! in
- & angles, &! in
- & polarisations, &! in
- & lprofiles, &! in
- & profiles, &! in
- & profiles_k, &! inout
- & coef, &! in
- & predictors, &! in
- & predictors_k ) ! inout
-
- Use rttov_const, Only : &
- & gravity ,&
- & sensor_id_mw
-
- Use rttov_types, Only : &
- & rttov_coef ,&
- & profile_Type ,&
- & geometry_Type ,&
- & predictors_Type
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
- Integer(Kind=jpim), Intent(in) :: nfrequencies ! Number of frequencies
- Integer(Kind=jpim), Intent(in) :: nchannels ! Number of output radiances
- Integer(Kind=jpim), Intent(in) :: nprofiles ! Number of profiles
- Integer(Kind=jpim), Intent(in) :: nlevels ! Number of levels
- Integer(Kind=jpim), Intent(in) :: polarisations(nchannels,3) ! polarisation indices
- Integer(Kind=jpim), Intent(in) :: lprofiles(nfrequencies) ! Profiles indices
-
-
- Type(profile_Type), Intent(in) :: profiles(nprofiles)
- Type(profile_Type), Intent(inout) :: profiles_k(nchannels)
- Type(geometry_Type), Intent(in) :: angles(nprofiles)
- Type(rttov_coef), Intent(in) :: coef
- Type(predictors_Type), Intent(in) :: predictors(nprofiles)
- Type(predictors_Type), Intent(inout) :: predictors_k(nchannels)
-
-End Subroutine rttov_setpredictors_k
-End Interface
diff --git a/src/LIB/RTTOV/src/rttov_setpredictors_tl.F90 b/src/LIB/RTTOV/src/rttov_setpredictors_tl.F90
deleted file mode 100644
index e7fcda491f93186219d2fa8079951fa883fe41ef..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_setpredictors_tl.F90
+++ /dev/null
@@ -1,388 +0,0 @@
-!
-Subroutine rttov_setpredictors_tl( &
- & prof, &! in
- & prof_tl, &! in
- & geom, &! in
- & coef, &! in
- & predictors, &! in
- & predictors_tl ) ! inout
- ! Description
- ! RTTOV-7 Model
- ! TL of rttov_setpredictors
- ! To calculate and store the profile variables (predictors) required
- ! in subsequent transmittance calculations.
- ! Code based on PRFTAU from previous versions of RTTOV
- ! Only one profile per call
- !
- ! Copyright:
- ! This software was developed within the context of
- ! the EUMETSAT Satellite Application Facility on
- ! Numerical Weather Prediction (NWP SAF), under the
- ! Cooperation Agreement dated 25 November 1998, between
- ! EUMETSAT and the Met Office, UK, by one or more partners
- ! within the NWP SAF. The partners in the NWP SAF are
- ! the Met Office, ECMWF, KNMI and MeteoFrance.
- !
- ! Copyright 2002, EUMETSAT, All Rights Reserved.
- !
- ! Method:
- ! see RTTOV7 science and validation report pages 18/19
- ! variable names are close to the documentation
- !
- ! Current Code Owner: SAF NWP
- !
- ! History:
- ! Version Date Comment
- ! ------- ---- -------
- ! 1.0 01/12/2002 New F90 code with structures (P Brunel A Smith)
- ! 1.1 04/12/2003 Optimisation (J Hague and D Salmond ECMWF)
- ! 1.2 29/03/2005 Add end of header comment (J. Cameron)
- !
- ! Code Description:
- ! Language: Fortran 90.
- ! Software Standards: "European Standards for Writing and
- ! Documenting Exchangeable Fortran 90 Code".
- !
- ! Declarations:
- ! Modules used:
- ! Imported Parameters:
- Use rttov_const, Only : &
- & gravity
-
- ! Imported Type Definitions:
- Use rttov_types, Only : &
- & rttov_coef ,&
- & profile_Type ,&
- & geometry_Type ,&
- & predictors_Type
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
- !subroutine arguments:
- Type(profile_Type), Intent(in) :: prof
- Type(profile_Type), Intent(in) :: prof_tl
- Type(rttov_coef), Intent(in) :: coef
- Type(geometry_Type), Intent(in) :: geom
- Type(predictors_Type), Intent(in) :: predictors
- Type(predictors_Type), Intent(inout) :: predictors_tl ! in because of mem allocation
-
-
- !local variables:
- Integer(Kind=jpim) :: level
-
- ! user profile
- Real(Kind=jprb) :: t(prof % nlevels)
- Real(Kind=jprb) :: w(prof % nlevels)
-
- ! reference profile
- Real(Kind=jprb) :: tr(prof % nlevels)
- Real(Kind=jprb) :: wr(prof % nlevels)
-
- ! user - reference
- Real(Kind=jprb) :: dt(prof % nlevels)
-
- ! pressure weighted
- Real(Kind=jprb) :: tw(prof % nlevels)
-
-
- ! intermediate variables
- Real(Kind=jprb) :: sum1,sum2
-! Real(Kind=jprb) :: oz11,oz22
- Real(Kind=jprb) :: deltac(prof %nlevels)
- Real(Kind=jprb) :: sec_wr(prof %nlevels)
-
- ! TL variables
- Real(Kind=jprb) :: t_tl(prof % nlevels)
- Real(Kind=jprb) :: w_tl(prof % nlevels)
- Real(Kind=jprb) :: o_tl(prof % nlevels)
-
- Real(Kind=jprb) :: tr_tl(prof % nlevels)
- Real(Kind=jprb) :: wr_tl(prof % nlevels)
- Real(Kind=jprb) :: or_tl(prof % nlevels)
-
- Real(Kind=jprb) :: dt_tl(prof % nlevels)
- Real(Kind=jprb) :: dto_tl(prof % nlevels)
-
- Real(Kind=jprb) :: tw_tl(prof % nlevels)
- Real(Kind=jprb) :: ww_tl(prof % nlevels)
- Real(Kind=jprb) :: ow_tl(prof % nlevels)
-
-
- Real(Kind=jprb) :: sec_or_tl(prof %nlevels)
- Real(Kind=jprb) :: sec_wr_tl(prof %nlevels)
- Real(Kind=jprb) :: zsqrt, zrecip
-
- !- End of header --------------------------------------------------------
-
- ! profile layer quantities
- ! Direct variables
- t(1) = prof % t(1)
- t(2 : prof % nlevels ) = ( prof % t(1 : prof % nlevels-1) + &
- & prof % t(2 : prof % nlevels ) ) / 2
-
- w(1) = prof % q(1)
- w(2 : prof % nlevels ) = ( prof % q(1 : prof % nlevels-1) + &
- & prof % q(2 : prof % nlevels ) ) / 2
-
- ! Direct value of o NOT needed for TL
-
- ! TL variables
- t_tl(1) = prof_tl % t(1)
- t_tl(2 : prof_tl % nlevels ) = ( prof_tl % t(1 : prof_tl % nlevels-1) + &
- & prof_tl % t(2 : prof_tl % nlevels ) ) / 2
-
- w_tl(1) = prof_tl % q(1)
- w_tl(2 : prof_tl % nlevels ) = ( prof_tl % q(1 : prof_tl % nlevels-1) + &
- & prof_tl % q(2 : prof_tl % nlevels ) ) / 2
-
- If ( prof % ozone_Data .And. coef % nozone > 0 ) Then
- o_tl(1) = prof_tl % o3(1)
- o_tl(2 : prof_tl % nlevels ) = ( prof_tl % o3(1 : prof_tl % nlevels-1) + &
- & prof_tl % o3(2 : prof_tl % nlevels ) ) / 2
- Endif
-
- !3) calculate deviations from reference profile (layers)
- ! if no input O3 profile, set to reference value (dto =0)
- ! Direct variables
- dt(:) = t(:) - coef % tstar(:)
- ! Direct value of dto NOT needed for TL
-
- ! TL variables
- dt_tl(:) = t_tl(:)
- If ( prof % ozone_Data .And. coef % nozone > 0 ) Then
- dto_tl(:) = t_tl(:)
- Else
- dto_tl(:) = 0._JPRB
- Endif
-
- !2) calculate (profile / reference profile) ratios; tr wr or
- ! if no input O3 profile, set to reference value (or =1)
- ! Direct variables
- tr(:) = t(:) / coef % tstar(:)
- wr(:) = w(:) / coef % wstar(:)
- ! Direct value of or NOT needed for TL
- ! TL variables
- tr_tl(:) = t_tl(:) / coef % tstar(:)
- wr_tl(:) = w_tl(:) / coef % wstar(:)
- If ( prof % ozone_Data .And. coef % nozone > 0 ) Then
- or_tl(:) = o_tl(:) / coef % ostar(:)
- Else
- or_tl(:) = 0._JPRB
- Endif
-
- ! calculate profile / reference profile sums: tw ww ow
- ! if no input O3 profile, set to reference value (ow =1)
- ! Direct variables
- tw(1) = 0._JPRB
- Do level = 2 , prof % nlevels
- tw( level ) = tw( level-1 ) + coef % dpp( level ) * tr ( level -1 )
- End Do
-
- ! Direct value of ww NOT needed for TL
- ! Direct value of ow NOT needed for TL
-
-
- ! TL variables
- tw_tl(1) = 0._JPRB
- Do level = 2 , prof_tl % nlevels
- tw_tl( level ) = tw_tl( level-1 ) + coef % dpp( level ) * tr_tl ( level -1 )
- End Do
-
- sum1 = 0._JPRB
- sum2 = 0._JPRB
- Do level = 1, prof_tl % nlevels
- sum1 = sum1 + coef % dpp( level ) * w_tl ( level )
- sum2 = sum2 + coef % dpp( level ) * coef % wstar ( level )
- ww_tl ( level ) = sum1 / sum2
- End Do
-
- If ( prof % ozone_Data .And. coef % nozone > 0 ) Then
- sum1 = 0._JPRB
- sum2 = 0._JPRB
- Do level = 1, prof_tl % nlevels
- sum1 = sum1 + coef % dpp( level ) * o_tl ( level )
- sum2 = sum2 + coef % dpp( level ) * coef % ostar ( level )
- ow_tl ( level ) = sum1 / sum2
- End Do
- Else
- ow_tl(:) = 0._JPRB
- Endif
-
-
-
-
- ! ATTENTION
- ! w_tl(:) = prof_tl % q(:)
-
-
- !5) set predictors
- !--
-
- !5.1 mixed gases
- !---
-
- Do level = 1, prof_tl % nlevels
- predictors_tl % mixedgas(1,level) = 0._JPRB
- predictors_tl % mixedgas(2,level) = 0._JPRB
- predictors_tl % mixedgas(3,level) = geom % seczen * tr_tl(level)
- predictors_tl % mixedgas(4,level) = 2._JPRB * predictors % mixedgas(3,level) * tr_tl(level)
- ! or predictors_tl % mixedgas(4,level) = 2. * geom % seczen * tr_tl(level) * tr(level)
- predictors_tl % mixedgas(5,level) = tr_tl(level)
- predictors_tl % mixedgas(6,level) = 2._JPRB * tr_tl(level) * tr(level)
- ! or predictors_tl % mixedgas(6,level) = 2. * tr_tl(level) * predictors % mixedgas(5,level)
- predictors_tl % mixedgas(7,level) = geom % seczen * tw_tl(level)
- predictors_tl % mixedgas(8,level) =&
- & geom % seczen * tw_tl(level) / predictors % mixedgas(5,level) &
- & - predictors % mixedgas(7,level) * tr_tl(level) / predictors % mixedgas(6,level)
- ! or predictors_tl % mixedgas(8,level) = geom % seczen *&
- ! & ( tw_tl(level) / tr(level) - tw(level) * tr_tl(level) / tr(level)**2 )
- predictors_tl % mixedgas(9,level) = 0._JPRB
- ! predictor 10 is always 0 for the first level
- End Do
-
- predictors_tl % mixedgas(10,1) = 0._JPRB
- predictors_tl % mixedgas(10,2:prof_tl % nlevels) =&
- & 0.25_JPRB * geom % seczen_sq * tw_tl(2:prof_tl % nlevels)&
- & / predictors % mixedgas(10,2:prof_tl % nlevels)**3
- ! or predictors_tl % mixedgas(10,level) = 0.25 * geom % seczen_sqrt * tw_tl(level) / tw(level)**0.75
-
-
- !5.2 water vapour ( numbers in right hand are predictor numbers
- ! in the reference document for RTTOV7 (science and validation report)
- !----------------
-
- Do level = 1, prof_tl % nlevels
- sec_wr(level) = geom%seczen * wr(level)
- sec_wr_tl(level) = geom%seczen * wr_tl(level)
- predictors_tl % watervapour(1,level) = sec_wr_tl(level) ! 7
-
- predictors_tl % watervapour(2,level) = 0.5_JPRB * sec_wr_tl(level)/predictors % watervapour(2,level)! 5
-
- zrecip=1.0_JPRB/ predictors % watervapour(1,level)
- predictors_tl % watervapour(3,level) = &! 12
- & 2 * predictors % watervapour(3,level) * sec_wr_tl(level) *zrecip &
- & - predictors % watervapour(3,level)**2 * geom%seczen * ww_tl(level) / predictors % watervapour(5,level)
-
- predictors_tl % watervapour(4,level) = &! 4
- & sec_wr_tl(level) * predictors % watervapour(4,level) *zrecip &
- & + predictors % watervapour(1,level) * dt_tl(level)
-
- predictors_tl % watervapour(5,level) = &! 1
- & 2 * predictors % watervapour(1,level) * sec_wr_tl(level)
-
- predictors_tl % watervapour(6,level) = &! 11
- & predictors % watervapour(2,level) * dt_tl(level)&
- & + 0.5_JPRB * sec_wr_tl(level) * predictors % watervapour(6,level) *zrecip
-
- predictors_tl % watervapour(7,level) = &! 6
- & 0.25_JPRB * sec_wr_tl(level) / predictors % watervapour(7,level)**3
-
- predictors_tl % watervapour(8,level) = &! 13
- & geom%seczen * predictors % watervapour(8,level) * &
- & ( 1.5_JPRB * wr_tl(level) *zrecip &
- & - ww_tl(level) / predictors % watervapour(13,level)**0.5_JPRB)
-
- predictors_tl % watervapour(9,level) = &! 8
- & 3 * sec_wr_tl(level) * predictors % watervapour(5,level)
-
- predictors_tl % watervapour(10,level) = &! 9
- & 4 * sec_wr_tl(level) * predictors % watervapour(9,level)
-
- predictors_tl % watervapour(11,level) = &! 10
- & Abs(dt(level)) * &
- & (sec_wr_tl(level) * dt(level) + 2 * sec_wr(level) * dt_tl(level) )
-
- zsqrt=Sqrt(predictors % watervapour(13,level))
- predictors_tl % watervapour(12,level) = &! 3
- & 4 * geom%seczen * ww_tl(level) * predictors % watervapour(12,level) &
- & / zsqrt
-
- predictors_tl % watervapour(13,level) = &! 2
- & 2 * geom%seczen * ww_tl(level) * zsqrt
-
- predictors_tl % watervapour(14,level) = &! 14
- & 2 * predictors % watervapour(14,level) * sec_wr_tl(level) *zrecip &
- & - predictors % watervapour(14,level)**2 * tr_tl(level) / (geom%seczen * wr(level) * wr(level))
-
- predictors_tl % watervapour(15,level) = &! 15
- & ( predictors % watervapour(15,level) * geom%seczen ) * &
- & ( 2 * wr_tl(level) *zrecip - &
- & 4 * tr_tl(level) * predictors % watervapour(14,level) / &
- & predictors % watervapour(5,level) )
- End Do
-
- !5.3 ozone
- !---------
-
- If ( coef % nozone > 0 ) Then
- Do level = 1, prof_tl % nlevels
- sec_or_tl(level) = geom%seczen * or_tl(level)
-
- predictors_tl % ozone(1,level) = &
- & sec_or_tl(level)
-
- predictors_tl % ozone(2,level) = &
- & 0.5_JPRB * sec_or_tl(level) / predictors % ozone(2,level)
-
- predictors_tl % ozone(3,level) = &
- & sec_or_tl(level) * predictors % ozone(3,level) / predictors % ozone(1,level)&
- & + predictors % ozone(1,level) * dto_tl(level)
-
- predictors_tl % ozone(4,level) = &
- & 2 * sec_or_tl(level) * predictors % ozone(1,level)
-
-!oz11=predictors % ozone(1,level)
-!oz22=predictors % ozone(2,level)
-
- predictors_tl % ozone(5,level) = &
- & 0.5_JPRB * sec_or_tl(level) * predictors % ozone(3,level) /&
- & ( predictors % ozone(1,level) *predictors % ozone(2,level))&
- & + predictors % ozone(2,level) * dto_tl(level)
-
- predictors_tl % ozone(6,level) = &
- & 2 * predictors % ozone(8,level) * or_tl(level)&
- & + predictors % ozone(4,level) * ow_tl(level) / geom%seczen
-
- predictors_tl % ozone(7,level) = &
- & 1.5_JPRB * sec_or_tl(level) * predictors % ozone(2,level) / predictors % ozone(10,level)&
- & - geom%seczen * ow_tl(level) * predictors % ozone(2,level)**3 / predictors % ozone(10,level)**2
-
- predictors_tl % ozone(8,level) = &
- & predictors % ozone(10,level) * or_tl(level)&
- & + predictors % ozone(1,level) * ow_tl(level)
-
- zsqrt=Sqrt(predictors % ozone(10,level))
- predictors_tl % ozone(9,level) = &
- & sec_or_tl(level) * zsqrt&
- & + 0.5_JPRB * geom%seczen * ow_tl(level) * predictors % ozone(1,level)&
- & / zsqrt
-
- predictors_tl % ozone(10,level) = &
- & geom%seczen * ow_tl(level)
-
- predictors_tl % ozone(11,level) = &
- & 2 * geom%seczen * ow_tl(level) * predictors % ozone(10,level)
-
- End Do
- Endif
-
-
- !5.4 cloud
- !---------
- If ( prof % clw_Data ) Then
- deltac(:) = 0.1820_JPRB * 100.0_JPRB * coef % dp(:) / (4.3429_JPRB * gravity)
-
- predictors_tl % clw(:) = deltac(:) * prof_tl%clw(:) * geom%seczen
-
- predictors_tl % clw(2:prof_tl % nlevels) = &
- & 0.5_JPRB * &
- & ( predictors_tl % clw(2:prof_tl % nlevels) + &
- & deltac(2:prof_tl % nlevels) * prof_tl%clw(1:prof_tl % nlevels-1) * &
- & geom%seczen )
- Else
- predictors_tl % ncloud = 0
- Endif
-
-
-End Subroutine rttov_setpredictors_tl
diff --git a/src/LIB/RTTOV/src/rttov_setpredictors_tl.interface b/src/LIB/RTTOV/src/rttov_setpredictors_tl.interface
deleted file mode 100644
index 2fcb12d94b23595840eb38ff82504b618311bec3..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_setpredictors_tl.interface
+++ /dev/null
@@ -1,32 +0,0 @@
-Interface
-!
-Subroutine rttov_setpredictors_tl( &
- prof, & ! in
- prof_tl, & ! in
- geom, & ! in
- coef, & ! in
- predictors, & ! in
- predictors_tl ) ! inout
- Use rttov_const, Only : &
- gravity
-
- Use rttov_types, Only : &
- rttov_coef ,&
- profile_Type ,&
- geometry_Type ,&
- predictors_Type
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
- Type(profile_Type), Intent(in) :: prof
- Type(profile_Type), Intent(in) :: prof_tl
- Type(rttov_coef), Intent(in) :: coef
- Type(geometry_Type), Intent(in) :: geom
- Type(predictors_Type), Intent(in) :: predictors
- Type(predictors_Type), Intent(inout) :: predictors_tl ! in because of mem allocation
-
-
-
-End Subroutine rttov_setpredictors_tl
-End Interface
diff --git a/src/LIB/RTTOV/src/rttov_setpressure.F90 b/src/LIB/RTTOV/src/rttov_setpressure.F90
deleted file mode 100644
index 571744b47145bb164667cbf075a8f2dc509ea773..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_setpressure.F90
+++ /dev/null
@@ -1,70 +0,0 @@
- subroutine rttov_setpressure (p_sfc, p, ph)
-
- Use parkind1, Only : jpim ,jprb
-
- implicit none
-
- Integer (Kind=jpim), parameter :: nlev = 60
- Integer (Kind=jpim) :: ilev
-
- Real (Kind=jprb) :: p_sfc
- Real (Kind=jprb) :: vah (nlev+1), vbh (nlev+1)
- Real (Kind=jprb) :: p (nlev) , ph (nlev+1)
-
- data vah / &
- & 0.000000_JPRB, 20.000000_JPRB, 38.425343_JPRB, &
- & 63.647804_JPRB, 95.636963_JPRB, 134.483307_JPRB, &
- & 180.584351_JPRB, 234.779053_JPRB, 298.495789_JPRB, &
- & 373.971924_JPRB, 464.618134_JPRB, 575.651001_JPRB, &
- & 713.218079_JPRB, 883.660522_JPRB, 1094.834717_JPRB, &
- & 1356.474609_JPRB, 1680.640259_JPRB, 2082.273926_JPRB, &
- & 2579.888672_JPRB, 3196.421631_JPRB, 3960.291504_JPRB, &
- & 4906.708496_JPRB, 6018.019531_JPRB, 7306.631348_JPRB, &
- & 8765.053711_JPRB, 10376.126953_JPRB, 12077.446289_JPRB, &
- & 13775.325195_JPRB, 15379.805664_JPRB, 16819.474609_JPRB, &
- & 18045.183594_JPRB, 19027.695313_JPRB, 19755.109375_JPRB, &
- & 20222.205078_JPRB, 20429.863281_JPRB, 20384.480469_JPRB, &
- & 20097.402344_JPRB, 19584.330078_JPRB, 18864.750000_JPRB, &
- & 17961.357422_JPRB, 16899.468750_JPRB, 15706.447266_JPRB, &
- & 14411.124023_JPRB, 13043.218750_JPRB, 11632.758789_JPRB, &
- & 10209.500977_JPRB, 8802.356445_JPRB, 7438.803223_JPRB, &
- & 6144.314941_JPRB, 4941.778320_JPRB, 3850.913330_JPRB, &
- & 2887.696533_JPRB, 2063.779785_JPRB, 1385.912598_JPRB, &
- & 855.361755_JPRB, 467.333588_JPRB, 210.393890_JPRB, &
- & 65.889244_JPRB, 7.367743_JPRB, 0.000000_JPRB, &
- & 0.000000_JPRB &
- & /
- data vbh / &
- & 0.0000000000_JPRB, 0.0000000000_JPRB, 0.0000000000_JPRB, &
- & 0.0000000000_JPRB, 0.0000000000_JPRB, 0.0000000000_JPRB, &
- & 0.0000000000_JPRB, 0.0000000000_JPRB, 0.0000000000_JPRB, &
- & 0.0000000000_JPRB, 0.0000000000_JPRB, 0.0000000000_JPRB, &
- & 0.0000000000_JPRB, 0.0000000000_JPRB, 0.0000000000_JPRB, &
- & 0.0000000000_JPRB, 0.0000000000_JPRB, 0.0000000000_JPRB, &
- & 0.0000000000_JPRB, 0.0000000000_JPRB, 0.0000000000_JPRB, &
- & 0.0000000000_JPRB, 0.0000000000_JPRB, 0.0000000000_JPRB, &
- & 0.0000758235_JPRB, 0.0004613950_JPRB, 0.0018151561_JPRB, &
- & 0.0050811190_JPRB, 0.0111429105_JPRB, 0.0206778757_JPRB, &
- & 0.0341211632_JPRB, 0.0516904071_JPRB, 0.0735338330_JPRB, &
- & 0.0996746942_JPRB, 0.1300225109_JPRB, 0.1643843204_JPRB, &
- & 0.2024759352_JPRB, 0.2439331412_JPRB, 0.2883229554_JPRB, &
- & 0.3351548910_JPRB, 0.3838921487_JPRB, 0.4339629412_JPRB, &
- & 0.4847715795_JPRB, 0.5357099175_JPRB, 0.5861684084_JPRB, &
- & 0.6355474591_JPRB, 0.6832686067_JPRB, 0.7287858129_JPRB, &
- & 0.7715966105_JPRB, 0.8112534285_JPRB, 0.8473749161_JPRB, &
- & 0.8796569109_JPRB, 0.9078838825_JPRB, 0.9319403172_JPRB, &
- & 0.9518215060_JPRB, 0.9676452279_JPRB, 0.9796627164_JPRB, &
- & 0.9882701039_JPRB, 0.9940194488_JPRB, 0.9976301193_JPRB, &
- & 1.0000000000_JPRB &
- & /
-
- !- End of header ------------------------------------------------------
-
- ph (:) = vah (:) + vbh (:) * p_sfc
-
- do ilev = 1, nlev
- p (ilev) = 0.5_JPRB * (ph (ilev) + ph (ilev+1))
- end do
-
- return
- end subroutine rttov_setpressure
diff --git a/src/LIB/RTTOV/src/rttov_setpressure.interface b/src/LIB/RTTOV/src/rttov_setpressure.interface
deleted file mode 100644
index 3a808aa1e273037fb8aac8d2b9326c2cb825ea00..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_setpressure.interface
+++ /dev/null
@@ -1,16 +0,0 @@
-INTERFACE
- subroutine rttov_setpressure (p_sfc, p, ph)
-
- Use parkind1, Only : jpim ,jprb
-
- implicit none
-
- Integer (Kind=jpim), parameter :: nlev = 60
- Integer (Kind=jpim) :: ilev
-
- Real (Kind=jprb) :: p_sfc
- Real (Kind=jprb) :: vah (nlev+1), vbh (nlev+1)
- Real (Kind=jprb) :: p (nlev) , ph (nlev+1)
-
- end subroutine rttov_setpressure
-END INTERFACE
diff --git a/src/LIB/RTTOV/src/rttov_setup.F90 b/src/LIB/RTTOV/src/rttov_setup.F90
deleted file mode 100644
index 9d9f4225ee149a2abe2278ee868b897f354a6635..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_setup.F90
+++ /dev/null
@@ -1,196 +0,0 @@
-!
-Subroutine rttov_setup (&
- & errorstatus, &! out
- & Err_unit, &! in
- & verbosity_level, &! in
- & ninst, &! in
- & coef, &! out
- & instrument, &! in
- & channels ) ! in Optional
- !
- ! Description:
- !
- ! Setup routine for RTTOV
- ! Handling of error messages. (rttov_errorhandling)
- ! Read coefficients (rttov_readcoeffs)
- !
- ! Error messages will be sent on the optional unit number errunit.
- ! Default is the value defined in the module for constants.
- !
- ! The levels of verbosity are
- ! 0 = no error messages output
- ! 1 = FATAL errors only printed. these are errors which
- ! mean that profile should be aborted (e.g. unphysical
- ! profile input)
- ! 2 = WARNING errors only printed. Errors which can allow
- ! the computation to continue but the results may be
- ! suspect (e.g. profile outside basis profile limits)
- ! 3 = INFORMATION messages which inform the user about
- ! the computation
- !
- ! For each instrument:
- ! Read an ASCII or binary coefficient file and allocate coeff structure
- ! arrays according to the optional list of channels.
- ! The user can provide an optional list of channels in "channels" argument
- ! array to reduce the output coefficient structure to this list. This
- ! can be important for reducing the memory allocation required when running
- ! with advanced IR sounders (e.g. AIRS or IASI). If the user
- ! wants all channels the "channels" argument shall not be present.
- !
- !
- ! Copyright:
- !
- ! This software was developed within the context of
- ! the EUMETSAT Satellite Application Facility on
- ! Numerical Weather Prediction (NWP SAF), under the
- ! Cooperation Agreement dated 25 November 1998, between
- ! EUMETSAT and the Met Office, UK, by one or more partners
- ! within the NWP SAF. The partners in the NWP SAF are
- ! the Met Office, ECMWF, KNMI and MeteoFrance.
- !
- ! Copyright 2002, EUMETSAT, All Rights Reserved.
- !
- !
- !
- ! Current Code Owner: SAF NWP
- !
- ! History:
- ! Version Date Comment
- ! 1.0 10/03/2003 Original code (P Brunel)
- ! 1.1 29/10/2009 Corrected bug in channel indexing on line 155(R Saunders)
- !
- ! Code Description:
- ! FORTRAN 90, following AAPP standards
- !
- ! Declarations
- !
- ! Global variables:
- ! Modules used:
- !
- Use rttov_const, Only : &
- & errorstatus_fatal
-
- ! Imported Type Definitions:
- Use rttov_types, Only : &
- & rttov_coef
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
-#include "rttov_errorhandling.interface"
-#include "rttov_errorreport.interface"
-#include "rttov_readcoeffs.interface"
-#include "rttov_initcoeffs.interface"
- !
- ! Subroutine arguments
- ! Scalar arguments with intent(in):
- Integer(Kind=jpim), Intent (in) :: Err_Unit ! Logical error unit (<0 for default)
- Integer(Kind=jpim), Intent (in) :: verbosity_level ! (<0 for default)
- Integer(Kind=jpim), Intent (in) :: ninst ! number of RTTOV ids / instruments requested
- Integer(Kind=jpim), Intent (in) :: instrument(:,:) ! Instrument triplet
- ! first dimension : (platform, satellite identification, instrument) number
- ! second dimension : nsat
- Integer(Kind=jpim), Optional, Intent (in) :: channels(:,:) ! list of channels to extract (channels,msat)
-
- ! scalar arguments with intent(out):
- Integer(Kind=jpim), Intent (out) :: errorstatus(ninst) ! return code
- Type( rttov_coef ), Intent (out) :: coef(ninst) ! coefficients
-
-
-
- ! Local scalars/arrays
- Integer(Kind=jpim) :: dimchans ! size of array channels for channels dimension
- Integer(Kind=jpim) :: inst ! instrument loop index
- Integer(Kind=jpim) :: nchans ! number of requested channels per instrument (0 = all)
- Integer(Kind=jpim) :: alloc_status ! de/allocation status
- Integer(Kind=jpim) :: i ! loop index
- Integer(Kind=jpim), allocatable :: channels_list(:) ! list of requested channels
- Character (len=80) :: errMessage
- Character (len=12) :: NameOfRoutine = 'rttov_setup '
- !- End of header --------------------------------------------------------
-
- ! Error is set to fatal, in case of return
- ! before processing all instruments
- ! Readcoeffs will reset it to success
- errorstatus(:) = errorstatus_fatal
-
- ! Error Handling setup routine
- call rttov_errorhandling(Err_Unit, verbosity_level)
-
- ! Check optional argument channels
- If( Present ( channels ) ) Then
- dimchans = Size( channels, dim=1 )
- Else
- dimchans = 0
- End If
-
- Do inst = 1, ninst
-
- ! Finds the last non null channel for ninst
- nchans = 0
- if( Present ( channels ) ) Then
- do i = 1, dimchans
- if( channels(i, inst) > 0 ) then
- nchans = nchans + 1
- endif
- End Do
- Endif
-
- If( nchans > 0 ) Then
- ! Some channels wanted, create a list of the
- ! selected channels without O values
-
- ! Allocate intermediate channels list
- Allocate ( channels_list ( nchans ), stat= alloc_status)
- If( alloc_status /= 0 ) Then
- errorstatus(inst) = errorstatus_fatal
- Write( errMessage, '( "allocation of intermediate channels list")' )
- Call Rttov_ErrorReport (errorstatus(inst), errMessage, NameOfRoutine)
- Return
- End If
-
- ! Create intermediate channels list (use nchans var. again)
- nchans = 0
- do i = 1, dimchans
- if( channels(i, inst) > 0 ) then
- nchans = nchans + 1
- channels_list(nchans) = channels(i, inst)
- endif
- End Do
-
- ! Read coefficients
- Call rttov_readcoeffs ( &
- & errorstatus(inst), &! out
- & coef(inst), &! inout
- & instrument(:,inst), &! in
- & channels = channels_list ) ! in
- Call rttov_initcoeffs ( &
- & errorstatus(inst), &! out
- & coef(inst) ) ! inout
-
- Deallocate ( channels_list , stat=alloc_status )
- If( alloc_status /= 0 ) Then
- errorstatus(inst) = errorstatus_fatal
- Write( errMessage, '( "deallocation of intermediate channels list")' )
- Call Rttov_ErrorReport (errorstatus(inst), errMessage, NameOfRoutine)
- Return
- End If
-
-
- Else
- ! All channels , read coefficients
- Call rttov_readcoeffs ( &
- & errorstatus(inst), &! out
- & coef(inst), &! out
- & instrument(:,inst) ) ! in
- Call rttov_initcoeffs ( &
- & errorstatus(inst), &! out
- & coef(inst) ) ! inout
-
- Endif
-
- End Do
-
-
-
-End Subroutine rttov_setup
diff --git a/src/LIB/RTTOV/src/rttov_setup.interface b/src/LIB/RTTOV/src/rttov_setup.interface
deleted file mode 100644
index ad9f5ebe5d5fb2392659c5c883fb080123087d64..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_setup.interface
+++ /dev/null
@@ -1,34 +0,0 @@
-Interface
-!
-Subroutine rttov_setup (&
- & errorstatus, & ! out
- & Err_unit, & ! in
- & verbosity_level, & ! in
- & ninst, & ! in
- & coef, & ! out
- & instrument, & ! in
- & channels ) ! in Optional
- Use rttov_const, Only : &
- errorstatus_fatal
-
- Use rttov_types, Only : &
- rttov_coef
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
- Integer(Kind=jpim), Intent (in) :: Err_Unit ! Logical error unit (<0 for default)
- Integer(Kind=jpim), Intent (in) :: verbosity_level ! (<0 for default)
- Integer(Kind=jpim), Intent (in) :: ninst ! number of RTTOV ids / instruments requested
- Integer(Kind=jpim), Intent (in) :: instrument(:,:) ! Instrument triplet
- ! first dimension : (platform, satellite identification, instrument) number
- ! second dimension : nsat
- Integer(Kind=jpim), Optional, Intent (in) :: channels(:,:) ! list of channels to extract (channels,msat)
-
- Integer(Kind=jpim), Intent (out) :: errorstatus(ninst) ! return code
- Type( rttov_coef ), Intent (out) :: coef(ninst) ! coefficients
-
-
-
-End Subroutine rttov_setup
-End Interface
diff --git a/src/LIB/RTTOV/src/rttov_setupchan.F90 b/src/LIB/RTTOV/src/rttov_setupchan.F90
deleted file mode 100644
index 606ef6b1f21b5749e8a86896fe0e30f94a1c07fa..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_setupchan.F90
+++ /dev/null
@@ -1,95 +0,0 @@
-!
-Subroutine rttov_setupchan (&
- & nprofiles, & ! in
- & nchan, & ! in
- & coef, & ! in
- & nfrequencies, & ! out
- & nchannels, & ! out
- & nbtout) ! out
- !
- ! Description:
- !
- ! Setup default number of frequencies, channels , output BTs
- ! for the coeff file. These are then used by rttov_setupindex
- ! to set up channel and polarisation indices.
- !
- !
- ! Copyright:
- !
- ! This software was developed within the context of
- ! the EUMETSAT Satellite Application Facility on
- ! Numerical Weather Prediction (NWP SAF), under the
- ! Cooperation Agreement dated 25 November 1998, between
- ! EUMETSAT and the Met Office, UK, by one or more partners
- ! within the NWP SAF. The partners in the NWP SAF are
- ! the Met Office, ECMWF, KNMI and MeteoFrance.
- !
- ! Copyright 2004, EUMETSAT, All Rights Reserved.
- !
- !
- ! Current Code Owner: SAF NWP
- !
- ! History:
- ! Version Date Comment
- ! 1.0 31/03/2004 Original code (R Saunders)
- !
- ! Code Description:
- ! FORTRAN 90, following AAPP standards
- !
- ! Declarations
- !
- ! Global variables:
- ! Modules used:
- !
- ! Imported Type Definitions:
- Use rttov_types, Only : &
- & rttov_coef
- Use rttov_const, Only : &
- & sensor_id_mw, &
- & npolar_return, &
- & npolar_compute
-
- Use parkind1, Only : jpim
- Implicit None
- !
- ! Subroutine arguments
- Integer(Kind=jpim), Intent(in) :: nprofiles ! Number of profiles
- Integer(Kind=jpim), Intent(in) :: nchan(nprofiles)! Number of channels requested
- Type( rttov_coef ), Intent (in) :: coef ! coefficients
- Integer(Kind=jpim), Intent(out) :: nchannels ! Number of radiances computed
- Integer(Kind=jpim), Intent(out) :: nfrequencies ! Number of frequencies
- ! (= channels used * profiles)
- Integer(Kind=jpim), Intent(out) :: nbtout ! Number of BTs returned
- ! Local scalars/arrays
- Integer(Kind=jpim) :: j ,jch ! loop index
- Integer(Kind=jpim) :: nch , pol_id
- Integer(Kind=jpim) :: ichannels, ibtout ! counters
- !- End of header --------------------------------------------------------
- !
- nfrequencies = 0
- Do j = 1 , nprofiles
- nfrequencies = nfrequencies + nchan (j)
- End Do
- ! Find out size of channel arrays summing all polarisation states required.
- nch = 0
- ichannels=0
- ibtout=0
- DO j = 1 , nprofiles
- Do jch = 1 , nchan(j)
- nch = nch +1
- If( coef % id_sensor /= sensor_id_mw) then
- ichannels=ichannels+1
- ibtout=ibtout+1
- End If
- If( coef % id_sensor == sensor_id_mw) then
- pol_id = coef % fastem_polar(jch) + 1
- ichannels=ichannels+npolar_compute(pol_id)
- ibtout=ibtout+npolar_return(pol_id)
- End If
- End Do
- End Do
- nchannels = ichannels
- nbtout = ibtout
- !
-
-End Subroutine rttov_setupchan
diff --git a/src/LIB/RTTOV/src/rttov_setupchan.interface b/src/LIB/RTTOV/src/rttov_setupchan.interface
deleted file mode 100644
index 0ef75886ec44f1cea15e0d2f6e51fad93d7fb5be..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_setupchan.interface
+++ /dev/null
@@ -1,66 +0,0 @@
-Interface
-!
-Subroutine rttov_setupchan (&
- & nprofiles, & ! in
- & nchan, & ! in
- & coef, & ! in
- & nfrequencies, & ! out
- & nchannels, & ! out
- & nbtout) ! out
- !
- ! Description:
- !
- ! Setup default number of frequencies, channels , output BTs
- ! for the coeff file. These are then used by rttov_indexsetup
- ! to set up channel and polarisation indices.
- !
- !
- ! Copyright:
- !
- ! This software was developed within the context of
- ! the EUMETSAT Satellite Application Facility on
- ! Numerical Weather Prediction (NWP SAF), under the
- ! Cooperation Agreement dated 25 November 1998, between
- ! EUMETSAT and the Met Office, UK, by one or more partners
- ! within the NWP SAF. The partners in the NWP SAF are
- ! the Met Office, ECMWF, KNMI and MeteoFrance.
- !
- ! Copyright 2004, EUMETSAT, All Rights Reserved.
- !
- !
- ! Current Code Owner: SAF NWP
- !
- ! History:
- ! Version Date Comment
- ! 1.0 31/03/2004 Original code (R Saunders)
- !
- ! Code Description:
- ! FORTRAN 90, following AAPP standards
- !
- ! Declarations
- !
- ! Global variables:
- ! Modules used:
- !
- ! Imported Type Definitions:
- Use rttov_types, Only : &
- rttov_coef
- Use rttov_const, Only : &
- sensor_id_mw, &
- npolar_return, &
- npolar_compute
-
- Use parkind1, Only : jpim
- Implicit None
- !
- ! Subroutine arguments
- Integer(Kind=jpim), Intent(in) :: nprofiles ! Number of profiles
- Integer(Kind=jpim), Intent(in) :: nchan(nprofiles) ! Number of channels requested
- Type( rttov_coef ), Intent (in) :: coef ! coefficients
- Integer(Kind=jpim), Intent(out) :: nchannels ! Number of radiances computed
- Integer(Kind=jpim), Intent(out) :: nfrequencies ! Number of frequencies
- ! (= channels used * profiles)
- Integer(Kind=jpim), Intent(out) :: nbtout ! Number of BTs returned
-
- End Subroutine rttov_setupchan
-End Interface
diff --git a/src/LIB/RTTOV/src/rttov_setupindex.F90 b/src/LIB/RTTOV/src/rttov_setupindex.F90
deleted file mode 100644
index 0c98e21ddd404d64ec0648cae58064e17342c434..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_setupindex.F90
+++ /dev/null
@@ -1,114 +0,0 @@
-!
-Subroutine rttov_setupindex (&
- & mchan, & ! in
- & nprofiles, & ! in
- & nfrequencies, & ! in
- & nchannels, & ! in
- & nbtout, & ! in
- & coef, & ! in
- & surfem, & ! in
- & lprofiles, & ! out
- & channels, & ! out
- & polarisations, & ! out
- & emissivity) ! out
-
- !
- ! Description:
- !
- ! Setup profile, channel and polarisation indices and emissivity
- ! for RTTOV.
- !
- ! Copyright:
- !
- ! This software was developed within the context of
- ! the EUMETSAT Satellite Application Facility on
- ! Numerical Weather Prediction (NWP SAF), under the
- ! Cooperation Agreement dated 25 November 1998, between
- ! EUMETSAT and the Met Office, UK, by one or more partners
- ! within the NWP SAF. The partners in the NWP SAF are
- ! the Met Office, ECMWF, KNMI and MeteoFrance.
- !
- ! Copyright 2004, EUMETSAT, All Rights Reserved.
- !
- !
- ! Current Code Owner: SAF NWP
- !
- ! History:
- ! Version Date Comment
- ! 1.0 31/03/2004 Original code (R Saunders)
- ! 1.1 11/11/2004 Corrected idexing of emissivity array
- !
- ! Code Description:
- ! FORTRAN 90, following AAPP standards
- !
- ! Declarations
- !
- ! Global variables:
- ! Modules used:
- !
- ! Imported Type Definitions:
- Use rttov_types, Only : &
- & rttov_coef
- Use rttov_const, Only : &
- & sensor_id_mw, &
- & npolar_compute
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
- !
- ! Subroutine arguments
- Integer(Kind=jpim), Intent(in) :: nprofiles ! Number of profiles
- Integer(Kind=jpim), Intent(in) :: mchan(nprofiles)! nfrequencies/nprofiles
- Integer(Kind=jpim), Intent(in) :: nchannels ! Total Number of radiances computed
- Integer(Kind=jpim), Intent(in) :: nfrequencies ! Total Number of frequencies
- ! (= channels used * profiles)
- Integer(Kind=jpim), Intent(in) :: nbtout ! Total Number of BTs returned
- Integer(Kind=jpim), Intent(out) :: channels(nfrequencies) ! Channel indices
- Integer(Kind=jpim), Intent(out) :: polarisations(nchannels,3) ! Channel indices
- Integer(Kind=jpim), Intent(out) :: lprofiles(nfrequencies) !Profiles indices
- Real(Kind=jprb), Intent(in) :: surfem(nchannels) !Inputsurface emissivity for first profile
- Real(Kind=jprb), Intent(out) :: emissivity(nchannels) ! Surface emissivity array for RTTOV
-
- Type( rttov_coef ), Intent (in) :: coef ! coefficients
-
- ! Local scalars/arrays
- Integer(Kind=jpim) :: j ,jch ,n ! loop index
- Integer(Kind=jpim) :: nch , pol_id, ich2
- Integer(Kind=jpim) :: ichannels, ibtout ! counters
- !- End of header --------------------------------------------------------
- !
- nch = 0
- ichannels=0
- ibtout=0
- polarisations(:,:) = 0
- !
- DO J = 1,nprofiles
- DO jch = 1,mchan(j)
- nch = nch +1
- lprofiles ( nch ) = j
- ! because we have read the coefficient file with a selection of channels
- ! we have now to introduce the indices of the channels for rttov runs
- channels ( nch ) = jch
- polarisations(nch,1) = ichannels+1
- If( coef % id_sensor /= sensor_id_mw) then
- ichannels=ichannels+1
- emissivity(nch) = surfem(jch)
- polarisations(nch,2) = nch
- polarisations(nch,3) = 1
- End If
- If( coef % id_sensor == sensor_id_mw) then
- pol_id = coef % fastem_polar(jch) + 1
- Do ich2=1,npolar_compute(pol_id)
- emissivity(ichannels+ich2)=surfem(jch)
- enddo
- Do n=ichannels+1,ichannels+npolar_compute(pol_id)
- polarisations(n,2)= nch
- End Do
- ichannels=ichannels+npolar_compute(pol_id)
- polarisations(nch,3)=npolar_compute(pol_id)
- End If
- End Do
- End Do
-
-
-End Subroutine rttov_setupindex
diff --git a/src/LIB/RTTOV/src/rttov_setupindex.interface b/src/LIB/RTTOV/src/rttov_setupindex.interface
deleted file mode 100644
index 9d78a0c71f1155c5d6af0e2cd19784d78884ac20..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_setupindex.interface
+++ /dev/null
@@ -1,76 +0,0 @@
-Interface
-!
-Subroutine rttov_setupindex (&
- & mchan, & ! in
- & nprofiles, & ! in
- & nfrequencies, & ! in
- & nchannels, & ! in
- & nbtout, & ! in
- & coef, & ! in
- & surfem, & ! in
- & lprofiles, & ! out
- & channels, & ! out
- & polarisations, & ! out
- & emissivity) ! out
-
- !
- ! Description:
- !
- ! Setup profile, channel and polarisation indices and emissivity
- ! for RTTOV.
- !
- ! Copyright:
- !
- ! This software was developed within the context of
- ! the EUMETSAT Satellite Application Facility on
- ! Numerical Weather Prediction (NWP SAF), under the
- ! Cooperation Agreement dated 25 November 1998, between
- ! EUMETSAT and the Met Office, UK, by one or more partners
- ! within the NWP SAF. The partners in the NWP SAF are
- ! the Met Office, ECMWF, KNMI and MeteoFrance.
- !
- ! Copyright 2004, EUMETSAT, All Rights Reserved.
- !
- !
- ! Current Code Owner: SAF NWP
- !
- ! History:
- ! Version Date Comment
- ! 1.0 31/03/2004 Original code (R Saunders)
- !
- ! Code Description:
- ! FORTRAN 90, following AAPP standards
- !
- ! Declarations
- !
- ! Global variables:
- ! Modules used:
- !
- ! Imported Type Definitions:
- Use rttov_types, Only : &
- rttov_coef
- Use rttov_const, Only : &
- sensor_id_mw, &
- npolar_return, &
- npolar_compute
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
- !
- ! Subroutine arguments
- Integer(Kind=jpim), Intent(in) :: nprofiles ! Number of profiles
- Integer(Kind=jpim), Intent(in) :: mchan(nprofiles) ! nfrequencies/nprofiles
- Integer(Kind=jpim), Intent(in) :: nchannels ! Number of radiances computed
- Integer(Kind=jpim), Intent(in) :: nfrequencies ! Number of frequencies
- ! (= channels used * profiles)
- Integer(Kind=jpim), Intent(in) :: nbtout ! Number of BTs returned
- Integer(Kind=jpim), Intent(out) :: channels(nfrequencies) ! Channel indices
- Integer(Kind=jpim), Intent(out) :: polarisations(nchannels,3) ! Channel indices
- Integer(Kind=jpim), Intent(out) :: lprofiles(nfrequencies) ! Profiles indices
- Real(Kind=jprb), Intent(in) :: surfem(nchannels) ! Input surface emissivity
- Real(Kind=jprb), Intent(out) :: emissivity(nchannels) ! Surface emissivity array for RTTOV
-
- Type( rttov_coef ), Intent (in) :: coef ! coefficients
-
- End Subroutine rttov_setupindex
-End Interface
diff --git a/src/LIB/RTTOV/src/rttov_skipcommentline.F90 b/src/LIB/RTTOV/src/rttov_skipcommentline.F90
deleted file mode 100644
index 5193e99c83664bfdd9fabae980c1579831e4f1e2..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_skipcommentline.F90
+++ /dev/null
@@ -1,66 +0,0 @@
-!
-Subroutine rttov_skipcommentline( fileunit,readstatus )
- ! Description:
- ! read the file while input cards are starting by "!" character
- ! position the file before the first data line
- !
- ! Copyright:
- ! This software was developed within the context of
- ! the EUMETSAT Satellite Application Facility on
- ! Numerical Weather Prediction (NWP SAF), under the
- ! Cooperation Agreement dated 25 November 1998, between
- ! EUMETSAT and the Met Office, UK, by one or more partners
- ! within the NWP SAF. The partners in the NWP SAF are
- ! the Met Office, ECMWF, KNMI and MeteoFrance.
- !
- ! Copyright 2002, EUMETSAT, All Rights Reserved.
- !
- ! Method:
- !
- ! Current Code Owner: SAF NWP
- !
- ! History:
- ! Version Date Comment
- ! ------- ---- -------
- ! 1.0 01/12/2002 New F90 code with structures (P Brunel A Smith)
- !
- ! Code Description:
- ! Language: Fortran 90.
- ! Software Standards: "European Standards for Writing and
- ! Documenting Exchangeable Fortran 90 Code".
- !
- ! Declarations:
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
- !subroutine arguments:
- Integer(Kind=jpim), Intent(in) :: fileunit ! logical unit of file
- Integer(Kind=jpim), Intent(out) :: readstatus ! I/O status
-
-
-
- !local variables:
- Character(len=80) :: line ! input line
-
- !- End of header --------------------------------------------------------
-
-
- readfile: Do
-
- Read( unit=fileunit,fmt='(a)',iostat=readstatus ) line
- If ( readstatus /= 0 ) Exit
-
- line = Adjustl(line)
- If ( line(1:1) == '!' .Or. line == '' ) Then
- Cycle !skip blank/comment lines
- Else
- !reposition file at the start of the line and exit
- Backspace( fileunit )
- Exit readfile
- End If
-
- End Do readfile
-
-
-
-End Subroutine rttov_skipcommentline
diff --git a/src/LIB/RTTOV/src/rttov_skipcommentline.interface b/src/LIB/RTTOV/src/rttov_skipcommentline.interface
deleted file mode 100644
index 4ab750dece33ee6d1ac24dbc3511492a30ec79cf..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_skipcommentline.interface
+++ /dev/null
@@ -1,13 +0,0 @@
-Interface
-!
-Subroutine rttov_skipcommentline( fileunit,readstatus )
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
- Integer(Kind=jpim), Intent(in) :: fileunit ! logical unit of file
- Integer(Kind=jpim), Intent(out) :: readstatus ! I/O status
-
-
-
-End Subroutine rttov_skipcommentline
-End Interface
diff --git a/src/LIB/RTTOV/src/rttov_tl.F90 b/src/LIB/RTTOV/src/rttov_tl.F90
deleted file mode 100644
index 83feb12be77ddaae9dc8af3392d50de7d1cdd878..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_tl.F90
+++ /dev/null
@@ -1,623 +0,0 @@
-!
-Subroutine rttov_tl( &
- & errorstatus, &! out
- & nfrequencies, &! in
- & nchannels, &! in
- & nbtout, &! in
- & nprofiles, &! in
- & channels, &! in
- & polarisations, &! in
- & lprofiles, &! in
- & profiles, &! in
- & coef, &! in
- & addcloud, &! in
- & calcemis, &! in
- & emissivity, &! inout
- & profiles_tl, &! in
- & emissivity_tl, &! inout
- & transmission, &! inout
- & transmission_tl, &! inout
- & radiancedata, &! inout
- & radiancedata_tl ) ! inout
- !
- ! Description:
- ! Tangent Linear of rttov_direct
- ! to compute multi-channel level to space transmittances,
- ! top of atmosphere and level to space radiances and brightness
- ! temperatures and optionally surface emissivities, for many
- ! profiles in a single call, for satellite
- ! infrared or microwave sensors. The code requires a coefficient file
- ! for each sensor for which simulated radiances are requested.
- !
- ! Copyright:
- ! This software was developed within the context of
- ! the EUMETSAT Satellite Application Facility on
- ! Numerical Weather Prediction (NWP SAF), under the
- ! Cooperation Agreement dated 25 November 1998, between
- ! EUMETSAT and the Met Office, UK, by one or more partners
- ! within the NWP SAF. The partners in the NWP SAF are
- ! the Met Office, ECMWF, KNMI and MeteoFrance.
- !
- ! Copyright 2002, EUMETSAT, All Rights Reserved.
- !
- ! Method: The methodology is described in the following:
- !
- ! Eyre J.R. and H.M. Woolf 1988 Transmittance of atmospheric gases
- ! in the microwave region: a fast model. Applied Optics 27 3244-3249
- !
- ! Eyre J.R. 1991 A fast radiative transfer model for satellite sounding
- ! systems. ECMWF Research Dept. Tech. Memo. 176 (available from the
- ! librarian at ECMWF).
- !
- ! Saunders R.W., M. Matricardi and P. Brunel 1999 An Improved Fast Radiative
- ! Transfer Model for Assimilation of Satellite Radiance Observations.
- ! QJRMS, 125, 1407-1425.
- !
- ! Matricardi, M., F. Chevallier and S. Tjemkes 2001 An improved general
- ! fast radiative transfer model for the assimilation of radiance
- ! observations. ECMWF Research Dept. Tech. Memo. 345
- ! (available from the librarian at ECMWF).
- !
- ! Current Code Owner: SAF NWP
- !
- ! History:
- ! Version Date Comment
- ! ------- ---- -------
- ! 1.1 01/12/2002 New F90 code with structures (P Brunel A Smith)
- ! 1.2 02/01/2003 More comments added (R Saunders)
- ! 1.3 24/01/2003 Error return code by input profile (P Brunel)
- ! 1.4 Add WV Continuum and CO2 capability
- ! 1.5 04/12/2003 Optimisation (J Hague and D Salmond ECMWF)
- ! 1.6 02/06/2004 Change tests on id_comp_lvl == 7 by tests on fmv_model_ver (P. Brunel)
- !
- ! Code Description:
- ! Language: Fortran 90.
- ! Software Standards: "European Standards for Writing and
- ! Documenting Exchangeable Fortran 90 Code".
- ! A user guide and technical documentation is available at
- ! http://www.metoffice.com/research/interproj/nwpsaf/rtm/index.html
- !
- ! Declarations:
- ! Modules used:
- ! Imported Parameters:
- Use rttov_const, Only : &
- & errorstatus_success ,&
- & errorstatus_warning ,&
- & errorstatus_fatal ,&
- & max_optical_depth ,&
- & sensor_id_mw ,&
- & sensor_id_ir
-
- ! Imported Type Definitions:
- Use rttov_types, Only : &
- & rttov_coef ,&
- & profile_Type ,&
- & geometry_Type ,&
- & predictors_Type,&
- & profile_aux ,&
- & transmission_Type ,&
- & radiance_Type ,&
- & radiance_aux
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
-#include "rttov_errorreport.interface"
-#include "rttov_checkinput.interface"
-#include "rttov_profaux.interface"
-#include "rttov_setgeometry.interface"
-#include "rttov_setpredictors.interface"
-#include "rttov_setpredictors_8.interface"
-#include "rttov_transmit.interface"
-#include "rttov_calcemis_ir.interface"
-#include "rttov_calcemis_mw.interface"
-#include "rttov_integrate.interface"
-#include "rttov_profaux_tl.interface"
-#include "rttov_setpredictors_tl.interface"
-#include "rttov_setpredictors_8_tl.interface"
-#include "rttov_transmit_tl.interface"
-#include "rttov_calcemis_mw_tl.interface"
-#include "rttov_integrate_tl.interface"
-
- !subroutine arguments:
- Integer(Kind=jpim), Intent(in) :: nchannels
- Integer(Kind=jpim), Intent(in) :: nbtout
- Integer(Kind=jpim), Intent(in) :: nfrequencies
- Integer(Kind=jpim), Intent(in) :: nprofiles
- Integer(Kind=jpim), Intent(out) :: errorstatus(nprofiles)
- Integer(Kind=jpim), Intent(in) :: channels(nfrequencies)
- Integer(Kind=jpim), Intent(in) :: polarisations(nchannels,3)
- Integer(Kind=jpim), Intent(in) :: lprofiles(nfrequencies)
- Logical, Intent(in) :: addcloud
- Type(profile_Type), Intent(in) :: profiles(nprofiles)
- Type(rttov_coef), Intent(in) :: coef
- Logical, Intent(in) :: calcemis(nchannels)
- Real(Kind=jprb), Intent(inout) :: emissivity(nchannels)
- Type(transmission_Type), Intent(inout) :: transmission! in because of meme allocation
- Type(radiance_Type), Intent(inout) :: radiancedata! in because of meme allocation
-
-
- Type(profile_Type), Intent(in) :: profiles_tl(nprofiles)
- Real(Kind=jprb), Intent(inout) :: emissivity_tl(nchannels)
- Type(transmission_Type), Intent(inout) :: transmission_tl! in because of meme allocation
- Type(radiance_Type), Intent(inout) :: radiancedata_tl ! in because of meme allocation
-
- !local variables:
- Integer(Kind=jpim) :: i ! loop index
- Logical :: addcosmic ! switch for adding temp of cosmic background
- Real(Kind=jprb) :: reflectivity(nchannels) ! surface reflectivity
- Real(Kind=jprb) :: reflectivity_tl(nchannels) ! TL surface reflectivity
- Real(Kind=jprb) :: od_layer(coef%nlevels,nchannels) ! layer optical depth
- Real(Kind=jprb) :: opdp_ref(coef%nlevels,nfrequencies) ! layer optical depth before threshold
-
- Character (len=80) :: errMessage
- Character (len=8) :: NameOfRoutine = 'rttov_tl'
-
- Type(geometry_Type) :: angles(nprofiles) ! geometry angles
- Type(predictors_Type) :: predictors(nprofiles) ! predictors
- Type(profile_aux) :: aux_prof(nprofiles) ! auxillary profiles informations
-
- Type(predictors_Type) :: predictors_tl(nprofiles) ! TL of above predictors
- Type(profile_aux) :: aux_prof_tl(nprofiles) ! TL of above aux_prof
- Type(radiance_aux) :: auxrad
-
- Real(Kind=jprb), target :: zdeb (5,coef%nlevels,nprofiles)
- Real(Kind=jprb), target :: zdeb_tl(5,coef%nlevels,nprofiles)
- Real(Kind=jprb), target :: zmixed (coef%nmixed,coef%nlevels,nprofiles)
- Real(Kind=jprb), target :: zmixed_tl(coef%nmixed,coef%nlevels,nprofiles)
- Real(Kind=jprb), target :: zwater (coef%nwater,coef%nlevels,nprofiles)
- Real(Kind=jprb), target :: zwater_tl(coef%nwater,coef%nlevels,nprofiles)
- Real(Kind=jprb), target :: zlev (coef%nlevels,nprofiles)
- Real(Kind=jprb), target :: zlev_tl(coef%nlevels,nprofiles)
- Real(Kind=jprb), target :: zozone (coef%nozone,coef%nlevels,nprofiles)
- Real(Kind=jprb), target :: zozone_tl(coef%nozone,coef%nlevels,nprofiles)
- Real(Kind=jprb), target :: zwvcont (coef%nwvcont,coef%nlevels,nprofiles)
- Real(Kind=jprb), target :: zwvcont_tl(coef%nwvcont,coef%nlevels,nprofiles)
- Real(Kind=jprb), target :: zco2 (coef%nco2,coef%nlevels,nprofiles)
- Real(Kind=jprb), target :: zco2_tl(coef%nco2,coef%nlevels,nprofiles)
-
- Real(Kind=jprb), target :: surfair(nchannels)
- Real(Kind=jprb), target :: skin (nchannels)
- Real(Kind=jprb), target :: cosmic (nchannels)
- Real(Kind=jprb), target :: layer(coef%nlevels,nchannels)
- Real(Kind=jprb), target :: up (coef%nlevels,nchannels)
- Real(Kind=jprb), target :: down (coef%nlevels,nchannels)
- Real(Kind=jprb), target :: down_cloud(coef%nlevels,nchannels)
-
- Integer(Kind=jpim) :: jn
-
- !- End of header --------------------------------------------------------
-
- !-------------
- !0. initialize
- !-------------
-
- errorstatus(:) = errorstatus_success
-
- !------------------------------------------------------
- !1. check input data is within suitable physical limits
- !------------------------------------------------------
-
-
- Do i = 1, nprofiles
-
- Call rttov_checkinput( &
- & profiles( i ), &!in
- & coef, &!in
- & errorstatus(i) ) !out
-
- End Do
-
- ! 1.1 test check input return code
- !-----------------------------_---
- If ( any( errorstatus(:) == errorstatus_warning ) ) Then
- Do i = 1, nprofiles
- If ( errorstatus(i) == errorstatus_warning ) Then
- Write( errMessage, '( "checkinput warning error for profile",i4)' ) i
- Call Rttov_ErrorReport (errorstatus_warning, errMessage, NameOfRoutine)
- End If
- End Do
- End If
-
- If ( any( errorstatus(:) == errorstatus_fatal ) ) Then
- Do i = 1, nprofiles
- If ( errorstatus(i) == errorstatus_fatal ) Then
- ! Some unphysical values; Do not run RTTOV
- Write( errMessage, '( "checkinput fatal error for profile",i4)' ) i
- Call Rttov_ErrorReport (errorstatus_fatal, errMessage, NameOfRoutine)
- End If
- End Do
- ! nothing processed so all profiles get the fatal error code
- ! user will know which profile
- errorstatus(:) = errorstatus_fatal
- Return
- End If
-
-
-
- !-----------------------------------------
- !2. determine cloud top and surface levels
- !-----------------------------------------
- If( coef % id_sensor == sensor_id_mw ) Then
- jn=coef%nlevels
- Do i = 1, nprofiles
- aux_prof(i) % debye_prof => zdeb(1:5,1:jn,i)
- End Do
- Endif
- Do i = 1, nprofiles
- Call rttov_profaux( &
- & profiles(i), &! in
- & coef, &! in
- & aux_prof(i)) ! inout
- End Do
-
-
- !------------------------------------------------------------------
- !3. set up common geometric variables for transmittance calculation
- !------------------------------------------------------------------
-
- Do i = 1, nprofiles
- Call rttov_setgeometry( &
- & profiles(i), &! in
- & coef, &! in
- & angles(i) ) ! out
- End Do
-
-
-
- !------------------------------------------
- !5. calculate transmittance path predictors
- !------------------------------------------
-
- jn=coef%nlevels
- Do i = 1, nprofiles
- predictors(i) % nlevels = coef % nlevels
- predictors(i) % nmixed = coef % nmixed
- predictors(i) % nwater = coef % nwater
- predictors(i) % nozone = coef % nozone
- predictors(i) % nwvcont = coef % nwvcont
- predictors(i) % nco2 = coef % nco2
- predictors(i) % ncloud = 0 ! (can be set to 1 inside setpredictors)
-
-
- predictors(i) % mixedgas => zmixed(1:coef%nmixed, 1:jn, i)
- predictors(i) % watervapour => zwater(1:coef%nwater, 1:jn, i)
- predictors(i) % clw => zlev(1:jn, i)
-
- If( coef%nozone > 0 ) Then
- predictors(i) % ozone => zozone(1:coef%nozone, 1:jn, i)
- End If
- If( coef%nwvcont > 0 ) Then
- predictors(i) % wvcont => zwvcont(1:coef%nwvcont, 1:jn, i)
- End If
- If( coef%nco2 > 0 ) Then
- predictors(i) % co2 => zco2(1:coef%nco2, 1:jn, i)
- End If
- End Do ! Profile loop
-
-
- Do i = 1, nprofiles
- If (coef%fmv_model_ver == 7) Then
- Call rttov_setpredictors( &
- & profiles(i), &! in
- & angles(i), &! in
- & coef, &! in
- & predictors(i) ) ! inout (in because of mem allocation)
-
- Else If (coef%fmv_model_ver == 8) Then
- Call rttov_setpredictors_8( &
- & profiles(i), &! in
- & angles(i), &! in
- & coef, &! in
- & predictors(i) ) ! inout (in because of mem allocation)
-
- Else
- errorstatus(:) = errorstatus_fatal
- Write( errMessage,&
- & '( "Unexpected RTTOV compatibility version number" )' )
- Call Rttov_ErrorReport (errorstatus_fatal, errMessage, NameOfRoutine)
- Return
- End If
- End Do ! Profile loop
-
-
- !----------------------------------------------
- !6. calculate optical depths and transmittances
- !----------------------------------------------
-
- Call rttov_transmit( &
- & nfrequencies, &! in
- & nchannels, &! in
- & nprofiles, &! in
- & coef%nlevels, &! in
- & channels, &! in
- & polarisations, &! in
- & lprofiles, &! in
- & predictors, &! in
- & aux_prof, &! in
- & coef, &! in
- & transmission, &! inout
- & od_layer, &! out
- & opdp_ref) ! out
-
- !--------------------------------------
- !7. calculate channel emissivity values
- !--------------------------------------
-
- If ( Any(calcemis) ) Then
- ! calculate surface emissivity for selected channels
- ! and reflectivity
- If ( coef % id_sensor == sensor_id_ir ) Then
- !Infrared
- Call rttov_calcemis_ir( &
- & profiles, &! in
- & angles, &! in
- & coef, &! in
- & nfrequencies, &! in
- & nprofiles, &! in
- & channels, &! in
- & lprofiles, &! in
- & calcemis, &! in
- & emissivity ) ! inout
- reflectivity(:) = 1 - emissivity(:)
-
- Elseif ( coef % id_sensor == sensor_id_mw ) Then
- !Microwave
- Call rttov_calcemis_mw ( &
- & profiles, &! in
- & angles, &! in
- & coef, &! in
- & nfrequencies, &! in
- & nchannels, &! in
- & nprofiles, &! in
- & channels, &! in
- & polarisations, &! in
- & lprofiles, &! in
- & transmission, &! in
- & calcemis, &! in
- & emissivity, &! inout
- & reflectivity, &! out
- & errorstatus ) ! out
- If ( Any( errorstatus == errorstatus_fatal ) ) Then
- errorstatus(:) = errorstatus_fatal
- Return
- End If
- Else
- ! Hires
- Call rttov_calcemis_ir( &
- & profiles, &! in
- & angles, &! in
- & coef, &! in
- & nfrequencies, &! in
- & nprofiles, &! in
- & channels, &! in
- & lprofiles, &! in
- & calcemis, &! in
- & emissivity ) ! inout
- reflectivity(:) = 1 - emissivity(:)
- End If
-
- ! reflectivity for other channels
- Where( .Not. calcemis(:) )
- reflectivity(:) = 1 - emissivity(:)
- End Where
-
- Else
- ! reflectivity for all channels
- reflectivity(:) = 1 - emissivity(:)
- End If
-
-
- !--------------------------------------------
- !8. integrate the radiative transfer equation
- !--------------------------------------------
-
- auxrad % layer => layer(:,:)
- auxrad % surfair => surfair(:)
- auxrad % skin => skin(:)
- auxrad % cosmic => cosmic(:)
- auxrad % up => up(:,:)
- auxrad % down => down(:,:)
-
- If ( addcloud ) then
- auxrad % down_cloud => down_cloud(:,:)
- End If
-
- addcosmic = ( coef % id_sensor == sensor_id_mw )
- Call rttov_integrate( &
- & addcloud, &! in
- & addcosmic, &! in
- & nfrequencies, &! in
- & nchannels, &! in
- & nbtout, &! in
- & nprofiles, &! in
- & angles, &! in
- & channels, &! in
- & polarisations, &! in
- & lprofiles, &! in
- & emissivity, &! in
- & reflectivity, &! in
- & transmission, &! in
- & profiles, &! in
- & aux_prof, &! in
- & coef, &! in
- & radiancedata, &! inout
- & auxrad ) ! inout
-
-
-
- ! Tangent Linear
- !----------------
-
- !
-
- Do i = 1, nprofiles
- aux_prof_tl(i) % nearestlev_surf = 0 ! no meaning
- aux_prof_tl(i) % nearestlev_ctp = 0 ! no meaning
- aux_prof_tl(i) % pfraction_surf = 0._JPRB ! calculated
- aux_prof_tl(i) % pfraction_ctp = 0._JPRB ! calculated inside rttov_profaux_tl
- aux_prof_tl(i) % cfraction = 0._JPRB ! calculated
- ! Note that cfraction and pfraction_ctp are set to 0 in case
- ! of MicroWaves
- If( coef % id_sensor == sensor_id_mw ) Then
- aux_prof_tl(i) % debye_prof => zdeb_tl(1:5,1:jn,i)
- Endif
- End Do
-
- Do i = 1, nprofiles
- If( coef % id_sensor == sensor_id_mw ) Then
- aux_prof_tl(i) % debye_prof(:,:) = 0._JPRB
- Endif
- Call rttov_profaux_tl( &
- & profiles(i), &! in
- & profiles_tl(i), &! in
- & coef, &! in
- & aux_prof(i), &! in
- & aux_prof_tl(i)) ! inout
- End Do
-
- ! No TL on geometry
-
- ! TL of predictors
-
- jn=coef%nlevels
- Do i = 1, nprofiles
- predictors_tl(i) % mixedgas => zmixed_tl(1:coef%nmixed, 1:jn, i)
- predictors_tl(i) % watervapour => zwater_tl(1:coef%nwater, 1:jn, i)
- predictors_tl(i) % clw => zlev_tl(1:jn, i)
- If( coef%nozone > 0 ) Then
- predictors_tl(i) % ozone => zozone_tl(1:coef%nozone, 1:jn, i)
- End If
- If( coef%nwvcont > 0 ) Then
- predictors_tl(i) % wvcont => zwvcont_tl(1:coef%nwvcont, 1:jn, i)
- End If
-
- If( coef%nco2 > 0 ) Then
- predictors_tl(i) % co2 => zco2_tl(1:coef%nco2, 1:jn, i)
- End If
-
- End Do
-
- Do i = 1, nprofiles
- predictors_tl(i) % nlevels = predictors(i) % nlevels
- predictors_tl(i) % nmixed = predictors(i) % nmixed
- predictors_tl(i) % nwater = predictors(i) % nwater
- predictors_tl(i) % nozone = predictors(i) % nozone
- predictors_tl(i) % nwvcont = predictors(i) % nwvcont
- predictors_tl(i) % nco2 = predictors(i) % nco2
- predictors_tl(i) % ncloud = predictors(i) % ncloud
-
- If (coef%fmv_model_ver == 7) Then
- Call rttov_setpredictors_tl( &
- & profiles(i), &! in
- & profiles_tl(i), &! in
- & angles(i), &! in
- & coef, &! in
- & predictors(i), &! in
- & predictors_tl(i) ) ! inout
-
- ElseIf (coef%fmv_model_ver == 8) Then
- Call rttov_setpredictors_8_tl( &
- & profiles(i), &! in
- & profiles_tl(i), &! in
- & angles(i), &! in
- & coef, &! in
- & predictors(i), &! in
- & predictors_tl(i) ) ! inout
- End If
- End Do
-
-
- !TL of optical depths and transmittances
- Call rttov_transmit_tl( &
- & nfrequencies, &! in
- & nchannels, &! in
- & nprofiles, &! in
- & coef%nlevels, &! in
- & channels, &! in
- & polarisations, &! in
- & lprofiles, &! in
- & predictors, &! in
- & predictors_tl, &! in
- & aux_prof, &! in
- & aux_prof_tl, &! in
- & coef, &! in
- & od_layer, &! in
- & opdp_ref, &! in
- & transmission, &! in
- & transmission_tl ) ! inout
-
- If ( Any(calcemis) ) Then
- ! calculate surface emissivity for selected channels
- ! and reflectivity
- If ( coef % id_sensor == sensor_id_ir ) Then
- !Infrared
- ! nothing to do
- reflectivity_tl(:) = - emissivity_tl(:)
-
- Elseif ( coef % id_sensor == sensor_id_mw ) Then
- !Microwave
- Call rttov_calcemis_mw_tl ( &
- & profiles, &! in
- & profiles_tl, &! in
- & angles, &! in
- & coef, &! in
- & nfrequencies, &! in
- & nchannels, &! in
- & nprofiles, &! in
- & channels, &! in
- & polarisations, &! in
- & lprofiles, &! in
- & transmission, &! in
- & transmission_tl, &! in
- & calcemis, &! in
- & emissivity_tl, &! inout
- & reflectivity_tl ) ! out
- Else
- ! Hires
- reflectivity_tl(:) = - emissivity_tl(:)
- End If
-
- ! reflectivity for other channels
- Where( .Not. calcemis(:) )
- reflectivity_tl(:) = - emissivity_tl(:)
- End Where
-
- Else
- ! reflectivity for all channels
- reflectivity_tl(:) = - emissivity_tl(:)
- End If
-
- !--------------------------------------------
- !8. integrate the radiative transfer equation
- !--------------------------------------------
-
- addcosmic = ( coef % id_sensor == sensor_id_mw )
- Call rttov_integrate_tl( &
- & addcloud, &! in
- & addcosmic, &! in
- & nfrequencies, &! in
- & nchannels, &! in
- & nbtout, &! in
- & nprofiles, &! in
- & angles, &! in
- & channels, &! in
- & polarisations, &! in
- & lprofiles, &! in
- & emissivity, &! in
- & emissivity_tl, &! in
- & reflectivity, &! in
- & reflectivity_tl, &! in
- & transmission, &! in
- & transmission_tl, &! in
- & profiles, &! in
- & profiles_tl, &! in
- & aux_prof, &! in
- & aux_prof_tl, &! in
- & coef, &! in
- & radiancedata, &! in
- & auxrad , &! in
- & radiancedata_tl ) ! inout
-
-
-End Subroutine rttov_tl
diff --git a/src/LIB/RTTOV/src/rttov_tl.interface b/src/LIB/RTTOV/src/rttov_tl.interface
deleted file mode 100644
index 1bf3698cb41e1f0d62c1e7357e6dfbd9d71fe1fc..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_tl.interface
+++ /dev/null
@@ -1,70 +0,0 @@
-Interface
-!
-Subroutine rttov_tl( &
- errorstatus, & ! out
- nfrequencies, & ! in
- nchannels, & ! in
- nbtout, & ! in
- nprofiles, & ! in
- channels, & ! in
- polarisations, & ! in
- lprofiles, & ! in
- profiles, & ! in
- coef, & ! in
- addcloud, & ! in
- calcemis, & ! in
- emissivity, & ! inout
- profiles_tl, & ! in
- emissivity_tl, & ! inout
- transmission, & ! inout
- transmission_tl,& ! inout
- radiancedata, & ! inout
- radiancedata_tl ) ! inout
- Use rttov_const, Only : &
- errorstatus_success ,&
- errorstatus_warning ,&
- errorstatus_fatal ,&
- max_optical_depth ,&
- sensor_id_mw ,&
- sensor_id_ir
-
- Use rttov_types, Only : &
- rttov_coef ,&
- profile_Type ,&
- geometry_Type ,&
- predictors_Type,&
- profile_aux ,&
- transmission_Type ,&
- radiance_Type ,&
- radiance_aux
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
- Integer(Kind=jpim), Intent(in) :: nfrequencies
- Integer(Kind=jpim), Intent(in) :: nchannels
- Integer(Kind=jpim), Intent(in) :: nbtout
- Integer(Kind=jpim), Intent(in) :: nprofiles
- Integer(Kind=jpim), Intent(out) :: errorstatus(nprofiles)
- Integer(Kind=jpim), Intent(in) :: channels(nfrequencies)
- Integer(Kind=jpim), Intent(in) :: polarisations(nchannels,3)
- Integer(Kind=jpim), Intent(in) :: lprofiles(nfrequencies)
- Logical, Intent(in) :: addcloud
- Type(profile_Type), Intent(in) :: profiles(nprofiles)
- Type(rttov_coef), Intent(in) :: coef
- Logical, Intent(in) :: calcemis(nchannels)
- Real(Kind=jprb), Intent(inout) :: emissivity(nchannels)
- Type(transmission_Type), Intent(inout) :: transmission! in because of meme allocation
- Type(radiance_Type), Intent(inout) :: radiancedata! in because of meme allocation
-
-
- Type(profile_Type), Intent(in) :: profiles_tl(nprofiles)
- Real(Kind=jprb), Intent(inout) :: emissivity_tl(nchannels)
- Type(transmission_Type), Intent(inout) :: transmission_tl! in because of meme allocation
- Type(radiance_Type), Intent(inout) :: radiancedata_tl ! in because of meme allocation
-
-
-
-
-End Subroutine rttov_tl
-End Interface
diff --git a/src/LIB/RTTOV/src/rttov_transmit.F90 b/src/LIB/RTTOV/src/rttov_transmit.F90
deleted file mode 100644
index 315491545b709b086e3e6af8fcc0d00434ad3ea6..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_transmit.F90
+++ /dev/null
@@ -1,284 +0,0 @@
-Subroutine rttov_transmit( &
- & nfrequencies, &! in
- & nchannels, &! in
- & nprofiles, &! in
- & nlevels, &! in
- & channels, &! in
- & polarisations, &! in
- & lprofiles, &! in
- & predictors, &! in
- & aux, &! in
- & coef, &! in
- & transmission, &! out
- & od_layer, &! out
- & opdp_ref_freq) ! out
- !
- ! Description:
- ! To calculate optical depths for a number of channels
- ! and profiles from every pressure level to space.
- ! To interpolate optical depths on to levels of radiative transfer model
- ! (which, at present, entails only surface transmittance, as
- ! other optical depths are on *rt* levels) and to convert
- ! optical depths to transmittances.
- !
- ! Code based on OPDEP and RTTAU from previous versions of RTTOV
- ! Only one profile per call
- !
- ! Copyright:
- ! This software was developed within the context of
- ! the EUMETSAT Satellite Application Facility on
- ! Numerical Weather Prediction (NWP SAF), under the
- ! Cooperation Agreement dated 25 November 1998, between
- ! EUMETSAT and the Met Office, UK, by one or more partners
- ! within the NWP SAF. The partners in the NWP SAF are
- ! the Met Office, ECMWF, KNMI and MeteoFrance.
- !
- ! Copyright 2002, EUMETSAT, All Rights Reserved.
- !
- ! Method:
- !
- ! Current Code Owner: SAF NWP
- !
- ! History:
- ! Version Date Comment
- ! ------- ---- -------
- ! 1.0 01/12/2002 New F90 code with structures (P Brunel A Smith)
- ! 1.1 29/01/2003 Add WV Continuum and CO2 capability (P Brunel)
- ! 1.2 04/12/2003 Optimisation (J Hague and D Salmond ECMWF)
- ! 1.3 26/09/2003 Modified to allow for multiple polarisations (S English)
- ! 1.4 17/08/2004 Bug fixed in setting transmission to 1 (S English)
- ! 1.5 28/02/2005 Improved vectorisation (D Dent)
- !
- ! Code Description:
- ! Language: Fortran 90.
- ! Software Standards: "European Standards for Writing and
- ! Documenting Exchangeable Fortran 90 Code".
- !
- ! Declarations:
- ! Modules used:
-
- ! Imported Parameters:
- Use rttov_const, Only: &
- & mwcldtop ,&
- & sensor_id_mw ,&
- & max_optical_depth
-
- ! Imported Type Definitions:
- Use rttov_types, Only : &
- & rttov_coef ,&
- & predictors_Type,&
- & transmission_Type ,&
- & profile_aux
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
- !subroutine arguments:
- Integer(Kind=jpim), Intent(in) :: nfrequencies ! Number of frequencies
- Integer(Kind=jpim), Intent(in) :: nchannels ! Number of output radiances
- Integer(Kind=jpim), Intent(in) :: nprofiles ! Number of profiles
- Integer(Kind=jpim), Intent(in) :: nlevels ! Number of pressure levels
- Integer(Kind=jpim), Intent(in) :: channels(nfrequencies) ! Channel indices
- Integer(Kind=jpim), Intent(in) :: polarisations(nchannels,3) ! polarisation indices
- Integer(Kind=jpim), Intent(in) :: lprofiles(nfrequencies) ! Profiles indices
- Type(predictors_Type), Intent(in) :: predictors( nprofiles ) ! Predictors
- Type(rttov_coef), Intent(in) :: coef ! Coefficients
- Type(transmission_Type),Intent(inout) :: transmission ! Transmittances and single-layer od
- Type(profile_aux), Intent(in) :: aux( nprofiles ) ! auxillary profiles informations
- Real(Kind=jprb), Intent(out) :: od_layer(nlevels,nchannels) ! sat to layer optical depth
- Real(Kind=jprb), Intent(out) :: opdp_ref_freq(nlevels,nfrequencies) ! layer optical depth
- ! before threshold
-
- !local variables:
- Real(Kind=jprb) :: opticaldepth(nlevels,nfrequencies) ! raw layer optical depth
- Real(Kind=jprb) :: od_surf(nfrequencies) ! sat to surface optical depth
- Real(Kind=jprb) :: od_layer_freq(nlevels,nfrequencies) ! sat to layer optical depth
- Real(Kind=jprb) :: od_singlelayer_freq(nlevels,nfrequencies) ! sat to layer optical depth
- Real(Kind=jprb) :: opdp_ref(nlevels,nchannels) ! layer optical depth
- Real(Kind=jprb) :: tau_surf_freq(nfrequencies) ! sat to surface transmission at each frequency
- Real(Kind=jprb) :: tau_layer_freq(nlevels,nfrequencies) ! sat to layer transmission
- Real(Kind=jprb), Pointer :: debye_prof(:,:) ! pointer on Debye profiles
- Integer(Kind=jpim) :: lev, chan, j, prof, freq, kpol ! loop variables
-
- ! cloud liquid water local variables
- Real(Kind=jprb) :: zf, zf_sq, z34_dif, z45_dif, z1_sq, z2_sq, z1_div, z2_div
- Real(Kind=jprb) :: z1_den, z2_den, zastar, z1_prod, z2_prod, z3_prod, z4_prod
- Real(Kind=jprb) :: zbstar, zbstar_sq, za2star, za2star_sq, zdiv, zgstar
- Real(Kind=jprb) :: z1f_sq_z1_sq, z2f_sq_z2_sq
- Integer(Kind=jpim) :: ii
-
- !- End of header --------------------------------------------------------
-
-
- !-----------------------------------------
- !1. calculate layer gaseous optical depths
- !-----------------------------------------
-
- !--------------------------
- !1.1 start with mixed gases
- !--------------------------
- opticaldepth(:,:)=0
- Do j = 1, nfrequencies
- chan = channels(j)
- prof = lprofiles(j)
-
- Do ii=1,coef % nmixed
- Do lev=1,nlevels
- opticaldepth(lev,j)= opticaldepth(lev,j) + &
- & coef%mixedgas(lev,chan,ii) * predictors( prof ) % mixedgas(ii,lev)
- End Do
- End Do
-
- !--------------------
- !1.2 add water vapour
- !--------------------
-
- Do ii=1,coef % nwater
- Do lev=1,nlevels
- opticaldepth(lev,j)= opticaldepth(lev,j) + &
- & coef%watervapour(lev,chan,ii) * predictors( prof ) % watervapour(ii,lev)
- End Do
- End Do
-
- !-------------
- !1.3 add ozone
- !-------------
-
- Do ii=1,coef % nozone
- Do lev=1,nlevels
- opticaldepth(lev,j)= opticaldepth(lev,j) + &
- & coef%ozone(lev,chan,ii) * predictors( prof ) % ozone(ii,lev)
- End Do
- End Do
-
- !------------------------------
- !1.4 add Water Vapour Continuum
- !------------------------------
-
- Do ii=1,coef % nwvcont
- Do lev=1,nlevels
- opticaldepth(lev,j)= opticaldepth(lev,j) + &
- & coef%wvcont(lev,chan,ii) * predictors( prof ) % wvcont(ii,lev)
- End Do
- End Do
-
- !-----------
- !1.5 add CO2
- !-----------
-
- Do ii=1,coef % nco2
- Do lev=1,nlevels
- opticaldepth(lev,j)= opticaldepth(lev,j) + &
- & coef%co2(lev,chan,ii) * predictors( prof ) % co2(ii,lev)
- End Do
- End Do
-
- !--------------------
- !1.6 add liquid water (MW only)
- !--------------------
-
- If ( coef % id_sensor == sensor_id_mw ) Then
- debye_prof => aux(prof) % debye_prof
- If( predictors(prof) % ncloud >= 1 ) Then
- Do lev = mwcldtop, nlevels
- zf = coef % frequency_ghz(chan)
- zf_sq = zf*zf
- z1_sq = debye_prof(1,lev) * debye_prof(1,lev)
- z2_sq = debye_prof(2,lev) * debye_prof(2,lev)
- z34_dif = debye_prof(3,lev) - debye_prof(4,lev)
- z45_dif = debye_prof(4,lev) - debye_prof(5,lev)
- z1f_sq_z1_sq = zf_sq + z1_sq
- z2f_sq_z2_sq = zf_sq + z2_sq
- z1_div = 1.0_JPRB / z1f_sq_z1_sq
- z2_div = 1.0_JPRB / z2f_sq_z2_sq
- z1_den = z34_dif * z1_div
- z2_den = z45_dif * z2_div
- zastar = debye_prof(3,lev) - zf_sq * (z1_den + z2_den)
- z1_prod = z34_dif * debye_prof(1,lev)
- z2_prod = z1_prod * z1_div
- z3_prod = z45_dif * debye_prof(2,lev)
- z4_prod = z3_prod * z2_div
- zbstar = -zf * (z2_prod + z4_prod)
- zbstar_sq = zbstar * zbstar
- za2star = zastar + 2.0_JPRB
- za2star_sq = za2star * za2star
- zdiv = za2star_sq + zbstar_sq
- zgstar = -3.0_JPRB * zbstar / zdiv
- opticaldepth(lev,j) = opticaldepth(lev,j) -&
- & 1.5_JPRB * zf * zgstar * predictors ( prof ) % clw(lev)
- End Do
- Endif
- End If
- End Do
-
-
- !----------------------------------------
- !2. Compute layer to space optical depths
- !----------------------------------------
- ! notes: apply gamma correction; check value is sensible and constrain
- ! if necessary.
-
- ! note that optical depth in the calculations is negative
- ! store optical depth in reference array for TL, AD and K calculations
- opdp_ref_freq(:,:) = opticaldepth(:,:)
- Where( opticaldepth(:,:) > 0.0_JPRB )
- opticaldepth = 0.0_JPRB
- End Where
-
- Do j = 1, nfrequencies
- chan = channels(j)
- opticaldepth(:,j) = coef%ff_gam(chan) * opticaldepth(:,j)
- End Do
- od_singlelayer_freq(:,:) = - opticaldepth(:,:)
-
- od_layer_freq(1,:) = opticaldepth(1,:)
- Do lev = 2, nlevels
- od_layer_freq(lev,:) = od_layer_freq(lev-1,:) + opticaldepth(lev,:)
- End Do
-
- !-------------------------------------------
- !3. Convert optical depths to transmittances
- !-------------------------------------------
-
- ! On some computers when optical depth is too thick
- ! there is an underflow during the conversion in
- ! transmittances. In that case uncomment following line
- ! and the declaration statement of max_optical_depth
- od_layer_freq(:,:) = Max(od_layer_freq(:,:),-max_optical_depth)
-
- tau_layer_freq(:,:) = Exp(od_layer_freq(:,:))
-
-
- !-----------------------------------------------------
- !4. Compute optical depth and transmittance at surface
- !-----------------------------------------------------
- Do j = 1, nfrequencies
- prof = lprofiles(j)
- od_surf(j) = od_layer_freq(aux(prof) % nearestlev_surf,j) + &
- & aux(prof) % pfraction_surf * &
- & ( od_layer_freq(aux(prof) % nearestlev_surf-1,j) - &
- & od_layer_freq(aux(prof) % nearestlev_surf ,j) )
- End Do
-
- tau_surf_freq(:) = Exp(od_surf(:))
-
- !-----------------------------------------------------
- !5. Store transmittances for other polarisations
- !-----------------------------------------------------
-
- transmission % tau_layer(:,:) = 1.0_JPRB
- transmission % od_singlelayer(:,:) = 1.0_JPRB
- od_layer(:,:) = 0.0_JPRB
- opdp_ref(:,:) = 0.0_JPRB
- Do j = 1, nchannels
- freq = polarisations(j,2) ! Frequency index
- kpol = 1 + j - polarisations(freq,1) ! Polarisation index
- prof = lprofiles(freq) ! Profile index
- transmission % tau_layer(:,j) = tau_layer_freq(:,freq)
- transmission % od_singlelayer(:,j) = od_singlelayer_freq(:,freq)
- od_layer(:,j) = od_layer_freq(:,freq)
- opdp_ref(:,j) = opdp_ref_freq(:,freq)
- transmission % tau_surf(j) = tau_surf_freq(freq)
- End Do
-
-End Subroutine rttov_transmit
diff --git a/src/LIB/RTTOV/src/rttov_transmit.interface b/src/LIB/RTTOV/src/rttov_transmit.interface
deleted file mode 100644
index f293048e837541d4823fd681eaa7c431f8588c8b..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_transmit.interface
+++ /dev/null
@@ -1,47 +0,0 @@
-Interface
-!
-Subroutine rttov_transmit( &
- nfrequencies, & ! in
- nchannels, & ! in
- nprofiles, & ! in
- nlevels, & ! in
- channels, & ! in
- polarisations, & ! in
- lprofiles, & ! in
- predictors, & ! in
- aux, & ! in
- coef, & ! in
- transmission, & ! out
- od_layer, & ! out
- opdp_ref) ! out
-
- Use rttov_const, Only: &
- mwcldtop ,&
- sensor_id_mw ,&
- max_optical_depth
-
- Use rttov_types, Only : &
- rttov_coef ,&
- predictors_Type,&
- transmission_Type ,&
- profile_aux
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
- Integer(Kind=jpim), Intent(in) :: nfrequencies
- Integer(Kind=jpim), Intent(in) :: nchannels ! Number of output radiances
- Integer(Kind=jpim), Intent(in) :: nprofiles
- Integer(Kind=jpim), Intent(in) :: nlevels
- Integer(Kind=jpim), Intent(in) :: channels(nfrequencies)
- Integer(Kind=jpim), Intent(in) :: polarisations(nchannels,3)
- Integer(Kind=jpim), Intent(in) :: lprofiles(nfrequencies)
- Type(predictors_Type), Intent(in) :: predictors( nprofiles ) ! Predictors
- Type(rttov_coef), Intent(in) :: coef ! Coefficients
- Type(transmission_Type), Intent(inout) :: transmission ! Transmittances and single-layer od
- Type(profile_aux), Intent(in) :: aux( nprofiles ) ! auxillary profiles informations
- Real(Kind=jprb), Intent(out) :: od_layer(nlevels,nchannels) ! sat to layer optical depth
- Real(Kind=jprb), Intent(out) :: opdp_ref(nlevels,nfrequencies) ! layer optical depth
- ! before threshold
-
-End Subroutine rttov_transmit
-End Interface
diff --git a/src/LIB/RTTOV/src/rttov_transmit_ad.F90 b/src/LIB/RTTOV/src/rttov_transmit_ad.F90
deleted file mode 100644
index 4836d6053e39b3bef596ac04f7a8a7b481070810..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_transmit_ad.F90
+++ /dev/null
@@ -1,426 +0,0 @@
-Subroutine rttov_transmit_ad( &
- & nfrequencies, &! in
- & nchannels, &! in
- & nprofiles, &! in
- & nlevels, &! in
- & channels, &! in
- & polarisations, &! in
- & lprofiles, &! in
- & predictors, &! in
- & predictors_ad, &! inout
- & aux, &! in
- & aux_ad, &! inout
- & coef, &! in
- & od_layer, &! in
- & opdp_ref, &! in
- & transmission, &! in
- & transmission_ad ) ! inout
-
- ! Description:
- ! Adjoint of rttov_transmit_tl
- ! To calculate optical depths for a number of channels
- ! and profiles from every pressure level to space.
- ! To interpolate optical depths on to levels of radiative transfer model
- ! (which, at present, entails only surface transmittance, as
- ! other optical depths are on *rt* levels) and to convert
- ! optical depths to transmittances.
- !
- ! Code based on OPDEPAD and RTTAUAD from previous versions of RTTOV
- ! Only one profile per call
- !
- ! Adjoint variables
- ! input transmission_ad % tau_surf and transmission_ad % tau_layer
- ! set inside integrate_ad
- !
- ! input/output aux_ad
- !
- ! output predictors_ad initialised inside rttov_ad (need input
- ! intent for memory allocation in calling routine)
- !
- !
- ! Copyright:
- ! This software was developed within the context of
- ! the EUMETSAT Satellite Application Facility on
- ! Numerical Weather Prediction (NWP SAF), under the
- ! Cooperation Agreement dated 25 November 1998, between
- ! EUMETSAT and the Met Office, UK, by one or more partners
- ! within the NWP SAF. The partners in the NWP SAF are
- ! the Met Office, ECMWF, KNMI and MeteoFrance.
- !
- ! Copyright 2002, EUMETSAT, All Rights Reserved.
- !
- ! Method:
- !
- ! Current Code Owner: SAF NWP
- !
- ! History:
- ! Version Date Comment
- ! ------- ---- -------
- ! 1.0 01/12/2002 New F90 code with structures (P Brunel A Smith)
- ! 1.1 29/01/2003 Add WV Continuum and CO2 capability (P Brunel)
- ! 1.2 04/12/2003 Optimisation (J Hague and D Salmond ECMWF)
- ! 1.3 26/09/2003 Modified to allow for multiple polarisations (S English)
- ! 06/09/2004 Mods. for Vectorisation (D Salmond ECMWF & B Carruthers, Cray)
- ! 28/02/2005 Improved vectorisation (D Dent)
- !
- ! Code Description:
- ! Language: Fortran 90.
- ! Software Standards: "European Standards for Writing and
- ! Documenting Exchangeable Fortran 90 Code".
- !
- ! Declarations:
- ! Modules used:
-
- ! Imported Parameters:
-
- Use rttov_const, Only: &
- & mwcldtop ,&
- & sensor_id_mw
-
-
- Use rttov_types, Only : &
- & rttov_coef ,&
- & predictors_Type,&
- & transmission_Type ,&
- & profile_aux
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
- !subroutine arguments:
- Integer(Kind=jpim), Intent(in) :: nfrequencies
- Integer(Kind=jpim), Intent(in) :: nchannels
- Integer(Kind=jpim), Intent(in) :: nprofiles
- Integer(Kind=jpim), Intent(in) :: nlevels
- Integer(Kind=jpim), Intent(in) :: channels(nfrequencies)
- Integer(Kind=jpim), Intent(in) :: polarisations(nchannels,3)
- Integer(Kind=jpim), Intent(in) :: lprofiles(nfrequencies)
- Type(predictors_Type), Intent(in) :: predictors( nprofiles )
- Type(predictors_Type), Intent(inout) :: predictors_ad( nprofiles )
- Type(rttov_coef), Intent(in) :: coef
- Type(profile_aux), Intent(in) :: aux( nprofiles )
- Type(profile_aux), Intent(inout) :: aux_ad( nprofiles )
- Real(Kind=jprb), Intent(in) :: od_layer(nlevels,nchannels)
- Real(Kind=jprb), Intent(in) :: opdp_ref(nlevels,nfrequencies)
- Type(transmission_Type),Intent(in) :: transmission
- Type(transmission_Type),Intent(inout):: transmission_ad
-
- !local variables:
- Real(Kind=jprb) :: od_layer_ad(nlevels,nfrequencies)
- Real(Kind=jprb) :: opticaldepth_ad(nlevels,nfrequencies)
- Real(Kind=jprb) :: od_surf_ad(nfrequencies)
- Real(Kind=jprb) :: tau_layer_freq(nlevels,nfrequencies) ! sat to layer transmission at each frequency
- Real(Kind=jprb) :: tau_surf_freq_ad(nfrequencies) ! sat to surface transmission at each frequency
- Real(Kind=jprb) :: tau_layer_freq_ad(nlevels,nfrequencies) ! sat to layer transmission at each frequency
- Real(Kind=jprb) :: od_singlelayer_freq_ad(nlevels,nfrequencies)
- Real(Kind=jprb), Pointer :: debye_prof(:,:)
- Real(Kind=jprb), Pointer :: debye_prof_ad(:,:)
- Integer(Kind=jpim) :: lev,chan,j,freq,kpol
- Integer(Kind=jpim) :: prof
-
- ! cloud liquid water local variables
- Real(Kind=jprb) :: zf, zf_sq, z34_dif, z45_dif, z1_sq, z2_sq, z1_div, z2_div
- Real(Kind=jprb) :: z1_den, z2_den, zastar, z1_prod, z2_prod, z3_prod, z4_prod
- Real(Kind=jprb) :: zbstar, zbstar_sq, za2star, za2star_sq, zdiv, zgstar
- Real(Kind=jprb) :: z1f_sq_z1_sq, z2f_sq_z2_sq
-
- Real(Kind=jprb) :: z34_dif_ad, z45_dif_ad, z1_sq_ad, z2_sq_ad, z1_div_ad, z2_div_ad
- Real(Kind=jprb) :: z1_den_ad, z2_den_ad, zastar_ad, z1_prod_ad, z2_prod_ad, z3_prod_ad, z4_prod_ad
- Real(Kind=jprb) :: zbstar_ad, zbstar_sq_ad, za2star_ad, za2star_sq_ad, zdiv_ad, zgstar_ad
- Real(Kind=jprb) :: z1f_sq_z1_sq_ad, z2f_sq_z2_sq_ad
- Integer(Kind=jpim) :: II
-
- !- End of header --------------------------------------------------------
-
- od_layer_ad(:,:) = 0._JPRB
- opticaldepth_ad(:,:) = 0._JPRB
-
- !-----------------------------------------------------
- !5. Store transmittances for other polarisations
- !-----------------------------------------------------
-
- tau_layer_freq_ad(:, :) = 0.0_JPRB
- od_singlelayer_freq_ad(:, :) = 0.0_JPRB
- tau_surf_freq_ad(:) = 0.0_JPRB
-
-!dir$ concurrent
- Do j = 1, nchannels
- freq = polarisations(j,2) ! Frequency index
- tau_layer_freq(:,freq) = transmission % tau_layer(:,j)
- tau_layer_freq_ad(:,freq) = tau_layer_freq_ad(:,freq) + transmission_ad % tau_layer(:,j)
- od_singlelayer_freq_ad(:,freq) = od_singlelayer_freq_ad(:,freq) + &
- & transmission_ad % od_singlelayer(:,j)
- tau_surf_freq_ad(freq) = tau_surf_freq_ad(freq) + transmission_ad % tau_surf(j)
- od_surf_ad(freq) = transmission % tau_surf(j) * tau_surf_freq_ad(freq)
- End Do
-
- !-----------------------------------------------------
- !4. Compute optical depth and transmittance at surface
- !-----------------------------------------------------
-
- Do j = 1, nfrequencies
- prof = lprofiles(j)
- chan = polarisations(j,1)
-
- od_layer_ad(aux(prof) % nearestlev_surf,j) = od_layer_ad(aux(prof) % nearestlev_surf,j) +&
- & od_surf_ad(j) * (1._JPRB - aux(prof) % pfraction_surf )
- od_layer_ad(aux(prof) % nearestlev_surf-1,j) = od_layer_ad(aux(prof) % nearestlev_surf-1,j) +&
- & od_surf_ad(j) * aux(prof) % pfraction_surf
- aux_ad(prof) % pfraction_surf = aux_ad(prof) % pfraction_surf + od_surf_ad(j) *&
- & ( od_layer(aux(prof) % nearestlev_surf-1,chan) - &
- & od_layer(aux(prof) % nearestlev_surf ,chan) )
- od_surf_ad(j) = 0._JPRB
- End Do
-
- !-------------------------------------------
- !3. Convert optical depths to transmittances
- !-------------------------------------------
- od_layer_ad(:,:) = od_layer_ad(:,:) + tau_layer_freq_ad(:,:) * tau_layer_freq(:,:)
-
- !transmission_ad % tau_layer(:,:) = 0.
-
- !----------------------------------------
- !2. Compute layer to space optical depths
- !----------------------------------------
- ! notes: apply gamma correction; check value is sensible and constrain
- ! if necessary.
-
- Do lev = nlevels, 2, -1
- od_layer_ad(lev-1,:) = od_layer_ad(lev-1,:) + od_layer_ad(lev,:)
- opticaldepth_ad(lev,:) = opticaldepth_ad(lev,:) + od_layer_ad(lev,:)
- od_layer_ad(lev,:) = 0._JPRB
- End Do
-
- opticaldepth_ad(1,:) = opticaldepth_ad(1,:) + od_layer_ad(1,:)
- opticaldepth_ad(:,:) = opticaldepth_ad(:,:) - od_singlelayer_freq_ad(:,:)
-
- Do j = 1, nfrequencies
- chan = channels(j)
- opticaldepth_ad(:,j) = coef%ff_gam(chan) * opticaldepth_ad(:,j)
- End Do
-
-
- ! note that optical depth in the calculations is negative
- Where( opdp_ref(:,:) > 0.0_JPRB )
- opticaldepth_ad = 0.0_JPRB
- End Where
-
- !--------------------
- !1.6 add liquid water (MW only)
- !--------------------
- If ( coef % id_sensor == sensor_id_mw ) Then
-!dir$ concurrent
- Do j = 1, nfrequencies
- chan = channels(j)
- prof = lprofiles(j)
- debye_prof => aux(prof) % debye_prof
- debye_prof_ad => aux_ad(prof) % debye_prof
- If( predictors(prof) % ncloud >= 1 ) Then
-!dir$ concurrent
- Do lev = mwcldtop, nlevels
-
- ! Repeat direct code
- zf = coef % frequency_ghz(chan)
- zf_sq = zf*zf
- z1_sq = debye_prof(1,lev) * debye_prof(1,lev)
- z2_sq = debye_prof(2,lev) * debye_prof(2,lev)
- z34_dif = debye_prof(3,lev) - debye_prof(4,lev)
- z45_dif = debye_prof(4,lev) - debye_prof(5,lev)
- z1f_sq_z1_sq = zf_sq + z1_sq
- z2f_sq_z2_sq = zf_sq + z2_sq
- z1_div = 1.0_JPRB / z1f_sq_z1_sq
- z2_div = 1.0_JPRB / z2f_sq_z2_sq
- z1_den = z34_dif * z1_div
- z2_den = z45_dif * z2_div
- zastar = debye_prof(3,lev) - zf_sq * (z1_den + z2_den)
- z1_prod = z34_dif * debye_prof(1,lev)
- z2_prod = z1_prod * z1_div
- z3_prod = z45_dif * debye_prof(2,lev)
- z4_prod = z3_prod * z2_div
- zbstar = -zf * (z2_prod + z4_prod)
- zbstar_sq = zbstar * zbstar
- za2star = zastar + 2.0_JPRB
- za2star_sq = za2star * za2star
- zdiv = za2star_sq + zbstar_sq
- zgstar = -3.0_JPRB * zbstar / zdiv
-
-
- ! Now compute Adjoint code
- !opticaldepth_ad(lev,j)= opticaldepth_ad(lev,j)
- zgstar_ad = opticaldepth_ad(lev,j) *&
- & (-1.5_JPRB * zf * predictors ( prof ) % clw(lev))
- predictors_ad ( prof ) % clw(lev) = predictors_ad ( prof ) % clw(lev) +&
- & opticaldepth_ad(lev,j) * (-1.5_JPRB * zf * zgstar)
-
- zbstar_ad = -3.0_JPRB * zgstar_ad / zdiv
- zdiv_ad = 3.0_JPRB * zgstar_ad * zbstar / (zdiv*zdiv)
- !zgstar_ad = 0.
-
- za2star_sq_ad = zdiv_ad
- zbstar_sq_ad = zdiv_ad
- !zdiv_ad = 0.
-
- za2star_ad = 2.0_JPRB * za2star * za2star_sq_ad
- !za2star_sq_ad = 0.
-
- zastar_ad = za2star_ad
- !za2star_ad = 0.
-
- zbstar_ad = zbstar_ad + 2.0_JPRB * zbstar * zbstar_sq_ad
- !zbstar_sq_ad = 0.
-
- z2_prod_ad = -zf * zbstar_ad
- z4_prod_ad = -zf * zbstar_ad
- !zbstar_ad = 0.
-
- z3_prod_ad = z2_div * z4_prod_ad
- z2_div_ad = z3_prod * z4_prod_ad
- !z4_prod_ad = 0.
-
- z45_dif_ad = debye_prof(2,lev) * z3_prod_ad
- debye_prof_ad(2,lev) = debye_prof_ad(2,lev) + z45_dif* z3_prod_ad
- !z3_prod_ad = 0.
-
- z1_prod_ad = z1_div * z2_prod_ad
- z1_div_ad = z1_prod * z2_prod_ad
- !z2_prod_ad = 0.
-
- z34_dif_ad = debye_prof(1,lev) * z1_prod_ad
- debye_prof_ad(1,lev) = debye_prof_ad(1,lev) + z34_dif * z1_prod_ad
- !z1_prod_ad = 0.
-
- debye_prof_ad(3,lev) = debye_prof_ad(3,lev) + zastar_ad
- z1_den_ad = -zf_sq * zastar_ad
- z2_den_ad = -zf_sq * zastar_ad
- !zastar_ad = 0.
-
- z2_div_ad = z2_div_ad + z45_dif * z2_den_ad
- z45_dif_ad = z45_dif_ad + z2_div * z2_den_ad
- !z2_den_ad = 0.
-
- z1_div_ad = z1_div_ad + z34_dif * z1_den_ad
- z34_dif_ad = z34_dif_ad + z1_div * z1_den_ad
- !z1_den_ad = 0.
-
- z2f_sq_z2_sq_ad = -z2_div_ad / (z2f_sq_z2_sq * z2f_sq_z2_sq)
- !z2_div_ad = 0.
-
- z1f_sq_z1_sq_ad = -z1_div_ad / (z1f_sq_z1_sq * z1f_sq_z1_sq)
- !z1_div_ad = 0.
-
- z2_sq_ad = z2f_sq_z2_sq_ad
- !z2f_sq_z2_sq_ad = 0.
-
- z1_sq_ad = z1f_sq_z1_sq_ad
- !z1f_sq_z1_sq_ad = 0.
-
- debye_prof_ad(4,lev) = debye_prof_ad(4,lev) + z45_dif_ad
- debye_prof_ad(5,lev) = debye_prof_ad(5,lev) - z45_dif_ad
- !z45_dif_ad = 0.
-
- debye_prof_ad(3,lev) = debye_prof_ad(3,lev) + z34_dif_ad
- debye_prof_ad(4,lev) = debye_prof_ad(4,lev) - z34_dif_ad
- !z34_dif_ad = 0.
-
- debye_prof_ad(2,lev) = debye_prof_ad(2,lev) + z2_sq_ad *&
- & 2.0_JPRB * debye_prof(2,lev)
- !z2_sq_ad = 0.
-
- debye_prof_ad(1,lev) = debye_prof_ad(1,lev) + z1_sq_ad *&
- & 2.0_JPRB * debye_prof(1,lev)
- !z1_sq_ad = 0.
-
- End Do
- Endif
- End Do
- End If
- !-----------
- !1.5 add CO2
- !-----------
-
- If ( coef%nco2 > 0 ) Then
- Do j = 1, nfrequencies
- chan = channels(j)
- prof = lprofiles(j)
- Do lev=nlevels, 1, -1
-
- predictors_ad( prof ) % co2(:,lev) =&
- & predictors_ad( prof ) % co2(:,lev) +&
- & coef%co2(lev,chan,:) * opticaldepth_ad(lev,j)
-
- End Do
- End Do
- End If
-
- !------------------------------
- !1.4 add Water Vapour Continuum
- !------------------------------
-
- If ( coef%nwvcont > 0 ) Then
- Do j = 1, nfrequencies
- chan = channels(j)
- prof = lprofiles(j)
- Do lev=nlevels, 1, -1
-
- predictors_ad( prof ) % wvcont(:,lev) =&
- & predictors_ad( prof ) % wvcont(:,lev) +&
- & coef%wvcont(lev,chan,:) * opticaldepth_ad(lev,j)
-
- End Do
- End Do
- End If
-
- !-------------
- !1.3 add ozone
- !-------------
-
- If ( coef%nozone > 0 ) Then
- Do j = 1, nfrequencies
- chan = channels(j)
- prof = lprofiles(j)
- Do ii=1,coef%nozone
-!dir$ concurrent
- Do lev=nlevels, 1, -1
- predictors_ad( prof ) % ozone(ii,lev) =&
- & predictors_ad( prof ) % ozone(ii,lev) +&
- & coef%ozone(lev,chan,ii) * opticaldepth_ad(lev,j)
- End Do
- End Do
- End Do
- End If
-
- !--------------------
- !1.2 add water vapour
- !--------------------
-
- Do j = 1, nfrequencies
- chan = channels(j)
- prof = lprofiles(j)
- Do ii=1,coef%nwater
-!dir$ concurrent
- Do lev=nlevels, 1, -1
- predictors_ad( prof ) % watervapour(ii,lev) =&
- & predictors_ad( prof ) % watervapour(ii,lev) + &
- & coef%watervapour(lev,chan,ii) * opticaldepth_ad(lev,j)
- End Do
- End Do
- End Do
-
- !--------------------------
- !1.1 start with mixed gases
- !--------------------------
-
- Do j = 1, nfrequencies
- chan = channels(j)
- prof = lprofiles(j)
- Do ii=1,coef%nmixed
-!dir$ concurrent
- Do lev=nlevels, 1, -1
- predictors_ad( prof ) % mixedgas(ii,lev) =&
- & predictors_ad( prof ) % mixedgas(ii,lev) +&
- & coef%mixedgas(lev,chan,ii) * opticaldepth_ad(lev,j)
- End Do
- End Do
- End Do
-
-End Subroutine rttov_transmit_ad
diff --git a/src/LIB/RTTOV/src/rttov_transmit_ad.interface b/src/LIB/RTTOV/src/rttov_transmit_ad.interface
deleted file mode 100644
index 437c2896ba2b20fbdd9e23997bc719867913468b..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_transmit_ad.interface
+++ /dev/null
@@ -1,62 +0,0 @@
-Interface
-Subroutine rttov_transmit_ad( &
- nfrequencies, & ! in
- nchannels, & ! in
- nprofiles, & ! in
- nlevels, & ! in
- channels, & ! in
- polarisations, & ! in
- lprofiles, & ! in
- predictors, & ! in
- predictors_ad, & ! inout
- aux, & ! in
- aux_ad, & ! inout
- coef, & ! in
- od_layer, & ! in
- opdp_ref, & ! in
- transmission, & ! in
- transmission_ad ) ! inout
-
-! Adjoint variables
-! input transmission_ad % tau_surf and transmission_ad % tau_layer set inside integrate_ad
-!
-! input/output aux_ad
-!
-! output predictors_ad initialised inside rttov_ad (need input
-! intent for memory allocation in calling routine)
-!
-
- Use rttov_const, Only: &
- mwcldtop ,&
- sensor_id_mw
-
-
- Use rttov_types, Only : &
- rttov_coef ,&
- predictors_Type,&
- transmission_Type ,&
- profile_aux
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
- Integer(Kind=jpim), Intent(in) :: nfrequencies ! Number of output radiances
- Integer(Kind=jpim), Intent(in) :: nchannels
- Integer(Kind=jpim), Intent(in) :: nprofiles
- Integer(Kind=jpim), Intent(in) :: nlevels
- Integer(Kind=jpim), Intent(in) :: channels(nfrequencies)
- Integer(Kind=jpim), Intent(in) :: polarisations(nchannels,3)
- Integer(Kind=jpim), Intent(in) :: lprofiles(nfrequencies)
- Type(predictors_Type), Intent(in) :: predictors( nprofiles )
- Type(predictors_Type), Intent(inout) :: predictors_ad( nprofiles )
- Type(rttov_coef), Intent(in) :: coef
- Type(profile_aux), Intent(in) :: aux( nprofiles )
- Type(profile_aux), Intent(inout) :: aux_ad( nprofiles )
- Real(Kind=jprb), Intent(in) :: od_layer(nlevels,nchannels)
- Real(Kind=jprb), Intent(in) :: opdp_ref(nlevels,nfrequencies)
- Type(transmission_Type), Intent(in) :: transmission
- Type(transmission_Type), Intent(inout):: transmission_ad
-
-
-
-End Subroutine rttov_transmit_ad
-End Interface
diff --git a/src/LIB/RTTOV/src/rttov_transmit_k.F90 b/src/LIB/RTTOV/src/rttov_transmit_k.F90
deleted file mode 100644
index 12295a92c27238df883abd9fe33d48e5d37409d3..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_transmit_k.F90
+++ /dev/null
@@ -1,363 +0,0 @@
-Subroutine rttov_transmit_k( &
- & nfrequencies, &! in
- & nchannels, &! in
- & nprofiles, &! in
- & nlevels, &! in
- & polarisations, &! in
- & channels, &! in
- & lprofiles, &! in
- & predictors, &! in
- & predictors_k, &! inout
- & aux, &! in
- & aux_k, &! inout
- & coef, &! in
- & od_layer, &! in
- & opdp_ref, &! in
- & transmission, &! in
- & transmission_k ) ! inout
-
-! History:
-! Version Date Comment
-! ------- ---- -------
-! 1.0
-! 1.1 26/09/2003 Modified to allow for multiple polarisations (S English)
-! 1.2 29/03/2005 Add end of header comment (J. Cameron)
-
-! Adjoint variables
-! input transmission_k% tau_surf and transmission_k% tau_layer set inside integrate_k
-!
-! input/output aux_k
-!
-! output predictors_k initialised inside rttov_k (need input
-! intent for memory allocation in calling routine)
-!
-
- Use rttov_const, Only: &
- & mwcldtop ,&
- & sensor_id_mw
-
-
- Use rttov_types, Only : &
- & rttov_coef ,&
- & predictors_Type,&
- & transmission_Type ,&
- & profile_aux
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
- !subroutine arguments:
- Integer(Kind=jpim), Intent(in) :: nfrequencies
- Integer(Kind=jpim), Intent(in) :: nchannels
- Integer(Kind=jpim), Intent(in) :: nprofiles
- Integer(Kind=jpim), Intent(in) :: nlevels
- Integer(Kind=jpim), Intent(in) :: channels(nfrequencies)
- Integer(Kind=jpim), Intent(in) :: polarisations(nchannels,3)
- Integer(Kind=jpim), Intent(in) :: lprofiles(nfrequencies)
- Type(predictors_Type), Intent(in) :: predictors( nprofiles )
- Type(predictors_Type), Intent(inout) :: predictors_k( nchannels )
- Type(rttov_coef), Intent(in) :: coef
- Type(profile_aux), Intent(in) :: aux( nprofiles )
- Type(profile_aux), Intent(inout) :: aux_k( nchannels )
- Real(Kind=jprb), Intent(in) :: od_layer(nlevels,nchannels)
- Real(Kind=jprb), Intent(in) :: opdp_ref(nlevels,nfrequencies)
- Type(transmission_Type),Intent(in) :: transmission
- Type(transmission_Type),Intent(inout):: transmission_k
-
-
-
- !local variables:
- Real(Kind=jprb) :: od_layer_k(nlevels,nchannels)
- Real(Kind=jprb) :: opticaldepth_k(nlevels,nchannels)
- Real(Kind=jprb) :: od_surf_k(nchannels)
- Real(Kind=jprb) :: opdp_ref_chan(nlevels,nchannels)
- Real(Kind=jprb), Pointer :: debye_prof(:,:)
- Real(Kind=jprb), Pointer :: debye_prof_k(:,:)
- Integer(Kind=jpim) :: lev,chan,j,freq
- Integer(Kind=jpim) :: prof, kpol
-
-
- ! cloud liquid water local variables
- Real(Kind=jprb) :: zf, zf_sq, z34_dif, z45_dif, z1_sq, z2_sq, z1_div, z2_div
- Real(Kind=jprb) :: z1_den, z2_den, zastar, z1_prod, z2_prod, z3_prod, z4_prod
- Real(Kind=jprb) :: zbstar, zbstar_sq, za2star, za2star_sq, zdiv, zgstar
- Real(Kind=jprb) :: z1f_sq_z1_sq, z2f_sq_z2_sq
-
- Real(Kind=jprb) :: z34_dif_k, z45_dif_k, z1_sq_k, z2_sq_k, z1_div_k, z2_div_k
- Real(Kind=jprb) :: z1_den_k, z2_den_k, zastar_k, z1_prod_k, z2_prod_k, z3_prod_k, z4_prod_k
- Real(Kind=jprb) :: zbstar_k, zbstar_sq_k, za2star_k, za2star_sq_k, zdiv_k, zgstar_k
- Real(Kind=jprb) :: z1f_sq_z1_sq_k, z2f_sq_z2_sq_k
-
-!- End of header --------------------------------------------------------
-
- od_layer_k(:,:) = 0._JPRB
- opticaldepth_k(:,:) = 0._JPRB
-
- !-----------------------------------------------------
- !4. Compute optical depth and transmittance at surface
- !-----------------------------------------------------
-
- od_surf_k(:) = 0.0_JPRB
- od_surf_k(:) = transmission % tau_surf(:) * transmission_k% tau_surf(:)
- Do j = 1, nchannels
- freq=polarisations(j,2)
- prof = lprofiles(freq)
- od_layer_k(aux(prof) % nearestlev_surf,j) = od_layer_k(aux(prof) % nearestlev_surf,j) +&
- & od_surf_k(j) * (1._JPRB - aux(prof) % pfraction_surf )
- od_layer_k(aux(prof) % nearestlev_surf-1,j) = od_layer_k(aux(prof) % nearestlev_surf-1,j) +&
- & od_surf_k(j) * aux(prof) % pfraction_surf
- aux_k(j) % pfraction_surf = aux_k(j) % pfraction_surf + od_surf_k(j) *&
- & ( od_layer(aux(prof) % nearestlev_surf-1,j) - &
- & od_layer(aux(prof) % nearestlev_surf ,j) )
- od_surf_k(j) = 0._JPRB
- opdp_ref_chan(:,j)=opdp_ref(:, freq)
- End Do
-
- !-------------------------------------------
- !3. Convert optical depths to transmittances
- !-------------------------------------------
-
- od_layer_k(:,:) = od_layer_k(:,:) + transmission_k% tau_layer(:,:) * transmission % tau_layer(:,:)
- !transmission_k% tau_layer(:,:) = 0.
-
- !----------------------------------------
- !2. Compute layer to space optical depths
- !----------------------------------------
- ! notes: apply gamma correction; check value is sensible and constrain
- ! if necessary.
-
- Do lev = nlevels, 2, -1
- od_layer_k(lev-1,:) = od_layer_k(lev-1,:) + od_layer_k(lev,:)
- opticaldepth_k(lev,:) = opticaldepth_k(lev,:) + od_layer_k(lev,:)
- od_layer_k(lev,:) = 0._JPRB
- End Do
-
- opticaldepth_k(1,:) = opticaldepth_k(1,:) + od_layer_k(1,:)
-
- opticaldepth_k(:,:) = opticaldepth_k(:,:) - transmission_k % od_singlelayer(:,:)
- transmission_k % od_singlelayer(:,:) = 0._JPRB
- Do j = 1, nchannels
- freq=polarisations(j,2)
- chan = channels(freq)
- opticaldepth_k(:,j) = coef%ff_gam(chan) * opticaldepth_k(:,j)
- End Do
-
- ! note that optical depth in the calculations is negative
- Where( opdp_ref_chan(:,:) > 0.0_JPRB )
- opticaldepth_k = 0.0_JPRB
- End Where
-
- !--------------------
- !1.6 add liquid water (MW only)
- !--------------------
- If ( coef % id_sensor == sensor_id_mw ) Then
- Do j = 1, nchannels
- freq = polarisations(j,2)
- chan = channels(freq)
- prof = lprofiles(freq)
- debye_prof => aux(prof) % debye_prof
- debye_prof_k => aux_k(j) % debye_prof
- If( predictors(prof) % ncloud >= 1 ) Then
- Do lev = mwcldtop, nlevels
-
- ! Repeat direct code
- zf = coef % frequency_ghz(chan)
- zf_sq = zf*zf
- z1_sq = debye_prof(1,lev) * debye_prof(1,lev)
- z2_sq = debye_prof(2,lev) * debye_prof(2,lev)
- z34_dif = debye_prof(3,lev) - debye_prof(4,lev)
- z45_dif = debye_prof(4,lev) - debye_prof(5,lev)
- z1f_sq_z1_sq = zf_sq + z1_sq
- z2f_sq_z2_sq = zf_sq + z2_sq
- z1_div = 1.0_JPRB / z1f_sq_z1_sq
- z2_div = 1.0_JPRB / z2f_sq_z2_sq
- z1_den = z34_dif * z1_div
- z2_den = z45_dif * z2_div
- zastar = debye_prof(3,lev) - zf_sq * (z1_den + z2_den)
- z1_prod = z34_dif * debye_prof(1,lev)
- z2_prod = z1_prod * z1_div
- z3_prod = z45_dif * debye_prof(2,lev)
- z4_prod = z3_prod * z2_div
- zbstar = -zf * (z2_prod + z4_prod)
- zbstar_sq = zbstar * zbstar
- za2star = zastar + 2.0_JPRB
- za2star_sq = za2star * za2star
- zdiv = za2star_sq + zbstar_sq
- zgstar = -3.0_JPRB * zbstar / zdiv
-
-
- ! Now compute Adjoint code
- !opticaldepth_k(lev,j)= opticaldepth_k(lev,j)
- zgstar_k = opticaldepth_k(lev,j) *&
- & (-1.5_JPRB * zf * predictors ( prof ) % clw(lev))
- predictors_k ( j ) % clw(lev) = predictors_k ( j ) % clw(lev) +&
- & opticaldepth_k(lev,j) * (-1.5_JPRB * zf * zgstar)
-
- zbstar_k = -3.0_JPRB * zgstar_k / zdiv
- zdiv_k = 3.0_JPRB * zgstar_k * zbstar / (zdiv*zdiv)
- !zgstar_k = 0.
-
- za2star_sq_k = zdiv_k
- zbstar_sq_k = zdiv_k
- !zdiv_k = 0.
-
- za2star_k = 2.0_JPRB * za2star * za2star_sq_k
- !za2star_sq_k = 0.
-
- zastar_k = za2star_k
- !za2star_k = 0.
-
- zbstar_k = zbstar_k + 2.0_JPRB * zbstar * zbstar_sq_k
- !zbstar_sq_k = 0.
-
- z2_prod_k = -zf * zbstar_k
- z4_prod_k = -zf * zbstar_k
- !zbstar_k = 0.
-
- z3_prod_k = z2_div * z4_prod_k
- z2_div_k = z3_prod * z4_prod_k
- !z4_prod_k = 0.
-
- z45_dif_k = debye_prof(2,lev) * z3_prod_k
- debye_prof_k(2,lev) = debye_prof_k(2,lev) + z45_dif* z3_prod_k
- !z3_prod_k = 0.
-
- z1_prod_k = z1_div * z2_prod_k
- z1_div_k = z1_prod * z2_prod_k
- !z2_prod_k = 0.
-
- z34_dif_k = debye_prof(1,lev) * z1_prod_k
- debye_prof_k(1,lev) = debye_prof_k(1,lev) + z34_dif * z1_prod_k
- !z1_prod_k = 0.
-
- debye_prof_k(3,lev) = debye_prof_k(3,lev) + zastar_k
- z1_den_k = -zf_sq * zastar_k
- z2_den_k = -zf_sq * zastar_k
- !zastar_k = 0.
-
- z2_div_k = z2_div_k + z45_dif * z2_den_k
- z45_dif_k = z45_dif_k + z2_div * z2_den_k
- !z2_den_k = 0.
-
- z1_div_k = z1_div_k + z34_dif * z1_den_k
- z34_dif_k = z34_dif_k + z1_div * z1_den_k
- !z1_den_k = 0.
-
- z2f_sq_z2_sq_k = -z2_div_k / (z2f_sq_z2_sq * z2f_sq_z2_sq)
- !z2_div_k = 0.
-
- z1f_sq_z1_sq_k = -z1_div_k / (z1f_sq_z1_sq * z1f_sq_z1_sq)
- !z1_div_k = 0.
-
- z2_sq_k = z2f_sq_z2_sq_k
- !z2f_sq_z2_sq_k = 0.
-
- z1_sq_k = z1f_sq_z1_sq_k
- !z1f_sq_z1_sq_k = 0.
-
- debye_prof_k(4,lev) = debye_prof_k(4,lev) + z45_dif_k
- debye_prof_k(5,lev) = debye_prof_k(5,lev) - z45_dif_k
- !z45_dif_k = 0.
-
- debye_prof_k(3,lev) = debye_prof_k(3,lev) + z34_dif_k
- debye_prof_k(4,lev) = debye_prof_k(4,lev) - z34_dif_k
- !z34_dif_k = 0.
-
- debye_prof_k(2,lev) = debye_prof_k(2,lev) + z2_sq_k *&
- & 2.0_JPRB * debye_prof(2,lev)
- !z2_sq_k = 0.
-
- debye_prof_k(1,lev) = debye_prof_k(1,lev) + z1_sq_k *&
- & 2.0_JPRB * debye_prof(1,lev)
- !z1_sq_k = 0.
-
- End Do
- Endif
- End Do
- End If
-
- !-----------
- !1.5 add CO2
- !-----------
-
- If ( coef%nco2 > 0 ) Then
- Do j = 1, nchannels
- freq=polarisations(j,2)
- chan = channels(freq)
- Do lev=nlevels, 1, -1
-
- predictors_k( j ) % co2(:,lev) =&
- & predictors_k( j ) % co2(:,lev) +&
- & coef%co2(lev,chan,:) * opticaldepth_k(lev,j)
-
- End Do
- End Do
- End If
-
- !------------------------------
- !1.4 add Water Vapour Continuum
- !------------------------------
-
- If ( coef%nwvcont > 0 ) Then
- Do j = 1, nchannels
- freq=polarisations(j,2)
- chan = channels(freq)
- Do lev=nlevels, 1, -1
-
- predictors_k( j ) % wvcont(:,lev) =&
- & predictors_k( j ) % wvcont(:,lev) +&
- & coef%wvcont(lev,chan,:) * opticaldepth_k(lev,j)
-
- End Do
- End Do
- End If
-
- !-------------
- !1.3 add ozone
- !-------------
-
- If ( coef%nozone > 0 ) Then
- Do j = 1, nchannels
- freq=polarisations(j,2)
- chan = channels(freq)
- Do lev=nlevels, 1, -1
-
- predictors_k( j ) % ozone(:,lev) =&
- & predictors_k( j ) % ozone(:,lev) +&
- & coef%ozone(lev,chan,:) * opticaldepth_k(lev,j)
-
- End Do
- End Do
- End If
-
- !--------------------
- !1.2 add water vapour
- !--------------------
-
- Do j = 1, nchannels
- freq=polarisations(j,2)
- chan = channels(freq)
- Do lev=nlevels, 1, -1
-
- predictors_k( j ) % watervapour(:,lev) =&
- & predictors_k( j ) % watervapour(:,lev) + &
- & coef%watervapour(lev,chan,:) * opticaldepth_k(lev,j)
- End Do
- End Do
-
- !--------------------------
- !1.1 start with mixed gases
- !--------------------------
-
- Do j = 1, nchannels
- freq=polarisations(j,2)
- chan = channels(freq)
- Do lev=nlevels, 1, -1
-
- predictors_k( j ) % mixedgas(:,lev) =&
- & predictors_k( j ) % mixedgas(:,lev) +&
- & coef%mixedgas(lev,chan,:) * opticaldepth_k(lev,j)
- End Do
- End Do
-
-End Subroutine rttov_transmit_k
diff --git a/src/LIB/RTTOV/src/rttov_transmit_k.interface b/src/LIB/RTTOV/src/rttov_transmit_k.interface
deleted file mode 100644
index bb70558ba55cff58ae024e64cc418b54e15fcdb7..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_transmit_k.interface
+++ /dev/null
@@ -1,63 +0,0 @@
-Interface
-Subroutine rttov_transmit_k( &
- nfrequencies, & ! in
- nchannels, & ! in
- nprofiles, & ! in
- nlevels, & ! in
- channels, & ! in
- polarisations, & ! in
- lprofiles, & ! in
- predictors, & ! in
- predictors_k, & ! inout
- aux, & ! in
- aux_k, & ! inout
- coef, & ! in
- od_layer, & ! in
- opdp_ref, & ! in
- transmission, & ! in
- transmission_k ) ! inout
-
-! Adjoint variables
-! input transmission_k% tau_surf and transmission_k% tau_layer set inside integrate_k
-!
-! input/output aux_k
-!
-! output predictors_k initialised inside rttov_k (need input
-! intent for memory allocation in calling routine)
-!
-
- Use rttov_const, Only: &
- mwcldtop ,&
- sensor_id_mw
-
-
- Use rttov_types, Only : &
- rttov_coef ,&
- predictors_Type,&
- transmission_Type ,&
- profile_aux
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
- Integer(Kind=jpim), Intent(in) :: nfrequencies ! Number of output radiances
- Integer(Kind=jpim), Intent(in) :: nchannels
- Integer(Kind=jpim), Intent(in) :: nprofiles
- Integer(Kind=jpim), Intent(in) :: nlevels
- Integer(Kind=jpim), Intent(in) :: channels(nfrequencies)
- Integer(Kind=jpim), Intent(in) :: polarisations(nchannels,3)
- Integer(Kind=jpim), Intent(in) :: lprofiles(nfrequencies)
- Type(predictors_Type), Intent(in) :: predictors( nprofiles )
- Type(predictors_Type), Intent(inout) :: predictors_k( nfrequencies )
- Type(rttov_coef), Intent(in) :: coef
- Type(profile_aux), Intent(in) :: aux( nprofiles )
- Type(profile_aux), Intent(inout) :: aux_k( nfrequencies )
- Real(Kind=jprb), Intent(in) :: od_layer(nlevels,nchannels)
- Real(Kind=jprb), Intent(in) :: opdp_ref(nlevels,nfrequencies)
- Type(transmission_Type), Intent(in) :: transmission
- Type(transmission_Type), Intent(inout) :: transmission_k
-
-
-
-End Subroutine rttov_transmit_k
-End Interface
diff --git a/src/LIB/RTTOV/src/rttov_transmit_tl.F90 b/src/LIB/RTTOV/src/rttov_transmit_tl.F90
deleted file mode 100644
index 902f8d8ca264446d357466383be73d7d928f3306..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_transmit_tl.F90
+++ /dev/null
@@ -1,356 +0,0 @@
-Subroutine rttov_transmit_tl( &
- & nfrequencies, &! in
- & nchannels, &! in
- & nprofiles, &! in
- & nlevels, &! in
- & channels, &! in
- & polarisations, &! in
- & lprofiles, &! in
- & predictors, &! in
- & predictors_tl, &! in
- & aux, &! in
- & aux_tl, &! in
- & coef, &! in
- & od_layer, &! in
- & opdp_ref, &! in
- & transmission, &! in
- & transmission_tl ) ! inout
- ! Description:
- ! Tangent linear of rttov_transmit
- ! To calculate optical depths for a number of channels
- ! and profiles from every pressure level to space.
- ! To interpolate optical depths on to levels of radiative transfer model
- ! (which, at present, entails only surface transmittance, as
- ! other optical depths are on *rt* levels) and to convert
- ! optical depths to transmittances.
- !
- ! Code based on OPDEPTL and RTTAUTL from previous versions of RTTOV
- ! Only one profile per call
- !
- ! Copyright:
- ! This software was developed within the context of
- ! the EUMETSAT Satellite Application Facility on
- ! Numerical Weather Prediction (NWP SAF), under the
- ! Cooperation Agreement dated 25 November 1998, between
- ! EUMETSAT and the Met Office, UK, by one or more partners
- ! within the NWP SAF. The partners in the NWP SAF are
- ! the Met Office, ECMWF, KNMI and MeteoFrance.
- !
- ! Copyright 2002, EUMETSAT, All Rights Reserved.
- !
- ! Method:
- !
- ! Current Code Owner: SAF NWP
- !
- ! History:
- ! Version Date Comment
- ! ------- ---- -------
- ! 1.0 01/12/2002 New F90 code with structures (P Brunel A Smith)
- ! 1.1 29/01/2003 Add WV Continuum and CO2 capability (P Brunel)
- ! 1.2 04/12/2003 Optimisation (J Hague and D Salmond ECMWF)
- ! 1.3 26/09/2003 Modified to allow for multiple polarisations (S English)
- ! 1.4 28/02/2005 Improved vectorisation (D Dent)
- !
- ! Code Description:
- ! Language: Fortran 90.
- ! Software Standards: "European Standards for Writing and
- ! Documenting Exchangeable Fortran 90 Code".
- !
- ! Declarations:
- ! Modules used:
-
- ! Imported Parameters:
-
- Use rttov_const, Only: &
- & mwcldtop ,&
- & sensor_id_mw
-
-
- Use rttov_types, Only : &
- & rttov_coef ,&
- & predictors_Type,&
- & transmission_Type ,&
- & profile_aux
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
- !subroutine arguments:
- Integer(Kind=jpim), Intent(in) :: nfrequencies
- Integer(Kind=jpim), Intent(in) :: nchannels
- Integer(Kind=jpim), Intent(in) :: nprofiles
- Integer(Kind=jpim), Intent(in) :: channels(nfrequencies)
- Integer(Kind=jpim), Intent(in) :: polarisations(nchannels,3)
- Integer(Kind=jpim), Intent(in) :: nlevels
- Integer(Kind=jpim), Intent(in) :: lprofiles(nfrequencies)
- Type(predictors_Type), Intent(in) :: predictors( nprofiles )
- Type(predictors_Type), Intent(in) :: predictors_tl( nprofiles )
- Type(rttov_coef) , Intent(in) :: coef
- Type(profile_aux) , Intent(in) :: aux( nprofiles )
- Type(profile_aux) , Intent(in) :: aux_tl( nprofiles )
- Real(Kind=jprb), Intent(in) :: od_layer(nlevels,nchannels)
- Real(Kind=jprb), Intent(in) :: opdp_ref(nlevels,nfrequencies)
- Type(transmission_Type),Intent(in) :: transmission
- Type(transmission_Type),Intent(inout):: transmission_tl
-
-
- !local variables:
- Real(Kind=jprb) :: od_layer_tl(nlevels,nfrequencies)
- Real(Kind=jprb) :: opticaldepth_tl(nlevels,nfrequencies)
- Real(Kind=jprb) :: od_surf_tl(nfrequencies)
- Real(Kind=jprb) :: tau_surf_freq(nfrequencies) ! sat to surface transmission at each frequency
- Real(Kind=jprb) :: tau_layer_freq(nlevels,nfrequencies) ! sat to layer transmission at each frequency
- Real(Kind=jprb) :: tau_surf_freq_tl(nfrequencies) ! sat to surface transmission at each frequency
- Real(Kind=jprb) :: tau_layer_freq_tl(nlevels,nfrequencies) ! sat to layer transmission at each frequency
- Real(Kind=jprb) :: od_singlelayer_freq_tl(nlevels,nfrequencies)
-
- Real(Kind=jprb), Pointer :: debye_prof(:,:)
- Real(Kind=jprb), Pointer :: debye_prof_tl(:,:)
- Integer(Kind=jpim) :: lev,chan,j,freq,kpol
- Integer(Kind=jpim) :: prof
-
- ! cloud liquid water local variables
- Real(Kind=jprb) :: zf, zf_sq, z34_dif, z45_dif, z1_sq, z2_sq, z1_div, z2_div
- Real(Kind=jprb) :: z1_den, z2_den, zastar, z1_prod, z2_prod, z3_prod, z4_prod
- Real(Kind=jprb) :: zbstar, zbstar_sq, za2star, za2star_sq, zdiv, zgstar
- Real(Kind=jprb) :: z1f_sq_z1_sq, z2f_sq_z2_sq
-
- Real(Kind=jprb) :: z34_dif_tl, z45_dif_tl, z1_sq_tl, z2_sq_tl, z1_div_tl, z2_div_tl
- Real(Kind=jprb) :: z1_den_tl, z2_den_tl, zastar_tl, z1_prod_tl, z2_prod_tl, z3_prod_tl, z4_prod_tl
- Real(Kind=jprb) :: zbstar_tl, zbstar_sq_tl, za2star_tl, za2star_sq_tl, zdiv_tl, zgstar_tl
- Real(Kind=jprb) :: z1f_sq_z1_sq_tl, z2f_sq_z2_sq_tl
- Integer(Kind=jpim) :: ii
-
-!- End of header --------------------------------------------------------
-
- !-----------------------------------------
- !1. calculate layer gaseous optical depths
- !-----------------------------------------
-
- !--------------------------
- !1.1 start with mixed gases
- !--------------------------
-
- Do j = 1, nfrequencies
- chan = channels(j)
- prof = lprofiles(j)
- Do lev=1,nlevels
- opticaldepth_tl(lev,j)=0
- End Do
- Do ii=2,coef % nmixed
- Do lev=1,nlevels
- opticaldepth_tl(lev,j)= opticaldepth_tl(lev,j) + &
- & coef%mixedgas(lev,chan,ii) * predictors_tl( prof ) % mixedgas(ii,lev)
- End Do
- End Do
- End Do
-
- !--------------------
- !1.2 add water vapour
- !--------------------
-
- Do j = 1, nfrequencies
- chan = channels(j)
- prof = lprofiles(j)
- Do ii=1,coef % nwater
- Do lev=1,nlevels
- opticaldepth_tl(lev,j)= opticaldepth_tl(lev,j) + &
- & coef%watervapour(lev,chan,ii) * predictors_tl( prof ) % watervapour(ii,lev)
- End Do
- End Do
- End Do
-
- !-------------
- !1.3 add ozone
- !-------------
-
- If ( coef%nozone > 0 ) Then
- Do j = 1, nfrequencies
- chan = channels(j)
- prof = lprofiles(j)
- Do ii=1,coef % nozone
- Do lev=1,nlevels
- opticaldepth_tl(lev,j)= opticaldepth_tl(lev,j) + &
- & coef%ozone(lev,chan,ii) * predictors_tl( prof ) % ozone(ii,lev)
- End Do
- End Do
- End Do
- End If
-
- !------------------------------
- !1.4 add Water Vapour Continuum
- !------------------------------
-
- If ( coef%nwvcont > 0 ) Then
- Do j = 1, nfrequencies
- chan = channels(j)
- prof = lprofiles(j)
- Do ii=1,coef % nwvcont
- Do lev=1,nlevels
- opticaldepth_tl(lev,j)= opticaldepth_tl(lev,j) + &
- & coef%wvcont(lev,chan,ii) * predictors_tl( prof ) % wvcont(ii,lev)
- End Do
- End Do
- End Do
- End If
-
- !-----------
- !1.5 add CO2
- !-----------
-
- If ( coef%nco2 > 0 ) Then
- Do j = 1, nfrequencies
- chan = channels(j)
- prof = lprofiles(j)
- Do ii=1,coef % nco2
- Do lev=1,nlevels
- opticaldepth_tl(lev,j)= opticaldepth_tl(lev,j) + &
- & coef%co2(lev,chan,ii) * predictors_tl( prof ) % co2(ii,lev)
- End Do
- End Do
- End Do
- End If
-
- !--------------------
- !1.6 add liquid water (MW only)
- !--------------------
- If ( coef % id_sensor == sensor_id_mw ) Then
- Do j = 1, nfrequencies
- chan = channels(j)
- prof = lprofiles(j)
- debye_prof => aux(prof) % debye_prof
- debye_prof_tl => aux_tl(prof) % debye_prof
- If( predictors(prof) % ncloud >= 1 ) Then
- Do lev = mwcldtop, nlevels
-
- ! Repeat direct code
- zf = coef % frequency_ghz(chan)
- zf_sq = zf*zf
- z1_sq = debye_prof(1,lev) * debye_prof(1,lev)
- z2_sq = debye_prof(2,lev) * debye_prof(2,lev)
- z34_dif = debye_prof(3,lev) - debye_prof(4,lev)
- z45_dif = debye_prof(4,lev) - debye_prof(5,lev)
- z1f_sq_z1_sq = zf_sq + z1_sq
- z2f_sq_z2_sq = zf_sq + z2_sq
- z1_div = 1.0_JPRB / z1f_sq_z1_sq
- z2_div = 1.0_JPRB / z2f_sq_z2_sq
- z1_den = z34_dif * z1_div
- z2_den = z45_dif * z2_div
- zastar = debye_prof(3,lev) - zf_sq * (z1_den + z2_den)
- z1_prod = z34_dif * debye_prof(1,lev)
- z2_prod = z1_prod * z1_div
- z3_prod = z45_dif * debye_prof(2,lev)
- z4_prod = z3_prod * z2_div
- zbstar = -zf * (z2_prod + z4_prod)
- zbstar_sq = zbstar * zbstar
- za2star = zastar + 2.0_JPRB
- za2star_sq = za2star * za2star
- zdiv = za2star_sq + zbstar_sq
- zgstar = -3.0_JPRB * zbstar / zdiv
-
-
- ! Now compute tangent-linear code
- !zf_tl = 0
- !zf_sq_tl = 0
- z1_sq_tl = 2.0_JPRB * debye_prof(1,lev) * debye_prof_tl(1,lev)
- z2_sq_tl = 2.0_JPRB * debye_prof(2,lev) * debye_prof_tl(2,lev)
- z34_dif_tl = debye_prof_tl(3,lev) - debye_prof_tl(4,lev)
- z45_dif_tl = debye_prof_tl(4,lev) - debye_prof_tl(5,lev)
- z1f_sq_z1_sq_tl = z1_sq_tl
- z2f_sq_z2_sq_tl = z2_sq_tl
- z1_div_tl = -z1f_sq_z1_sq_tl / (z1f_sq_z1_sq * z1f_sq_z1_sq)
- z2_div_tl = -z2f_sq_z2_sq_tl / (z2f_sq_z2_sq * z2f_sq_z2_sq)
- z1_den_tl = z34_dif * z1_div_tl + z34_dif_tl * z1_div
- z2_den_tl = z45_dif * z2_div_tl + z45_dif_tl * z2_div
- zastar_tl = debye_prof_tl(3,lev) - zf_sq * (z1_den_tl + z2_den_tl)
-
- z1_prod_tl = z34_dif_tl * debye_prof(1,lev)&
- & + z34_dif*debye_prof_tl(1,lev)
- z2_prod_tl = z1_prod_tl * z1_div + z1_prod * z1_div_tl
- z3_prod_tl = z45_dif_tl * debye_prof(2,lev)&
- & + z45_dif * debye_prof_tl(2,lev)
- z4_prod_tl = z3_prod_tl * z2_div + z3_prod * z2_div_tl
- zbstar_tl = -zf * (z2_prod_tl + z4_prod_tl)
- zbstar_sq_tl = 2.0_JPRB * zbstar * zbstar_tl
- za2star_tl = zastar_tl
- za2star_sq_tl = 2.0_JPRB * za2star * za2star_tl
- zdiv_tl = za2star_sq_tl + zbstar_sq_tl
- zgstar_tl = -3.0_JPRB*(zbstar_tl * zdiv - zbstar * zdiv_tl) / (zdiv * zdiv)
-
- opticaldepth_tl(lev,j)= opticaldepth_tl(lev,j) &
- & - 1.5_JPRB * zf * ( zgstar_tl * predictors ( prof ) % clw(lev) + &
- & zgstar * predictors_tl ( prof ) % clw(lev) )
-
- End Do
- Endif
- End Do
- End If
-
-
- !----------------------------------------
- !2. Compute layer to space optical depths
- !----------------------------------------
- ! notes: apply gamma correction; check value is sensible and constrain
- ! if necessary.
-
- ! note that optical depth in the calculations is negative
- Where( opdp_ref(:,:) > 0.0_JPRB )
- opticaldepth_tl = 0.0_JPRB
- End Where
-
-
- Do j = 1, nchannels
- freq = polarisations(j,2) ! Frequency index
- kpol = 1 + j - polarisations(freq,1) ! Polarisation index
- prof = lprofiles(freq) ! Profile index
- If (kpol <= 2) Then
- tau_layer_freq(:,freq) = transmission % tau_layer(:,j)
- tau_surf_freq(freq) = transmission % tau_surf(j)
- End If
- End Do
-
- Do j = 1, nfrequencies
- chan = channels(j)
- opticaldepth_tl(:,j) = coef%ff_gam(chan) * opticaldepth_tl(:,j)
- End Do
- od_singlelayer_freq_tl(:,:) = - opticaldepth_tl(:,:)
- od_layer_tl(1,:) = opticaldepth_tl(1,:)
- Do lev = 2, nlevels
- od_layer_tl(lev,:) = od_layer_tl(lev-1,:) + opticaldepth_tl(lev,:)
- End Do
-
- !-------------------------------------------
- !3. Convert optical depths to transmittances
- !-------------------------------------------
- tau_layer_freq_tl(:,:) = od_layer_tl(:,:) * tau_layer_freq(:,:)
-
- !-----------------------------------------------------
- !4. Compute optical depth and transmittance at surface
- !-----------------------------------------------------
-
- Do j = 1, nfrequencies
- prof = lprofiles(j)
- chan = polarisations(j, 1)
- od_surf_tl(j) = od_layer_tl(aux(prof) % nearestlev_surf,j) &
- & + aux_tl(prof) % pfraction_surf * &
- & ( od_layer(aux(prof) % nearestlev_surf-1,chan) - &
- & od_layer(aux(prof) % nearestlev_surf ,chan) ) &
- & + aux(prof) % pfraction_surf * &
- & ( od_layer_tl(aux(prof) % nearestlev_surf-1,j) - &
- & od_layer_tl(aux(prof) % nearestlev_surf ,j) )
- End Do
- tau_surf_freq_tl(:) = od_surf_tl(:) * tau_surf_freq(:)
-
- !-----------------------------------------------------
- !5. Store transmittances for other polarisations
- !-----------------------------------------------------
-
- Do j = 1, nchannels
- freq = polarisations(j,2)
- transmission_tl % tau_layer(:,j) = tau_layer_freq_tl(:,freq)
- transmission_tl % od_singlelayer(:,j) = od_singlelayer_freq_tl(:,freq)
- transmission_tl % tau_surf(j) = tau_surf_freq_tl(freq)
- End Do
-
-End Subroutine rttov_transmit_tl
-
diff --git a/src/LIB/RTTOV/src/rttov_transmit_tl.interface b/src/LIB/RTTOV/src/rttov_transmit_tl.interface
deleted file mode 100644
index 69b90c1e3995bb965575d4d847a50ee2523061f6..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_transmit_tl.interface
+++ /dev/null
@@ -1,51 +0,0 @@
-Interface
-Subroutine rttov_transmit_tl( &
- nfrequencies, & ! in
- nchannels, & ! in
- nprofiles, & ! in
- nlevels, & ! in
- channels, & ! in
- polarisations, & ! in
- lprofiles, & ! in
- predictors, & ! in
- predictors_tl, & ! in
- aux, & ! in
- aux_tl, & ! in
- coef, & ! in
- od_layer, & ! in
- opdp_ref, & ! in
- transmission, & ! in
- transmission_tl ) ! inout
-
- Use rttov_const, Only: &
- mwcldtop ,&
- sensor_id_mw
-
-
- Use rttov_types, Only : &
- rttov_coef ,&
- predictors_Type,&
- transmission_Type ,&
- profile_aux
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
- Integer(Kind=jpim), Intent(in) :: nfrequencies
- Integer(Kind=jpim), Intent(in) :: nchannels
- Integer(Kind=jpim), Intent(in) :: nprofiles
- Integer(Kind=jpim), Intent(in) :: nlevels
- Integer(Kind=jpim), Intent(in) :: channels(nfrequencies)
- Integer(Kind=jpim), Intent(in) :: polarisations(nchannels,3)
- Integer(Kind=jpim), Intent(in) :: lprofiles(nfrequencies)
- Type(predictors_Type), Intent(in) :: predictors( nprofiles )
- Type(predictors_Type), Intent(in) :: predictors_tl( nprofiles )
- Type(rttov_coef), Intent(in) :: coef
- Type(profile_aux), Intent(in) :: aux( nprofiles )
- Type(profile_aux), Intent(in) :: aux_tl( nprofiles )
- Real(Kind=jprb), Intent(in) :: od_layer(nlevels,nchannels)
- Real(Kind=jprb), Intent(in) :: opdp_ref(nlevels,nfrequencies)
- Type(transmission_Type), Intent(in) :: transmission
- Type(transmission_Type), Intent(inout) :: transmission_tl
-
-End Subroutine rttov_transmit_tl
-End Interface
diff --git a/src/LIB/RTTOV/src/rttov_types.F90 b/src/LIB/RTTOV/src/rttov_types.F90
deleted file mode 100644
index d05a97cde62ecc98535d3e0deb4edabaaad2fc77..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_types.F90
+++ /dev/null
@@ -1,442 +0,0 @@
-!
-module rttov_types
- ! Description:
- ! defines all derived types for RTTOV
- !
- ! Copyright:
- ! This software was developed within the context of
- ! the EUMETSAT Satellite Application Facility on
- ! Numerical Weather Prediction (NWP SAF), under the
- ! Cooperation Agreement dated 25 November 1998, between
- ! EUMETSAT and the Met Office, UK, by one or more partners
- ! within the NWP SAF. The partners in the NWP SAF are
- ! the Met Office, ECMWF, KNMI and MeteoFrance.
- !
- ! Copyright 2002, EUMETSAT, All Rights Reserved.
- !
- ! Method:
- !
- ! Current Code Owner: SAF NWP
- !
- ! History:
- ! Version Date Comment
- ! ------- ---- -------
- ! 1.0 01/12/2002 New F90 code with structures (P Brunel A Smith)
- ! 1.1 29/01/2003 Add CO2 variable gaz to profile sturcture (P Brunel)
- ! Add rain and solid precip. to profile cloud structure
- ! 1.2 13/05/2003 Add structure for transmissions and optical depths (F Chevallier)
- ! 1.3 08/2003 Add scattering facility (F Chevallier)
- ! 1.4 18/09/2003 Add kice and kradip to profile_cloud_type (P Francis)
- ! 1.5 09/12/2003 Change type for mclayer to INTEGER (R Saunders)
- ! 1.6 06/01/2004 Add CO2 to ref profile (R Saunders)
- ! 1.7 02/06/2004 Add fast model version compatibility level in coef type (P. Brunel)
- ! 1.8 17/05/2005 Add q to profile_cloud_type ( U O'Keeffe)
- !
- ! Code Description:
- ! Language: Fortran 90.
- ! Software Standards: "European Standards for Writing and
- ! Documenting Exchangeable Fortran 90 Code".
- !
- ! Declarations:
- ! Modules used:
-
- ! Imported Parameters:
- use rttov_const, only: &
- & fastem_sp
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
- ! Surface skin
- Type sskin_type
- Integer(Kind=jpim) :: surftype ! 0=land, 1=sea, 2=sea-ice
- Real(Kind=jprb) :: t ! radiative skin temperature (K)
- Real(Kind=jprb) :: fastem(fastem_sp) ! land/sea-ice surface parameters for fastem-2
- End Type sskin_type
-
- ! Surface 2m
- Type s2m_type
- Real(Kind=jprb) :: t ! temperature (K)
- Real(Kind=jprb) :: q ! water vapour (ppmv)
- Real(Kind=jprb) :: o ! ozone (ppmv)
- Real(Kind=jprb) :: p ! surface pressure (hPa)
- Real(Kind=jprb) :: u ! U wind component (m/s)
- Real(Kind=jprb) :: v ! V wind component (m/s)
- End Type s2m_type
-
-
- ! structure for atmospheric profiles on model pressure levels
- Type profile_type
- ! number of atmospheric levels
- Integer(Kind=jpim) :: nlevels
- ! ozone, CO2 and cloud liquid water profiles available
- logical :: ozone_data
- logical :: co2_data
- logical :: clw_data
- ! atmosphere defined on nlevels
- Real(Kind=jprb), Pointer :: p(:) ! pressure (hPa)
- Real(Kind=jprb), Pointer :: t(:) ! temperature (K)
- Real(Kind=jprb), Pointer :: q(:) ! water vapour (ppmv)
- Real(Kind=jprb), Pointer :: o3(:) ! ozone (ppmv)
- Real(Kind=jprb), Pointer :: co2(:) ! carbon dioxide (ppmv)
- Real(Kind=jprb), Pointer :: clw(:) ! cloud liquid water (kg/kg)
- ! surface
- Type(sskin_type) :: skin
- Type(s2m_type) :: s2m
- !angles
- Real(Kind=jprb) :: zenangle
- Real(Kind=jprb) :: azangle
- ! Black body cloud
- Real(Kind=jprb) :: ctp ! cloud top pressure (hPa)
- Real(Kind=jprb) :: cfraction ! cloud fraction (0 - 1) 1 for 100% cloud cover
- End Type profile_type
-
- ! structure for atmospheric profiles with information
- ! on clouds for each level
- Type profile_cloud_type
- ! number of atmospheric levels
- Integer(Kind=jpim) :: nlevels
- ! atmosphere defined on nlevels (nlevels+1 for ph)
- Real(Kind=jprb), Pointer :: p(:) ! full-level model pressure (hPa)
- Real(Kind=jprb), Pointer :: ph(:) ! half-level model pressure (hPa)
- Real(Kind=jprb), Pointer :: t(:) ! temperature (K)
- Real(Kind=jprb), Pointer :: q(:) ! specific humidity (kg/kg)
- Real(Kind=jprb), Pointer :: cc(:) ! cloud cover
- Real(Kind=jprb), Pointer :: clw(:) ! cloud liquid water (kg/kg)
- Real(Kind=jprb), Pointer :: ciw(:) ! cloud ice water (kg/kg)
- Real(Kind=jprb), Pointer :: rain(:) ! rain (kg/(m2._JPRBs))
- Real(Kind=jprb), Pointer :: sp(:) ! solid precipitation (kg/(m2._JPRBs))
- ! Ice cloud crystal type (0=hexagonal columns, 1=aggregates)
- Integer(Kind=jpim) :: kice
- ! Ice effective size scheme (0=Ou-Liou, 1=Wyser, 2=Boudala et al., 3=McFarquhar))
- Integer(Kind=jpim) :: kradip
- End Type profile_cloud_type
-
- ! satellite geometry
- Type geometry_type
- Real(Kind=jprb) :: sinzen
- Real(Kind=jprb) :: sinzen_sq
- Real(Kind=jprb) :: coszen
- Real(Kind=jprb) :: coszen_sq
- Real(Kind=jprb) :: seczen
- Real(Kind=jprb) :: seczen_sq
- Real(Kind=jprb) :: seczen_sqrt
- Real(Kind=jprb) :: seczen_minus1
- Real(Kind=jprb) :: seczen_minus1_sq
- Real(Kind=jprb) :: sinview
- Real(Kind=jprb) :: sinview_sq
- Real(Kind=jprb) :: cosview_sq
- Real(Kind=jprb) :: normzen
- End Type geometry_type
-
- ! Predictors
- Type predictors_type
- ! the nxxxx could be set to 0 to indicate the abscence
- ! of the predictor, in that case there is no need to
- ! allocate the corresponding predictor
- Integer(Kind=jpim) :: nlevels ! number of levels for predictors (all same)
- Integer(Kind=jpim) :: nmixed ! number of variables for Mixed Gases
- Integer(Kind=jpim) :: nwater ! number of variables for Water Vapour
- Integer(Kind=jpim) :: nozone ! number of variables for Ozone
- Integer(Kind=jpim) :: nwvcont ! number of variables for WV Continuum
- Integer(Kind=jpim) :: nco2 ! number of variables for CO2
- Integer(Kind=jpim) :: ncloud ! number of variables for MW Cloud
- Real(Kind=jprb), Pointer :: mixedgas(:,:) ! (nmixed, nlevels)
- Real(Kind=jprb), Pointer :: watervapour(:,:) ! (nwater, nlevels)
- Real(Kind=jprb), Pointer :: ozone(:,:) ! (nozone, nlevels)
- Real(Kind=jprb), Pointer :: wvcont(:,:) ! (nwvcont, nlevels)
- Real(Kind=jprb), Pointer :: co2(:,:) ! (nco2, nlevels)
- Real(Kind=jprb), Pointer :: clw(:) ! (nlevels)
- End Type predictors_type
-
-
-
- Type rttov_coef
- ! Structure for the storage of RTTOV coefficients
- ! this may differ from what is stored in the coefficient files especially
- ! for the units (ie kg/kg to ppmv)
- ! Gases are separated in MxG WV O3
- ! Number of levels is the same for all gases (taken from MxG).
- !
- Integer(Kind=jpim) :: id_platform ! platform (see documentation or MOD_CPARAM)
- Integer(Kind=jpim) :: id_sat ! satellite (.....)
- Integer(Kind=jpim) :: id_inst ! instrument (.....)
- Integer(Kind=jpim) :: id_sensor ! sensor
- ! 1 = Infrared
- ! 2 = Micro Wave
- ! 3 = High resolution
- Integer(Kind=jpim) :: id_comp_lvl ! RTTOV coefficient file version number
- Integer(Kind=jpim) ,Dimension(3) :: id_creation_date ! YYYY MM DD
- Character (len=80) :: id_creation ! Creation comment
- Character (len=32) :: id_Common_name ! usual name of the satellite
-
-
- !FAST_MODEL_VARIABLES section
- Character (len=32) :: fmv_model_def ! FMV definition (RTTOV6 OPTRAN RTTOV7)
- Integer(Kind=jpim) :: fmv_model_ver ! fast model version compatibility level
- Integer(Kind=jpim) :: fmv_chn ! number of channels in file
- Integer(Kind=jpim) :: fmv_gas ! number of gases in file
- Integer(Kind=jpim), pointer :: fmv_gas_id(:) ! gas id. number i gas_id list (fmv_gas)
- Integer(Kind=jpim), Pointer :: fmv_gas_pos(:) ! respective position of each gas of gas_id list (ngases_max)
- Integer(Kind=jpim), Pointer :: fmv_var(:) ! number of variables/predictors by gaz (fmv_gas)
- Integer(Kind=jpim), Pointer :: fmv_lvl(:) ! number of levels(pres/absorber) by gaz (fmv_gas)
- Integer(Kind=jpim) :: nmixed ! number of variables/predictors for Mixed Gases
- Integer(Kind=jpim) :: nwater ! number of variables/predictors for Water Vapour
- Integer(Kind=jpim) :: nozone ! number of variables/predictors for Ozone
- Integer(Kind=jpim) :: nwvcont ! number of variables/predictors for WV continuum
- Integer(Kind=jpim) :: nco2 ! number of variables/predictors for CO2
- Integer(Kind=jpim) :: nn2o ! number of variables/predictors for N2O
- Integer(Kind=jpim) :: nco ! number of variables/predictors for CO
- Integer(Kind=jpim) :: nch4 ! number of variables/predictors for CH4
- Integer(Kind=jpim) :: nlevels ! number of levels(pres/absorber) same for all gases
-
- !GAZ_UNITS section
- ! gases are in the order of gas id codes
- Integer(Kind=jpim), Pointer :: gaz_units(:) ! unit of gaz concentration for each gaz
- ! default value is specific conc. (kg/kg)
- ! value inside RTTOV calculations (ppmv)
- !FILTER_FUNCTIONS section array size is fmv_chn
- Integer(Kind=jpim) ,Pointer :: ff_ori_chn(:) ! original chan number
- Integer(Kind=jpim) ,Pointer :: ff_val_chn(:) ! validity of the channel (1=OK)
- Real(Kind=jprb) ,Pointer :: ff_cwn (:) ! cental wave number (cm-1)
- Real(Kind=jprb) ,Pointer :: ff_bco (:) ! band correction offset (K)
- Real(Kind=jprb) ,Pointer :: ff_bcs (:) ! band correction slope (K/K)
- Real(Kind=jprb) ,Pointer :: ff_gam (:) ! gamma factor transm. correction
-
- !FUNDAMENTAL_CONSTANTS section
- Real(Kind=jprb) :: fc_speedl ! speed of light (cm/s)
- Real(Kind=jprb) :: fc_planck_c1 ! first radiation constant (mW/(m2*sr*cm-4))
- Real(Kind=jprb) :: fc_planck_c2 ! second radiation constant (cm*K)
- Real(Kind=jprb) :: fc_sat_height ! satellite nominal altitude (km)
-
- !FASTEM section
- Integer(Kind=jpim) :: fastem_ver ! fastem version number
- Integer(Kind=jpim) :: fastem_coef_nb ! number of coefficients
- Real(Kind=jprb), Pointer :: fastem_coef(:) ! coefficients (fastem_coef_nb)
- Integer(Kind=jpim), Pointer :: fastem_polar(:) ! polarisation of each channel
- ! 0 = 0.5 V+H
- ! 1 = 90 - incident angle
- ! 2 = incident angle
- ! 3 = vertical
- ! 4 = horizontal
- ! 5 = V+H
- ! Full stokes vector
-
- !SSIREM section array size is fmv_chn
- ! ems = ssirem_a0
- ! - ssirem_a1*(zen**ssirem_xzn1)
- ! - ssirem_a2*(zen**ssirem_xzn2)
- ! where zen is satellite zenith angle in degrees, divided by 60.
- Integer(Kind=jpim) :: ssirem_ver ! version number
- Integer(Kind=jpim), Pointer :: ssirem_chn(:) ! original chan number
- Real(Kind=jprb), Pointer :: ssirem_a0(:) ! constant coef
- Real(Kind=jprb), Pointer :: ssirem_a1(:) ! first coef
- Real(Kind=jprb), Pointer :: ssirem_a2(:) ! second coef
- Real(Kind=jprb), Pointer :: ssirem_xzn1(:) ! 1st exponent on zenith angle
- Real(Kind=jprb), Pointer :: ssirem_xzn2(:) ! 2nd exponent on zenith angle
-
- !REFERENCE_PROFILE section defined on Mixed gases pressure levels
- ! Not working for OPTRAN gas absorber levels
- ! gases are in the order of gas id codes
- ! unit for mr in coeff file is kg/kg or ppmv (see gaz_units section)
- ! unit for mr for optical depth calculations is ppmv
- Real(Kind=jprb), Pointer :: ref_prfl_p(:) ! pressure (hPa) (levels)
- Real(Kind=jprb), Pointer :: ref_prfl_t(:,:) ! temperature (K) (levels, gases)
- Real(Kind=jprb), Pointer :: ref_prfl_mr(:,:) ! mixing ratio (ppmv) (levels, gases)
- !PROFILE_LIMITS section
- ! gases are in the order of gas id codes
- ! unit for mr in coeff file is kg/kg or ppmv (see gaz_units section)
- ! unit for mr for optical depth calculations is ppmv
- Real(Kind=jprb), Pointer :: lim_prfl_p(:) ! pressure (hPa) (levels)
- Real(Kind=jprb), Pointer :: lim_prfl_tmax(:) ! max temperature (K) (levels)
- Real(Kind=jprb), Pointer :: lim_prfl_tmin(:) ! min temperature (K) (levels)
- Real(Kind=jprb), Pointer :: lim_prfl_gmax(:,:) ! max mixing r (ppmv) (levels, gases)
- Real(Kind=jprb), Pointer :: lim_prfl_gmin(:,:) ! min mixing r (ppmv) (levels, gases)
-
-
- !FAST_COEFFICIENTS section
- ! separate arrays to allow dififerent number of variables for each gaz
- Real(Kind=jprb), Pointer :: mixedgas(:,:,:) ! Mixed gases coefs (levels, channels, variables)
- Real(Kind=jprb), Pointer :: watervapour(:,:,:) ! Water vapour coefs (levels, channels, variables)
- Real(Kind=jprb), Pointer :: ozone(:,:,:) ! Ozone coefs (levels, channels, variables)
- Real(Kind=jprb), Pointer :: wvcont(:,:,:) ! WV Cont coefs (levels, channels, variables)
- Real(Kind=jprb), Pointer :: co2(:,:,:) ! CO2 coefs (levels, channels, variables)
- Real(Kind=jprb), Pointer :: n2o(:,:,:) ! N2O coefs (levels, channels, variables)
- Real(Kind=jprb), Pointer :: co(:,:,:) ! CO coefs (levels, channels, variables)
- Real(Kind=jprb), Pointer :: ch4(:,:,:) ! CH4 coefs (levels, channels, variables)
-
- ! Auxillary variables
- Real(Kind=jprb) :: ratoe ! ratio (H+R)/R H=sat height, R=Earth radius
- Real(Kind=jprb), pointer :: planck1(:) ! C1 * Nu**3
- Real(Kind=jprb), pointer :: planck2(:) ! C2 * Nu
- Real(Kind=jprb), pointer :: frequency_ghz(:) ! frequency in GHz
-
- ! other predictor variables see Science and Validation report
- Real(Kind=jprb), pointer :: dp(:) ! interval between standard p levels (hPa)
- Real(Kind=jprb), pointer :: dpp(:) ! pressure based variable (hPa**2)
- Real(Kind=jprb), pointer :: tstar(:) ! layer temp (K)
- Real(Kind=jprb), pointer :: to3star(:) ! layer temp for O3 calculations (K)
- Real(Kind=jprb), pointer :: wstar(:) ! layer WV (ppmv)
- Real(Kind=jprb), pointer :: ostar(:) ! layer O3 (ppmv)
- Real(Kind=jprb), pointer :: co2star(:) ! layer co2 (ppmv)
-
- End Type rttov_coef
-
- Type rttov_scatt_coef
- ! Structure for the storage of RTTOV_SCATT coefficients
- Integer(Kind=jpim) :: nhydro ! Number of hydrometeors in computation
- Integer(Kind=jpim) :: mtype ! Number of hydrometeors in Mie tables
- Integer(Kind=jpim) :: mfreqm ! Number of frequencies in Mie tables
- Integer(Kind=jpim) :: mtemp ! Number of temperature bins in Mie tables
- Integer(Kind=jpim) :: mwc ! Number of water bins in Mie tables
- Real(Kind=jprb) :: offset_temp_rain ! temperature offset in table for rain type
- Real(Kind=jprb) :: offset_temp_sp ! temperature offset in table for solid prec. type
- Real(Kind=jprb) :: offset_temp_liq ! temperature offset in table for cloud water type
- Real(Kind=jprb) :: offset_temp_ice ! temperature offset in table for cloud ice type
- Real(Kind=jprb) :: offset_water ! liquid/ice water offset in table
- Real(Kind=jprb) :: scale_water ! log10(liquid/ice water) scaling factor in table
- Real(Kind=jprb) :: from_scale_water ! 10**(1._JPRB/scale_water)
- Real(Kind=jprb) :: conv_rain(2) ! coefficients for rain unit conversion (mm.h-1 to g.m-3)
- Real(Kind=jprb) :: conv_sp (2) ! coefficients for solid prec. unit conversion (mm.h-1 to g.m-3)
- Real(Kind=jprb) :: conv_liq (2) ! coefficients for cloud water conversion (not used)
- Real(Kind=jprb) :: conv_ice (2) ! coefficients for cloud ice conversion (not used)
- Real(Kind=jprb), pointer :: mie_freq(:) ! list of frequencies in Mie table
- Real(Kind=jprb), pointer :: ext(:,:,:,:) ! extinction coefficent table
- Real(Kind=jprb), pointer :: ssa(:,:,:,:) ! single scattering albedo table
- Real(Kind=jprb), pointer :: asp(:,:,:,:) ! assymetry parameter table
-
- End Type rttov_scatt_coef
-
- ! Auxillary profile variables
- ! variables calculated by the model from profile
- type profile_aux
- Integer(Kind=jpim) :: nearestlev_surf ! nearest model level above surface
- Real(Kind=jprb) :: pfraction_surf ! pressure fraction of surface in model layer (hPa)
- Integer(Kind=jpim) :: nearestlev_ctp ! nearest model level above cloud top
- Real(Kind=jprb) :: pfraction_ctp ! pressure fraction of cloud top pressure in layer (hPa)
- Real(Kind=jprb) :: cfraction ! cloud fraction (0 - 1) 1 for 100% cloud cover
- Real(Kind=jprb), pointer :: debye_prof(:,:) ! Debye terms
- end type profile_aux
-
- ! Auxillary profile variables for RTTOV_SCATT
- ! variables calculated by the model from profile
- Type profile_scatt_aux
- Real(Kind=jprb), pointer :: ccmax(:) ! horizontal cloud fraction (one value used for all layers)
- Real(Kind=jprb), pointer :: ems_bnd(:) ! surface emissivity for boundary conditions
- Real(Kind=jprb), pointer :: ref_bnd(:) ! surface emissivity for boundary conditions
- Real(Kind=jprb), pointer :: ems_cld(:) ! surface emissivity taking into account cloud/rain impact on od
- Real(Kind=jprb), pointer :: ref_cld(:) ! surface reflectivity taking into account cloud/rain impact on od
- Real(Kind=jprb), pointer :: dz(:,:) ! layer depth [km]
- Real(Kind=jprb), pointer :: tbd(:,:) ! temperature at layer boundary [K]
- Real(Kind=jprb), Pointer :: clw(:,:) ! cloud liquid water (g/m3)
- Real(Kind=jprb), Pointer :: ciw(:,:) ! cloud ice water (g/m3)
- Real(Kind=jprb), Pointer :: rain(:,:) ! rain (g/m3)
- Real(Kind=jprb), Pointer :: sp(:,:) ! solid precipitation (g/m3)
-!RWS Real(Kind=jprb), pointer :: mclayer(:) ! upper level cloud layer
- Integer(Kind=jpim), pointer :: mclayer(:) ! upper level cloud layer
- Real(Kind=jprb), pointer :: delta(:,:) ! (= ext*dz/coszen)
- Real(Kind=jprb), pointer :: tau(:,:) ! optical depths (= exp(-delta))
- Real(Kind=jprb), pointer :: ext(:,:) ! extinction coefficient integreated over hydrometeor types
- Real(Kind=jprb), pointer :: ssa(:,:) ! single scattering albedo integreated over hydrometeor types
- Real(Kind=jprb), pointer :: asm(:,:) ! asymetry parameter integreated over hydrometeor types [-1,1]
- Real(Kind=jprb), pointer :: lambda(:,:) ! eddington approx. variable
- ! (= sqrt( 3*ext*ext*(1-ssa)*(1-ssa*asm) )
- Real(Kind=jprb), pointer :: h (:,:) ! boundary condition variable (= 1.5_JPRB*ext(1-ssa*asm))
- Real(Kind=jprb), pointer :: b0(:,:) ! lower level temperature
- Real(Kind=jprb), pointer :: b1(:,:) ! temperature gradient
- Real(Kind=jprb), pointer :: bn(:,:) ! upper level temperature
- end type profile_scatt_aux
-
- type transmission_type
- ! Transmissions and optical depths (unitless)
- Real(Kind=jprb), pointer :: tau_surf(:) ! transmittance from surface (array size is of size nchannels)
- Real(Kind=jprb), pointer :: tau_layer(:,:) ! transmittance from each standard pressure level
- ! (array size is of size (nlevels,nchannels))
- Real(Kind=jprb), pointer :: od_singlelayer(:,:) ! single-layer optical depth
- ! (array size is of size (nlevels,nchannels))
- end type transmission_type
-
- type radiance_type
- ! Radiance and corresponding brightness temperature
- ! Array size is of size nchannels
- ! except for cloudy calculations (nlevels, nchannels)
- ! unit for radiance is mw/cm-1/ster/sq.m
- ! unit for temperature is Kelvin
- !
- logical :: lcloud ! if true the last array is calculated
- ! if false it does not need to be allocated
- !
- Real(Kind=jprb), pointer :: clear(:) ! clear sky radiance
- Real(Kind=jprb), pointer :: clear_out(:) ! clear sky radiance
- Real(Kind=jprb), pointer :: cloudy(:) ! 100% cloudy radiance for given cloud
- Real(Kind=jprb), pointer :: total(:) ! cloudy radiance for given cloud
- Real(Kind=jprb), pointer :: total_out(:) ! cloudy radiance for given cloud
- Real(Kind=jprb), pointer :: out(:) ! BT equivalent to total radiance
- Real(Kind=jprb), pointer :: out_clear(:) ! BT equivalent to clear radiance
- Real(Kind=jprb), pointer :: bt(:) ! Brightness temp equivalent to total radiance
- Real(Kind=jprb), pointer :: bt_clear(:) ! Brightness temp equivalent to clear radiance
- Real(Kind=jprb), pointer :: upclear(:) ! clear sky radiance without reflection term
- Real(Kind=jprb), pointer :: dnclear(:) ! clear sky downwelling radiance
- Real(Kind=jprb), pointer :: reflclear(:) ! reflected clear sky downwelling radiance
- Real(Kind=jprb), pointer :: overcast(:,:) ! overcast radiance at given cloud
- ! top (levels,channels)
- Real(Kind=jprb), pointer :: downcld(:,:) ! contribution to radiance of downward
- ! cloud emission at given cloud top
- ! (levels,channels)
- end type radiance_type
-
- type radiance_cloud_type
- ! Emissivity and radiance arrays for cloudy conditions
- ! see rttov_cld
- ! Array size is of size nchannels
- ! except for cloudy calculations (nlevels, nchannels)
- !
- ! First part, same definition as the radiance type
- logical :: lcloud ! if true the last array is calculated
- ! if false it does not need to be allocated
- Real(Kind=jprb), pointer :: clear(:) ! clear sky radiance
- Real(Kind=jprb), pointer :: clear_out(:) ! clear sky radiance
- Real(Kind=jprb), pointer :: cloudy(:) ! 100% cloudy radiance for given cloud
- Real(Kind=jprb), pointer :: total(:) ! cloudy radiance for given cloud
- Real(Kind=jprb), pointer :: total_out(:) ! cloudy radiance for given cloud
- Real(Kind=jprb), pointer :: out(:) ! Brightness temp equivalent to total radiance
- Real(Kind=jprb), pointer :: out_clear(:) ! Brightness temp equivalent to clear radiance
- Real(Kind=jprb), pointer :: bt(:) ! Brightness temp equivalent to total radiance
- Real(Kind=jprb), pointer :: bt_clear(:) ! Brightness temp equivalent to clear radiance
- Real(Kind=jprb), pointer :: upclear(:) ! clear sky radiance without reflection term
- Real(Kind=jprb), pointer :: dnclear(:) ! clear sky downwelling radiance
- Real(Kind=jprb), pointer :: reflclear(:) ! reflected clear sky downwelling radiance
- Real(Kind=jprb), pointer :: overcast(:,:) ! overcast radiance at given cloud
- ! top (levels,channels)
- Real(Kind=jprb), pointer :: downcld(:,:) ! contribution to radiance of downward
- ! cloud emission at given cloud top
- ! (levels,channels)
- !
- ! Second part Cloud specific
- Real(Kind=jprb), pointer :: cldemis(:,:) ! cloud emissivity (levels, channels)
- Real(Kind=jprb), pointer :: wtoa(:,:) ! toa weights of of cloud layers
- Real(Kind=jprb), pointer :: wsurf(:,:) ! surface weights of cloud layers
- Real(Kind=jprb), pointer :: cs_wtoa(:) ! contribution from clear sky fraction
- Real(Kind=jprb), pointer :: cs_wsurf(:) ! contribution from clear sky fraction
-
- !
- ! Third part scatter specific
- Real(Kind=jprb), pointer :: freq_used(:) ! list of frequencies actually used for the Mie computations
- ! (they may not be strictly equal to the frequencies requested)
- end type radiance_cloud_type
-
-
-
- type radiance_aux
- ! auxillary calculation arrays for RTE integration
- ! Direct model arrays need to be passed to TL AD and K codes
- ! array size is of (nchannels) or (nlevels, nchannels)
- Real(Kind=jprb), pointer :: layer(:,:)
- Real(Kind=jprb), pointer :: surfair(:)
- Real(Kind=jprb), pointer :: skin(:)
- Real(Kind=jprb), pointer :: cosmic(:)
- Real(Kind=jprb), pointer :: up(:,:) ! sum( B * dT )
- Real(Kind=jprb), pointer :: down(:,:) ! sum ( B / T**2 dT )
- Real(Kind=jprb), pointer :: down_cloud(:,:)
- end type radiance_aux
-
-End Module rttov_types
diff --git a/src/LIB/RTTOV/src/rttov_v2q.F90 b/src/LIB/RTTOV/src/rttov_v2q.F90
deleted file mode 100644
index a10c56f4a78baee96714d572fabe9f93665073dd..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_v2q.F90
+++ /dev/null
@@ -1,140 +0,0 @@
-!
-Subroutine rttov_v2q (&
- & h2o_unit, &! in
- & h2o, &! in
- & gaz_id, &! in
- & v_gaz, &! in
- & q_gaz ) ! inout
- !
- ! Description:
- ! Conversion of volume mixing ratio to specific concentration.
- ! Gases are defined by the "gas_id_xxx" codes in the rttov_const module
- ! Method use an equivalent molecular weight of wet air
- !
- ! Copyright:
- !
- ! This software was developed within the context of
- ! the EUMETSAT Satellite Application Facility on
- ! Numerical Weather Prediction (NWP SAF), under the
- ! Cooperation Agreement dated 25 November 1998, between
- ! EUMETSAT and the Met Office, UK, by one or more partners
- ! within the NWP SAF. The partners in the NWP SAF are
- ! the Met Office, ECMWF, KNMI and MeteoFrance.
- !
- ! Copyright 2002, EUMETSAT, All Rights Reserved.
- !
- !
- !
- ! Current Code Owner: SAF NWP
- !
- ! History:
- ! Version Date Comment
- ! 1.0 27/01/2003 Original code. (P. Brunel)
- ! 1.1 13/02/2003 Remove capability of array of gases (P. Brunel)
- !
- ! Code Description:
- ! FORTRAN 90, following AAPP standards
- !
- ! Declarations
- !
- ! Global variables:
- ! Modules used:
- ! Imported Parameters:
- Use rttov_const, Only : &
- & mair ,&
- & mh2o ,&
- & mo3 ,&
- & mco2 ,&
- & mn2o ,&
- & mco ,&
- & mch4 ,&
- & gas_id_mixed ,&
- & gas_id_watervapour ,&
- & gas_id_ozone ,&
- & gas_id_wvcont ,&
- & gas_id_co2 ,&
- & gas_id_n2o ,&
- & gas_id_co ,&
- & gas_id_ch4 ,&
- & gas_unit_specconc ,&
- & gas_unit_ppmv
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
- ! Subroutine arguments
- ! Scalar arguments with intent(in):
- Integer(Kind=jpim) , Intent (in) :: h2o_unit ! Water vapour input unit
- ! 1 = specific concent. (kg/kg)
- ! 2 = volume mixing ratio (ppmv)
- ! (see gaz id codes in module rttov_const)
- Real(Kind=jprb) , Intent (in) :: h2o ! Water Vapour content in unit h2o_unit
-
- Integer(Kind=jpim) , Intent (in) :: gaz_id ! Gaz identification number
- ! (see gaz id codes in module rttov_const)
- Real(Kind=jprb) , Intent (in) :: v_gaz ! volume mixing ratio for gaz (ppmv)
- Real(Kind=jprb) , Intent (inout):: q_gaz ! specific concentration for gaz (kg/kg)
-
-
-
-
- ! Local parameter
- Real(Kind=jprb), Parameter :: eps = mh2o / mair
-
-
-
- ! Local variables
- Real(Kind=jprb) :: Mwet ! equivalent molecular weight of wet air (g)
- Real(Kind=jprb) :: v_h2o ! volume mixing ratio for Water Vapour (v:v)
-
- !- End of header --------------------------------------------------------
-
- ! Calculate volume mixing ratio (no unit) for Water Vapour
- If( h2o_unit == gas_unit_specconc ) then
- v_h2o = h2o / (eps * (1-h2o) + h2o)
- Else If( h2o_unit == gas_unit_ppmv ) then
- v_h2o = h2o * 1.e-06_JPRB
- Else
- v_h2o = 0._JPRB
- End If
-
- ! Humid air molar mass
- Mwet = (1 - v_h2o)*Mair + v_h2o*Mh2o
-
- ! calculate specific concentration for gaz (kg/kg)
- Select Case( gaz_id )
- Case( gas_id_mixed )
- ! keep same value for Mixed gases
- q_gaz = v_gaz
-
- Case( gas_id_watervapour )
- q_gaz = v_gaz * 1.e-06_JPRB * Mh2o / Mwet
- !q_gaz = v_gaz / 1.60771704e+6
-
- Case( gas_id_ozone )
- q_gaz = v_gaz * 1.e-06_JPRB * Mo3 / Mwet
- !q_gaz = v_gaz / 6.03504e+5
-
- Case( gas_id_wvcont )
- q_gaz = v_gaz * 1.e-06_JPRB * Mh2o / Mwet
-
- Case( gas_id_co2 )
- q_gaz = v_gaz * 1.e-06_JPRB * Mco2 / Mwet
-
- Case( gas_id_n2o )
- q_gaz = v_gaz * 1.e-06_JPRB * Mn2o / Mwet
-
- Case( gas_id_co )
- q_gaz = v_gaz * 1.e-06_JPRB * Mco / Mwet
-
- Case( gas_id_ch4 )
- q_gaz = v_gaz * 1.e-06_JPRB * Mch4 / Mwet
-
- Case Default
- q_gaz = 0._JPRB
-
- End Select
-
-
-
-End Subroutine rttov_v2q
diff --git a/src/LIB/RTTOV/src/rttov_v2q.interface b/src/LIB/RTTOV/src/rttov_v2q.interface
deleted file mode 100644
index f93cf0e74630364a41beb606dac3cae747cd502a..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_v2q.interface
+++ /dev/null
@@ -1,46 +0,0 @@
-Interface
-!
-Subroutine rttov_v2q (&
- & h2o_unit, & ! in
- & h2o, & ! in
- & gaz_id, & ! in
- & v_gaz, & ! in
- & q_gaz ) ! inout
- Use rttov_const, Only : &
- mair ,&
- mh2o ,&
- mo3 ,&
- mco2 ,&
- mn2o ,&
- mco ,&
- mch4 ,&
- gas_id_mixed ,&
- gas_id_watervapour ,&
- gas_id_ozone ,&
- gas_id_wvcont ,&
- gas_id_co2 ,&
- gas_id_n2o ,&
- gas_id_co ,&
- gas_id_ch4 ,&
- gas_unit_specconc ,&
- gas_unit_ppmv
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
- Integer(Kind=jpim) , Intent (in) :: h2o_unit ! Water vapour input unit
- ! 1 = specific concent. (kg/kg)
- ! 2 = volume mixing ratio (ppmv)
- ! (see gaz id codes in module rttov_const)
- Real(Kind=jprb) , Intent (in) :: h2o ! Water Vapour content in unit h2o_unit
-
- Integer(Kind=jpim) , Intent (in) :: gaz_id ! Gaz identification number
- ! (see gaz id codes in module rttov_const)
- Real(Kind=jprb) , Intent (in) :: v_gaz ! volume mixing ratio for gaz (ppmv)
- Real(Kind=jprb) , Intent (inout):: q_gaz ! specific concentration for gaz (kg/kg)
-
-
-
-
-End Subroutine rttov_v2q
-End Interface
diff --git a/src/LIB/RTTOV/src/rttov_writecoef.F90 b/src/LIB/RTTOV/src/rttov_writecoef.F90
deleted file mode 100644
index c97de52f7dfdafae7395ec0018cf8a0170d4abc6..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_writecoef.F90
+++ /dev/null
@@ -1,469 +0,0 @@
-!
-Subroutine Rttov_writecoef (errorstatus, coef, file_id, lbinary)
- ! Description:
- ! write on unit file_id the coef structure.
- ! If lbinary is false or not present the file is assumed as
- ! an ASCII sequential formatted, in other case it is sequential unformatted.
- ! I/O write status are only tested at the end of the code
- !
- ! Copyright:
- ! This software was developed within the context of
- ! the EUMETSAT Satellite Application Facility on
- ! Numerical Weather Prediction (NWP SAF), under the
- ! Cooperation Agreement dated 25 November 1998, between
- ! EUMETSAT and the Met Office, UK, by one or more partners
- ! within the NWP SAF. The partners in the NWP SAF are
- ! the Met Office, ECMWF, KNMI and MeteoFrance.
- !
- ! Copyright 2002, EUMETSAT, All Rights Reserved.
- !
- ! Method:
- !
- ! Current Code Owner: SAF NWP
- !
- ! History:
- ! Version Date Comment
- ! ------- ---- -------
- ! 1.0 01/12/2002 New F90 code with structures (P Brunel A Smith)
- ! 1.1 24/01/2003 insert I/O status (P Brunel)
- ! one record per channel for coefficients in binary format
- ! New header to allow checking R4<->R8
- ! 1.2 02/06/2004 Update for RTTOV8 coefs (P. Brunel)
- !
- ! Code Description:
- ! Language: Fortran 90.
- ! Software Standards: "European Standards for Writing and
- ! Documenting Exchangeable Fortran 90 Code".
- !
- ! Declarations:
- ! Modules used:
- ! Imported Parameters:
- Use rttov_const, Only : &
- & rttov_magic_string ,&
- & rttov_magic_number ,&
- & errorstatus_success ,&
- & errorstatus_fatal ,&
- & errorstatus_info ,&
- & gas_id_mixed ,&
- & gas_id_watervapour ,&
- & gas_id_ozone ,&
- & gas_id_wvcont ,&
- & gas_id_co2 ,&
- & gas_id_n2o ,&
- & gas_id_co ,&
- & gas_id_ch4 ,&
- & gas_name ,&
- & gas_unit_name
-
- ! Imported Type Definitions:
- Use rttov_types, Only : &
- & rttov_coef
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
-#include "rttov_errorreport.interface"
-
- ! subroutine arguments
- ! scalar arguments with intent(in):
- Integer(Kind=jpim), Intent (in) :: file_id ! file logical unit number
- Type( rttov_coef ), Intent (in) :: coef ! coefficients
- Logical, Optional, Intent (in) :: lbinary ! if binary file wanted
- ! scalar arguments with intent(in):
- Integer(Kind=jpim), Intent (out) :: errorstatus ! return code
-
-
-
- ! local scalars
- Integer(Kind=jpim) :: i, j, l, k
- Logical :: file_binary
- Integer(Kind=jpim) :: io_status
- Character (len=2) :: sensor
- Character (len=32) :: section
-
- Character (len=80) :: errMessage
- Character (len=16) :: NameOfRoutine = 'rttov_writecoef '
- !- End of header --------------------------------------------------------
-
- errorstatus = errorstatus_success
-
- ! Consider lbinary option to create the option
- If(Present(lbinary)) Then
- file_binary = lbinary
- Else
- file_binary = .False.
- Endif
-
-
- If( file_binary ) Then
- ! Binary file
- Write( errMessage, '( "write coefficient to file_id ", i2, " in binary format")' ) &
- & file_id
- Call Rttov_ErrorReport (errorstatus_info, errMessage, NameOfRoutine)
-
- ! Write a string that could be displayed
- ! Write a real number to be able to check single/double precision
- Write(file_id, iostat=io_status) rttov_magic_string, rttov_magic_number
-
- Write(file_id, iostat=io_status)&
- & coef % id_platform,&
- & coef % id_sat, &
- & coef % id_inst, &
- & coef % id_sensor
- Write(file_id, iostat=io_status)&
- & coef % id_comp_lvl, &
- & coef % id_creation_date, &
- & coef % id_creation, &
- & coef % id_Common_name
- If( coef % id_comp_lvl == 7 ) then
- Write(file_id, iostat=io_status)&
- & coef % fmv_model_def,&
- & coef % fmv_chn, &
- & coef % fmv_gas
- Else
- Write(file_id, iostat=io_status)&
- & coef % fmv_model_def,&
- & coef % fmv_model_ver,&
- & coef % fmv_chn, &
- & coef % fmv_gas
- Endif
- Write(file_id, iostat=io_status)&
- & coef % fmv_gas_id, &
- & coef % fmv_gas_pos, &
- & coef % fmv_var, &
- & coef % fmv_lvl
- Write(file_id, iostat=io_status)&
- & coef % gaz_units
- Write(file_id, iostat=io_status)&
- & coef % ff_ori_chn, &
- & coef % ff_val_chn, &
- & coef % ff_cwn, &
- & coef % ff_bco, &
- & coef % ff_bcs, &
- & coef % ff_gam
- Write(file_id, iostat=io_status)&
- & coef % fc_speedl, &
- & coef % fc_planck_c1, &
- & coef % fc_planck_c2, &
- & coef % fc_sat_height
- Write(file_id, iostat=io_status)&
- & coef % fastem_ver,&
- & coef % ssirem_ver
- If( coef % fastem_ver >= 1 ) Then
- Write(file_id, iostat=io_status)&
- & coef % fastem_coef_nb
- Write(file_id, iostat=io_status)&
- & coef % fastem_coef,&
- & coef % fastem_polar
- Endif
- If( coef % ssirem_ver >= 1 ) Then
- Write(file_id, iostat=io_status)&
- & coef % ssirem_chn, &
- & coef % ssirem_a0, &
- & coef % ssirem_a1, &
- & coef % ssirem_a2, &
- & coef % ssirem_xzn1,&
- & coef % ssirem_xzn2
- Endif
- Write(file_id, iostat=io_status)&
- & coef % ref_prfl_p,&
- & coef % ref_prfl_t,&
- & coef % ref_prfl_mr
- Write(file_id, iostat=io_status)&
- & coef % lim_prfl_p, &
- & coef % lim_prfl_tmax, &
- & coef % lim_prfl_tmin, &
- & coef % lim_prfl_gmax, &
- & coef % lim_prfl_gmin
-
- ! Write coefficients with ONE record per Channel
- If ( coef % nmixed > 0 ) Then
- Do i = 1, coef % fmv_chn
- Write(file_id,iostat=io_status) coef % mixedgas( : , i, : )
- End Do
- Endif
- If ( coef % nwater > 0 ) Then
- Do i = 1, coef % fmv_chn
- Write(file_id,iostat=io_status) coef % watervapour( : , i, : )
- End Do
- Endif
- If ( coef % nozone > 0 ) Then
- Do i = 1, coef % fmv_chn
- Write(file_id,iostat=io_status) coef % ozone( : , i, : )
- End Do
- Endif
- If ( coef % nwvcont > 0 ) Then
- Do i = 1, coef % fmv_chn
- Write(file_id,iostat=io_status) coef % wvcont( : , i, : )
- End Do
- Endif
- If ( coef % nco2 > 0 ) Then
- Do i = 1, coef % fmv_chn
- Write(file_id,iostat=io_status) coef % co2( : , i, : )
- End Do
- Endif
- If ( coef % nn2o > 0 ) Then
- Do i = 1, coef % fmv_chn
- Write(file_id,iostat=io_status) coef % n2o( : , i, : )
- End Do
- Endif
- If ( coef % nco > 0 ) Then
- Do i = 1, coef % fmv_chn
- Write(file_id,iostat=io_status) coef % co( : , i, : )
- End Do
- Endif
- If ( coef % nch4 > 0 ) Then
- Do i = 1, coef % fmv_chn
- Write(file_id,iostat=io_status) coef % ch4( : , i, : )
- End Do
- Endif
- !
- ! Add here other gases or new sections
- !
-
- Else
-
- !ASCII file
- Write( errMessage, '( "write coefficient to file_id ", i2, " in ASCII format")' ) &
- & file_id
- Call Rttov_ErrorReport (errorstatus_info, errMessage, NameOfRoutine)
-
- Write(file_id,'(a)') ' ! RTTOV coefficient file '//Trim(coef % id_Common_name)
- Write(file_id,'(a)') ' ! automatic creation by subroutine Rttov_writecoef '
- Write(file_id,'(a)') ' ! ------------------------------------------------------'
-
- ! IDENTIFICATION
- section = 'IDENTIFICATION'
- Select Case (coef % id_sensor)
- Case (1_jpim)
- sensor = 'ir'
- Case (2_jpim)
- sensor = 'mw'
- Case (3_jpim)
- sensor = 'hi'
- End Select
- Write(file_id,'(a)') Trim(section)
- Write(file_id,'(a)') ' ! '
- Write(file_id,'(3i3,T20,a)')&
- & coef % id_platform, coef % id_sat, coef % id_inst,'! platform sat_id instrument'
- Write(file_id,'(1x,a)') coef % id_Common_name
- Write(file_id,'(1x,a,T20,a)') sensor,'! sensor type [ir,mw,hi]'
- Write(file_id,'(1x,i2,T20,a)') coef % id_comp_lvl,'! RTTOV coefficient file version number'
- Write(file_id,'(1x,a)') coef % id_creation
- Write(file_id,'(1x,i4,1x,i2.2,1x,i2.2,t20,a)') coef % id_creation_date,'! creation date'
-
- ! No LINE-BY-LINE section
-
- ! FAST_MODEL_VARIABLES
- section = 'FAST_MODEL_VARIABLES'
- Write(file_id,'(a)') ' ! ------------------------------------------------------'
- Write(file_id,'(a)') Trim(section)
- Write(file_id,'(a)') ' ! '
- Write(file_id,'(a)') ' !'
- Write(file_id,'(1x,a,t20,a)') coef % fmv_model_def, '! fast model name'
- If( coef % id_comp_lvl > 7 ) then
- Write(file_id,'(1x,i4,t20,a)') coef % fmv_model_ver, '! fast model version compatibility level'
- Endif
- Write(file_id,'(1x,i4,t20,a)') coef % fmv_chn , '! Number of channels described in the coef file'
- Write(file_id,'(1x,i4,t20,a)') coef % fmv_gas , '! Number of gases described in the coef file'
- Do i = 1, coef % fmv_gas
- Write(file_id,'(1x,a,t20,a)') Trim(gas_name( coef % fmv_gas_id( i ) ) ),'! gas identification'
- Write(file_id,'(1x,2i4,t20,a)') coef % fmv_var(i), coef % fmv_lvl(i), '! variables/predictors levels (pressure/absorber)'
- End Do
-
- section = 'FILTER_FUNCTIONS'
- Write(file_id,'(a)') ' ! ------------------------------------------------------'
- Write(file_id,'(a)') Trim(section)
- Write(file_id,'(a)') ' ! '
- Write(file_id,'(a)') ' ! Channel Number (from instrument original description)'
- Write(file_id,'(a)') ' ! Channel status '
- Write(file_id,'(a)') ' ! Central Wavenumber'
- Write(file_id,'(a)') ' ! Band Correction coefficients(Offset,Slope)'
- Write(file_id,'(a)') ' ! Gamma correction factor'
-
- Do i = 1, coef % fmv_chn
- Write(file_id,'(1x,i4,1x,i4,4(1x,e18.10))') &
- & coef % ff_ori_chn(i), coef % ff_val_chn(i), coef % ff_cwn(i),&
- & coef % ff_bco(i), coef % ff_bcs(i), coef % ff_gam(i)
- End Do
-
- ! GAZ_UNITS
- section = 'GAZ_UNITS'
- Write(file_id,'(a)') ' ! ------------------------------------------------------'
- Write(file_id,'(a)') Trim(section)
- Write(file_id,'(a)') ' ! Gaz concentrations can be expressed in '
- Write(file_id,'(a)') ' ! volume mixing ratio (ppmv)'
- Write(file_id,'(a)') ' ! specific concentration (kg/kg)'
- Write(file_id,'(a)') ' ! '
- Do i = 1, coef % fmv_gas
- Write(file_id,'(a)') ' ! '//gas_name( coef % fmv_gas_id( i ) )
- Write(file_id,'(1x,i4,t20,"! ",a)') &
- & coef % gaz_units( i ), gas_unit_name( coef % gaz_units( i ) )
- End Do
-
-
- section = 'FUNDAMENTAL_CONSTANTS'
- Write(file_id,'(a)') ' ! ------------------------------------------------------'
- Write(file_id,'(a)') Trim(section)
- Write(file_id,'(a)') ' ! '
- Write(file_id,'(a)') ' ! units of constants for spectral radiance'
- Write(file_id,'(a)') ' ! first radiation constant(mW/(m2.sr.cm-4))'
- Write(file_id,'(a)') ' ! second radiation constant (cm.K)'
- Write(file_id,'(1x,f14.1,t30,a)') coef % fc_speedl,'! speed of light (cm/s)'
- Write(file_id,'(1x,1p,e15.8,0p,f10.6,t30,a)') coef % fc_planck_c1, coef % fc_planck_c2,'! Planck constants'
- Write(file_id,'(1x,f8.1,t30,a)') coef % fc_sat_height,'! nominal satellite height (km)'
-
- If( coef % fastem_ver >= 1 ) Then
- section = 'FASTEM'
- Write(file_id,'(a)') ' ! ------------------------------------------------------'
- Write(file_id,'(a)') Trim(section)
- Write(file_id,'(a)') ' ! '
- Write(file_id,'(a)') ' ! S. English fast generic millimetre wave ocean emissivity model'
- Write(file_id,'(a)') ' ! Polarisation of each channel', &
- & ' ! MPOL=0: 0.5_JPRB*(V+H)', &
- & ' ! MPOL=1: polarisation angle=90-incidence angle', &
- & ' ! MPOL=2: polarisation angle=incidence angle', &
- & ' ! MPOL=3: vertical polarisation', &
- & ' ! MPOL=4: horizontal polarisation'
- Write(file_id,'(1x,i2,a)') coef % fastem_ver,' ! version number'
- Write(file_id,'(1x,i3,a)') coef % fastem_coef_nb,' ! number of coefficients'
- Write(file_id,'(5e14.6)') coef % fastem_coef
- Write(file_id,'(20i3)') (coef % fastem_polar(i), i= 1, coef % fmv_chn)
- Endif
-
- If( coef % ssirem_ver >= 1 ) Then
- section = 'SSIREM'
- Write(file_id,'(a)') ' ! ------------------------------------------------------'
- Write(file_id,'(a)') Trim(section)
- Write(file_id,'(a)') ' ! '
- Write(file_id,'(a)') ' ! Channel Number (from instrument original description)'
- Write(file_id,'(a)') ' ! 5 coefficients for emissivity model ssirem'
- Write(file_id,'(1x,i2,a)') coef % ssirem_ver,' ! version number'
-
- Do i = 1, coef % fmv_chn
- Write(file_id,'(1x,i4,3f12.7,2f4.1)') &
- & coef % ssirem_chn(i) , coef % ssirem_a0(i),&
- & coef % ssirem_a1(i) , coef % ssirem_a2(i),&
- & coef % ssirem_xzn1(i), coef % ssirem_xzn2(i)
- End Do
- Endif
-
- section = 'REFERENCE_PROFILE'
- Write(file_id,'(a)') ' ! ------------------------------------------------------'
- Write(file_id,'(a)') Trim(section)
- Write(file_id,'(a)') ' ! '
- Write(file_id,'(a)') ' ! Ref.pressure (hPa)'
- Write(file_id,'(a)') ' ! Ref.Temp (K) Ref.Volume Mixing Ratio [ppmv] for each gas'
- Write(file_id,'(a)') ' ! Note for MxG that mixing ratio is "missing"'
-
- Do i = 1, coef % fmv_gas
- Write(file_id,'(a)') ' ! '//gas_name( coef % fmv_gas_id( i ) )
- Do l = 1, coef % fmv_lvl(i)
- Write(file_id,'(1x,f8.3,2x,f7.3,1x,e13.6)')&
- & coef % ref_prfl_p(l), coef % ref_prfl_t(l,i), coef % ref_prfl_mr(l,i)
-!!$ & coef % ref_prfl_p(l), coef % ref_prfl_t(l,i), ref_mr(l,i)
- End Do
- End Do
-
- section = 'PROFILE_LIMITS'
- Write(file_id,'(a)') ' ! ------------------------------------------------------'
- Write(file_id,'(a)') Trim(section)
- Write(file_id,'(a)') ' ! '
- Write(file_id,'(a)') ' ! Ref.pressure (hPa)'
- Write(file_id,'(a)') ' ! Temp Max (K) Temp Min (K)'
- Write(file_id,'(a)') ' ! Volume Mixing Ratio for Max and Min [ppmv] for each gas'
- Write(file_id,'(a)') ' ! Temperature'
- Do l = 1, coef % fmv_lvl(1)
- Write(file_id,'(1x,f8.3,2(1x,f7.2))',iostat=io_status)&
- & coef % lim_prfl_p(l), coef % lim_prfl_tmax(l), coef % lim_prfl_tmin(l)
- End Do
-
- Do i = 1, coef % fmv_gas
- Write(file_id,'(a)') ' ! '//gas_name( coef % fmv_gas_id( i ) )
- Do l = 1, coef % fmv_lvl(i)
- Write(file_id,'(1x,f8.3,2x,e12.4,e12.4)',iostat=io_status)&
- & coef % lim_prfl_p(l), coef % lim_prfl_gmax(l,i), coef % lim_prfl_gmin(l,i)
- End Do
- End Do
-
-
- section = 'FAST_COEFFICIENTS'
- Write(file_id,'(a)') ' ! ------------------------------------------------------'
- Write(file_id,'(a)') Trim(section)
- Write(file_id,'(a)') ' ! '
- Write(file_id,'(a)') ' ! transmission coefficients'
- Write(file_id,'(a)') ' ! Order of the gases:'
- Do i = 1, coef % fmv_gas
- Write(file_id,'(a)') ' ! '//gas_name( coef % fmv_gas_id ( i ) )
- End Do
-
-
- Do l = 1, coef % fmv_gas
- Write(file_id,'(a)') gas_name( coef % fmv_gas_id( l ) )
-
- Select Case( coef % fmv_gas_id(l) )
-
- Case(gas_id_mixed)
- Write(file_id,'(5(1x,e15.8))',iostat=io_status) &
- & (((coef % mixedgas(i,j,k) &
- & ,i = 1, coef % fmv_lvl(l) ) &
- & ,j = 1, coef % fmv_chn ) &
- & ,k = 1, coef % fmv_var(l) )
- Case(gas_id_watervapour)
- Write(file_id,'(5(1x,e15.8))',iostat=io_status) &
- & (((coef % watervapour(i,j,k) &
- & ,i = 1, coef % fmv_lvl(l) ) &
- & ,j = 1, coef % fmv_chn ) &
- & ,k = 1, coef % fmv_var(l) )
- Case(gas_id_ozone)
- Write(file_id,'(5(1x,e15.8))',iostat=io_status) &
- & (((coef % ozone(i,j,k) &
- & ,i = 1, coef % fmv_lvl(l) ) &
- & ,j = 1, coef % fmv_chn ) &
- & ,k = 1, coef % fmv_var(l) )
- Case(gas_id_wvcont)
- Write(file_id,'(5(1x,e15.8))',iostat=io_status) &
- & (((coef % wvcont(i,j,k) &
- & ,i = 1, coef % fmv_lvl(l) ) &
- & ,j = 1, coef % fmv_chn ) &
- & ,k = 1, coef % fmv_var(l) )
- Case(gas_id_co2)
- Write(file_id,'(5(1x,e15.8))',iostat=io_status) &
- & (((coef % co2(i,j,k) &
- & ,i = 1, coef % fmv_lvl(l) ) &
- & ,j = 1, coef % fmv_chn ) &
- & ,k = 1, coef % fmv_var(l) )
- Case(gas_id_n2o)
- Write(file_id,'(5(1x,e15.8))',iostat=io_status) &
- & (((coef % n2o(i,j,k) &
- & ,i = 1, coef % fmv_lvl(l) ) &
- & ,j = 1, coef % fmv_chn ) &
- & ,k = 1, coef % fmv_var(l) )
- Case(gas_id_co)
- Write(file_id,'(5(1x,e15.8))',iostat=io_status) &
- & (((coef % co(i,j,k) &
- & ,i = 1, coef % fmv_lvl(l) ) &
- & ,j = 1, coef % fmv_chn ) &
- & ,k = 1, coef % fmv_var(l) )
- Case(gas_id_ch4)
- Write(file_id,'(5(1x,e15.8))',iostat=io_status) &
- & (((coef % ch4(i,j,k) &
- & ,i = 1, coef % fmv_lvl(l) ) &
- & ,j = 1, coef % fmv_chn ) &
- & ,k = 1, coef % fmv_var(l) )
- End Select
- End Do
-
- section = 'END'
- Write(file_id,'(a)') ' ! ------------------------------------------------------'
- Write(file_id,'(a)') Trim(section)
-
- Endif
-
- If( io_status /= 0 ) Then
- Write( errMessage, '( "write IO error")' )
- Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine)
- Return
- End If
-
-End Subroutine Rttov_writecoef
diff --git a/src/LIB/RTTOV/src/rttov_writecoef.interface b/src/LIB/RTTOV/src/rttov_writecoef.interface
deleted file mode 100644
index 384efe27c4528d3820f232265cae96cbb720116d..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttov_writecoef.interface
+++ /dev/null
@@ -1,35 +0,0 @@
-Interface
-!
-Subroutine Rttov_writecoef (errorstatus, coef, file_id, lbinary)
- Use rttov_const, Only : &
- rttov_magic_string ,&
- rttov_magic_number ,&
- errorstatus_success ,&
- errorstatus_fatal ,&
- errorstatus_info ,&
- gas_id_mixed ,&
- gas_id_watervapour ,&
- gas_id_ozone ,&
- gas_id_wvcont ,&
- gas_id_co2 ,&
- gas_id_n2o ,&
- gas_id_co ,&
- gas_id_ch4 ,&
- gas_name ,&
- gas_unit_name
-
- Use rttov_types, Only : &
- rttov_coef
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
- Integer(Kind=jpim), Intent (in) :: file_id ! file logical unit number
- Type( rttov_coef ), Intent (in) :: coef ! coefficients
- Logical, Optional, Intent (in) :: lbinary ! if binary file wanted
- Integer(Kind=jpim), Intent (out) :: errorstatus ! return code
-
-
-
-End Subroutine Rttov_writecoef
-End Interface
diff --git a/src/LIB/RTTOV/src/rttovcld.F90 b/src/LIB/RTTOV/src/rttovcld.F90
deleted file mode 100644
index aec36be0ac8a2e950c3910927226187ebe5a28cb..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttovcld.F90
+++ /dev/null
@@ -1,466 +0,0 @@
-!
-! Cloud package
-!
-SUBROUTINE RTTOVCLD &
- & (knch,knpf, klenpf, klevm, &
- & ppres, pangl, pangs, ksurf, ksat, knchpf,&
- & kchan, kprof, pav, psav, pssv, pcvm, pap, paph, &
- & pemis, ifail, prad, ptb, pradcld, ptbcld, tau, tausfc, &
- & pradovm, pcldemis, pait, pais, &
- & nfrequencies, nchannels, nbtout)
-!
-! This software was developed within the context of
-! the EUMETSAT Satellite Application Facility on
-! Numerical Weather Prediction (NWP SAF), under the
-! Cooperation Agreement dated 25 November 1998, between
-! EUMETSAT and the Met Office, UK, by one or more partners
-! within the NWP SAF. The partners in the NWP SAF are
-! the Met Office, ECMWF, KNMI and MeteoFrance.
-!
-! Copyright 2002, EUMETSAT, All Rights Reserved.
-!
-! Description:
-! to compute multi-channel radiances and brightness
-! temperatures for many profiles in cloudy sky.
-! Compatible with RTTOV8 library but only able to
-! run with coefficients created on RTTOV7 43 pressure levels
-!
-! Method
-! see Saunders et al QJ 1999 for the clear-sky part
-! see comments for cloudy sky part
-!
-! Current Code Owner: SAF NWP
-!
-! History:
-! Version Date Comment
-! ------- ---- -------
-! 03/2001 Initial version (F. Chevallier)
-! 19/7/2001 Version for testing RTTOV-7 (R. Saunders)
-! 01/12/2002 Keep compatibility with RTTOV8 (P Brunel)
-! 09/01/2003 Add polarisation (S English)
-!
-! Code Description:
-! Language: Fortran 90.
-! Software Standards: "European Standards for Writing and
-! Documenting Exchangeable Fortran 90 Code".
-!
-! Declarations:
-! Modules used:
-!
- Use rttov_const, only : &
- nplatforms ,&
- ninst ,&
- pi ,&
- errorstatus_fatal ,&
- errorstatus_warning ,&
- errorstatus_success ,&
- platform_name ,&
- sensor_id_mw ,&
- inst_name, &
- npolar_return, &
- npolar_compute
-
-
-
- Use rttov_types, only : &
- & rttov_coef ,&
- & geometry_Type ,&
- & profile_type ,&
- & profile_cloud_type ,&
- & radiance_cloud_type
-
- USE MOD_CPARAM, ONLY : &
- ! Imported Scalar Variables with intent (in):
- & njpnsat , &! Total max sats to be used
- & njplev , &! No. of pressure levels
- & njpnav , &! No. of profile variables
- & njpnsav , &! No. of surface air variables
- & njpnssv , &! No. of skin variables
- & njpncv , &! No. of cloud variables
- & q_mixratio_to_ppmv ,&
- & o3_mixratio_to_ppmv , &
- & coef
-
- Use parkind1, Only : jpim ,jprb
- IMPLICIT NONE
-#include "rttov_cld.interface"
-#include "rttov_errorreport.interface"
-#include "rttov_setupindex.interface"
-!#include "rttov_setupchan.interface"
-
- ! Subroutine arguments
- ! Scalar arguments with intent(in):
- Integer(Kind=jpim) , INTENT(in) :: knpf ! Number of profiles
- Integer(Kind=jpim) , INTENT(in) :: knch(knpf) ! Number of channels
- Integer(Kind=jpim) , INTENT(in) :: klenpf ! Length of input profile vectors
- Integer(Kind=jpim) , INTENT(in) :: ksat ! Satellite index (see rttvi)
- Integer(Kind=jpim) , INTENT(in) :: knchpf ! Number of output radiances
- ! (= channels used * profiles)
- Integer(Kind=jpim) , INTENT(in) :: klevm ! Number of model(native) levels
-
- ! Array arguments with intent(in):
- Integer(Kind=jpim) , INTENT(in) :: kchan(knchpf) ! Channel indices
- Integer(Kind=jpim) , INTENT(in) :: kprof(knchpf) ! Profiles indices
- Integer(Kind=jpim) , INTENT(in) :: ksurf(knpf) ! Surface type index
- Real(Kind=jprb) , INTENT(in) :: ppres(njplev) ! Pressure levels (hpa) of
- ! atmospheric profile vectors
-
-
- Real(Kind=jprb) , INTENT(in) :: pangl(knpf) ! Satellite local zenith angle (deg)
- Real(Kind=jprb) , INTENT(in) :: pangs(knpf) ! Solar zenith angle at surface (deg)
- Real(Kind=jprb) , INTENT(in) :: pav(njplev,njpnav,knpf)! Atmosp. profile variables
- Real(Kind=jprb) , INTENT(in) :: psav(njpnsav,knpf) ! Surface air variables
- Real(Kind=jprb) , INTENT(in) :: pssv(njpnssv,knpf) ! Surface skin variables
- Real(Kind=jprb) , INTENT(in) :: pap(knpf,klevm) ! Full-level model pressures (hPa) of
- ! atmospheric profile vectors
- Real(Kind=jprb) , INTENT(in) :: paph(knpf,klevm+1) ! Half-level model pressures (hPa) of
- ! atmospheric profile vectors
- Real(Kind=jprb) , INTENT(in) :: pcvm(knpf,klevm,4) ! Temperature and
- ! cloud variables on klevm layers
- ! 1 = temperature (K)
- ! 2 = cloud cover
- ! 3 = cloud liquid water (kg/kg)
- ! 4 = cloud ice water (kg/kg)
-
- ! Array arguments with intent(inout):
- Real(Kind=jprb) , INTENT(inout) :: pemis(knchpf) ! surface emissivities
-
- ! Scalar arguments with intent(out):
-
- ! Array arguments with intent(out):
- Integer(Kind=jpim) , INTENT(out) :: ifail(knpf,njpnsat) ! return flag
- ! 0 = input profile OK
- ! 11-19 = outside profile limits
- ! 11 = temp profile
- ! 12 = specific humidity profile
- ! 13 = ozone profile
- ! 14 = surface temp profile
- ! 15 = surface specific humidity profile
- ! 16 = surface wind
- ! 20-29 = unphysical profile
- ! 20 = input pressure levels wrong
- ! 21 = temp profile
- ! 22 = specific humidity profile
- ! 23 = ozone profile
- ! 24 = surface temp profile
- ! 25 = surface specific humidity profile
- ! 26 = surface wind
- ! 27 = surface pressure
-
- Real(Kind=jprb) , INTENT(out) :: prad(knchpf) ! clear-sky radiances (mw/cm-1/ster/sq.m)
- Real(Kind=jprb) , INTENT(out) :: ptb(knchpf) ! clear-sky brightness temperatures (K)
- Real(Kind=jprb) , INTENT(out) :: pradcld(knchpf) ! cloud-affected radiance
- Real(Kind=jprb) , INTENT(out) :: ptbcld(knchpf) ! cloud-affected brightness temperature
- Real(Kind=jprb) , INTENT(out) :: tau(knchpf,njplev) ! clear-sky transmittance from each
- ! standard pressure level
- Real(Kind=jprb) , INTENT(out) :: tausfc(knchpf) ! clear-sky transmittance from surface
- Real(Kind=jprb) , INTENT(out) :: pradovm(knchpf,2*klevm+2)
- ! RT quantities for cloud computation (see def. of radov in rttov.f90)
- ! on native levels
- Real(Kind=jprb) , INTENT(out) :: pcldemis(knchpf,klevm) ! cloud emissivity
- Real(Kind=jprb) , INTENT(out) :: pait(knchpf,klevm+1) ! toa weights of the cloud layers
- Real(Kind=jprb) , INTENT(out) :: pais(knchpf,klevm+1) ! surface weights of the cloud layers
-
-!
-
-
-! Local scalars
-!
- Integer(Kind=jpim) :: errorstatus(knpf)
- Integer(Kind=jpim) :: alloc_status(23)
-
- Character (len=80) :: errMessage
- Character (len=8) :: NameOfRoutine = 'rttovcld'
-!
-
-
-! Local arrays
-!
-
- Type( rttov_coef ), pointer :: coef_pointer ! coefficients
- Type(profile_type),allocatable :: profiles(:)
- Type(profile_cloud_type),allocatable :: cld_profiles(:)
- Type(radiance_cloud_type) :: cld_radiance
-
- Integer(Kind=jpim) :: i,ich2 ,ibtout,jch,nch,j,jpol,ilev
- integer(Kind=jpim) :: nbtout
- Integer(Kind=jpim) :: nchannels ! Number of internal radiances
- Integer(Kind=jpim) :: nfrequencies ! Number of output frequencies
- Integer(Kind=jpim), Allocatable :: polarisations (:,:)
- Integer(Kind=jpim), Allocatable :: frequencies (:)
- Integer(Kind=jpim), Allocatable :: channels (:)
- Integer(Kind=jpim), Allocatable :: lprofiles (:)
- Integer(Kind=jpim), Allocatable :: indexout (:)
-
-
- Real(Kind=jprb) :: pol_id
- Real(Kind=jprb), Allocatable :: emissivity (:)
- Real(Kind=jprb), Allocatable :: input_emissivity (:)
-
-
- Logical, Allocatable :: calcemis (:)
-
- Real(Kind=jprb), target :: p__p (coef(ksat)%nlevels,knpf)
- Real(Kind=jprb), target :: p__t (coef(ksat)%nlevels,knpf)
- Real(Kind=jprb), target :: p__q (coef(ksat)%nlevels,knpf)
- Real(Kind=jprb), target :: p__o3 (coef(ksat)%nlevels,knpf)
- Real(Kind=jprb), target :: p__clw (coef(ksat)%nlevels,knpf)
-
- Real(Kind=jprb), target :: cp__p (klevm,knpf)
- Real(Kind=jprb), target :: cp__ph (klevm+1,knpf)
- Real(Kind=jprb), target :: cp__t (klevm,knpf)
- Real(Kind=jprb), target :: cp__cc (klevm,knpf)
- Real(Kind=jprb), target :: cp__clw (klevm,knpf)
- Real(Kind=jprb), target :: cp__ciw (klevm,knpf)
-
-
- !- End of header ------------------------------------------------------
-
- !
- !-----------------------------------------------------------------
- !* 0. Initialisation
- ! --------------
-
- errorstatus(:) = 0
- alloc_status(:) = 0
-
- coef_pointer => coef(ksat)
-
- ! Set up various channel numbers required by RTTOV-8
-! Call rttov_setupchan(knpf ,knchpf ,coef(ksat ),nfrequencies, &
-! & nchannels,nbtout)
-
- ! total number of channels
- ! Memory allocation for RTTOV_Direct
- !-----------------------------------
- allocate( channels ( nfrequencies ) ,stat= alloc_status(1))
- allocate( lprofiles ( nfrequencies ) ,stat= alloc_status(1))
- allocate( polarisations(nchannels,3),stat= alloc_status(3))
- allocate( frequencies(nbtout),stat= alloc_status(4))
- allocate( indexout(nbtout),stat= alloc_status(5))
- allocate( input_emissivity(nchannels),stat= alloc_status(6))
- allocate( emissivity(nchannels),stat= alloc_status(7))
- allocate( profiles(knpf) ,stat= alloc_status(2))
- allocate( cld_profiles(knpf) ,stat= alloc_status(2))
-
- If( any(alloc_status /= 0) ) then
- ifail(:,:) = 20
- Write( errMessage, '( "mem allocation error")' )
- errorstatus(1) = errorstatus_fatal
- Call Rttov_ErrorReport (errorstatus(1), errMessage, NameOfRoutine)
- Return
- End If
-
-
-
-
- Do j = 1, knpf
- ! allocate model profiles atmospheric arrays with model levels dimension
- profiles(j) % p => p__p (:,j)
- profiles(j) % t => p__t (:,j)
- profiles(j) % q => p__q (:,j)
- profiles(j) % o3 => p__o3 (:,j)
- profiles(j) % clw => p__clw(:,j)
-
- cld_profiles(j) % p => cp__p (:,j)
- cld_profiles(j) % ph => cp__ph (:,j)
- cld_profiles(j) % t => cp__t (:,j)
- cld_profiles(j) % cc => cp__cc (:,j)
- cld_profiles(j) % clw => cp__clw (:,j)
- cld_profiles(j) % ciw => cp__ciw (:,j)
- End Do
-
- Do j = 1, knpf
-
- profiles(j) % nlevels = coef(ksat) % nlevels
- profiles(j) % p (:) = ppres(:)
- profiles(j) % t (:) = pav(:,1,j)
- profiles(j) % q (:) = pav(:,2,j) * q_mixratio_to_ppmv
- profiles(j) % o3 (:) = pav(:,3,j) * o3_mixratio_to_ppmv
- profiles(j) % clw (:) = pav(:,4,j)
- profiles(j) % ozone_data = .true.
- profiles(j) % co2_data = .false.
- profiles(j) % clw_data = .false. ! No cloud calc inside opdep
- profiles(j) % s2m % t = psav(1,j)
- profiles(j) % s2m % q = psav(2,j) * q_mixratio_to_ppmv
- profiles(j) % s2m % p = psav(3,j)
- profiles(j) % s2m % u = psav(4,j)
- profiles(j) % s2m % v = psav(5,j)
- profiles(j) % skin % t = pssv(1,j)
- profiles(j) % skin % fastem = 0._JPRB
- profiles(j) % skin % surftype= ksurf(j)
- profiles(j) % ctp = 500._JPRB ! default value
- profiles(j) % cfraction = 0._JPRB ! default value
- profiles(j) % zenangle = pangl(j)
- profiles(j) % azangle = 0._JPRB
-
-
- cld_profiles(j) % nlevels = klevm
- cld_profiles(j) % p (:) = pap (j,:)
- cld_profiles(j) % ph (:) = paph(j,:)
- cld_profiles(j) % t (:) = pcvm(j,:,1)
- cld_profiles(j) % cc (:) = pcvm(j,:,2)
- cld_profiles(j) % clw (:) = pcvm(j,:,3)
- cld_profiles(j) % ciw (:) = pcvm(j,:,4)
- cld_profiles(j) % kice = 1 ! choose ice cristals = aggregates
- cld_profiles(j) % kradip = 3 ! choose McFarquhar et al. for ice particle radius
-
- End Do
-
- allocate( calcemis ( nchannels ) ,stat= alloc_status(1))
-
- ! allocate radiance results arrays with number of channels
- allocate( cld_radiance % clear ( nchannels ) ,stat= alloc_status(3))
- allocate( cld_radiance % cloudy ( nchannels ) ,stat= alloc_status(4))
- allocate( cld_radiance % total ( nchannels ) ,stat= alloc_status(5))
- allocate( cld_radiance % bt ( nchannels ) ,stat= alloc_status(6))
- allocate( cld_radiance % bt_clear ( nchannels ) ,stat= alloc_status(7))
- allocate( cld_radiance % out ( nbtout ) ,stat= alloc_status(6))
- allocate( cld_radiance % out_clear ( nbtout ) ,stat= alloc_status(7))
- allocate( cld_radiance % clear_out ( nbtout ) ,stat= alloc_status(7))
- allocate( cld_radiance % total_out ( nbtout ) ,stat= alloc_status(7))
- allocate( cld_radiance % upclear ( nchannels ) ,stat= alloc_status(8))
- allocate( cld_radiance % dnclear ( nchannels ) ,stat= alloc_status(17))
- allocate( cld_radiance % reflclear( nchannels ) ,stat= alloc_status(9))
- allocate( cld_radiance % overcast ( klevm, nchannels ) ,stat= alloc_status(10))
- allocate( cld_radiance % downcld ( klevm, nchannels ) ,stat= alloc_status(11))
- allocate( cld_radiance % cldemis ( klevm, nchannels ) ,stat= alloc_status(12))
- allocate( cld_radiance % wtoa ( klevm, nchannels ) ,stat= alloc_status(13))
- allocate( cld_radiance % wsurf ( klevm, nchannels ) ,stat= alloc_status(14))
- allocate( cld_radiance % cs_wtoa ( nchannels ) ,stat= alloc_status(15))
- allocate( cld_radiance % cs_wsurf ( nchannels ) ,stat= alloc_status(16))
- If( any(alloc_status /= 0) ) then
- ifail(:,:) = 20
- Write( errMessage, '( "mem allocation error")' )
- errorstatus(1) = errorstatus_fatal
- Call Rttov_ErrorReport (errorstatus(1), errMessage, NameOfRoutine)
- Return
- End If
- ! Build the list of channels/profiles indices
- input_emissivity(:) = pemis(:)
- Call rttov_setupindex (knch ,knpf ,nfrequencies,nchannels,nbtout,coef(ksat ),&
- & input_emissivity,lprofiles,channels,polarisations,emissivity)
- !
- !save input values of emissivities for all calculations
- ! calculate emissivity where the input emissivity value is less than 0.01
- ! calcemis(:) = emissivity(:) < 0.01_JPRB
-
- Do j = 1,nchannels
- calcemis(j)=.false.
- if( emissivity(j) > 1.5_JPRB )calcemis(j)=.true.
- if( emissivity(j) < .01_JPRB )calcemis(j)=.true.
- End Do
-
- !
- Call rttov_cld( &
- & errorstatus, &! out
- & nfrequencies, &! in
- & nchannels, &! in
- & nbtout, &! in
- & knpf, &! in
- & kchan, &! in
- & polarisations, &! in
- & kprof, &! in
- & profiles, &! inout (to invalid clw absorption)
- & cld_profiles, &! in
- & coef_pointer, &! in
- & calcemis, &! in
- & emissivity, &! inout
- & cld_radiance ) ! inout
-
- tausfc(:) = -999._JPRB ! output not available anymore
- tau(:,:) = -999._JPRB ! output not available anymore
-
- Do j = 1, knpf
- If( errorstatus(j) == errorstatus_fatal ) then
- ifail(j,:) = 20 ! unphysical profile
- Else If( errorstatus(j) == errorstatus_warning ) then
- ifail(j,:) = 11 ! outside profile limits
- Else
- ifail(j,:) = 0
- End If
- End Do
-
- ptbcld(:) = cld_radiance % out(:)
- ptb(:) = cld_radiance % out_clear(:)
-
- If( coef(ksat) % id_sensor == sensor_id_mw) then
- Do j=1,nchannels
- jpol = polarisations(j,2)
-
- prad(jpol) = cld_radiance % clear(j)
- pradcld(jpol) = cld_radiance % total(j)
-
- pradovm(jpol,2*klevm+1) = cld_radiance % upclear (j)
- pradovm(jpol,2*klevm+2) = cld_radiance % reflclear(j)
- pais(jpol,klevm+1) = cld_radiance % cs_wsurf(j)
- pait(jpol,klevm+1) = cld_radiance % cs_wtoa (j)
-
- Do ilev = 1 , klevm
- pradovm(jpol,ilev ) = cld_radiance % overcast (ilev,j)
- pradovm(jpol,ilev +klevm) = cld_radiance % downcld (ilev,j)
- pcldemis(jpol,ilev) = cld_radiance % cldemis (ilev,j)
- pais(jpol,ilev) = cld_radiance % wsurf (ilev,j)
- pait(jpol,ilev ) = cld_radiance % wtoa (ilev,j)
- End Do
- End Do
- Else
- Do j = 1, nfrequencies
- prad(j) = cld_radiance % clear(j)
- pradcld(j) = cld_radiance % total(j)
-
- pradovm(j,2*klevm+1) = cld_radiance % upclear (j)
- pradovm(j,2*klevm+2) = cld_radiance % reflclear(j)
- pais(j,klevm+1) = cld_radiance % cs_wsurf(j)
- pait(j,klevm+1) = cld_radiance % cs_wtoa (j)
-
- Do ilev = 1 , klevm
- pradovm(j,ilev ) = cld_radiance % overcast (ilev,j)
- pradovm(j,ilev +klevm) = cld_radiance % downcld (ilev,j)
- pcldemis(j,ilev) = cld_radiance % cldemis (ilev,j)
- pais(j,ilev) = cld_radiance % wsurf (ilev,j)
- pait(j,ilev ) = cld_radiance % wtoa (ilev,j)
- End Do
- End Do
- Endif
-
- ifail(:,:) = 0
-
- deallocate( calcemis ,stat= alloc_status(1))
- deallocate( cld_radiance % clear ,stat= alloc_status(3))
- deallocate( cld_radiance % cloudy ,stat= alloc_status(4))
- deallocate( cld_radiance % total ,stat= alloc_status(5))
- deallocate( cld_radiance % bt ,stat= alloc_status(6))
- deallocate( cld_radiance % bt_clear ,stat= alloc_status(7))
- deallocate( cld_radiance % out ,stat= alloc_status(6))
- deallocate( cld_radiance % out_clear ,stat= alloc_status(7))
- deallocate( cld_radiance % clear_out ,stat= alloc_status(7))
- deallocate( cld_radiance % total_out ,stat= alloc_status(7))
- deallocate( cld_radiance % upclear ,stat= alloc_status(8))
- deallocate( cld_radiance % dnclear ,stat= alloc_status(17))
- deallocate( cld_radiance % reflclear ,stat= alloc_status(9))
- deallocate( cld_radiance % overcast ,stat= alloc_status(10))
- deallocate( cld_radiance % downcld ,stat= alloc_status(11))
- deallocate( cld_radiance % cldemis ,stat= alloc_status(12))
- deallocate( cld_radiance % wtoa ,stat= alloc_status(13))
- deallocate( cld_radiance % wsurf ,stat= alloc_status(14))
- deallocate( cld_radiance % cs_wtoa ,stat= alloc_status(15))
- deallocate( cld_radiance % cs_wsurf ,stat= alloc_status(16))
- deallocate(polarisations ,stat= alloc_status(17))
- deallocate(frequencies ,stat= alloc_status(18))
- deallocate(channels ,stat= alloc_status(19))
- deallocate(lprofiles ,stat= alloc_status(20))
- deallocate(indexout ,stat= alloc_status(21))
- deallocate(emissivity ,stat= alloc_status(22))
- deallocate(input_emissivity,stat= alloc_status(23))
- deallocate(cld_profiles ,stat= alloc_status(23))
- If( any(alloc_status /= 0) ) then
- ifail(:,:) = 20
- Write( errMessage, '( "mem allocation error")' )
- errorstatus(1) = errorstatus_fatal
- Call Rttov_ErrorReport (errorstatus(1), errMessage, NameOfRoutine)
- Return
- End If
-
-
-END SUBROUTINE RTTOVCLD
diff --git a/src/LIB/RTTOV/src/rttovcld.interface b/src/LIB/RTTOV/src/rttovcld.interface
deleted file mode 100644
index aa58538ca94ca8227c33f262246463321ea74e63..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttovcld.interface
+++ /dev/null
@@ -1,92 +0,0 @@
-Interface
-!+ Fast radiative transfer model.
-! Cloud package
-!
-SUBROUTINE RTTOVCLD &
- (knpf, klenpf, klevm, &
- ppres, pangl, pangs, ksurf, ksat, knchpf, knpzpf, knout,&
- kchan, kpol, kprof, pav, psav, pssv, pcvm, pap, paph, &
- pemis, ifail, prad, ptb, pradcld, ptbcld, tau, tausfc, &
- pradovm, pcldemis, pait, pais)
-!
-! This software was developed within the context of
-! the EUMETSAT Satellite Application Facility on
-! Numerical Weather Prediction (NWP SAF), under the
-! Cooperation Agreement dated 25 November 1998, between
-! EUMETSAT and the Met Office, UK, by one or more partners
-! within the NWP SAF. The partners in the NWP SAF are
-! the Met Office, ECMWF, KNMI and MeteoFrance.
-!
-! Copyright 2002, EUMETSAT, All Rights Reserved.
-!
-! Description:
-! to compute multi-channel radiances and brightness
-! temperatures for many profiles in cloudy sky.
-! Compatible with RTTOV8 library but only able to
-! run with coefficients created on RTTOV7 43 pressure levels
-!
-! Method
-! see Saunders et al QJ 1999 for the clear-sky part
-! see comments for cloudy sky part
-!
-! Current Code Owner: SAF NWP
-!
-! History:
-! Version Date Comment
-! ------- ---- -------
-! 03/2001 Initial version (F. Chevallier)
-! 19/7/2001 Version for testing RTTOV-7 (R. Saunders)
-! 01/12/2002 Keep compatibility with RTTOV8 (P Brunel)
-! 04/02/2004 Added polairmetry (R Saunders)
-
-! Code Description:
-! Language: Fortran 90.
-! Software Standards: "European Standards for Writing and
-! Documenting Exchangeable Fortran 90 Code".
-!
-! Declarations:
-! Modules used:
-!
- Use rttov_const, only : &
- errorstatus_warning ,&
- errorstatus_fatal
-
- Use rttov_types, only : &
- rttov_coef ,&
- geometry_Type ,&
- profile_type ,&
- profile_cloud_type ,&
- radiance_cloud_type
-
- USE MOD_CPARAM, ONLY : &
- njpnsat ,& ! Total max sats to be used
- njplev ,& ! No. of pressure levels
- njpnav ,& ! No. of profile variables
- njpnsav ,& ! No. of surface air variables
- njpnssv ,& ! No. of skin variables
- q_mixratio_to_ppmv ,&
- o3_mixratio_to_ppmv ,&
- coef
-
- Use parkind1, Only : jpim ,jprb
- IMPLICIT NONE
-
- Integer(Kind=jpim) , INTENT(in) :: knpf ! Number of profiles
- Integer(Kind=jpim) , INTENT(in) :: klenpf ! Length of input profile vectors
- Integer(Kind=jpim) , INTENT(in) :: ksat ! Satellite index (see rttvi)
- Integer(Kind=jpim) , INTENT(in) :: knchpf ! Number of output radiances
- ! (= channels used * profiles)
- Integer(Kind=jpim) , INTENT(in) :: klevm ! Number of model (native) levels
-
- Integer(Kind=jpim) , INTENT(in) :: kchan(knchpf) ! Channel indices
- Integer(Kind=jpim) , INTENT(in) :: kprof(knchpf) ! Profiles indices
- Integer(Kind=jpim) , INTENT(in) :: ksurf(knpf) ! Surface type index
- Real(Kind=jprb) , INTENT(in) :: ppres(njplev) ! Pressure levels (hpa) of
- ! atmospheric profile vectors
-
- INTEGER(Kind=jpim) , INTENT(in) :: knpzpf ! Number of output radiances
- INTEGER(Kind=jpim) , INTENT(in) :: knout ! Number of output radiances
- INTEGER(Kind=jpim) , INTENT(in) :: kpol(knchpf, 3)! Polarisation indices
-
-END SUBROUTINE RTTOVCLD
-End Interface
diff --git a/src/LIB/RTTOV/src/rttovcld_test.F90 b/src/LIB/RTTOV/src/rttovcld_test.F90
deleted file mode 100644
index 962f406fa737d3ab19b07f40cd2a68c02965b8e3..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttovcld_test.F90
+++ /dev/null
@@ -1,2020 +0,0 @@
-PROGRAM rttovcld_test
- !
- ! This software was developed within the context of
- ! the EUMETSAT Satellite Application Facility on
- ! Numerical Weather Prediction (NWP SAF), under the
- ! Cooperation Agreement dated 25 November 1998, between
- ! EUMETSAT and the Met Office, UK, by one or more partners
- ! within the NWP SAF. The partners in the NWP SAF are
- ! the Met Office, ECMWF, KNMI and MeteoFrance.
- !
- ! Copyright 2002, EUMETSAT, All Rights Reserved.
- !
- !
- ! Description:
- ! 1- read ECMWF profiles on model levels
- ! 2- interpolate the T, q, o3 profiles to the 43-level RTTOV grid
- ! 4- run rttovcld direct model
- ! 5- test TL, AD and K codes of the rttovcld package
- !
- ! Method:
- ! see comments in program
- !
- ! Current Code Owner: SAF NWP
- !
- ! History:
- ! Version Date Comment
- ! ------- ---- -------
- ! 03/2001 Initial version (F. Chevallier)
- ! 23/07/2001 Modified for use to test RTTOV-7 (R.Saunders)
- ! 01/12/2002 New F90 code with structures (P Brunel A Smith)
- ! 10/10/2003 Update cloud inputs + Further clean up +Add K (F. Chevallier)
- ! 03/02/2004 Merged in polarimetry code (R Saunders)
- !
- ! Code Description:
- ! Language: Fortran 90.
- ! Software Standards: "European Standards for Writing and
- ! Documenting Exchangeable Fortran 90 Code".
- !
- ! Declarations:
- ! Modules used:
- !
- Use rttov_const, only : &
- & errorstatus_fatal, &
- & errorstatus_success, &
- & default_err_unit, &
- & sensor_id_mw, &
- & npolar_return, &
- & npolar_compute
-
- Use rttov_types, only : &
- & geometry_type ,&
- & rttov_coef ,&
- & profile_type ,&
- & profile_cloud_type ,&
- & radiance_cloud_type
-
- Use parkind1, Only : jpim ,jprb
- IMPLICIT NONE
-#include "rttov_errorhandling.interface"
-#include "rttov_readcoeffs.interface"
-#include "rttov_initcoeffs.interface"
-#include "rttov_cld.interface"
-#include "rttov_cld_tl.interface"
-#include "rttov_cld_ad.interface"
-#include "rttov_cld_k.interface"
-#include "rttov_intex.interface"
-!#include "rttov_intext_prof.interface"
-
- ! Program arguments:
-
- ! Local parameters:
- Integer(Kind=jpim), parameter :: idim=100
- Integer(Kind=jpim), parameter :: nwp_levels=60
-
- type( rttov_coef ) :: coef ! (Only one instrument)
- type(profile_type), allocatable :: profiles(:)
- type(profile_type), allocatable :: input_profiles(:)
- type(profile_cloud_type), allocatable :: cld_profiles(:)
- type(radiance_cloud_type) :: radiance
- Real(Kind=jprb), Allocatable :: emissivity (:)
-
- ! Taylor test
- type(profile_type), allocatable :: profiles2(:)
- type(profile_cloud_type), allocatable :: cld_profiles2(:)
- type(radiance_cloud_type) :: radiance2
- Real(Kind=jprb), Allocatable :: emissivity2 (:)
-
- ! TL arrays
- type(profile_type), allocatable :: prof_inc(:)
- type(profile_cloud_type), allocatable :: cld_prof_inc(:)
- type(radiance_cloud_type) :: radiance_tl
- Real(Kind=jprb), Allocatable :: emissivity_inc (:)
-
- type(profile_type), allocatable :: prof_inc2(:)
- type(profile_cloud_type), allocatable :: cld_prof_inc2(:)
- type(radiance_cloud_type) :: radiance_tl2
- Real(Kind=jprb), Allocatable :: emissivity_inc2 (:)
-
- ! AD arrays
- type(profile_type), allocatable :: profiles_ad(:)
- type(profile_cloud_type), allocatable :: cld_profiles_ad(:)
- type(radiance_cloud_type) :: radiance_inc
- Real(Kind=jprb), Allocatable :: emissivity_ad (:)
-
- type(profile_type), allocatable :: profiles_ad2(:)
- type(profile_cloud_type), allocatable :: cld_profiles_ad2(:)
- type(radiance_cloud_type) :: radiance_inc2
- Real(Kind=jprb), Allocatable :: emissivity_ad2 (:)
-
- ! K arrays
- type(profile_type), allocatable :: profiles_k(:)
- type(profile_cloud_type), allocatable :: cld_profiles_k(:)
- type(radiance_cloud_type) :: cld_radiance_k
- Real(Kind=jprb), Allocatable :: emissivity_k (:)
-
- ! Local arrays:
- Real(Kind=jprb), allocatable :: emis(:)
- Integer(Kind=jpim), allocatable :: lchan(:)
-
- Integer(Kind=jpim) :: coef_errorstatus ! read coeffs error return code
- Integer(Kind=jpim), Allocatable :: rttov_errorstatus(:) ! rttov error return code
-
- integer(Kind=jpim) :: nbtout
- integer(Kind=jpim) :: nfrequencies
- Integer(Kind=jpim) :: nchannels
- Integer(Kind=jpim) :: nprofiles
- Integer(Kind=jpim), Allocatable :: channels (:)
- Integer(Kind=jpim), Allocatable :: lprofiles (:)
- Real(Kind=jprb), Allocatable :: input_emissivity (:)
- Real(Kind=jprb), Allocatable :: radiance_total_ref (:)
- integer(Kind=jpim), Allocatable :: polarisations (:,:)
- integer(Kind=jpim), Allocatable :: frequencies (:)
- logical, Allocatable :: calcemis (:)
-
- Real(Kind=jprb), dimension(nwp_levels) :: t, q, o3, co2, cc, clw, ciw
- !
- ! Local scalars:
- !Character (len=80) :: errMessage
- !Character (len=12) :: NameOfRoutine = 'rttovcld_test '
- Integer(Kind=jpim) :: j, jch2, jchan
- Integer(Kind=jpim) :: ioff
- Integer(Kind=jpim) :: kinrad
- Real(Kind=jprb) :: st, t2m, q2m, psurf, u10, v10, zenangle, azangle
- Real(Kind=jprb) :: rlsm, rlon, rlat
- Real(Kind=jprb) :: x, lambda, lambda0
- Real(Kind=jprb) :: ratio(4)
- Integer(Kind=jpim) :: jdat
- Integer(Kind=jpim) :: iyyyy, iyyyymm, iyyyymmdd
- Integer(Kind=jpim) :: iyear, imonth, iday, itime
- Integer(Kind=jpim) :: iatm, ichan
- Integer(Kind=jpim) :: iexp
- Integer(Kind=jpim) :: ioout, ioin
- Integer(Kind=jpim) :: ich, isatid, nch, ich2
- Integer(Kind=jpim) :: i, ii, nchan, kradip, kice
- Integer(Kind=jpim) :: lev , n, kpol
- Integer(Kind=jpim) :: ichannels, ibtout, jch, pol_id
- Logical :: switchrad ! true if input is BT
-
- Integer(Kind=jpim) :: instrument(3) ! instrument triplet
- Real(Kind=jprb) :: zdelta1, zdelta2
- Real(Kind=jprb) :: z, eps, threshold, prec_factor
-
- Integer(Kind=jpim) :: Err_Unit ! Logical error unit (<0 for default)
- Integer(Kind=jpim) :: verbosity_level ! (<0 for default)
- ! End of program arguments
-
- !-----End of header-----------------------------------------------------
-
- !Initialise error management with default value for
- ! the error unit number and
- ! Fatal error message output
- Err_unit = -1
- verbosity_level = 1
- call rttov_errorhandling(Err_unit, verbosity_level)
-
- ! Machine accuracy
- !eps = 1._JPRB
- !do while ((1+eps) > 1._JPRB)
- ! eps = eps /2._JPRB
- !enddo
- ! 'threshold' is the maximum difference which is tolerated
- ! between two real numbers for them to be considered equal
- ! On some systems, 'threshold' can be set to a value as low as 10*eps
- ! Some other systems are not rigorous enough and larger values
- ! for prec_factor have to be used. It is set as default as 10.
- !prec_factor = 1000000._JPRB ! Edit for your machine
- !prec_factor = 10._JPRB ! Edit for your machine
- !threshold = prec_factor * eps
-
- eps = 10._JPRB * epsilon( 1._JPRB )
- threshold = eps
-
- !
- write(*,*) 'Radiances(1) or Tbs(2)?'
- read(*,*) kinrad
- switchrad = kinrad == 2
-
- !
- ! Set satellite configuration
- ! only one satellite processed
- instrument(1)=1 ! NOAA
- write(*,*) ' NOAA sat id?'
- read(*,*) isatid
- instrument(2)=isatid
-
- !
- ! Choose instrument
- !
- write(*,*) ' HIRS (0) or AMSUA (3)?'
- read(*,*) instrument(3)
-
- ! Read coef file
- call rttov_readcoeffs (coef_errorstatus, coef, instrument)
- call rttov_initcoeffs (coef_errorstatus, coef)
- nchan=coef%fmv_chn
- if(coef_errorstatus /= errorstatus_success ) then
- write ( ioout, * ) 'rttov_readcoeffs fatal error'
- stop
- endif
-
- if( any(coef%ff_val_chn( 1 : coef%fmv_chn ) /= 1 )) then
- WRITE(*,*) ' some requested channels have bad validity parameter'
- do i = 1, coef%fmv_chn
- write(*,*) i, coef%ff_val_chn(i)
- end do
- endif
- !
- ! If infrared, choose absorption parameterisation
- !
- kradip=0
- kice=0
- if(coef%id_sensor == 1) then
- ! Choose ice particle radius parameterisation
- write(*,*) ' Ice particle radius from Ou and Liou (0), Wyser et al. (1), Boudala (2) or McFarquhar et al. (3)?'
- read(*,*) kradip
-
- ! Choose ice cristal shape
- write(*,*) ' Ice cristals: hexagonal columns (0) or aggregates (1)?'
- read(*,*) kice
- endif
- !
- ! Open files
- !
- ioin = 1
- open(ioin,file='profiles_fmt',form='formatted',status='old')
- ioout = 2
- open(ioout,file='outputcld.ascii',form='formatted')
-
- !
- ! Count number of profiles
- !
- do iatm = 1,idim
- do i = 1,38
- read(ioin,*,end=50)
- enddo
- enddo
-50 continue
- nprofiles = iatm - 1
- write(ioout,*) 'This dataset is made of ',nprofiles,' ECMWF model profiles'
- rewind(ioin)
- ! nprof = 65
- !
- ! Find out size of channel arrays summing all polarisation states required.
- nch = 0
- ichannels=0
- ibtout=0
- DO J=1,nprofiles
- DO JCH=1,NCHAN
- nch = nch +1
- If( coef%id_sensor /= sensor_id_mw) then
- ichannels=ichannels+1
- ibtout=ibtout+1
- End If
- If( coef % id_sensor == sensor_id_mw) then
- pol_id = coef % fastem_polar(jch) + 1
- ichannels=ichannels+npolar_compute(pol_id)
- ibtout=ibtout+npolar_return(pol_id)
- End If
- End Do
- End Do
- nchannels = ichannels
- nbtout = ibtout
- ! Set list of channels and corresponding emissivities
- ! (process all channels and let RTTOV compute the emissivity)
- !
- allocate(lchan (nchannels) )
- allocate(emis (nchannels) )
- emis(:) = 0._JPRB
- do i = 1 , nchannels
- lchan(i) = i
- enddo
- !
- ! Initialisations and allocations
- ! NO allocation for CO2 profiles
- !
- nfrequencies = nprofiles * nchan
- Allocate( channels ( nfrequencies ) )
- allocate( lprofiles ( nfrequencies ) )
- allocate( emissivity ( nchannels ) )
- allocate( frequencies ( nbtout ) )
- allocate( polarisations ( nchannels ,3) )
- allocate( input_emissivity ( nchannels ) )
- allocate( calcemis ( nchannels ) )
-
- allocate( rttov_errorstatus(nprofiles))
-
- ! Profiles on RTTOV pressure levels
- allocate( profiles(nprofiles))
- do j = 1, nprofiles
- ! allocate model profiles atmospheric arrays with model levels dimension
- profiles(j) % nlevels = coef % nlevels
- allocate( profiles(j) % p ( coef % nlevels ) )
- allocate( profiles(j) % t ( coef % nlevels ) )
- allocate( profiles(j) % q ( coef % nlevels ) )
- allocate( profiles(j) % o3 ( coef % nlevels ) )
- allocate( profiles(j) % clw( coef % nlevels ) )
- profiles(j) % p(:) = coef % ref_prfl_p(:)
- end do
-
- ! Profiles on NWP model pressure levels
- allocate(input_profiles(nprofiles))
- do j = 1, nprofiles
- ! allocate model profiles atmospheric arrays with model levels dimension
- input_profiles(j) % nlevels = nwp_levels
- allocate( input_profiles(j) % p ( nwp_levels ) )
- allocate( input_profiles(j) % t ( nwp_levels ) )
- allocate( input_profiles(j) % q ( nwp_levels ) )
- allocate( input_profiles(j) % o3 ( nwp_levels ) )
- allocate( input_profiles(j) % clw( nwp_levels ) )
- end do
-
- ! Cloud additional profiles
- allocate( cld_profiles(nprofiles))
- do j = 1, nprofiles
- ! allocate model profiles atmospheric arrays with model levels dimension
- cld_profiles(j) % nlevels = nwp_levels
- allocate( cld_profiles(j) % p ( nwp_levels ) )
- allocate( cld_profiles(j) % ph ( nwp_levels+1 ) )
- allocate( cld_profiles(j) % t ( nwp_levels ) )
- allocate( cld_profiles(j) % cc ( nwp_levels ) )
- allocate( cld_profiles(j) % clw( nwp_levels ) )
- allocate( cld_profiles(j) % ciw( nwp_levels ) )
- end do
-
- ! allocate radiance results arrays with number of channels
- allocate( radiance % clear ( nchannels ) )
- allocate( radiance % cloudy ( nchannels ) )
- allocate( radiance % total ( nchannels ) )
- allocate( radiance % bt ( nchannels ) )
- allocate( radiance % bt_clear ( nchannels ) )
- allocate( radiance % upclear ( nchannels ) )
- allocate( radiance % dnclear ( nchannels ) )
- allocate( radiance % reflclear( nchannels ) )
- allocate( radiance % overcast ( nwp_levels, nchannels ) )
- allocate( radiance % downcld ( nwp_levels, nchannels ) )
- allocate( radiance % cldemis ( nwp_levels, nchannels ) )
- allocate( radiance % wtoa ( nwp_levels, nchannels ) )
- allocate( radiance % wsurf ( nwp_levels, nchannels ) )
- allocate( radiance % cs_wtoa ( nchannels ) )
- allocate( radiance % cs_wsurf ( nchannels ) )
- allocate( radiance_total_ref ( nchannels ) )
- allocate( radiance % out ( nbtout ) )
- allocate( radiance % out_clear( nbtout ) )
- allocate( radiance % total_out( nbtout ) )
- allocate( radiance % clear_out( nbtout ) )
-
- !
- ! Read profile dataset
- !
-
- iatmloop : do iatm = 1,nprofiles
- read(ioin,'(i12)') jdat ! date yyyymmddhh
- read(ioin,'(10e16.6)') rlon, &! longitude (deg)
- & rlat, &! latitude (deg)
- & rlsm, &! land-sea mask (1=land)
- & st, &! surface temperature (K)
- & psurf, &! surface pressure (Pa)
- & t2m, &! 2-meter temperature (K)
- & q2m ! 2-meter specific humidity (kg/kg)
- read(ioin,'(10e16.6)') t ! temperature (K)
- read(ioin,'(10e16.6)') q ! specific humidity (kg/kg)
- read(ioin,'(10e16.6)') o3 ! specific ozone (kg/kg)
- read(ioin,'(10e16.6)') cc ! cloud cover
- read(ioin,'(10e16.6)') clw ! liquid water (kg/kg)
- read(ioin,'(10e16.6)') ciw ! ice water (kg/kg)
-
- u10 = 5._JPRB ! 10-meter wind speed u (m/s)
- v10 = 2._JPRB ! 10-meter wind speed v (m/s)
- zenangle = 10._JPRB ! zenith angle (deg)
- azangle = 0._JPRB ! azimuth angle
- q(:) = max(q,0._JPRB)
- clw(:) = max(clw,0._JPRB)
- ciw(:) = max(ciw,0._JPRB)
-
- !*process date
- iyyyymmdd = jdat/100
- itime = jdat - iyyyymmdd*100
- iyyyymm = iyyyymmdd/100
- iday = iyyyymmdd - iyyyymm*100
- iyyyy = iyyyymm/100
- imonth = iyyyymm - iyyyy*100
- iyear = iyyyy
-
- !*get model vertical pressures from surface pressure (all Pa)
- call ec_p60l( &
- & psurf ,&
- & cld_profiles( iatm ) % p ,&
- & cld_profiles( iatm ) % ph )
-
- ! Convert to hPa
- cld_profiles( iatm ) % p(:) = cld_profiles( iatm ) % p(:) /100._JPRB
- cld_profiles( iatm ) % ph(:) = cld_profiles( iatm ) % ph(:) /100._JPRB
-
- ! Move to structures
-! input_profiles( iatm ) % p(:) = cld_profiles( iatm ) % p(:)
-! input_profiles( iatm ) % t(:) = t(:)
-! input_profiles( iatm ) % q(:) = (q(:) / (1-q(:))) * 1.60771704 *1e+06
-! input_profiles( iatm ) % o3(:) = (o3(:) / (1-o3(:)))* 0.6034476 *1e+06
-! input_profiles( iatm ) % clw(:) = clw(:)
-! input_profiles( iatm ) % s2m % p = psurf/100.
-! input_profiles( iatm ) % s2m % q = (q2m / (1-q2m)) * 1.60771704*1e+06
-! input_profiles( iatm ) % s2m % o = input_profiles( iatm ) % o3(nwp_levels)
-! input_profiles( iatm ) % s2m % t = t2m
-! input_profiles( iatm ) % s2m % u = 5. ! constant for this run
-! input_profiles( iatm ) % s2m % v = 2. ! constant for this run
-! input_profiles( iatm ) % skin % surftype = Int(1.0 - rlsm)
-! input_profiles( iatm ) % skin % t = st
-! input_profiles( iatm ) % skin % fastem(:) = (/ 3.0, 5.0, 15.0, 0.1, 0.3 /)
-
-! input_profiles( iatm ) % ozone_data = .true.
-! input_profiles( iatm ) % co2_data = .false.
-! input_profiles( iatm ) % clw_data = .true.
-! input_profiles( iatm ) % zenangle = 0. ! Nadir view
-! input_profiles( iatm ) % ctp = 500. ! default value
-! input_profiles( iatm ) % cfraction = 0. ! default value
-!
-! ! convert input profile to RTTOV pressure levels
-! call rttov_intext_prof(input_profiles( iatm ), profiles( iatm ) )
-! ! CLW is not interpolated, but profiles(iatm)%clw
-! ! has been allocated, so give 0. value for clw for security
-! profiles( iatm ) % clw_data = .false.
-! profiles( iatm ) % clw(:) = 0.
-
- profiles( iatm ) % clw(:) = 0._JPRB ! warning
- profiles( iatm ) % o3 (:) = 0._JPRB ! warning
- profiles( iatm ) % s2m % p = psurf / 100._JPRB
- profiles( iatm ) % s2m % q = (q2m / (1-q2m)) * 1.60771704_JPRB*1e+06 ! ppmv
- profiles( iatm ) % s2m % o = 0._JPRB
- profiles( iatm ) % s2m % t = t2m
- profiles( iatm ) % s2m % u = u10
- profiles( iatm ) % s2m % v = v10
- profiles( iatm ) % skin % surftype = Int(1.0_JPRB - rlsm)
- profiles( iatm ) % skin % t = st
- profiles( iatm ) % skin % fastem(:) = (/ 3.0_JPRB, 5.0_JPRB, 15.0_JPRB, 0.1_JPRB, 0.3_JPRB /)
-
- profiles( iatm ) % ozone_data = .false. !!!!WARNING
- profiles( iatm ) % co2_data = .false.
- profiles( iatm ) % clw_data = .false.
- profiles( iatm ) % zenangle = zenangle
- profiles( iatm ) % azangle = azangle
- profiles( iatm ) % ctp = 500._JPRB ! default value
- profiles( iatm ) % cfraction = 0._JPRB ! default value
-
- cld_profiles( iatm ) % t(:) = t(:)
- cld_profiles( iatm ) % cc(:) = cc(:)
- cld_profiles( iatm ) % clw(:) = clw(:)
- cld_profiles( iatm ) % ciw(:) = ciw(:)
- cld_profiles( iatm ) % kice = kice
- cld_profiles( iatm ) % kradip = kradip
-
- ! convert q to ppmv
- q(:) = (q(:) / (1- q(:))) * 1.60771704_JPRB *1e+06
-
- ! convert input profile to RTTOV pressure levels
- call rttov_intex ( &
- & nwp_levels, &
- & coef%nlevels, &
- & cld_profiles(iatm) % p, &
- & profiles(iatm) % p, &
- & t(:), &
- & profiles(iatm) % t)
- call rttov_intex ( &
- & nwp_levels, &
- & coef%nlevels, &
- & cld_profiles(iatm) % p, &
- & profiles(iatm) % p, &
- & q(:), &
- & profiles(iatm) % q)
-
- enddo iatmloop
-
- close(ioin)
-
- ! Channel, profile list and emissivity arrays
- nch = 0
- ichannels=0
- ibtout=0
- DO iatm = 1, nprofiles
- ioff = (iatm - 1) * nchan
- channels(1+ioff:nchan+ioff) = lchan(1:nchan)
- lprofiles(1+ioff:nchan+ioff) = iatm
- !
- DO JCH=1,nchan
- nch = nch +1
- polarisations(nch,1)=ichannels+1
- If( coef % id_sensor /= sensor_id_mw) then
- ! Note if input polarisation used this is only valid for a single polarisation option.
- emissivity( ichannels+1 ) = emis(jch)
- ichannels=ichannels+1
- polarisations(nch,2) = nch
- polarisations(nch,3) = 1
- frequencies(ibtout+1) = nch
- ibtout=ibtout+1
- End If
- If( coef% id_sensor == sensor_id_mw) then
- pol_id = coef % fastem_polar(jch) + 1
- Do ich2=1,npolar_compute(pol_id)
- emissivity(ichannels+ich2)=emis(jch)
- enddo
- Do n=ichannels+1,ichannels+npolar_compute(pol_id)
- polarisations(n,2)=nch
- End Do
- ichannels=ichannels+npolar_compute(pol_id)
- Do i=1, npolar_return(pol_id)
- frequencies(ibtout+i)=nch
- End Do
- polarisations(nch,3)=npolar_compute(pol_id)
- ! Note if input polarisation used this is only valid for a single polarisation option.
- ! We will need to know which frequency each element in the output array corresponds to
- ibtout=ibtout+npolar_return(pol_id)
- End If
- End Do
- End do
- nchannels = ichannels
- nbtout = ibtout
- calcemis(:) = emissivity(:) < 0.01_JPRB
- input_emissivity(:) = emissivity(:)
-
- !
- ! Call RTTOV_CLD
- !
-
- write(ioout,*)
- write(ioout,*) 'Call to RTTOV_CLD'
- write(ioout,*) '-----------------'
- write(ioout,*)
- write(6,*)' nfreq=',nfrequencies,' nchannels=',nchannels,' nbtout=',nbtout
-
- Call rttov_cld( &
- & rttov_errorstatus, &! out
- & nfrequencies, &! in
- & nchannels, &! in
- & nbtout, &! in
- & nprofiles, &! in
- & channels, &! in
- & polarisations, &! in
- & lprofiles, &! in
- & profiles, &! inout (to invalid clw absorption)
- & cld_profiles, &! in
- & coef, &! in
- & calcemis, &! in
- & emissivity, &! inout
- & radiance ) ! inout
-
- If ( any( rttov_errorstatus(:) == errorstatus_fatal ) ) Then
- Do iatm = 1, nprofiles
- If ( rttov_errorstatus(iatm) == errorstatus_fatal ) Then
- write ( ioout, * ) 'rttov_cld error for profile',iatm
- End If
- End Do
- Stop
- End If
-
- ! main output:
- !
- ! radiance%total_out = cloud-affected radiances
- ! radiance%clear_out = clear-sky radiances
- ! radiance%out = cloud-affected Tbs
- ! radiance%out_clear = clear-sky Tbs
- !
-
- if (kinrad == 2) then
- write(ioout,*) 'Channel cloudy Tb clear Tb'
- do ichan = 1, nbtout
- write(ioout,'(i4,3x,30e23.16)') &
- & ichan ,&
- & radiance%out(ichan) ,&
- & radiance%out_clear(ichan)
- enddo
- else
- write(ioout,*) 'Channel cloudy Rad clear Rad'
- do ichan = 1, nbtout
- write(ioout,'(i4,3x,30e23.16)') &
- & ichan ,&
- & radiance%total_out(ichan) ,&
- & radiance%clear_out(ichan)
- enddo
- endif
-! go to 9999 !#########
- !---------------------------------------------------------------------
- ! Test of TL
- !---------------------------------------------------------------------
- write(ioout,*)
- write(ioout,*) 'Test TL'
- write(ioout,*) '-------'
- write(ioout,*)
-
- ! Set perturbation of initial profile
- lambda0 = 0.01_JPRB
- !
- allocate ( prof_inc( nprofiles ))
- allocate ( cld_prof_inc( nprofiles ))
- Do j = 1, nprofiles
- prof_inc(j) % nlevels = coef % nlevels
- allocate( prof_inc(j) % p ( coef % nlevels ) )
- allocate( prof_inc(j) % t ( coef % nlevels ) )
- allocate( prof_inc(j) % q ( coef % nlevels ) )
- allocate( prof_inc(j) % o3 ( coef % nlevels ) )
- allocate( prof_inc(j) % clw( coef % nlevels ) )
-
- prof_inc(j) % ozone_Data = .False. ! no meaning
- prof_inc(j) % co2_Data = .False. ! no meaning
- prof_inc(j) % clw_Data = .False. ! no meaning
- prof_inc(j) % zenangle = -1 ! no meaning
- prof_inc(j) % azangle = -1 ! no meaning
-
- ! increments for atmospheric variables
- prof_inc(j) % p(:) = 0._JPRB ! no tl on pressure levels
- prof_inc(j) % t(:) = profiles(j) % t(:) *lambda0
- prof_inc(j) % o3(:) = profiles(j) % o3(:) *lambda0
- prof_inc(j) % clw(:) = profiles(j) % clw(:)*lambda0
- prof_inc(j) % q(:) = profiles(j) % q(:) *lambda0
-
- ! increments for air surface variables
- prof_inc(j) % s2m % t = profiles(j) % s2m % t *lambda0
- prof_inc(j) % s2m % q = profiles(j) % s2m % q *lambda0
- prof_inc(j) % s2m % p = profiles(j) % s2m % p *lambda0
- prof_inc(j) % s2m % u = profiles(j) % s2m % u *lambda0
- prof_inc(j) % s2m % v = profiles(j) % s2m % v *lambda0
-
- ! increments for skin variables
- prof_inc(j) % skin % surftype = -1 ! no meaning
- prof_inc(j) % skin % t = profiles(j) % skin % t *lambda0
- prof_inc(j) % skin % fastem(:)= profiles(j) % skin % fastem(:) *lambda0
-
- ! increments for cloud variables
- prof_inc(j) % ctp = profiles(j) % ctp *lambda0
- prof_inc(j) % cfraction = profiles(j) % cfraction *lambda0
-
- ! increments for cloud variables
- cld_prof_inc(j) % nlevels = nwp_levels
- allocate( cld_prof_inc(j) % p ( nwp_levels ) )
- allocate( cld_prof_inc(j) % ph ( nwp_levels+1 ) )
- allocate( cld_prof_inc(j) % t ( nwp_levels ) )
- allocate( cld_prof_inc(j) % cc ( nwp_levels ) )
- allocate( cld_prof_inc(j) % clw( nwp_levels ) )
- allocate( cld_prof_inc(j) % ciw( nwp_levels ) )
- cld_prof_inc(j) % p(:) = cld_profiles(j) % p(:) *lambda0
- cld_prof_inc(j) % ph(:) = cld_profiles(j) % ph(:) *lambda0
- cld_prof_inc(j) % t(:) = cld_profiles(j) % t(:) *lambda0
- cld_prof_inc(j) % cc(:) = cld_profiles(j) % cc(:) *lambda0
- cld_prof_inc(j) % clw(:) = cld_profiles(j) % clw(:) *lambda0
- cld_prof_inc(j) % ciw(:) = cld_profiles(j) % ciw(:) *lambda0
- End Do
-
- ! emissivity
- allocate( emissivity_inc( nchannels ))
- emissivity_inc(:) = emissivity(:) * lambda0
- ! The set up of rttov_calcemis_mw_tl prevents any straightforwrd TL and AD
- ! test with calcemis(:) = true. So set it to false.
- calcemis(:) = .false.
-
- ! allocate radiance results arrays with number of channels
- allocate( radiance_tl % clear ( nchannels ) )
- allocate( radiance_tl % cloudy ( nchannels ) )
- allocate( radiance_tl % total ( nchannels ) )
- allocate( radiance_tl % bt ( nchannels ) )
- allocate( radiance_tl % bt_clear ( nchannels ) )
- allocate( radiance_tl % out ( nbtout ) )
- allocate( radiance_tl % out_clear ( nbtout ) )
- allocate( radiance_tl % total_out ( nbtout ) )
- allocate( radiance_tl % clear_out ( nbtout ) )
- allocate( radiance_tl % upclear ( nchannels ) )
- allocate( radiance_tl % reflclear( nchannels ) )
- allocate( radiance_tl % overcast ( nwp_levels, nchannels ) )
- allocate( radiance_tl % downcld ( nwp_levels, nchannels ) )
- allocate( radiance_tl % cldemis ( nwp_levels, nchannels ) )
- allocate( radiance_tl % wtoa ( nwp_levels, nchannels ) )
- allocate( radiance_tl % wsurf ( nwp_levels, nchannels ) )
- allocate( radiance_tl % cs_wtoa ( nchannels ) )
- allocate( radiance_tl % cs_wsurf ( nchannels ) )
-
- !---------------------------
- Call Rttov_cld_tl ( &
- & rttov_errorstatus, &! out
- & nfrequencies, &! in
- & nchannels, &! in
- & nbtout, &! in
- & nprofiles, &! in
- & channels, &! in
- & polarisations, &! in
- & lprofiles, &! in
- & profiles, &! in
- & cld_profiles, &! in
- & coef, &! in
- & calcemis, &! in
- & emissivity, &! inout
- & prof_inc, &! in
- & cld_prof_inc, &! in
- & emissivity_inc, &! inout
- & radiance, &! inout
- & radiance_tl ) ! inout
-
- If ( any( rttov_errorstatus(:) == errorstatus_fatal ) ) Then
- Do iatm = 1, nprofiles
- If ( rttov_errorstatus(iatm) == errorstatus_fatal ) Then
- write ( ioout, * ) 'rttov_cld_tl error for profile',iatm
- End If
- End Do
- Stop
- End If
-
- ! Save radiance as a reference for the trajectory
- ! TL is used instead of rttov_cld because
- ! calcemis = F and reflectivities have not been saved
- radiance_total_ref(:) = radiance%total(:)
-
- !---------------------------
- ! second run of TL
- !---------------------------
- lambda = 0.5_JPRB
- allocate ( prof_inc2( nprofiles ))
- allocate ( cld_prof_inc2( nprofiles ))
- Do j = 1, nprofiles
- prof_inc2(j) % nlevels = coef % nlevels
- allocate( prof_inc2(j) % p ( coef % nlevels ) )
- allocate( prof_inc2(j) % t ( coef % nlevels ) )
- allocate( prof_inc2(j) % q ( coef % nlevels ) )
- allocate( prof_inc2(j) % o3 ( coef % nlevels ) )
- allocate( prof_inc2(j) % clw( coef % nlevels ) )
-
- prof_inc2(j) % ozone_Data = .False. ! no meaning
- prof_inc2(j) % co2_Data = .False. ! no meaning
- prof_inc2(j) % clw_Data = .False. ! no meaning
- prof_inc2(j) % zenangle = -1 ! no meaning
- prof_inc2(j) % azangle = -1 ! no meaning
-
- ! increments for atmospheric variables
- prof_inc2(j) % p(:) = 0._JPRB ! no tl on pressure levels
- prof_inc2(j) % t(:) = prof_inc(j) % t(:) *lambda
- prof_inc2(j) % o3(:) = prof_inc(j) % o3(:) *lambda
- prof_inc2(j) % clw(:) = prof_inc(j) % clw(:)*lambda
- prof_inc2(j) % q(:) = prof_inc(j) % q(:) *lambda
-
- ! increments for air surface variables
- prof_inc2(j) % s2m % t = prof_inc(j) % s2m % t *lambda
- prof_inc2(j) % s2m % q = prof_inc(j) % s2m % q *lambda
- prof_inc2(j) % s2m % p = prof_inc(j) % s2m % p *lambda
- prof_inc2(j) % s2m % u = prof_inc(j) % s2m % u *lambda
- prof_inc2(j) % s2m % v = prof_inc(j) % s2m % v *lambda
-
- ! increments for skin variables
- prof_inc2(j) % skin % surftype = -1 ! no meaning
- prof_inc2(j) % skin % t = prof_inc(j) % skin % t *lambda
- prof_inc2(j) % skin % fastem(:)= prof_inc(j) % skin % fastem(:) *lambda
-
- ! increments for cloud variables
- prof_inc2(j) % ctp = prof_inc(j) % ctp *lambda
- prof_inc2(j) % cfraction = prof_inc(j) % cfraction *lambda
-
- ! increments for cloud variables
- cld_prof_inc2(j) % nlevels = nwp_levels
- allocate( cld_prof_inc2(j) % p ( nwp_levels ) )
- allocate( cld_prof_inc2(j) % ph ( nwp_levels+1 ) )
- allocate( cld_prof_inc2(j) % t ( nwp_levels ) )
- allocate( cld_prof_inc2(j) % cc ( nwp_levels ) )
- allocate( cld_prof_inc2(j) % clw( nwp_levels ) )
- allocate( cld_prof_inc2(j) % ciw( nwp_levels ) )
- cld_prof_inc2(j) % p(:) = cld_prof_inc(j) % p(:) *lambda
- cld_prof_inc2(j) % ph(:) = cld_prof_inc(j) % ph(:) *lambda
- cld_prof_inc2(j) % t(:) = cld_prof_inc(j) % t(:) *lambda
- cld_prof_inc2(j) % cc(:) = cld_prof_inc(j) % cc(:) *lambda
- cld_prof_inc2(j) % clw(:) = cld_prof_inc(j) % clw(:) *lambda
- cld_prof_inc2(j) % ciw(:) = cld_prof_inc(j) % ciw(:) *lambda
- End Do
-
- ! emissivity
- allocate( emissivity_inc2( nchannels ))
- emissivity_inc2(:) = emissivity_inc(:) * lambda
- calcemis(:) = .false.
-
- ! allocate radiance results arrays with number of channels
- allocate( radiance_tl2 % clear ( nchannels ) )
- allocate( radiance_tl2 % cloudy ( nchannels ) )
- allocate( radiance_tl2 % total ( nchannels ) )
- allocate( radiance_tl2 % bt ( nchannels ) )
- allocate( radiance_tl2 % bt_clear ( nchannels ) )
- allocate( radiance_tl2 % out ( nbtout ) )
- allocate( radiance_tl2 % out_clear ( nbtout ) )
- allocate( radiance_tl2 % total_out ( nbtout ) )
- allocate( radiance_tl2 % clear_out ( nbtout ) )
- allocate( radiance_tl2 % upclear ( nchannels ) )
- allocate( radiance_tl2 % reflclear( nchannels ) )
- allocate( radiance_tl2 % overcast ( nwp_levels, nchannels ) )
- allocate( radiance_tl2 % downcld ( nwp_levels, nchannels ) )
- allocate( radiance_tl2 % cldemis ( nwp_levels, nchannels ) )
- allocate( radiance_tl2 % wtoa ( nwp_levels, nchannels ) )
- allocate( radiance_tl2 % wsurf ( nwp_levels, nchannels ) )
- allocate( radiance_tl2 % cs_wtoa ( nchannels ) )
- allocate( radiance_tl2 % cs_wsurf ( nchannels ) )
-
- !---------------------------
- Call Rttov_cld_tl ( &
- & rttov_errorstatus, &! out
- & nfrequencies, &! in
- & nchannels, &! in
- & nbtout, &! in
- & nprofiles, &! in
- & channels, &! in
- & polarisations, &! in
- & lprofiles, &! in
- & profiles, &! in
- & cld_profiles, &! in
- & coef, &! in
- & calcemis, &! in
- & emissivity, &! inout
- & prof_inc2, &! in
- & cld_prof_inc2, &! in
- & emissivity_inc2, &! inout
- & radiance, &! inout
- & radiance_tl2 ) ! inout
-
- If ( any( rttov_errorstatus(:) == errorstatus_fatal ) ) Then
- Do iatm = 1, nprofiles
- If ( rttov_errorstatus(iatm) == errorstatus_fatal ) Then
- write ( ioout, * ) 'rttov_cld_tl error for profile',iatm
- End If
- End Do
- Stop
- End If
-
- !---------------------------
-
- do ichan = 1, nchannels
- if( abs(lambda * radiance_tl%total(ichan) - radiance_tl2%total(ichan)) > threshold ) then
- write(default_err_unit,*) 'TL test fails for radiance_tl%total for channel ', ichan
- stop
- endif
- if( abs(lambda * radiance_tl%clear(ichan) - radiance_tl2%clear(ichan)) > threshold ) then
- write(default_err_unit,*) 'TL test fails for radiance_tl%clear for channel ', ichan
- stop
- endif
- if( abs(lambda * radiance_tl%bt(ichan) - radiance_tl2%bt(ichan)) > threshold ) then
- write(default_err_unit,*) 'TL test fails for radiance_tl%bt for channel ', ichan
- stop
- endif
- if( abs(lambda * radiance_tl%bt_clear(ichan) - radiance_tl2%bt_clear(ichan)) > threshold ) then
- write(default_err_unit,*) 'TL test fails for radiance_tl%bt for channel ', ichan
- stop
- endif
-
- end do
-
-
- ! Now run the Taylor test
- !-------------------------
-
- !Allocate new profiles for direct code
- ! Profiles on RTTOV pressure levels
- allocate( profiles2(nprofiles))
- do j = 1, nprofiles
- ! allocate model profiles atmospheric arrays with model levels dimension
- profiles2(j) % nlevels = coef % nlevels
- allocate( profiles2(j) % p ( coef % nlevels ) )
- allocate( profiles2(j) % t ( coef % nlevels ) )
- allocate( profiles2(j) % q ( coef % nlevels ) )
- allocate( profiles2(j) % o3 ( coef % nlevels ) )
- allocate( profiles2(j) % clw( coef % nlevels ) )
- profiles2(j) % p(:) = coef % ref_prfl_p(:)
- end do
-
- ! Cloud additional profiles
- allocate( cld_profiles2(nprofiles))
- do j = 1, nprofiles
- ! allocate model profiles atmospheric arrays with model levels dimension
- cld_profiles2(j) % nlevels = nwp_levels
- allocate( cld_profiles2(j) % p ( nwp_levels ) )
- allocate( cld_profiles2(j) % ph ( nwp_levels+1 ) )
- allocate( cld_profiles2(j) % t ( nwp_levels ) )
- allocate( cld_profiles2(j) % cc ( nwp_levels ) )
- allocate( cld_profiles2(j) % clw( nwp_levels ) )
- allocate( cld_profiles2(j) % ciw( nwp_levels ) )
- end do
-
- allocate( emissivity2( nchannels ))
-
- ! allocate radiance results arrays with number of channels
- allocate( radiance2 % clear ( nchannels ) )
- allocate( radiance2 % cloudy ( nchannels ) )
- allocate( radiance2 % total ( nchannels ) )
- allocate( radiance2 % bt ( nchannels ) )
- allocate( radiance2 % bt_clear ( nchannels ) )
- allocate( radiance2 % out ( nbtout ) )
- allocate( radiance2 % out_clear ( nbtout ) )
- allocate( radiance2 % total_out ( nbtout ) )
- allocate( radiance2 % clear_out ( nbtout ) )
- allocate( radiance2 % upclear ( nchannels ) )
- allocate( radiance2 % dnclear ( nchannels ) )
- allocate( radiance2 % reflclear( nchannels ) )
- allocate( radiance2 % overcast ( nwp_levels, nchannels ) )
- allocate( radiance2 % downcld ( nwp_levels, nchannels ) )
- allocate( radiance2 % cldemis ( nwp_levels, nchannels ) )
- allocate( radiance2 % wtoa ( nwp_levels, nchannels ) )
- allocate( radiance2 % wsurf ( nwp_levels, nchannels ) )
- allocate( radiance2 % cs_wtoa ( nchannels ) )
- allocate( radiance2 % cs_wsurf ( nchannels ) )
-
- do j = 1, nprofiles
- cld_profiles2(j) % kice = cld_profiles(j) % kice
- cld_profiles2(j) % kradip = cld_profiles(j) % kradip
- enddo
-
-! Goto 1000
-
- Do ichan = 1, nchannels
-
- write(ioout,*)
- write(ioout,*) '(Profile x channel) no. ',ichan
- write(ioout,*) ' Lambda Clear Rad Cloudy Rad' &
- & //' Clear Tb Cloudy Tb'
- do iexp = -10, 0
- lambda = 10**(real(iexp))
-
- do j = 1, nprofiles
- profiles2(j) % ozone_Data = profiles(j) % ozone_Data
- profiles2(j) % co2_Data = profiles(j) % co2_Data
- profiles2(j) % clw_Data = profiles(j) % clw_Data
- profiles2(j) % zenangle = profiles(j) % zenangle
- profiles2(j) % azangle = profiles(j) % azangle
-
- ! increments for atmospheric variables
- profiles2(j) % p(:) = profiles(j) % p(:)
- profiles2(j) % t(:) = profiles(j) % t(:) + prof_inc(j) % t(:) *lambda
- profiles2(j) % o3(:) = profiles(j) % o3(:) + prof_inc(j) % o3(:) *lambda
- profiles2(j) % clw(:) = profiles(j) % clw(:)+ prof_inc(j) % clw(:)*lambda
- profiles2(j) % q(:) = profiles(j) % q(:) + prof_inc(j) % q(:) *lambda
-
- ! increments for air surface variables
- profiles2(j) % s2m % t = profiles(j) % s2m % t + prof_inc(j) % s2m % t *lambda
- profiles2(j) % s2m % q = profiles(j) % s2m % q + prof_inc(j) % s2m % q *lambda
- profiles2(j) % s2m % p = profiles(j) % s2m % p + prof_inc(j) % s2m % p *lambda
- profiles2(j) % s2m % u = profiles(j) % s2m % u + prof_inc(j) % s2m % u *lambda
- profiles2(j) % s2m % v = profiles(j) % s2m % v + prof_inc(j) % s2m % v *lambda
-
- ! increments for skin variables
- profiles2(j) % skin % surftype = profiles(j) % skin % surftype
- profiles2(j) % skin % t = profiles(j) % skin % t + prof_inc(j) % skin % t *lambda
- profiles2(j) % skin % fastem(:)= profiles(j) % skin % fastem(:) + prof_inc(j) % skin % fastem(:) *lambda
-
- ! increments for cloud variables
- profiles2(j) % ctp = profiles(j) % ctp + prof_inc(j) % ctp *lambda
- profiles2(j) % cfraction = profiles(j) % cfraction + prof_inc(j) % cfraction *lambda
-
- ! increments for cloud variables
- cld_profiles2(j) % nlevels = nwp_levels
- cld_profiles2(j) % p(:) = cld_profiles(j) % p(:) + cld_prof_inc(j) % p(:) *lambda
- cld_profiles2(j) % ph(:) = cld_profiles(j) % ph(:) + cld_prof_inc(j) % ph(:) *lambda
- cld_profiles2(j) % t(:) = cld_profiles(j) % t(:) + cld_prof_inc(j) % t(:) *lambda
- cld_profiles2(j) % cc(:) = cld_profiles(j) % cc(:) + cld_prof_inc(j) % cc(:) *lambda
- cld_profiles2(j) % clw(:) = cld_profiles(j) % clw(:) + cld_prof_inc(j) % clw(:) *lambda
- cld_profiles2(j) % ciw(:) = cld_profiles(j) % ciw(:) + cld_prof_inc(j) % ciw(:) *lambda
- end do
- emissivity2(:) = emissivity(:) + emissivity_inc(:) * lambda
- calcemis(:) = .false.
-
- !---------------------------
- Call rttov_cld( &
- & rttov_errorstatus, &! out
- & nfrequencies, &! in
- & nchannels, &! in
- & nbtout, &! in
- & nprofiles, &! in
- & channels, &! in
- & polarisations, &! in
- & lprofiles, &! in
- & profiles2, &! inout (to invalid clw absorption)
- & cld_profiles2, &! in
- & coef, &! in
- & calcemis, &! in
- & emissivity2, &! inout
- & radiance2 ) ! inout
-
- If ( any( rttov_errorstatus(:) == errorstatus_fatal ) ) Then
- Do iatm = 1, nprofiles
- If ( rttov_errorstatus(iatm) == errorstatus_fatal ) Then
- write ( ioout, * ) 'rttov_cld error for profile',iatm
- End If
- End Do
- Stop
- End If
-
- !---------------------------
-
- ratio(1) = (radiance2 % clear(ichan) - radiance % clear(ichan)) / (lambda * radiance_tl % clear(ichan))
- ratio(2) = (radiance2 % total(ichan) - radiance % total(ichan)) / (lambda * radiance_tl % total(ichan))
- ratio(3) = (radiance2 % bt_clear(ichan) - radiance % bt_clear(ichan)) / (lambda * radiance_tl % bt_clear(ichan))
- ratio(4) = (radiance2 % bt(ichan) - radiance % bt(ichan)) / (lambda * radiance_tl % bt(ichan))
- write(ioout,'(5f16.10)') lambda, ratio
-
- End do
-
- End do
-
-1000 continue
-
- ! End of TL tests
-
- !---------------------------------------------------------------------
- ! Test of AD
- !---------------------------------------------------------------------
- write(ioout,*)
- write(ioout,*) 'Test AD'
- write(ioout,*) '-------'
- write(ioout,*)
-
- write(ioout,*) '1- Test linearity'
- write(ioout,*)
-
-!
-
- !Allocate new profiles for AD code
- ! Profiles on RTTOV pressure levels
- allocate( profiles_ad(nprofiles))
- do j = 1, nprofiles
- ! allocate model profiles atmospheric arrays with model levels dimension
- profiles_ad(j) % nlevels = coef % nlevels
- allocate( profiles_ad(j) % p ( coef % nlevels ) )
- allocate( profiles_ad(j) % t ( coef % nlevels ) )
- allocate( profiles_ad(j) % q ( coef % nlevels ) )
- allocate( profiles_ad(j) % o3 ( coef % nlevels ) )
- allocate( profiles_ad(j) % clw( coef % nlevels ) )
- profiles_ad(j) % p(:) = coef % ref_prfl_p(:)
- end do
-
- ! Cloud additional profiles
- allocate( cld_profiles_ad(nprofiles))
- do j = 1, nprofiles
- ! allocate model profiles atmospheric arrays with model levels dimension
- cld_profiles_ad(j) % nlevels = nwp_levels
- allocate( cld_profiles_ad(j) % p ( nwp_levels ) )
- allocate( cld_profiles_ad(j) % ph ( nwp_levels+1 ) )
- allocate( cld_profiles_ad(j) % t ( nwp_levels ) )
- allocate( cld_profiles_ad(j) % cc ( nwp_levels ) )
- allocate( cld_profiles_ad(j) % clw( nwp_levels ) )
- allocate( cld_profiles_ad(j) % ciw( nwp_levels ) )
- end do
- Do j = 1, nprofiles
- profiles_ad(j) % ozone_Data = .False. ! no meaning
- profiles_ad(j) % co2_Data = .False. ! no meaning
- profiles_ad(j) % clw_Data = .False. ! no meaning
- profiles_ad(j) % zenangle = -1 ! no meaning
- profiles_ad(j) % azangle = -1 ! no meaning
-
- ! increments for atmospheric variables
- profiles_ad(j) % p(:) = 0._JPRB ! no AD on pressure levels
- profiles_ad(j) % t(:) = 0._JPRB ! temperarure
- profiles_ad(j) % o3(:) = 0._JPRB ! O3 ppmv
- profiles_ad(j) % clw(:) = 0._JPRB ! clw
- profiles_ad(j) % q(:) = 0._JPRB ! WV
-
- ! increments for air surface variables
- profiles_ad(j) % s2m % t = 0._JPRB! temperarure
- profiles_ad(j) % s2m % q = 0 ! WV
- profiles_ad(j) % s2m % p = 0._JPRB! pressure
- profiles_ad(j) % s2m % u = 0._JPRB! wind components
- profiles_ad(j) % s2m % v = 0._JPRB! wind components
-
- ! increments for skin variables
- profiles_ad(j) % skin % surftype = -1 ! no meaning
- profiles_ad(j) % skin % t = 0._JPRB ! on temperarure
- profiles_ad(j) % skin % fastem = 0._JPRB
-
- ! increments for cloud variables
- profiles_ad(j) % ctp = 0._JPRB ! pressure
- profiles_ad(j) % cfraction = 0._JPRB ! cloud fraction
-
- ! Cloud profiles
- cld_profiles_ad(j) % p (:) = 0._JPRB
- cld_profiles_ad(j) % ph (:) = 0._JPRB
- cld_profiles_ad(j) % t (:) = 0._JPRB
- cld_profiles_ad(j) % cc (:) = 0._JPRB
- cld_profiles_ad(j) % clw(:) = 0._JPRB
- cld_profiles_ad(j) % ciw(:) = 0._JPRB
- End Do
-
- allocate( emissivity_ad( nchannels ))
- emissivity_ad(:) = 0._JPRB
-
- ! Set perturbations
- !
- ! allocate radiance results arrays with number of channels
- allocate( radiance_inc % clear ( nchannels ) )
- allocate( radiance_inc % cloudy ( nchannels ) )
- allocate( radiance_inc % total ( nchannels ) )
- allocate( radiance_inc % bt ( nchannels ) )
- allocate( radiance_inc % bt_clear ( nchannels ) )
- allocate( radiance_inc % out ( nbtout ) )
- allocate( radiance_inc % out_clear ( nbtout ) )
- allocate( radiance_inc % total_out ( nbtout ) )
- allocate( radiance_inc % clear_out ( nbtout ) )
- allocate( radiance_inc % upclear ( nchannels ) )
- allocate( radiance_inc % reflclear( nchannels ) )
- allocate( radiance_inc % overcast ( nwp_levels, nchannels ) )
- allocate( radiance_inc % downcld ( nwp_levels, nchannels ) )
- allocate( radiance_inc % cldemis ( nwp_levels, nchannels ) )
- allocate( radiance_inc % wtoa ( nwp_levels, nchannels ) )
- allocate( radiance_inc % wsurf ( nwp_levels, nchannels ) )
- allocate( radiance_inc % cs_wtoa ( nchannels ) )
- allocate( radiance_inc % cs_wsurf ( nchannels ) )
- if (kinrad == 2) then
- radiance_inc % clear_out(:) = 0._JPRB
- radiance_inc % total_out(:) = 0._JPRB
- radiance_inc % out_clear(:) = radiance % out_clear(:) *lambda0
- radiance_inc % out(:) = radiance % out(:) *lambda0
- else
- radiance_inc % clear_out(:) = radiance % clear_out(:) *lambda0
- radiance_inc % total_out(:) = radiance % total_out(:) *lambda0
- radiance_inc % out_clear(:) = 0._JPRB
- radiance_inc % out(:) = 0._JPRB
- endif
- radiance_inc % cloudy (:) = 0._JPRB
- radiance_inc % upclear (:) = 0._JPRB
- radiance_inc % reflclear(:) = 0._JPRB
- radiance_inc % overcast (:,:) = 0._JPRB
- radiance_inc % downcld (:,:) = 0._JPRB
- radiance_inc % cldemis (:,:) = 0._JPRB
- radiance_inc % wtoa (:,:) = 0._JPRB
- radiance_inc % wsurf (:,:) = 0._JPRB
- radiance_inc % cs_wtoa (:) = 0._JPRB
- radiance_inc % cs_wsurf (:) = 0._JPRB
- radiance_inc % bt (:) = 0._JPRB
- radiance_inc % bt_clear (:) = 0._JPRB
- radiance_inc % total (:) = 0._JPRB
- radiance_inc % clear (:) = 0._JPRB
-
-
- !---------------------------
- Call Rttov_cld_ad ( &
- & rttov_errorstatus, &! out
- & nfrequencies, &! in
- & nchannels, &! in
- & nbtout, &! in
- & nprofiles, &! in
- & channels, &! in
- & polarisations, &! in
- & lprofiles, &! in
- & profiles, &! in
- & cld_profiles, &! in
- & coef, &! in
- & switchrad, &! in
- & calcemis, &! in
- & emissivity, &! inout
- & profiles_ad, &! inout
- & cld_profiles_ad, &! inout
- & emissivity_ad, &! inout
- & radiance2, &! inout
- & radiance_inc ) ! inout
-
- If ( any( rttov_errorstatus(:) == errorstatus_fatal ) ) Then
- Do iatm = 1, nprofiles
- If ( rttov_errorstatus(iatm) == errorstatus_fatal ) Then
- write ( ioout, * ) 'rttov_cld_ad error for profile',iatm
- End If
- End Do
- Stop
- End If
-
- If ( Any( abs(radiance_total_ref(:) - radiance2%total(:)) > eps * radiance_total_ref(:) )) Then
- ! If ( Any( abs(radiance_total_ref(:) - radiance2%total(:)) > threshold )) Then
- write(default_err_unit,*) 'wrong forward model in AD'
- write(default_err_unit,*) radiance_total_ref(:)
- write(default_err_unit,*) abs(radiance_total_ref(:) - radiance2%total(:)) / ( eps * radiance_total_ref(:))
- Stop
- Endif
-
- !---------------------------
- ! Second run of AD
-
- !Allocate new profiles for AD code
- ! Profiles on RTTOV pressure levels
- allocate( profiles_ad2(nprofiles))
- do j = 1, nprofiles
- ! allocate model profiles atmospheric arrays with model levels dimension
- profiles_ad2(j) % nlevels = coef % nlevels
- allocate( profiles_ad2(j) % p ( coef % nlevels ) )
- allocate( profiles_ad2(j) % t ( coef % nlevels ) )
- allocate( profiles_ad2(j) % q ( coef % nlevels ) )
- allocate( profiles_ad2(j) % o3 ( coef % nlevels ) )
- allocate( profiles_ad2(j) % clw( coef % nlevels ) )
- profiles_ad2(j) % p(:) = coef % ref_prfl_p(:)
- end do
-
- ! Cloud additional profiles
- allocate( cld_profiles_ad2(nprofiles))
- do j = 1, nprofiles
- ! allocate model profiles atmospheric arrays with model levels dimension
- cld_profiles_ad2(j) % nlevels = nwp_levels
- allocate( cld_profiles_ad2(j) % p ( nwp_levels ) )
- allocate( cld_profiles_ad2(j) % ph ( nwp_levels+1 ) )
- allocate( cld_profiles_ad2(j) % t ( nwp_levels ) )
- allocate( cld_profiles_ad2(j) % cc ( nwp_levels ) )
- allocate( cld_profiles_ad2(j) % clw( nwp_levels ) )
- allocate( cld_profiles_ad2(j) % ciw( nwp_levels ) )
- end do
-
- Do j = 1, nprofiles
- profiles_ad2(j) % ozone_Data = .False. ! no meaning
- profiles_ad2(j) % co2_Data = .False. ! no meaning
- profiles_ad2(j) % clw_Data = .False. ! no meaning
- profiles_ad2(j) % zenangle = -1 ! no meaning
- profiles_ad2(j) % azangle = -1 ! no meaning
-
- ! increments for atmospheric variables
- profiles_ad2(j) % p(:) = 0._JPRB ! no AD on pressure levels
- profiles_ad2(j) % t(:) = 0._JPRB ! temperarure
- profiles_ad2(j) % o3(:) = 0._JPRB ! O3 ppmv
- profiles_ad2(j) % clw(:) = 0._JPRB ! clw
- profiles_ad2(j) % q(:) = 0._JPRB ! WV
-
- ! increments for air surface variables
- profiles_ad2(j) % s2m % t = 0._JPRB! temperarure
- profiles_ad2(j) % s2m % q = 0 ! WV
- profiles_ad2(j) % s2m % p = 0._JPRB! pressure
- profiles_ad2(j) % s2m % u = 0._JPRB! wind components
- profiles_ad2(j) % s2m % v = 0._JPRB! wind components
-
- ! increments for skin variables
- profiles_ad2(j) % skin % surftype = -1 ! no meaning
- profiles_ad2(j) % skin % t = 0._JPRB ! on temperarure
- profiles_ad2(j) % skin % fastem = 0._JPRB
-
- ! increments for cloud variables
- profiles_ad2(j) % ctp = 0._JPRB ! pressure
- profiles_ad2(j) % cfraction = 0._JPRB ! cloud fraction
-
- ! Cloud profiles
- cld_profiles_ad2(j) % p (:) = 0._JPRB
- cld_profiles_ad2(j) % ph (:) = 0._JPRB
- cld_profiles_ad2(j) % t (:) = 0._JPRB
- cld_profiles_ad2(j) % cc (:) = 0._JPRB
- cld_profiles_ad2(j) % clw(:) = 0._JPRB
- cld_profiles_ad2(j) % ciw(:) = 0._JPRB
- End Do
-
- allocate( emissivity_ad2( nchannels ))
- emissivity_ad2(:) = 0._JPRB
-
- ! allocate radiance results arrays with number of channels
- allocate( radiance_inc2 % clear ( nchannels ) )
- allocate( radiance_inc2 % cloudy ( nchannels ) )
- allocate( radiance_inc2 % total ( nchannels ) )
- allocate( radiance_inc2 % bt ( nchannels ) )
- allocate( radiance_inc2 % bt_clear ( nchannels ) )
- allocate( radiance_inc2 % out ( nbtout ) )
- allocate( radiance_inc2 % out_clear( nbtout ) )
- allocate( radiance_inc2 % total_out( nbtout ) )
- allocate( radiance_inc2 % clear_out( nbtout ) )
- allocate( radiance_inc2 % upclear ( nchannels ) )
- allocate( radiance_inc2 % reflclear( nchannels ) )
- allocate( radiance_inc2 % overcast ( nwp_levels, nchannels ) )
- allocate( radiance_inc2 % downcld ( nwp_levels, nchannels ) )
- allocate( radiance_inc2 % cldemis ( nwp_levels, nchannels ) )
- allocate( radiance_inc2 % wtoa ( nwp_levels, nchannels ) )
- allocate( radiance_inc2 % wsurf ( nwp_levels, nchannels ) )
- allocate( radiance_inc2 % cs_wtoa ( nchannels ) )
- allocate( radiance_inc2 % cs_wsurf ( nchannels ) )
-
- lambda = 0.5_JPRB
- if (kinrad == 2) then
- radiance_inc2 % clear_out(:) = 0._JPRB
- radiance_inc2 % total_out(:) = 0._JPRB
- radiance_inc2 % out_clear(:) = radiance % out_clear(:) * lambda0 * lambda
- radiance_inc2 % out(:) = radiance % out(:) * lambda0 * lambda
- else
- radiance_inc2 % clear_out(:) = radiance % clear_out(:) * lambda0 * lambda
- radiance_inc2 % total_out(:) = radiance % total_out(:) * lambda0 * lambda
- radiance_inc2 % out_clear(:) = 0._JPRB
- radiance_inc2 % out(:) = 0._JPRB
- endif
- radiance_inc2 % cloudy (:) = 0._JPRB
- radiance_inc2 % upclear (:) = 0._JPRB
- radiance_inc2 % reflclear(:) = 0._JPRB
- radiance_inc2 % overcast (:,:) = 0._JPRB
- radiance_inc2 % downcld (:,:) = 0._JPRB
- radiance_inc2 % cldemis (:,:) = 0._JPRB
- radiance_inc2 % wtoa (:,:) = 0._JPRB
- radiance_inc2 % wsurf (:,:) = 0._JPRB
- radiance_inc2 % cs_wtoa (:) = 0._JPRB
- radiance_inc2 % cs_wsurf (:) = 0._JPRB
- radiance_inc2 % bt (:) = 0._JPRB
- radiance_inc2 % bt_clear (:) = 0._JPRB
- radiance_inc2 % total (:) = 0._JPRB
- radiance_inc2 % clear (:) = 0._JPRB
-
- !---------------------------
- Call Rttov_cld_ad ( &
- & rttov_errorstatus, &! out
- & nfrequencies, &! in
- & nchannels, &! in
- & nbtout, &! in
- & nprofiles, &! in
- & channels, &! in
- & polarisations, &! in
- & lprofiles, &! in
- & profiles, &! in
- & cld_profiles, &! in
- & coef, &! in
- & switchrad, &! in
- & calcemis, &! in
- & emissivity, &! inout
- & profiles_ad2, &! inout
- & cld_profiles_ad2, &! inout
- & emissivity_ad2, &! inout
- & radiance2, &! inout
- & radiance_inc2 ) ! inout
-
- If ( any( rttov_errorstatus(:) == errorstatus_fatal ) ) Then
- Do iatm = 1, nprofiles
- If ( rttov_errorstatus(iatm) == errorstatus_fatal ) Then
- write ( ioout, * ) 'rttov_cld_ad error for profile',iatm
- End If
- End Do
- Stop
- End If
-
- do j = 1, nprofiles
- do lev = 1, profiles_ad(j) % nlevels
- if ( abs(lambda * profiles_ad(j)%t(lev) - profiles_ad2(j)%t(lev)) > threshold ) then
- write(default_err_unit,*) 'test AD 1 fails',lev
- stop
- End If
- if ( abs(lambda * profiles_ad(j)%q(lev) - profiles_ad2(j)%q(lev)) > threshold ) Then
- write(default_err_unit,*) 'test AD 2 fails',lev
- stop
- End If
- if ( abs(lambda * profiles_ad(j)%o3(lev) - profiles_ad2(j)%o3(lev)) > threshold ) Then
- write(default_err_unit,*) 'test AD 3 fails',lev
- stop
- End If
- enddo
- enddo
-
- do j = 1, nprofiles
- do lev = 1, cld_profiles_ad(j) % nlevels
- if ( abs(lambda * cld_profiles_ad(j)%p(lev) - cld_profiles_ad2(j)%p(lev)) > threshold ) Then
- write(default_err_unit,*) 'test AD 4 fails',lev
- stop
- End If
- if ( abs(lambda * cld_profiles_ad(j)%ph(lev) - cld_profiles_ad2(j)%ph(lev)) > threshold ) Then
- write(default_err_unit,*) 'test AD 5 fails',lev
- stop
- End If
- if ( abs(lambda * cld_profiles_ad(j)%t(lev) - cld_profiles_ad2(j)%t(lev)) > threshold ) Then
- write(default_err_unit,*) 'test AD 6 fails',lev
- stop
- End If
- if ( abs(lambda * cld_profiles_ad(j)%cc(lev) - cld_profiles_ad2(j)%cc(lev)) > threshold ) Then
- write(default_err_unit,*) 'test AD 7 fails',lev
- stop
- End If
- if ( abs(lambda * cld_profiles_ad(j)%clw(lev) - cld_profiles_ad2(j)%clw(lev)) > threshold ) Then
- write(default_err_unit,*) 'test AD 8 fails',lev
- stop
- End If
- if ( abs(lambda * cld_profiles_ad(j)%ciw(lev) - cld_profiles_ad2(j)%ciw(lev)) > threshold ) Then
- write(default_err_unit,*) 'test AD 9 fails',lev
- stop
- End If
- enddo
- lev = cld_profiles_ad(j) % nlevels+1
- if ( abs(lambda * cld_profiles_ad(j)%ph(lev) - cld_profiles_ad2(j)%ph(lev)) > threshold ) Then
- write(default_err_unit,*) 'test AD 10 fails',lev
- stop
- End If
- enddo
-
- do j = 1, nprofiles
- if ( abs(lambda * profiles_ad(j)%s2m%t - profiles_ad2(j)%s2m%t) > threshold ) Then
- write(default_err_unit,*) 'test AD 11 fails',j
- stop
- End If
- if ( abs(lambda * profiles_ad(j)%s2m%q - profiles_ad2(j)%s2m%q) > threshold ) Then
- write(default_err_unit,*) 'test AD 12 fails',j
- stop
- End If
- if ( abs(lambda * profiles_ad(j)%s2m%p - profiles_ad2(j)%s2m%p) > threshold ) Then
- write(default_err_unit,*) 'test AD 13 fails',j
- stop
- End If
- if ( abs(lambda * profiles_ad(j)%s2m%u - profiles_ad2(j)%s2m%u) > threshold ) Then
- write(default_err_unit,*) 'test AD 14 fails',j
- stop
- End If
- if ( abs(lambda * profiles_ad(j)%s2m%v - profiles_ad2(j)%s2m%v) > threshold ) Then
- write(default_err_unit,*) 'test AD 15 fails',j
- stop
- End If
-
- if ( abs(lambda * profiles_ad(j)%skin%t - profiles_ad2(j)%skin%t) > threshold ) Then
- write(default_err_unit,*) 'test AD 16 fails',j
- stop
- End If
- enddo
-
- do j = 1, nchannels
- if ( abs(lambda * emissivity_ad(j) - emissivity_ad2(j)) > threshold ) Then
- write(default_err_unit,*) 'test AD 17 fails',j
- stop
- End If
- enddo
-
-
- write(ioout,*) '2- Test equality of norms'
- write(ioout,*)
-!
-! Set perturbations
-!
-
- ! Set perturbation of initial profile
- lambda0 = 0.05_JPRB
- Do j = 1, nprofiles
- prof_inc(j) % nlevels = coef % nlevels
-
- prof_inc(j) % ozone_Data = .False. ! no meaning
- prof_inc(j) % co2_Data = .False. ! no meaning
- prof_inc(j) % clw_Data = .False. ! no meaning
- prof_inc(j) % zenangle = -1 ! no meaning
- prof_inc(j) % azangle = -1 ! no meaning
-
- ! increments for atmospheric variables
- prof_inc(j) % p(:) = 0._JPRB ! no tl on pressure levels
- prof_inc(j) % t(:) = profiles(j) % t(:) *lambda0
- prof_inc(j) % o3(:) = profiles(j) % o3(:) *lambda0
- prof_inc(j) % clw(:) = profiles(j) % clw(:)*lambda0
- prof_inc(j) % q(:) = profiles(j) % q(:) *lambda0
-
- ! increments for air surface variables
- prof_inc(j) % s2m % t = profiles(j) % s2m % t *lambda0
- prof_inc(j) % s2m % q = profiles(j) % s2m % q *lambda0
- prof_inc(j) % s2m % p = profiles(j) % s2m % p *lambda0
- prof_inc(j) % s2m % u = profiles(j) % s2m % u *lambda0
- prof_inc(j) % s2m % v = profiles(j) % s2m % v *lambda0
-
- ! increments for skin variables
- prof_inc(j) % skin % surftype = -1 ! no meaning
- prof_inc(j) % skin % t = profiles(j) % skin % t *lambda0
- prof_inc(j) % skin % fastem(:)= profiles(j) % skin % fastem(:) *lambda0
-
- ! increments for cloud variables
- prof_inc(j) % ctp = profiles(j) % ctp *lambda0
- prof_inc(j) % cfraction = profiles(j) % cfraction *lambda0
-
- ! increments for cloud variables
- cld_prof_inc(j) % nlevels = nwp_levels
- cld_prof_inc(j) % p(:) = cld_profiles(j) % p(:) *lambda0
- cld_prof_inc(j) % ph(:) = cld_profiles(j) % ph(:) *lambda0
- cld_prof_inc(j) % t(:) = cld_profiles(j) % t(:) *lambda0
- cld_prof_inc(j) % cc(:) = cld_profiles(j) % cc(:) *lambda0
- cld_prof_inc(j) % clw(:) = cld_profiles(j) % clw(:) *lambda0
- cld_prof_inc(j) % ciw(:) = cld_profiles(j) % ciw(:) *lambda0
- End Do
-
- ! emissivity
- emissivity_inc(:) = emissivity(:) * lambda0
- calcemis(:) = .false.
-
- !---------------------------
- Call Rttov_cld_tl ( &
- & rttov_errorstatus, &! out
- & nfrequencies, &! in
- & nchannels, &! in
- & nbtout, &! in
- & nprofiles, &! in
- & channels, &! in
- & polarisations, &! in
- & lprofiles, &! in
- & profiles, &! in
- & cld_profiles, &! in
- & coef, &! in
- & calcemis, &! in
- & emissivity, &! inout
- & prof_inc, &! in
- & cld_prof_inc, &! in
- & emissivity_inc, &! inout
- & radiance, &! inout
- & radiance_tl ) ! inout
-
- If ( any( rttov_errorstatus(:) == errorstatus_fatal ) ) Then
- Do iatm = 1, nprofiles
- If ( rttov_errorstatus(iatm) == errorstatus_fatal ) Then
- write ( ioout, * ) 'rttov_cld_tl error for profile',iatm
- End If
- End Do
- Stop
- End If
-
- if (kinrad == 2) then
- radiance_tl % clear_out(:) = 0._JPRB
- radiance_tl % total_out(:) = 0._JPRB
- else
- radiance_tl % out_clear(:) = 0._JPRB
- radiance_tl % out(:) = 0._JPRB
- endif
-
- !* compute <subtl(delta_x),delta_z>
- zdelta1 = 0._JPRB
- do j = 1, nbtout
- zdelta1 = zdelta1 + radiance_tl % total_out(j)**2 + radiance_tl % clear_out(j)**2
- zdelta1 = zdelta1 + radiance_tl % out(j)**2 + radiance_tl % out_clear(j)**2
- enddo
- write(ioout,fmt='('' delta1 = '',2e24.17)') zdelta1
-
- !---------------------------
- ! Now run AD code with TL radiances in input
- Do j = 1, nprofiles
- profiles_ad(j) % ozone_Data = .False. ! no meaning
- profiles_ad(j) % co2_Data = .False. ! no meaning
- profiles_ad(j) % clw_Data = .False. ! no meaning
- profiles_ad(j) % zenangle = -1 ! no meaning
- profiles_ad(j) % azangle = -1 ! no meaning
-
- ! increments for atmospheric variables
- profiles_ad(j) % p(:) = 0._JPRB ! no AD on pressure levels
- profiles_ad(j) % t(:) = 0._JPRB ! temperarure
- profiles_ad(j) % o3(:) = 0._JPRB ! O3 ppmv
- profiles_ad(j) % clw(:) = 0._JPRB ! clw
- profiles_ad(j) % q(:) = 0._JPRB ! WV
-
- ! increments for air surface variables
- profiles_ad(j) % s2m % t = 0._JPRB! temperarure
- profiles_ad(j) % s2m % q = 0 ! WV
- profiles_ad(j) % s2m % p = 0._JPRB! pressure
- profiles_ad(j) % s2m % u = 0._JPRB! wind components
- profiles_ad(j) % s2m % v = 0._JPRB! wind components
-
- ! increments for skin variables
- profiles_ad(j) % skin % surftype = -1 ! no meaning
- profiles_ad(j) % skin % t = 0._JPRB ! on temperarure
- profiles_ad(j) % skin % fastem = 0._JPRB
-
- ! increments for cloud variables
- profiles_ad(j) % ctp = 0._JPRB ! pressure
- profiles_ad(j) % cfraction = 0._JPRB ! cloud fraction
-
- ! Cloud profiles
- cld_profiles_ad(j) % p (:) = 0._JPRB
- cld_profiles_ad(j) % ph (:) = 0._JPRB
- cld_profiles_ad(j) % t (:) = 0._JPRB
- cld_profiles_ad(j) % cc (:) = 0._JPRB
- cld_profiles_ad(j) % clw(:) = 0._JPRB
- cld_profiles_ad(j) % ciw(:) = 0._JPRB
- End Do
-
- emissivity_ad(:) = 0._JPRB
-
- ! move TL results to AD radiance increments
- if (kinrad == 2) then
- radiance_inc % clear_out(:) = 0._JPRB
- radiance_inc % total_out(:) = 0._JPRB
- radiance_inc % out_clear(:) = radiance_tl % out_clear(:)
- radiance_inc % out(:) = radiance_tl % out(:)
- else
- radiance_inc % clear_out(:) = radiance_tl % clear_out(:)
- radiance_inc % total_out(:) = radiance_tl % total_out(:)
- radiance_inc % out_clear(:) = 0._JPRB
- radiance_inc % out(:) = 0._JPRB
- endif
- radiance_inc % cloudy (:) = 0._JPRB
- radiance_inc % upclear (:) = 0._JPRB
- radiance_inc % reflclear(:) = 0._JPRB
- radiance_inc % overcast (:,:) = 0._JPRB
- radiance_inc % downcld (:,:) = 0._JPRB
- radiance_inc % cldemis (:,:) = 0._JPRB
- radiance_inc % wtoa (:,:) = 0._JPRB
- radiance_inc % wsurf (:,:) = 0._JPRB
- radiance_inc % cs_wtoa (:) = 0._JPRB
- radiance_inc % cs_wsurf (:) = 0._JPRB
- radiance_inc % bt (:) = 0._JPRB
- radiance_inc % bt_clear (:) = 0._JPRB
- radiance_inc % total (:) = 0._JPRB
- radiance_inc % clear (:) = 0._JPRB
-
- Call Rttov_cld_ad ( &
- & rttov_errorstatus, &! out
- & nfrequencies, &! in
- & nchannels, &! in
- & nbtout, &! in
- & nprofiles, &! in
- & channels, &! in
- & polarisations, &! in
- & lprofiles, &! in
- & profiles, &! in
- & cld_profiles, &! in
- & coef, &! in
- & switchrad, &! in
- & calcemis, &! in
- & emissivity, &! inout
- & profiles_ad, &! inout
- & cld_profiles_ad, &! inout
- & emissivity_ad, &! inout
- & radiance2, &! inout
- & radiance_inc ) ! inout
-
- If ( any( rttov_errorstatus(:) == errorstatus_fatal ) ) Then
- Do iatm = 1, nprofiles
- If ( rttov_errorstatus(iatm) == errorstatus_fatal ) Then
- write ( ioout, * ) 'rttov_cld_ad error for profile',iatm
- End If
- End Do
- Stop
- End If
-
- !* compute <delta_x,subad(delta_z)>
- zdelta2 = 0._JPRB
- do j = 1, nprofiles
- do lev = 1, prof_inc(j) % nlevels
- zdelta2 = zdelta2 + &
- & prof_inc(j)%t(lev) * profiles_ad(j)%t(lev) +&
- & prof_inc(j)%q(lev) * profiles_ad(j)%q(lev) +&
- & prof_inc(j)%o3(lev) * profiles_ad(j)%o3(lev)
- enddo
- enddo
-
- do j = 1, nprofiles
- do lev = 1, cld_prof_inc(j) % nlevels
- zdelta2 = zdelta2 + &
- & cld_prof_inc(j)%p(lev)* cld_profiles_ad(j)%p(lev) +&
- & cld_prof_inc(j)%ph(lev)* cld_profiles_ad(j)%ph(lev) +&
- & cld_prof_inc(j)%t(lev)* cld_profiles_ad(j)%t(lev) +&
- & cld_prof_inc(j)%cc(lev)* cld_profiles_ad(j)%cc(lev) +&
- & cld_prof_inc(j)%clw(lev)* cld_profiles_ad(j)%clw(lev) +&
- & cld_prof_inc(j)%ciw(lev)* cld_profiles_ad(j)%ciw(lev)
- enddo
- lev = cld_prof_inc(j) % nlevels+1
- zdelta2 = zdelta2 + &
- & cld_prof_inc(j)%ph(lev) * cld_profiles_ad(j)%ph(lev)
- enddo
-
- do j = 1, nprofiles
- zdelta2 = zdelta2 + &
- & prof_inc(j)%s2m%t * profiles_ad(j)%s2m%t + &
- & prof_inc(j)%s2m%q * profiles_ad(j)%s2m%q + &
- & prof_inc(j)%s2m%p * profiles_ad(j)%s2m%p + &
- & prof_inc(j)%s2m%u * profiles_ad(j)%s2m%u + &
- & prof_inc(j)%s2m%v * profiles_ad(j)%s2m%v + &
- & prof_inc(j)%skin%t * profiles_ad(j)%skin%t
- enddo
-
- do j = 1, nchannels
- zdelta2 = zdelta2 + &
- & emissivity_inc(j) * emissivity_ad(j)
- enddo
- write(ioout,fmt='('' delta2 = '',2e24.17)') zdelta2
-
- if (zdelta2 == 0._JPRB) then
- z = 1._JPRB
- else
- z = zdelta2
- endif
-
- write (ioout, fmt= &
- & '('' The difference is '', f9.3, '' times the zero of the machine '')') &
- & abs(zdelta2-zdelta1)/eps/z
-
- !---------------------------------------------------------------------
- ! Test of K
- !---------------------------------------------------------------------
-! 9999 continue
- write(ioout,*)
- write(ioout,*) 'Test K'
- write(ioout,*) '------'
- write(ioout,*)
-
- !Allocate new profiles for K code
- ! Profiles on RTTOV pressure levels
- allocate( profiles_k(nchannels))
- do j = 1, nchannels
- ! allocate model profiles atmospheric arrays with model levels dimension
- profiles_k(j) % nlevels = coef % nlevels
- allocate( profiles_k(j) % p ( coef % nlevels ) )
- allocate( profiles_k(j) % t ( coef % nlevels ) )
- allocate( profiles_k(j) % q ( coef % nlevels ) )
- allocate( profiles_k(j) % o3 ( coef % nlevels ) )
- allocate( profiles_k(j) % clw( coef % nlevels ) )
- profiles_k(j) % p(:) = coef % ref_prfl_p(:)
- end do
-
- ! Cloud additional profiles
- allocate( cld_profiles_k(nchannels))
- do j = 1, nchannels
- ! allocate model profiles atmospheric arrays with model levels dimension
- cld_profiles_k(j) % nlevels = nwp_levels
- allocate( cld_profiles_k(j) % p ( nwp_levels ) )
- allocate( cld_profiles_k(j) % ph ( nwp_levels+1 ) )
- allocate( cld_profiles_k(j) % t ( nwp_levels ) )
- allocate( cld_profiles_k(j) % cc ( nwp_levels ) )
- allocate( cld_profiles_k(j) % clw( nwp_levels ) )
- allocate( cld_profiles_k(j) % ciw( nwp_levels ) )
- end do
- allocate( emissivity_k( nchannels ))
-
- Call Rttov_cld_k ( &
- & rttov_errorstatus, &! out
- & nfrequencies, &! in
- & nchannels, &! in
- & nbtout, &! in
- & nprofiles, &! in
- & channels, &! in
- & polarisations, &! in
- & lprofiles, &! in
- & profiles, &! in
- & cld_profiles, &! in
- & coef, &! in
- & switchrad, &! in
- & calcemis, &! in
- & emissivity, &! inout
- & profiles_k , &! inout
- & cld_profiles_k, &! inout
- & emissivity_k, &! inout
- & radiance) ! inout
-
- If ( Any( abs(radiance_total_ref(:) - radiance%total(:)) > eps * radiance_total_ref(:) )) Then
- ! If ( Any( abs(radiance_total_ref(:) - radiance%total(:)) > threshold )) Then
- write(default_err_unit,*) 'wrong forward model in K'
- write(default_err_unit,*) radiance_total_ref(:)
- write(default_err_unit,*) abs(radiance_total_ref(:) - radiance%total(:)) / ( eps * radiance_total_ref(:))
- Stop
- Endif
-
- !---------------------------
- ! Compares K to AD
- ! Actually Rttov_cld_k uses AD, but in an economical way
- ! the test here checks that values are correctly located in the matrix
- ! using the simplest (expensive) approach
- jchan = 0
- Do ichan = 1, nfrequencies
-
- Do j = 1, nprofiles
- ! increments for atmospheric variables
- profiles_ad(j) % p(:) = 0._JPRB ! no AD on pressure levels
- profiles_ad(j) % t(:) = 0._JPRB ! temperarure
- profiles_ad(j) % o3(:) = 0._JPRB ! O3 ppmv
- profiles_ad(j) % clw(:) = 0._JPRB ! clw
- profiles_ad(j) % q(:) = 0._JPRB ! WV
-
- ! increments for air surface variables
- profiles_ad(j) % s2m % t = 0._JPRB! temperarure
- profiles_ad(j) % s2m % q = 0 ! WV
- profiles_ad(j) % s2m % o = 0 ! WV
- profiles_ad(j) % s2m % p = 0._JPRB! pressure
- profiles_ad(j) % s2m % u = 0._JPRB! wind components
- profiles_ad(j) % s2m % v = 0._JPRB! wind components
-
- ! increments for skin variables
- profiles_ad(j) % skin % surftype = -1 ! no meaning
- profiles_ad(j) % skin % t = 0._JPRB ! on temperarure
- profiles_ad(j) % skin % fastem = 0._JPRB
-
- ! increments for cloud variables
- profiles_ad(j) % ctp = 0._JPRB ! pressure
- profiles_ad(j) % cfraction = 0._JPRB ! cloud fraction
-
- ! Cloud profiles
- cld_profiles_ad(j) % p (:) = 0._JPRB
- cld_profiles_ad(j) % ph (:) = 0._JPRB
- cld_profiles_ad(j) % t (:) = 0._JPRB
- cld_profiles_ad(j) % cc (:) = 0._JPRB
- cld_profiles_ad(j) % clw(:) = 0._JPRB
- cld_profiles_ad(j) % ciw(:) = 0._JPRB
- End Do
-
- emissivity_ad(:) = 0._JPRB
-
- radiance_inc % cloudy (:) = 0._JPRB
- radiance_inc % upclear (:) = 0._JPRB
- radiance_inc % reflclear(:) = 0._JPRB
- radiance_inc % overcast (:,:) = 0._JPRB
- radiance_inc % downcld (:,:) = 0._JPRB
- radiance_inc % cldemis (:,:) = 0._JPRB
- radiance_inc % wtoa (:,:) = 0._JPRB
- radiance_inc % wsurf (:,:) = 0._JPRB
- radiance_inc % cs_wtoa (:) = 0._JPRB
- radiance_inc % cs_wsurf (:) = 0._JPRB
- radiance_inc % clear(:) = 0._JPRB
- radiance_inc % total(:) = 0._JPRB
- radiance_inc % bt_clear(:) = 0._JPRB
- radiance_inc % bt(:) = 0._JPRB
- radiance_inc % clear_out(:) = 0._JPRB
- radiance_inc % total_out(:) = 0._JPRB
- radiance_inc % out_clear(:) = 0._JPRB
- radiance_inc % out(:) = 0._JPRB
-
- if (kinrad == 2) then
- radiance_inc % out(ichan) = 1._JPRB
- else
- radiance_inc % total_out(ichan) = 1._JPRB
- endif
-
- Call Rttov_cld_ad ( &
- & rttov_errorstatus, &! out
- & nfrequencies, &! in
- & nchannels, &! in
- & nbtout, &! in
- & nprofiles, &! in
- & channels, &! in
- & polarisations, &! in
- & lprofiles, &! in
- & profiles, &! in
- & cld_profiles, &! in
- & coef, &! in
- & switchrad, &! in
- & calcemis, &! in
- & emissivity, &! inout
- & profiles_ad, &! inout
- & cld_profiles_ad, &! inout
- & emissivity_ad, &! inout
- & radiance2, &! inout
- & radiance_inc ) ! inout
-
-
- If ( any( rttov_errorstatus(:) == errorstatus_fatal ) ) Then
- Do iatm = 1, nprofiles
- If ( rttov_errorstatus(iatm) == errorstatus_fatal ) Then
- write ( ioout, * ) 'rttov_cld_ad error for profile',iatm
- End If
- End Do
- Stop
- End If
- do j = lprofiles(ichan), lprofiles(ichan)
- do lev = 1, profiles_ad(j) % nlevels
- if ( abs(profiles_ad(j)%t(lev) - profiles_k(ichan)%t(lev)) > threshold ) then
- write(default_err_unit,*) 'test K 1 fails',lev
- !stop
- End If
- if ( abs(profiles_ad(j)%q(lev) - profiles_k(ichan)%q(lev)) > threshold ) Then
- write(default_err_unit,*) 'test K 2 fails',lev
- !stop
- End If
- if ( abs(profiles_ad(j)%o3(lev) - profiles_k(ichan)%o3(lev)) > threshold ) Then
- write(default_err_unit,*) 'test K 3 fails',lev
- !stop
- End If
- enddo
- enddo
-
- do j = lprofiles(ichan), lprofiles(ichan)
- do lev = 1, cld_profiles_ad(j) % nlevels
- if ( abs(cld_profiles_ad(j)%p(lev) - cld_profiles_k(ichan)%p(lev)) > threshold ) Then
- write(default_err_unit,*) 'test K 4 fails',lev
- stop
- End If
- if ( abs(cld_profiles_ad(j)%ph(lev) - cld_profiles_k(ichan)%ph(lev)) > threshold ) Then
- write(default_err_unit,*) 'test K 5 fails',lev
- stop
- End If
- if ( abs(cld_profiles_ad(j)%t(lev) - cld_profiles_k(ichan)%t(lev)) > threshold ) Then
- write(default_err_unit,*) 'test K 6 fails',lev
- stop
- End If
- if ( abs(cld_profiles_ad(j)%cc(lev) - cld_profiles_k(ichan)%cc(lev)) > threshold ) Then
- write(default_err_unit,*) 'test K 7 fails',lev
- stop
- End If
- if ( abs(cld_profiles_ad(j)%clw(lev) - cld_profiles_k(ichan)%clw(lev)) > threshold ) Then
- write(default_err_unit,*) 'test K 8 fails',lev
- stop
- End If
- if ( abs(cld_profiles_ad(j)%ciw(lev) - cld_profiles_k(ichan)%ciw(lev)) > threshold ) Then
- write(default_err_unit,*) 'test K 9 fails',lev
- stop
- End If
- enddo
- lev = cld_profiles_ad(j) % nlevels+1
- if ( abs(cld_profiles_ad(j)%ph(lev) - cld_profiles_k(ichan)%ph(lev)) > threshold ) Then
- write(default_err_unit,*) 'test K 10 fails',lev
- stop
- End If
- Enddo
-
- do j = lprofiles(ichan), lprofiles(ichan)
- if ( abs(profiles_ad(j)%s2m%t - profiles_k(ichan)%s2m%t) > threshold ) Then
- write(default_err_unit,*) 'test K 11 fails',j
- stop
- End If
- if ( abs(profiles_ad(j)%s2m%q - profiles_k(ichan)%s2m%q) > threshold ) Then
- write(default_err_unit,*) 'test K 12 fails',j
- stop
- End If
- if ( abs(profiles_ad(j)%s2m%p - profiles_k(ichan)%s2m%p) > threshold ) Then
- write(default_err_unit,*) 'test K 13 fails',j
- stop
- End If
- if ( abs(profiles_ad(j)%s2m%u - profiles_k(ichan)%s2m%u) > threshold ) Then
- write(default_err_unit,*) 'test K 14 fails',j
- stop
- End If
- if ( abs(profiles_ad(j)%s2m%v - profiles_k(ichan)%s2m%v) > threshold ) Then
- write(default_err_unit,*) 'test K 15 fails',j
- stop
- End If
-
- if ( abs(profiles_ad(j)%skin%t - profiles_k(ichan)%skin%t) > threshold ) Then
- write(default_err_unit,*) 'test K 16 fails',j
- stop
- End If
- enddo
-
- Do kpol = 1 , polarisations(ichan,3)
- jchan = jchan + 1
- if ( abs(emissivity_ad(jchan) - emissivity_k(jchan)) > threshold ) Then
- write(default_err_unit,*) 'test K 17 fails',j
- stop
- End If
- Enddo
- Enddo
-
- write(ioout,*) 'K is ok'
- write(ioout,*)
- write(ioout,*) 'End of RTTOVCLD tests'
-
- Stop
-
-
-CONTAINS
-!
-! ----------------------------------------
-!
- SUBROUTINE EC_P60l(spres,pap,paph)
-!
-! This software was developed within the context of
-! the EUMETSAT Satellite Application Facility on
-! Numerical Weather Prediction (NWP SAF), under the
-! Cooperation Agreement dated 25 November 1998, between
-! EUMETSAT and the Met Office, UK, by one or more partners
-! within the NWP SAF. The partners in the NWP SAF are
-! the Met Office, ECMWF, KNMI and MeteoFrance.
-!
-! Copyright 2002, EUMETSAT, All Rights Reserved.
-!
-! Description:
-! Computes the 60-level vertical pressure grid
-! associated to the input surface pressure
-! All pressures are in Pa
-
- Use parkind1, Only : jpim ,jprb
- implicit none
- Integer(Kind=jpim), parameter :: nlev=60
- Integer(Kind=jpim) :: jk
- Real(Kind=jprb) :: spres
- Real(Kind=jprb) :: aam(nlev+1), bbm(nlev+1)
- Real(Kind=jprb) :: pap(nlev), paph(nlev+1)
-
- data aam / &
- & 0.000000_JPRB, 20.000000_JPRB, 38.425343_JPRB, &
- & 63.647804_JPRB, 95.636963_JPRB, 134.483307_JPRB, &
- & 180.584351_JPRB, 234.779053_JPRB, 298.495789_JPRB, &
- & 373.971924_JPRB, 464.618134_JPRB, 575.651001_JPRB, &
- & 713.218079_JPRB, 883.660522_JPRB, 1094.834717_JPRB, &
- & 1356.474609_JPRB, 1680.640259_JPRB, 2082.273926_JPRB, &
- & 2579.888672_JPRB, 3196.421631_JPRB, 3960.291504_JPRB, &
- & 4906.708496_JPRB, 6018.019531_JPRB, 7306.631348_JPRB, &
- & 8765.053711_JPRB, 10376.126953_JPRB, 12077.446289_JPRB, &
- & 13775.325195_JPRB, 15379.805664_JPRB, 16819.474609_JPRB, &
- & 18045.183594_JPRB, 19027.695313_JPRB, 19755.109375_JPRB, &
- & 20222.205078_JPRB, 20429.863281_JPRB, 20384.480469_JPRB, &
- & 20097.402344_JPRB, 19584.330078_JPRB, 18864.750000_JPRB, &
- & 17961.357422_JPRB, 16899.468750_JPRB, 15706.447266_JPRB, &
- & 14411.124023_JPRB, 13043.218750_JPRB, 11632.758789_JPRB, &
- & 10209.500977_JPRB, 8802.356445_JPRB, 7438.803223_JPRB, &
- & 6144.314941_JPRB, 4941.778320_JPRB, 3850.913330_JPRB, &
- & 2887.696533_JPRB, 2063.779785_JPRB, 1385.912598_JPRB, &
- & 855.361755_JPRB, 467.333588_JPRB, 210.393890_JPRB, &
- & 65.889244_JPRB, 7.367743_JPRB, 0.000000_JPRB, &
- & 0.000000_JPRB &
- & /
- data bbm / &
- & 0.0000000000_JPRB, 0.0000000000_JPRB, 0.0000000000_JPRB, &
- & 0.0000000000_JPRB, 0.0000000000_JPRB, 0.0000000000_JPRB, &
- & 0.0000000000_JPRB, 0.0000000000_JPRB, 0.0000000000_JPRB, &
- & 0.0000000000_JPRB, 0.0000000000_JPRB, 0.0000000000_JPRB, &
- & 0.0000000000_JPRB, 0.0000000000_JPRB, 0.0000000000_JPRB, &
- & 0.0000000000_JPRB, 0.0000000000_JPRB, 0.0000000000_JPRB, &
- & 0.0000000000_JPRB, 0.0000000000_JPRB, 0.0000000000_JPRB, &
- & 0.0000000000_JPRB, 0.0000000000_JPRB, 0.0000000000_JPRB, &
- & 0.0000758235_JPRB, 0.0004613950_JPRB, 0.0018151561_JPRB, &
- & 0.0050811190_JPRB, 0.0111429105_JPRB, 0.0206778757_JPRB, &
- & 0.0341211632_JPRB, 0.0516904071_JPRB, 0.0735338330_JPRB, &
- & 0.0996746942_JPRB, 0.1300225109_JPRB, 0.1643843204_JPRB, &
- & 0.2024759352_JPRB, 0.2439331412_JPRB, 0.2883229554_JPRB, &
- & 0.3351548910_JPRB, 0.3838921487_JPRB, 0.4339629412_JPRB, &
- & 0.4847715795_JPRB, 0.5357099175_JPRB, 0.5861684084_JPRB, &
- & 0.6355474591_JPRB, 0.6832686067_JPRB, 0.7287858129_JPRB, &
- & 0.7715966105_JPRB, 0.8112534285_JPRB, 0.8473749161_JPRB, &
- & 0.8796569109_JPRB, 0.9078838825_JPRB, 0.9319403172_JPRB, &
- & 0.9518215060_JPRB, 0.9676452279_JPRB, 0.9796627164_JPRB, &
- & 0.9882701039_JPRB, 0.9940194488_JPRB, 0.9976301193_JPRB, &
- & 1.0000000000_JPRB &
- & /
-
- do jk=1,nlev+1
- paph(jk)=aam(jk)+bbm(jk)*spres
- end do
- do jk=1,nlev
- pap(jk)=0.5_JPRB*(paph(jk)+paph(jk+1))
- end do
-
- end subroutine ec_p60l
-
-
-END PROGRAM rttovcld_test
diff --git a/src/LIB/RTTOV/src/rttovcld_testad.F90 b/src/LIB/RTTOV/src/rttovcld_testad.F90
deleted file mode 100644
index ee19dca3ba1455f1517e3799d4c1d436db666c2c..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttovcld_testad.F90
+++ /dev/null
@@ -1,616 +0,0 @@
-PROGRAM rttovcld_testad
- !
- ! This software was developed within the context of
- ! the EUMETSAT Satellite Application Facility on
- ! Numerical Weather Prediction (NWP SAF), under the
- ! Cooperation Agreement dated 25 November 1998, between
- ! EUMETSAT and the Met Office, UK, by one or more partners
- ! within the NWP SAF. The partners in the NWP SAF are
- ! the Met Office, ECMWF, KNMI and MeteoFrance.
- !
- ! Copyright 2002, EUMETSAT, All Rights Reserved.
- !
- !
- ! Description:
- ! 1- read ECMWF profiles on model levels
- ! 2- interpolate the T, q, o3 profiles to the 43-level RTTOV grid
- ! 4- run rttovcld direct model
- ! 5- test TL and AD codes of the rttovcld package
- !
- ! Method:
- ! see comments in program
- !
- ! Current Code Owner: SAF NWP
- !
- ! History:
- ! Version Date Comment
- ! ------- ---- -------
- ! 03/2001 Initial version (F. Chevallier)
- ! 23/07/2001 Modified for use to test RTTOV-7 (R.Saunders)
- ! 01/12/2002 New F90 code with structures (P Brunel A Smith)
- ! 10/10/2003 Update cloud inputs + Further clean up (F. Chevallier)
- !
- ! Code Description:
- ! Language: Fortran 90.
- ! Software Standards: "European Standards for Writing and
- ! Documenting Exchangeable Fortran 90 Code".
- !
- ! Declarations:
- ! Modules used:
- !
- Use rttov_const, only : &
- & errorstatus_fatal, &
- & errorstatus_success, &
- & default_err_unit
-
- Use rttov_types, only : &
- & rttov_coef ,&
- & profile_type ,&
- & profile_cloud_type ,&
- & radiance_cloud_type
-
- Use parkind1, Only : jpim ,jprb
- IMPLICIT NONE
-#include "rttov_errorhandling.interface"
-#include "rttov_readcoeffs.interface"
-#include "rttov_initcoeffs.interface"
-!#include "rttov_cld.interface"
-#include "rttov_intex.interface"
-!#include "rttov_intext_prof.interface"
-
- ! Program arguments:
-
- ! Local parameters:
- Integer(Kind=jpim), parameter :: idim=100
- Integer(Kind=jpim), parameter :: nwp_levels=60
-
- type( rttov_coef ) :: coef ! (Only one instrument)
- type(profile_type), allocatable :: profiles(:)
- type(profile_type), allocatable :: input_profiles(:)
- type(profile_cloud_type), allocatable :: cld_profiles(:)
- type(radiance_cloud_type) :: radiance
- Real(Kind=jprb), Allocatable :: emissivity (:)
-
- ! Taylor test
- type(profile_type), allocatable :: profiles2(:)
- type(profile_cloud_type), allocatable :: cld_profiles2(:)
- type(radiance_cloud_type) :: radiance2
- Real(Kind=jprb), Allocatable :: emissivity2 (:)
-
- ! TL arrays
- type(profile_type), allocatable :: prof_inc(:)
- type(profile_cloud_type), allocatable :: cld_prof_inc(:)
- type(radiance_cloud_type) :: radiance_tl
- Real(Kind=jprb), Allocatable :: emissivity_inc (:)
-
- type(profile_type), allocatable :: prof_inc2(:)
- type(profile_cloud_type), allocatable :: cld_prof_inc2(:)
- type(radiance_cloud_type) :: radiance_tl2
- Real(Kind=jprb), Allocatable :: emissivity_inc2 (:)
-
- ! AD arrays
- type(profile_type), allocatable :: profiles_ad(:)
- type(profile_cloud_type), allocatable :: cld_profiles_ad(:)
- type(radiance_cloud_type) :: radiance_inc
- Real(Kind=jprb), Allocatable :: emissivity_ad (:)
-
- type(profile_type), allocatable :: profiles_ad2(:)
- type(profile_cloud_type), allocatable :: cld_profiles_ad2(:)
- type(radiance_cloud_type) :: radiance_inc2
- Real(Kind=jprb), Allocatable :: emissivity_ad2 (:)
-
- ! Local arrays:
- Real(Kind=jprb), allocatable :: emis(:)
- Integer(Kind=jpim), allocatable :: lchan(:)
-
- Integer(Kind=jpim) :: coef_errorstatus ! read coeffs error return code
- Integer(Kind=jpim), Allocatable :: rttov_errorstatus(:) ! rttov error return code
-
- Integer(Kind=jpim) :: nchannels
- Integer(Kind=jpim) :: nprofiles
- Integer(Kind=jpim), Allocatable :: channels (:)
- Integer(Kind=jpim), Allocatable :: lprofiles (:)
- Real(Kind=jprb), Allocatable :: input_emissivity (:)
- Real(Kind=jprb), Allocatable :: radiance_total_ref (:)
- logical, Allocatable :: calcemis (:)
-
-
- Real(Kind=jprb), dimension(nwp_levels) :: t, q, o3, co2, cc, clw, ciw
- !
-
- ! Local scalars:
- !Character (len=80) :: errMessage
- !Character (len=12) :: NameOfRoutine = 'main_testad '
- Integer(Kind=jpim) :: j
- Integer(Kind=jpim) :: ioff
- Integer(Kind=jpim) :: kinrad
- Real(Kind=jprb) :: tbobs(7), rsatid
- Real(Kind=jprb) :: st, t2m, q2m, psurf, u10, v10
- Real(Kind=jprb) :: rlsm, rlon, rlat
- Real(Kind=jprb) :: x, lambda, lambda0
- Real(Kind=jprb) :: ratio(4)
- Integer(Kind=jpim) :: jdat
- Integer(Kind=jpim) :: iyyyy, iyyyymm, iyyyymmdd
- Integer(Kind=jpim) :: iyear, imonth, iday, itime
- Integer(Kind=jpim) :: iatm, katm, ichan
- Integer(Kind=jpim) :: iexp
- Integer(Kind=jpim) :: ioout, ioin
- Integer(Kind=jpim) :: isatid
- Integer(Kind=jpim) :: i, ii, nchan, kradip, kice
- Integer(Kind=jpim) :: lev
- Logical :: switchrad ! true if input is BT
-
- Integer(Kind=jpim) :: instrument(3) ! instrument triplet
- Real(Kind=jprb) :: zdelta1, zdelta2
- Real(Kind=jprb) :: z, eps
-
- Integer(Kind=jpim) :: Err_Unit ! Logical error unit (<0 for default)
- Integer(Kind=jpim) :: verbosity_level ! (<0 for default)
- ! End of program arguments
-
- !-----End of header-----------------------------------------------------
-
- !Initialise error management with default value for
- ! the error unit number and
- ! Fatal error message output
- Err_unit = -1
- verbosity_level = 1
- call rttov_errorhandling(Err_unit, verbosity_level)
-
- !
- write(*,*) 'Radiances(1) or Tbs(2)?'
- read(*,*) kinrad
- switchrad = kinrad == 2
-
- !
- ! Set satellite configuration
- ! only one satellite processed
- instrument(1)=1 ! NOAA
- write(*,*) ' NOAA sat id?'
- read(*,*) isatid
- instrument(2)=isatid
-
- !
- ! Choose instrument
- !
- write(*,*) ' HIRS (0), MSU (1) or AMSUA (3)?'
- read(*,*) instrument(3)
-
- ! Read coef file
- call rttov_readcoeffs (coef_errorstatus, coef, instrument)
- Call rttov_initcoeffs (coef_errorstatus, coef)
-
- if(coef_errorstatus /= errorstatus_success ) then
- write ( ioout, * ) 'rttov_readcoeffs fatal error'
- stop
- endif
-
- if( any(coef%ff_val_chn( 1 : coef%fmv_chn ) /= 1 )) then
- WRITE(*,*) ' some requested channels have bad validity parameter'
- do i = 1, coef%fmv_chn
- write(*,*) i, coef%ff_val_chn(i)
- end do
- endif
-
- !
- ! If infrared, choose absorption parameterisation
- !
- if(coef%id_sensor == 1) then
- ! Choose ice particle radius parameterisation
- write(*,*) ' Ice particle radius from Ou and Liou (0), Wyser et al. (1), Boudala (2) or McFarquhar et al. (3)?'
- read(*,*) kradip
-
- ! Choose ice cristal shape
- write(*,*) ' Ice cristals: hexagonal columns (0) or aggregates (1)?'
- read(*,*) kice
- endif
-
- !
- ! Set list of channels and corresponding emissivities
- ! (process all channels and let RTTOV compute the emissivity)
- !
- allocate(lchan (coef%fmv_chn) )
- allocate(emis (coef%fmv_chn) )
- nchan=coef%fmv_chn
- emis(:) = 0._JPRB
- do i = 1 , coef%fmv_chn
- lchan(i) = i
- enddo
-
- !
- ! Open files
- !
- ioin = 1
-! open(ioin,file='profiles_fmt',form='formatted')
- open(ioin,file='file_tot',form='unformatted')
- ioout = 2
- open(ioout,file='print.dat',form='formatted')
-
- !
- ! Count number of profiles
- !
-! do iatm = 1,idim
-! do i = 1,38
-! read(ioin,*,end=50)
-! enddo
-! enddo
-!50 continue
- nprofiles = iatm - 1
-! write(ioout,*) 'This dataset is made of ',nprofiles,' ECMWF model profiles'
- rewind(ioin)
- nprofiles = 1
-
- !
- ! Initialisations and allocations
- ! NO allocation for CO2 profiles
- !
- nchannels = nprofiles * nchan
- Allocate( channels ( nchannels ) )
- allocate( lprofiles ( nchannels ) )
- allocate( emissivity ( nchannels ) )
- allocate( input_emissivity ( nchannels ) )
- allocate( calcemis ( nchannels ) )
-
- allocate( rttov_errorstatus(nprofiles))
-
- ! Profiles on RTTOV pressure levels
- allocate( profiles(nprofiles))
- do j = 1, nprofiles
- ! allocate model profiles atmospheric arrays with model levels dimension
- profiles(j) % nlevels = coef % nlevels
- allocate( profiles(j) % p ( coef % nlevels ) )
- allocate( profiles(j) % t ( coef % nlevels ) )
- allocate( profiles(j) % q ( coef % nlevels ) )
- allocate( profiles(j) % o3 ( coef % nlevels ) )
- allocate( profiles(j) % clw( coef % nlevels ) )
- profiles(j) % p(:) = coef % ref_prfl_p(:)
- end do
-
- ! Profiles on NWP model pressure levels
- allocate(input_profiles(nprofiles))
- do j = 1, nprofiles
- ! allocate model profiles atmospheric arrays with model levels dimension
- input_profiles(j) % nlevels = nwp_levels
- allocate( input_profiles(j) % p ( nwp_levels ) )
- allocate( input_profiles(j) % t ( nwp_levels ) )
- allocate( input_profiles(j) % q ( nwp_levels ) )
- allocate( input_profiles(j) % o3 ( nwp_levels ) )
- allocate( input_profiles(j) % clw( nwp_levels ) )
- end do
-
- ! Cloud additional profiles
- allocate( cld_profiles(nprofiles))
- do j = 1, nprofiles
- ! allocate model profiles atmospheric arrays with model levels dimension
- cld_profiles(j) % nlevels = nwp_levels
- allocate( cld_profiles(j) % p ( nwp_levels ) )
- allocate( cld_profiles(j) % ph ( nwp_levels+1 ) )
- allocate( cld_profiles(j) % t ( nwp_levels ) )
- allocate( cld_profiles(j) % cc ( nwp_levels ) )
- allocate( cld_profiles(j) % clw( nwp_levels ) )
- allocate( cld_profiles(j) % ciw( nwp_levels ) )
- end do
-
- ! allocate radiance results arrays with number of channels
- allocate( radiance % clear ( nchannels ) )
- allocate( radiance % cloudy ( nchannels ) )
- allocate( radiance % total ( nchannels ) )
- allocate( radiance % bt ( nchannels ) )
- allocate( radiance % bt_clear ( nchannels ) )
- allocate( radiance % upclear ( nchannels ) )
- allocate( radiance % reflclear( nchannels ) )
- allocate( radiance % overcast ( nwp_levels, nchannels ) )
- allocate( radiance % downcld ( nwp_levels, nchannels ) )
- allocate( radiance % cldemis ( nwp_levels, nchannels ) )
- allocate( radiance % wtoa ( nwp_levels, nchannels ) )
- allocate( radiance % wsurf ( nwp_levels, nchannels ) )
- allocate( radiance % cs_wtoa ( nchannels ) )
- allocate( radiance % cs_wsurf ( nchannels ) )
- allocate( radiance_total_ref ( nchannels ) )
-
-
-
- !
- ! Read profile dataset
- !
-
- iatmloop : do katm = 1,1000 !!!!1000000000
- iatm = 1
-! read(ioin,'(i12)') jdat ! date yyyymmddhh
-! read(ioin,'(10e16.6)') rlon, & ! longitude (deg)
-! rlat, & ! latitude (deg)
-! rlsm, & ! land-sea mask (1=land)
-! st, & ! surface temperature (K)
-! psurf, & ! surface pressure (Pa)
-! t2m, & ! 2-meter temperature (K)
-! q2m ! 2-meter specific humidity (kg/kg)
-! read(ioin,'(10e16.6)') t ! temperature (K)
-! read(ioin,'(10e16.6)') q ! specific humidity (kg/kg)
-! read(ioin,'(10e16.6)') o3 ! specific ozone (kg/kg)
-! read(ioin,'(10e16.6)') cc ! cloud cover
-! read(ioin,'(10e16.6)') clw ! liquid water (kg/kg)
-! read(ioin,'(10e16.6)') ciw ! ice water (kg/kg)
-
- read(ioin,end=10) rlon, &! longitude (deg)
- & rlat, &! latitude (deg)
- & rsatid, &! latitude (deg)
- & tbobs, &! latitude (deg)
- & rlsm, &! land-sea mask (1=land)
- & st, &! surface temperature (K)
- & psurf, &! surface pressure (Pa)
- & u10, &! surface pressure (Pa)
- & v10, &! surface pressure (Pa)
- & t2m, &! 2-meter temperature (K)
- & q2m, &! 2-meter specific humidity (kg/kg)
- & t, &! temperature (K)
- & q , &! specific humidity (kg/kg)
- & cc, &! cloud cover
- & clw, &! liquid water (kg/kg)
- & ciw ! ice water (kg/kg)
-
- o3(:) = 1.e-7_JPRB
- q(:) = max(q(:),0._JPRB)
- clw(:) = max(clw(:),0._JPRB)
- ciw(:) = max(ciw(:),0._JPRB)
- psurf = psurf * 100._JPRB
-
- !*process date
- iyyyymmdd = jdat/100
- itime = jdat - iyyyymmdd*100
- iyyyymm = iyyyymmdd/100
- iday = iyyyymmdd - iyyyymm*100
- iyyyy = iyyyymm/100
- imonth = iyyyymm - iyyyy*100
- iyear = iyyyy
-
- !*get model vertical pressures from surface pressure (all Pa)
- call ec_p60l( &
- & psurf ,&
- & cld_profiles( iatm ) % p ,&
- & cld_profiles( iatm ) % ph )
-
- ! Convert to hPa
- cld_profiles( iatm ) % p(:) = cld_profiles( iatm ) % p(:) /100._JPRB
- cld_profiles( iatm ) % ph(:) = cld_profiles( iatm ) % ph(:) /100._JPRB
-
- ! Move to structures
-! input_profiles( iatm ) % p(:) = cld_profiles( iatm ) % p(:)
-! input_profiles( iatm ) % t(:) = t(:)
-! input_profiles( iatm ) % q(:) = (q(:) / (1-q(:))) * 1.60771704 *1e+06
-! input_profiles( iatm ) % o3(:) = (o3(:) / (1-o3(:)))* 0.6034476 *1e+06
-! input_profiles( iatm ) % clw(:) = clw(:)
-! input_profiles( iatm ) % s2m % p = psurf/100.
-! input_profiles( iatm ) % s2m % q = (q2m / (1-q2m)) * 1.60771704*1e+06
-! input_profiles( iatm ) % s2m % o = input_profiles( iatm ) % o3(nwp_levels)
-! input_profiles( iatm ) % s2m % t = t2m
-! input_profiles( iatm ) % s2m % u = 5. ! constant for this run
-! input_profiles( iatm ) % s2m % v = 2. ! constant for this run
-! input_profiles( iatm ) % skin % surftype = Int(1.0 - rlsm)
-! input_profiles( iatm ) % skin % t = st
-! input_profiles( iatm ) % skin % fastem(:) = (/ 3.0, 5.0, 15.0, 0.1, 0.3 /)
-
-! input_profiles( iatm ) % ozone_data = .true.
-! input_profiles( iatm ) % co2_data = .false.
-! input_profiles( iatm ) % clw_data = .true.
-! input_profiles( iatm ) % zenangle = 0. ! Nadir view
-! input_profiles( iatm ) % ctp = 500. ! default value
-! input_profiles( iatm ) % cfraction = 0. ! default value
-!
-! ! convert input profile to RTTOV pressure levels
-! call rttov_intext_prof(input_profiles( iatm ), profiles( iatm ) )
-! ! CLW is not interpolated, but profiles(iatm)%clw
-! ! has been allocated, so give 0. value for clw for security
-! profiles( iatm ) % clw_data = .false.
-! profiles( iatm ) % clw(:) = 0.
-
-
- profiles( iatm ) % clw(:) = 0._JPRB ! warning
- profiles( iatm ) % o3 (:) = 0._JPRB ! warning
- profiles( iatm ) % s2m % p = psurf / 100._JPRB
- profiles( iatm ) % s2m % q = (q2m / (1-q2m)) * 1.60771704_JPRB*1e+06 ! ppmv
- profiles( iatm ) % s2m % o = 0._JPRB
- profiles( iatm ) % s2m % t = t2m
- profiles( iatm ) % s2m % u = u10
- profiles( iatm ) % s2m % v = v10
- profiles( iatm ) % skin % surftype = Int(1.0_JPRB - rlsm)
- profiles( iatm ) % skin % t = st
- profiles( iatm ) % skin % fastem(:) = (/ 3.0_JPRB, 5.0_JPRB, 15.0_JPRB, 0.1_JPRB, 0.3_JPRB /)
-
- profiles( iatm ) % ozone_data = .false. !!!!WARNING
- profiles( iatm ) % co2_data = .false.
- profiles( iatm ) % clw_data = .false.
- profiles( iatm ) % zenangle = 53.1_JPRB ! SSM/I
- profiles( iatm ) % ctp = 500._JPRB ! default value
- profiles( iatm ) % cfraction = 0._JPRB ! default value
-
- cld_profiles( iatm ) % t(:) = t(:)
- cld_profiles( iatm ) % cc(:) = cc(:)
- cld_profiles( iatm ) % clw(:) = clw(:)
- cld_profiles( iatm ) % ciw(:) = ciw(:)
- cld_profiles( iatm ) % kice = kice
- cld_profiles( iatm ) % kradip = kradip
-
- ! convert q to ppmv
- q(:) = (q(:) / (1- q(:))) * 1.60771704_JPRB *1e+06
-
- ! convert input profile to RTTOV pressure levels
- call rttov_intex ( &
- & nwp_levels, &
- & coef%nlevels, &
- & cld_profiles(iatm) % p, &
- & profiles(iatm) % p, &
- & t(:), &
- & profiles(iatm) % t)
- call rttov_intex ( &
- & nwp_levels, &
- & coef%nlevels, &
- & cld_profiles(iatm) % p, &
- & profiles(iatm) % p, &
- & q(:), &
- & profiles(iatm) % q)
-
-
- ! Channel, porfile list and emissivity arrays
- do iatm = 1, nprofiles
- ioff = (iatm - 1) * nchan
- channels(1+ioff:nchan+ioff) = lchan(1:nchan)
- lprofiles(1+ioff:nchan+ioff) = iatm
- emissivity(1+ioff:nchan+ioff) = emis(1:nchan)
- End do
-
- calcemis(:) = emissivity(:) < 0.01_JPRB
- input_emissivity(:) = emissivity(:)
-
- !
- ! Call RTTOV_CLD
- !
-
-! write(ioout,*)
-! write(ioout,*) 'Call to RTTOV_CLD'
-! write(ioout,*) '----------------'
-! write(ioout,*)
-
-! Call rttov_cld( &
-! & rttov_errorstatus, &! out
-! & nchannels, &! in
-! & nprofiles, &! in
-! & channels, &! in
-! & lprofiles, &! in
-! & profiles, &! inout (to invalid clw absorption)
-! & cld_profiles, &! in
-! & coef, &! in
-! & calcemis, &! in
-! & emissivity, &! inout
-! & radiance ) ! inout
-
- If ( any( rttov_errorstatus(:) == errorstatus_fatal ) ) Then
- Do iatm = 1, nprofiles
- If ( rttov_errorstatus(iatm) == errorstatus_fatal ) Then
- write ( ioout, * ) 'rttov_cld error for profile',iatm
- End If
- End Do
- Stop
- End If
-
-
- ! main output:
- !
- ! radiance%total = cloud-affected radiances
- ! radiance%clear = clear-sky radiances
- ! radiance%bt = cloud-affected Tbs
- ! radiance%bt_clear = clear-sky Tbs
- !
-
- radiance_total_ref(:) = radiance%total(:)
-
-! if (kinrad == 2) then
-! write(ioout,*) 'Channel cloudy Tb clear Tb'
-! do ichan = 1, nchannels
-
- write(ioout,'(30f7.2)') (radiance%bt(ichan) ,ichan = 1, nchannels)
-
-! & radiance%bt_clear(ichan)
-! enddo
-! else
-! write(ioout,*) 'Channel cloudy Rad clear Rad'
-! do ichan = 1, nchannels
-! write(ioout,'(i4,3x,30e12.4)') &
-! & ichan ,&
-! & radiance%total(ichan) ,&
-! & radiance%clear(ichan)
-! enddo
-! endif
-
- enddo iatmloop
-
-10 continue
- close(ioin)
-
- Stop
-
-CONTAINS
-!
-! ----------------------------------------
-!
- SUBROUTINE EC_P60l(spres,pap,paph)
-!
-! This software was developed within the context of
-! the EUMETSAT Satellite Application Facility on
-! Numerical Weather Prediction (NWP SAF), under the
-! Cooperation Agreement dated 25 November 1998, between
-! EUMETSAT and the Met Office, UK, by one or more partners
-! within the NWP SAF. The partners in the NWP SAF are
-! the Met Office, ECMWF, KNMI and MeteoFrance.
-!
-! Copyright 2002, EUMETSAT, All Rights Reserved.
-!
-! Description:
-! Computes the 60-level vertical pressure grid
-! associated to the input surface pressure
-! All pressures are in Pa
-
- Use parkind1, Only : jpim ,jprb
- implicit none
- Integer(Kind=jpim), parameter :: nlev=60
- Integer(Kind=jpim) :: jk
- Real(Kind=jprb) :: spres
- Real(Kind=jprb) :: aam(nlev+1), bbm(nlev+1)
- Real(Kind=jprb) :: pap(nlev), paph(nlev+1)
-
- data aam / &
- & 0.000000_JPRB, 20.000000_JPRB, 38.425343_JPRB, &
- & 63.647804_JPRB, 95.636963_JPRB, 134.483307_JPRB, &
- & 180.584351_JPRB, 234.779053_JPRB, 298.495789_JPRB, &
- & 373.971924_JPRB, 464.618134_JPRB, 575.651001_JPRB, &
- & 713.218079_JPRB, 883.660522_JPRB, 1094.834717_JPRB, &
- & 1356.474609_JPRB, 1680.640259_JPRB, 2082.273926_JPRB, &
- & 2579.888672_JPRB, 3196.421631_JPRB, 3960.291504_JPRB, &
- & 4906.708496_JPRB, 6018.019531_JPRB, 7306.631348_JPRB, &
- & 8765.053711_JPRB, 10376.126953_JPRB, 12077.446289_JPRB, &
- & 13775.325195_JPRB, 15379.805664_JPRB, 16819.474609_JPRB, &
- & 18045.183594_JPRB, 19027.695313_JPRB, 19755.109375_JPRB, &
- & 20222.205078_JPRB, 20429.863281_JPRB, 20384.480469_JPRB, &
- & 20097.402344_JPRB, 19584.330078_JPRB, 18864.750000_JPRB, &
- & 17961.357422_JPRB, 16899.468750_JPRB, 15706.447266_JPRB, &
- & 14411.124023_JPRB, 13043.218750_JPRB, 11632.758789_JPRB, &
- & 10209.500977_JPRB, 8802.356445_JPRB, 7438.803223_JPRB, &
- & 6144.314941_JPRB, 4941.778320_JPRB, 3850.913330_JPRB, &
- & 2887.696533_JPRB, 2063.779785_JPRB, 1385.912598_JPRB, &
- & 855.361755_JPRB, 467.333588_JPRB, 210.393890_JPRB, &
- & 65.889244_JPRB, 7.367743_JPRB, 0.000000_JPRB, &
- & 0.000000_JPRB &
- & /
- data bbm / &
- & 0.0000000000_JPRB, 0.0000000000_JPRB, 0.0000000000_JPRB, &
- & 0.0000000000_JPRB, 0.0000000000_JPRB, 0.0000000000_JPRB, &
- & 0.0000000000_JPRB, 0.0000000000_JPRB, 0.0000000000_JPRB, &
- & 0.0000000000_JPRB, 0.0000000000_JPRB, 0.0000000000_JPRB, &
- & 0.0000000000_JPRB, 0.0000000000_JPRB, 0.0000000000_JPRB, &
- & 0.0000000000_JPRB, 0.0000000000_JPRB, 0.0000000000_JPRB, &
- & 0.0000000000_JPRB, 0.0000000000_JPRB, 0.0000000000_JPRB, &
- & 0.0000000000_JPRB, 0.0000000000_JPRB, 0.0000000000_JPRB, &
- & 0.0000758235_JPRB, 0.0004613950_JPRB, 0.0018151561_JPRB, &
- & 0.0050811190_JPRB, 0.0111429105_JPRB, 0.0206778757_JPRB, &
- & 0.0341211632_JPRB, 0.0516904071_JPRB, 0.0735338330_JPRB, &
- & 0.0996746942_JPRB, 0.1300225109_JPRB, 0.1643843204_JPRB, &
- & 0.2024759352_JPRB, 0.2439331412_JPRB, 0.2883229554_JPRB, &
- & 0.3351548910_JPRB, 0.3838921487_JPRB, 0.4339629412_JPRB, &
- & 0.4847715795_JPRB, 0.5357099175_JPRB, 0.5861684084_JPRB, &
- & 0.6355474591_JPRB, 0.6832686067_JPRB, 0.7287858129_JPRB, &
- & 0.7715966105_JPRB, 0.8112534285_JPRB, 0.8473749161_JPRB, &
- & 0.8796569109_JPRB, 0.9078838825_JPRB, 0.9319403172_JPRB, &
- & 0.9518215060_JPRB, 0.9676452279_JPRB, 0.9796627164_JPRB, &
- & 0.9882701039_JPRB, 0.9940194488_JPRB, 0.9976301193_JPRB, &
- & 1.0000000000_JPRB &
- & /
-
- do jk=1,nlev+1
- paph(jk)=aam(jk)+bbm(jk)*spres
- end do
- do jk=1,nlev
- pap(jk)=0.5_JPRB*(paph(jk)+paph(jk+1))
- end do
-
- end subroutine ec_p60l
-
-END PROGRAM rttovcld_testad
diff --git a/src/LIB/RTTOV/src/rttovscatt_test.F90 b/src/LIB/RTTOV/src/rttovscatt_test.F90
deleted file mode 100644
index 872bee0e4fe1c0d2917b9797cdfc1fca2a641edd..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttovscatt_test.F90
+++ /dev/null
@@ -1,101 +0,0 @@
- program rttovscatt_test
-
- use parkind1, only: jpim ,jprb
-
- Use rttov_types, only : rttov_coef, rttov_scatt_coef
- Use rttov_const, only : inst_id_ssmi, inst_id_amsua, inst_id_amsub
-
- use mod_rttov_scatt_test, only: kproma, ioin, inproc, imyproc, iioproc, zenangle
-
- implicit none
-
-#include "rttov_readcoeffs.interface"
-#include "rttov_readscattcoeffs.interface"
-#include "rttov_setupchan.interface"
-#include "rttov_setupindex.interface"
-#include "rttov_initcoeffs.interface"
-#include "rttov_scatt_setupindex.interface"
-#include "rttov_scatt_test.interface"
-
- integer (kind=jpim) :: nfrequencies, nchannels, nbtout, n_chan (kproma)
- real (kind=jprb), allocatable :: emissivity (:), surfem (:)
- integer (kind=jpim), allocatable :: polarisations (:,:)
- integer (kind=jpim), allocatable :: channels (:)
- integer (kind=jpim), allocatable :: frequencies (:)
- integer (kind=jpim), allocatable :: lprofiles (:)
- integer (kind=jpim), allocatable :: lsprofiles (:)
- integer (kind=jpim), allocatable :: lsprofiles2 (:)
-
- type (rttov_coef ) :: coef_rttov
- type (rttov_scatt_coef) :: coef_scatt
-
- integer (kind=jpim) :: errorstatus, instrument (3), i
-
-!- End of header ------------------------------------------------------
-
-!* Read satellite/instrument ID's
- read (*,*) instrument (1)
- read (*,*) instrument (2)
- read (*,*) instrument (3)
- read (*,*) zenangle
-
-!* Read coefficients
- call rttov_readcoeffs (errorstatus, coef_rttov, instrument, file_id = ioin)
- call rttov_initcoeffs (errorstatus, coef_rttov, inproc, imyproc, iioproc)
- call rttov_readscattcoeffs (errorstatus, coef_rttov, coef_scatt)
-
- n_chan=coef_rttov%fmv_chn
-
-
-!* in IFS called from /satrad/rttov/rttov_parm.F90 (called from /ifs/pp_obs/radtr.F90)
- call rttov_setupchan (&
- & kproma, & ! in
- & n_chan, & ! in
- & coef_rttov, & ! in
- & nfrequencies, & ! out
- & nchannels, & ! out
- & nbtout) ! out
-
-!* as in /satrad/rttov/rttov.F90
- allocate (lprofiles (nfrequencies))
- allocate (lsprofiles (nchannels))
- allocate (lsprofiles2 (nbtout))
- allocate (channels (nfrequencies))
- allocate (frequencies (nchannels))
- allocate (polarisations (nchannels,3))
- allocate (surfem (nchannels ) )
- allocate (emissivity (nchannels ) )
-
- surfem (:) = 0.0_JPRB
-
- call rttov_setupindex (&
- & n_chan, & ! in
- & kproma, & ! in
- & nfrequencies, & ! in
- & nchannels, & ! in
- & nbtout, & ! in
- & coef_rttov, & ! in
- & surfem, & ! in
- & lprofiles, & ! out
- & channels, & ! out
- & polarisations, & ! out
- & emissivity) ! out
-
-!* Set up remaining indices
- call rttov_scatt_setupindex (kproma, n_chan, coef_rttov, nchannels, &
- & lsprofiles, lsprofiles2 , &
- & frequencies, nbtout)
-
- call rttov_scatt_test (nfrequencies, nchannels, nbtout, &
- & coef_rttov, coef_scatt , &
- & lprofiles , &
- & lsprofiles , &
- & lsprofiles2 , &
- & channels , &
- & frequencies , &
- & polarisations , &
- & emissivity)
-
- end program rttovscatt_test
-
-
diff --git a/src/LIB/RTTOV/src/rttvi.F90 b/src/LIB/RTTOV/src/rttvi.F90
deleted file mode 100644
index cd8e9b91530700355e5309e95dbd7fee6bf74293..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttvi.F90
+++ /dev/null
@@ -1,329 +0,0 @@
-!+ Initialize fast radiative transfer model.
-!
-Subroutine RTTVI( &
- kerr, kppf, kpnsat, kplev, kpch, kpchus, &
- kpnav, kpnsav, kpnssv, kpncv, &
- nrttovid, platform, satellite, instrument , numchans, &
- preslev, otmin, otmax, oqmin, oqmax, oozmin, oozmax, &
- ivch, niu1)
- !
- ! This software was developed within the context of
- ! the EUMETSAT Satellite Application Facility on
- ! Numerical Weather Prediction (NWP SAF), under the
- ! Cooperation Agreement dated 25 November 1998, between
- ! EUMETSAT and the Met Office, UK, by one or more partners
- ! within the NWP SAF. The partners in the NWP SAF are
- ! the Met Office, ECMWF, KNMI and MeteoFrance.
- !
- ! Copyright 2002, EUMETSAT, All Rights Reserved.
- !
- ! Description:
- ! Initialisation for tovs rt routine, rttov.
- ! to be called before first call to rttov.
- ! allows arrays to be allocated correct size.
- ! IVCH array and numchans is normally initialised to zero
- ! in main program. It can be used to read in
- ! only those coefficients for channels you
- ! want to process by specifying valid channel
- ! numbers in this array on input. This is useful
- ! for sounders with many channels (eg AIRS)
- ! as it saves storing all coefficients (eg 2300+ for AIRS)
- ! for just a few channels required (eg ~300 for AIRS).
- ! On return IVCH either contains a list of valid channel
- ! numbers for the instrument or if non-zero input
- ! those requested.
- !
- ! Compatible with RTTOV8 library but only able to
- ! run with coefficients created on RTTOV7 43 pressure levels
- !
- ! Method
- !
- ! Current Code Owner: SAF NWP
- !
- ! History:
- ! Version Date Comment
- ! ------- ---- -------
- ! 13/8/92. For version 2. input sat ids required and
- ! store only data for these.
- ! 11/7/96 Modified to include meteosat & goes
- ! 9/12/96 Water vapour transmittance extended to level 1
- ! 6/12/97 Rose Munro - Modified for multiple satellite series,
- ! 6/12/97 Rose Munro - Modified for multiple satellite series,
- ! id's and subtypes
- ! 18/3/98 Roger Saunders - Modified to generalise no. of levels
- ! 18/8/98 Roger Saunders - Added key array sizes to output
- ! 06/4/99 Roger Saunders - Added ssm/i
- ! 01/12/99 Roger Saunders - Added variable unit number KIU1
- ! 04/01/00 Roger Saunders - Added AVHRRCF+GOESIMCF
- ! 01/05/2000 F90 code
- ! 10/08/2000 P. Brunel - Added GOESSNDCF
- ! 21/03/2001 P, Brunel - Unique coefficient file reading subroutine
- ! 26/03/2001 P, Brunel - New RTTOV identification numbers
- ! 18/09/2001 A. Collard - Allow a subset of channels to be initialised
- ! 20/09/2001 A. Collard - Allow coeffs file to be opened externally
- ! 01/12/2002 P. Brunel - Keep compatibility with RTTOV8
- !
- ! Code Description:
- ! Language: Fortran 90.
- ! Software Standards: "European Standards for Writing and
- ! Documenting Exchangeable Fortran 90 Code".
- !
- ! Declarations:
- ! Modules used:
- Use MOD_CPARAM, Only : &
- ! Imported Paramters:
- jpnsat ,& ! Total max sats to be used
- jplev ,& ! No. of pressure levels
- jpnav ,& ! No. of profile variables
- jpnsav ,& ! No. of surface air variables
- jpnssv ,& ! No. of skin variables
- jpncv ,& ! No. of cloud variables
- jppf ,& ! Max no. profiles
- jpch ,& ! Max. no. of tovs channels
- jpchus ,& ! Max. no. of channels used tovs
- jpchpf ,& ! Max no. of profs * chans used
- jpcofm ,& ! Mixed gas coeffs (max)
- jpcofw ,& ! Water vapour coeffs (max)
- jpcofo ,& ! Ozone coeffs (max)
- jpst ,& ! Max no. of surface types
- jmwcldtop ,& ! Upper level for lwp calcs
- rcnv ,& ! kg/kg--> ppmv ozone
- rcnw ,& ! kg/kg--> ppmv water vapour
- nulout ,& ! unit for error messages
- coef
-
- Use MOD_CPARAM, Only : &
- ! Imported Scalar Variables with intent (in):
- njpnsat ,& ! Total max sats to be used
- njplev ,& ! No. of pressure levels
- njpnav ,& ! No. of profile variables
- njpnsav ,& ! No. of surface air variables
- njpnssv ,& ! No. of skin variables
- njpncv ,& ! No. of cloud variables
- njppf ,& ! Max no. profiles
- njpch ,& ! Max. no. of tovs channels
- njpchus ,& ! Max. no. of channels used tovs
- njpchpf ,& ! Max no. of profs * chans used
- njpcofm ,& ! Mixed gas coeffs (max)
- njpcofw ,& ! Water vapour coeffs (max)
- njpcofo ,& ! Ozone coeffs (max)
- njpst ,& ! Max no. of surface types
- nmwcldtop ! Upper level for lwp calcs
-
- Use rttov_const, Only : &
- gas_id_watervapour ,&
- gas_id_ozone ,&
- sensor_id_mw
- !
- Use parkind1, Only : jpim ,jprb
- Implicit None
- !
-#include "rttov_readcoeffs.interface"
-#include "rttov_initcoeffs.interface"
-
- ! Subroutine arguments
- ! scalar arguments with intent(in):
- Integer(Kind=jpim), Intent(in) :: nrttovid ! number of RTTOV ids requested
- ! RTTOV id is defined by 3 numbers:
- ! platform = satellite serie (Noaa=1, Goes=4, DMSP=2...)
- ! satellite = satellite number in the serie
- ! Noaa14 = 14
- ! instrument = instrument number (HIRS=0, AMSU-A=3)
-
- ! Array arguments with intent(in):
- ! ............. for each RTTOVid
- Integer(Kind=jpim), Intent(in) :: platform(*) ! number of platform. id's
- Integer(Kind=jpim), Intent(in) :: satellite(*) ! number of satellite. id's
- Integer(Kind=jpim), Intent(in) :: instrument(*) ! number of instrument. id's
-
- ! Array arguments with intent(inout):
- ! ............. for each RTTOVid
- Integer(Kind=jpim), Intent(inout) :: numchans(*) ! Number of channels initialised
- Integer(Kind=jpim), Intent(inout) :: niu1(*) ! optional unit number to read
- Integer(Kind=jpim) :: niu2(30) ! optional unit number to read
- ! rt_coef... files.
-
- !
- ! Scalar arguments with intent(out):
- Integer(Kind=jpim), Intent(out) :: kerr ! error flag, returns kerr /= 0 if error
- ! <0 is RTTVI error
- ! >0 is RTTOVCF error
- Integer(Kind=jpim), Intent(out) :: kppf ! max no. profiles processed in parallel
- Integer(Kind=jpim), Intent(out) :: kpnsat ! max no. of satellites
- Integer(Kind=jpim), Intent(out) :: kplev ! no of rt levels
- Integer(Kind=jpim), Intent(out) :: kpch ! max no. of channels
- Integer(Kind=jpim), Intent(out) :: kpchus ! max no. of channels used
- Integer(Kind=jpim), Intent(out) :: kpnav ! max no of profile variables
- Integer(Kind=jpim), Intent(out) :: kpnsav ! max no of surface variables
- Integer(Kind=jpim), Intent(out) :: kpnssv ! max no of skin variables
- Integer(Kind=jpim), Intent(out) :: kpncv ! max no of cloud variables
-
- ! Array arguments with intent(out):
- Real(Kind=jprb), Intent(out) :: preslev(jplev) ! 43 pressure levels (Pa)
- Real(Kind=jprb), Intent(out) :: otmin(jplev) ! min temp array (K)
- Real(Kind=jprb), Intent(out) :: otmax(jplev) ! max temp array (K)
- Real(Kind=jprb), Intent(out) :: oqmin(jplev) ! min q array (kg/kg)
- Real(Kind=jprb), Intent(out) :: oqmax(jplev) ! max q array (kg/kg)
- Real(Kind=jprb), Intent(out) :: oozmin(jplev) ! min ozone array (kg/kg)
- Real(Kind=jprb), Intent(out) :: oozmax(jplev) ! max ozone array (kg/kg)
- Integer(Kind=jpim), Intent(inout) :: ivch(jpch,jpnsat) ! array of valid channel numbers
- !
-
- ! Local scalars:
- Integer(Kind=jpim) :: msat ! indice for RTTOV ids
- Integer(Kind=jpim) :: ref_ind ! reference index for min/max
-
- Integer(Kind=jpim) :: ig
- Integer(Kind=jpim) :: in_inst(3) ! instrument rttov id
- Integer(Kind=jpim) :: ich
- !- End of header ------------------------------------------------------
-
- !
- ! -----------------------------------------------------------------
- !* 1. Set up profile constants.
- ! --- -- ------- ---------
- !
- kerr = 0
- kppf = jppf
- kpnsat = jpnsat
- kplev = jplev
- kpch = jpch
- kpchus = jpchus
- kpnav = jpnav
- kpnsav = jpnsav
- kpnssv = jpnssv
- kpncv = jpncv
- !
- njpnsat = jpnsat
- njplev = jplev
- njpnav = jpnav
- njpnsav = jpnsav
- njpnssv = jpnssv
- njpncv = jpncv
- njppf = jppf
- njpch = jpch
- njpchus = jpchus
- njpchpf = jpchpf
- njpcofm = jpcofm
- njpcofw = jpcofw
- njpcofo = jpcofo
- njpst = jpst
- nmwcldtop = jmwcldtop
- !ivch(:,:) = 0
- niu2(1:nrttovid)=niu1(1:nrttovid)
- !
- !* 1. Set up data for all satellites.
- ! --- -- ---- --- --- ----------
- !
- ! 1.1 Set up Sat ids FOR TOVS/METEOSAT/GOES
- !
-
- If (nrttovid > jpnsat) Then
- kerr=-1
- Return
- End If
- !
- !* 1.2 Set up satellite-specific data for tovs/meteosat/goes
- !
- ref_ind = 0
- Do msat = 1, nrttovid
- in_inst(1) = platform(msat)
- in_inst(2) = satellite(msat)
- in_inst(3) = instrument(msat)
-
-! airs aqua
- if(instrument(msat) == 11)then
- in_inst(2) = 2
- in_inst(1) = 9
- endif
-
-! amsua aqua
- if(instrument(msat) == 3 .and. satellite(msat) == 20) then
- in_inst(2) = 2
- in_inst(1) = 9
- endif
-
- If(numchans(msat) > 0) Then
- If( niu2(msat) >0 ) Then
- Call rttov_readcoeffs (kerr, coef(msat), &
- & channels = ivch(1:numchans(msat),msat), &
- & file_id = niu2(msat) )
- Call rttov_initcoeffs ( &
- & kerr, &! out
- & coef(msat) ) ! inout
- Else
- Call rttov_readcoeffs (kerr, coef(msat), in_inst, &
- & channels = ivch(1:numchans(msat),msat) )
- Call rttov_initcoeffs ( &
- & kerr, &! out
- & coef(msat) ) ! inout
- End If
- Else
- If( niu2(msat) >0 ) Then
- Call rttov_readcoeffs (kerr, coef(msat), &
- & file_id = niu2(msat) )
- Call rttov_initcoeffs ( &
- & kerr, &! out
- & coef(msat) ) ! inout
- Else
- Call rttov_readcoeffs (kerr, coef(msat), in_inst )
- Call rttov_initcoeffs ( &
- & kerr, &! out
- & coef(msat) ) ! inout
- End If
- numchans(msat) = coef(msat) % fmv_chn
- Do ich = 1, numchans(msat)
- If(coef(msat) % ff_val_chn(ich) /= 0) Then
- ivch(ich,msat) = ich
- Else
- ivch(ich,msat) = 0
- Endif
- Enddo
- Endif
-
- If(kerr /= 0) Then
- Return
- Else
- If (ref_ind == 0) ref_ind = msat
- Endif
-
- If( jplev /= coef(msat) % nlevels ) Then
- kerr = -3
- Return
- Endif
- End Do
- !
- ! -----------------------------------------------------------------
- !
- !* 2.1 Set up pressure level constants and limits and output
- ! array for ifs
- !
- If (ref_ind == 0) Then
- kerr = -2
- Write(nulout,*) 'rttvi: reference profiles index zero'
- Return
- Endif
- !
- preslev(1:jplev) = coef(ref_ind) % ref_prfl_p(1:jplev)*100._JPRB ! (Pa)
- otmin(1:jplev) = coef(ref_ind) % lim_prfl_tmin(1:jplev) ! (K)
- otmax(1:jplev) = coef(ref_ind) % lim_prfl_tmax(1:jplev) ! (K)
- ig = coef(ref_ind) % fmv_gas_pos( gas_id_watervapour )
- oqmin(1:jplev) = coef(ref_ind) % lim_prfl_gmin(1:jplev,ig)/rcnw ! ppmv -> kg/kg
- oqmax(1:jplev) = coef(ref_ind) % lim_prfl_gmax(1:jplev,ig)/rcnw ! ppmv -> kg/kg
- !
- Do msat = 1, nrttovid
- If (coef(msat) % id_sensor /= sensor_id_mw .and. in_inst(3) /= 2 ) Then !If not MW or SSU
- ig = coef(ref_ind) % fmv_gas_pos( gas_id_ozone )
- oozmin(1:jplev) = coef(ref_ind) % lim_prfl_gmin(1:jplev,ig)/rcnv ! ppmv -> kg/kg
- oozmax(1:jplev) = coef(ref_ind) % lim_prfl_gmax(1:jplev,ig)/rcnv ! ppmv -> kg/kg
- endif
- End do
- !
- !
- !
- !
- ! -----------------------------------------------------------------
- !
- Return
-
-End Subroutine RTTVI
diff --git a/src/LIB/RTTOV/src/rttvi.interface b/src/LIB/RTTOV/src/rttvi.interface
deleted file mode 100644
index 42e9b85c7ba6b126144da082f8de72507cfb7a18..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/rttvi.interface
+++ /dev/null
@@ -1,89 +0,0 @@
-Interface
-!+ Initialize fast radiative transfer model.
-!
-Subroutine RTTVI( &
- kerr, kppf, kpnsat, kplev, kpch, kpchus, &
- kpnav, kpnsav, kpnssv, kpncv, &
- nrttovid, platform, satellite, instrument , numchans, &
- preslev, otmin, otmax, oqmin, oqmax, oozmin, oozmax, &
- ivch, niu1)
- Use MOD_CPARAM, Only : &
- ! Imported Paramters:
- jpnsat ,& ! Total max sats to be used
- jplev ,& ! No. of pressure levels
- jpnav ,& ! No. of profile variables
- jpnsav ,& ! No. of surface air variables
- jpnssv ,& ! No. of skin variables
- jpncv ,& ! No. of cloud variables
- jppf ,& ! Max no. profiles
- jpch ,& ! Max. no. of tovs channels
- jpchus ,& ! Max. no. of channels used tovs
- jpchpf ,& ! Max no. of profs * chans used
- jpcofm ,& ! Mixed gas coeffs (max)
- jpcofw ,& ! Water vapour coeffs (max)
- jpcofo ,& ! Ozone coeffs (max)
- jpst ,& ! Max no. of surface types
- jmwcldtop ,& ! Upper level for lwp calcs
- rcnv ,& ! kg/kg--> ppmv ozone
- rcnw ,& ! kg/kg--> ppmv water vapour
- nulout ,& ! unit for error messages
- coef
-
- Use MOD_CPARAM, Only : &
- ! Imported Scalar Variables with intent (in):
- njpnsat ,& ! Total max sats to be used
- njplev ,& ! No. of pressure levels
- njpnav ,& ! No. of profile variables
- njpnsav ,& ! No. of surface air variables
- njpnssv ,& ! No. of skin variables
- njpncv ,& ! No. of cloud variables
- njppf ,& ! Max no. profiles
- njpch ,& ! Max. no. of tovs channels
- njpchus ,& ! Max. no. of channels used tovs
- njpchpf ,& ! Max no. of profs * chans used
- njpcofm ,& ! Mixed gas coeffs (max)
- njpcofw ,& ! Water vapour coeffs (max)
- njpcofo ,& ! Ozone coeffs (max)
- njpst ,& ! Max no. of surface types
- nmwcldtop ! Upper level for lwp calcs
-
- Use rttov_const, Only : &
- gas_id_watervapour ,&
- gas_id_ozone
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
-
- Integer(Kind=jpim), Intent(in) :: nrttovid ! number of RTTOV ids requested
-
- Integer(Kind=jpim), Intent(in) :: platform(*) ! number of platform. id's
- Integer(Kind=jpim), Intent(in) :: satellite(*) ! number of satellite. id's
- Integer(Kind=jpim), Intent(in) :: instrument(*) ! number of instrument. id's
-
- Integer(Kind=jpim), Intent(inout) :: numchans(*) ! Number of channels initialised
- Integer(Kind=jpim), Intent(inout) :: niu1(*) ! optional unit number to read
-
- Integer(Kind=jpim), Intent(out) :: kerr ! error flag, returns kerr /= 0 if error
- Integer(Kind=jpim), Intent(out) :: kppf ! max no. profiles processed in parallel
- Integer(Kind=jpim), Intent(out) :: kpnsat ! max no. of satellites
- Integer(Kind=jpim), Intent(out) :: kplev ! no of rt levels
- Integer(Kind=jpim), Intent(out) :: kpch ! max no. of channels
- Integer(Kind=jpim), Intent(out) :: kpchus ! max no. of channels used
- Integer(Kind=jpim), Intent(out) :: kpnav ! max no of profile variables
- Integer(Kind=jpim), Intent(out) :: kpnsav ! max no of surface variables
- Integer(Kind=jpim), Intent(out) :: kpnssv ! max no of skin variables
- Integer(Kind=jpim), Intent(out) :: kpncv ! max no of cloud variables
-
- Real(Kind=jprb), Intent(out) :: preslev(jplev) ! 43 pressure levels (Pa)
- Real(Kind=jprb), Intent(out) :: otmin(jplev) ! min temp array (K)
- Real(Kind=jprb), Intent(out) :: otmax(jplev) ! max temp array (K)
- Real(Kind=jprb), Intent(out) :: oqmin(jplev) ! min q array (kg/kg)
- Real(Kind=jprb), Intent(out) :: oqmax(jplev) ! max q array (kg/kg)
- Real(Kind=jprb), Intent(out) :: oozmin(jplev) ! min ozone array (kg/kg)
- Real(Kind=jprb), Intent(out) :: oozmax(jplev) ! max ozone array (kg/kg)
- Integer(Kind=jpim), Intent(inout) :: ivch(jpch,jpnsat) ! array of valid channel numbers
-
-
-End Subroutine RTTVI
-End Interface
diff --git a/src/LIB/RTTOV/src/test_2_coef.F90 b/src/LIB/RTTOV/src/test_2_coef.F90
deleted file mode 100644
index 46443cb6e8222fd9e9d4cc6247d3bb6c66ed2870..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/test_2_coef.F90
+++ /dev/null
@@ -1,137 +0,0 @@
-!
-Program test_2_coef
- ! Description:
- ! Tests the reading of a coefficent file for all channels or
- ! for a selection.
- ! Input are:
- ! the triplet for identification (platform, satellite, instrument)
- ! flag for acees to binary or ASCII coefficent file
- ! number of channels (0= all -n for first n channels)
- ! channels selection (if input number of channels is >0)
- !
- ! The program invites you to check the memory allocation and
- ! to press return to exit
- !
- ! Copyright:
- ! This software was developed within the context of
- ! the EUMETSAT Satellite Application Facility on
- ! Numerical Weather Prediction (NWP SAF), under the
- ! Cooperation Agreement dated 25 November 1998, between
- ! EUMETSAT and the Met Office, UK, by one or more partners
- ! within the NWP SAF. The partners in the NWP SAF are
- ! the Met Office, ECMWF, KNMI and MeteoFrance.
- !
- ! Copyright 2002, EUMETSAT, All Rights Reserved.
- !
- ! Method:
- !
- ! Current Code Owner: SAF NWP
- !
- ! History:
- ! Version Date Comment
- ! ------- ---- -------
- ! 1.0 01/12/2002 New F90 code with structures (P Brunel A Smith)
- !
- ! Code Description:
- ! Language: Fortran 90.
- ! Software Standards: "European Standards for Writing and
- ! Documenting Exchangeable Fortran 90 Code".
- !
- ! Declarations:
- ! Modules used:
-
- ! Imported Parameters:
- Use rttov_const, Only : &
- & errorstatus_success
-
- ! Imported Type Definitions:
- Use rttov_types, Only : &
- & rttov_coef
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
-#include "rttov_coeffname.interface"
-#include "rttov_opencoeff.interface"
-#include "rttov_readcoeffs.interface"
-#include "rttov_initcoeffs.interface"
-#include "rttov_errorreport.interface"
-
-
- ! Local variables
- !-------------------
- Type( rttov_coef ) :: coef ! coefficients
-
- ! Instrument triplet for "classical" creation of coefficient filename
- Integer(Kind=jpim) :: instrument(3)
- ! Logical units for input/output
- Integer(Kind=jpim) :: file_id
- ! error return code for subroutines
- Integer(Kind=jpim) :: errorstatus
- ! character string for file name
- Character(len=128) :: coeffname
- !ascii / binary option
- Integer(Kind=jpim) :: iascii
- Logical :: lbinary
- ! number of channels to prosess
- Integer(Kind=jpim) :: nchannels
- Integer(Kind=jpim), Pointer :: channels(:)
- Integer(Kind=jpim) :: i
-!- End of header --------------------------------------------------------
-
-
-
- ! Now open a new ASCII coefficient file with a selection of channels
- Write(*,*) 'enter platform, satid, instrument '
- Read(*,*) instrument
- Write(*,*) 'enter ascii or binary (0/1) '
- Read(*,*) iascii
- Write(*,*) 'enter the number of channels (0 for all, -n for first n channels) '
- Read(*,*) nchannels
- If( nchannels > 0 ) Then
- Write(*,*) 'enter a list of channels '
- Allocate ( channels( nchannels ) )
- Read(*,*) channels(:)
- ElseIf( nchannels < 0 ) Then
- nchannels = -nchannels
- Allocate ( channels( nchannels ) )
- Do i = 1, nchannels
- channels(i) = i
- End Do
- Endif
- If(iascii == 0) Then
- lbinary = .False.
- Else
- lbinary = .True.
- Endif
-
- ! get the file name from instrument triplet
- Call rttov_coeffname (errorstatus, instrument, coeffname, lbinary)
- ! let the subroutine choose a logical unit for the file
- file_id = 0
-
- If( errorstatus == errorstatus_success ) Then
- ! open the file in ASCII mode
- Call rttov_opencoeff (errorstatus, coeffname, file_id, lbinary=lbinary)
-
- If( errorstatus == errorstatus_success ) Then
- ! read the coefficients for the selection of channels
- Call Rttov_errorreport( errorstatus_success, 'start reading', 'main')
- If ( nchannels /= 0 ) Then
- Call rttov_readcoeffs (errorstatus, coef, file_id = file_id, channels = channels)
- Call rttov_initcoeffs (errorstatus, coef)
- Else
- Call rttov_readcoeffs (errorstatus, coef, file_id = file_id)
- Call rttov_initcoeffs (errorstatus, coef)
- Endif
- Call Rttov_errorreport( errorstatus, 'end reading', 'main')
- End If
-
- If( errorstatus == errorstatus_success ) Then
- Write(*,*) 'you can check the memory allocation, then press return '
- Read(*,*)
- End If
- End If
-
- Stop
-End Program test_2_coef
diff --git a/src/LIB/RTTOV/src/test_coef.F90 b/src/LIB/RTTOV/src/test_coef.F90
deleted file mode 100644
index 80d4a5714b8d44f91e8645b73c2af47911fed954..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/test_coef.F90
+++ /dev/null
@@ -1,165 +0,0 @@
-!
-Program test_coef
- ! Description:
- ! Main code to test functionalities for coefficients (open/read/write)
- ! Read from standard input the identification triplet platform, satid, instrument
- ! Open the ASCII coef file
- ! Read the coeff file (rttov_readcoeffs without opening)
- ! Writes to rtcoef_1_ascii.out file the same coeff structure in ASCII format
- ! Writes to rtcoef_1_binary.out file the same coeff structure in binary format
- ! Opens rtcoef_1_binary.out file, reads it and writes it in ASCII format
- ! in file rtcoef_1_ascii_2.out
- ! Read from standard input a new identification triplet platform, satid, instrument
- ! Read from standard input a number of channels and a list of channels
- ! Open the corresponding ASCII coef file for the list of channels
- ! Read the coeff file (rttov_readcoeffs without opening and for a list of channels)
- ! Writes to rtcoef_2_ascii.out file the coeff structure in ASCII format
- !
- ! The user can check by editor that the ascii output are correct.
- ! rtcoef_1_ascii.out and rtcoef_1_ascii_2.out should be the same
- ! They can be different from original file for comments
- ! and units of reference profile and profile limits
- !
- ! Copyright:
- ! This software was developed within the context of
- ! the EUMETSAT Satellite Application Facility on
- ! Numerical Weather Prediction (NWP SAF), under the
- ! Cooperation Agreement dated 25 November 1998, between
- ! EUMETSAT and the Met Office, UK, by one or more partners
- ! within the NWP SAF. The partners in the NWP SAF are
- ! the Met Office, ECMWF, KNMI and MeteoFrance.
- !
- ! Copyright 2002, EUMETSAT, All Rights Reserved.
- !
- ! Method:
- !
- ! Current Code Owner: SAF NWP
- !
- ! History:
- ! Version Date Comment
- ! ------- ---- -------
- ! 1.0 01/12/2002 New F90 code with structures (P Brunel A Smith)
- !
- ! Code Description:
- ! Language: Fortran 90.
- ! Software Standards: "European Standards for Writing and
- ! Documenting Exchangeable Fortran 90 Code".
- !
- ! Declarations:
- ! Modules used:
-
- ! Imported Type Definitions:
- Use rttov_types, Only : &
- & rttov_coef
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
-#include "rttov_coeffname.interface"
-#include "rttov_opencoeff.interface"
-#include "rttov_readcoeffs.interface"
-#include "rttov_initcoeffs.interface"
-#include "rttov_writecoef.interface"
-
-
- ! Local variables
- !-------------------
- ! coeffiecnt structure for 2 instruments
- Type( rttov_coef ), Allocatable :: coef(:) ! coefficients
-
- ! Instrument triplet for "classical" creation of coefficient filename
- Integer(Kind=jpim) :: instrument(3)
- ! Logical units for input/output
- Integer(Kind=jpim) :: file_id
- Integer(Kind=jpim) :: file_out =20
- ! coefficient index
- Integer(Kind=jpim) :: icoef
- ! error return code for subroutines
- Integer(Kind=jpim) :: errorstatus
- ! if open file is for output
- Logical :: for_output = .True.
- ! character string for file name
- Character(len=128) :: coeffname
- ! number of channels to prosess
- Integer(Kind=jpim) :: nchannels
- Integer(Kind=jpim), Pointer :: channels(:)
-
- ! reserve memory for 4 instruments
- Allocate ( coef (4) )
-
- !- End of header --------------------------------------------------------
-
- ! Instrument ONE
- icoef = 1
- Write(*,*) 'enter platform, satid, instrument for coef ',icoef
- Read(*,*) instrument
- !instrument = (/ 1, 15, 5 /)
-
- ! get the file name from instrument triplet
- Call rttov_coeffname (errorstatus, instrument, coeffname)
-
- Write(*,*) 'coeffname ',coeffname
-
- ! let the subroutine choose a logical unit for the file
- file_id = 0
-
- ! open the file in ASCII mode
- Call rttov_opencoeff (errorstatus, coeffname, file_id)
-
- ! read the coefficients for all channels
- Call rttov_readcoeffs (errorstatus, coef(icoef), file_id = file_id)
- Call rttov_initcoeffs (errorstatus, coef(icoef))
-
- ! Open an output file and store the coefficents in ASCII format
- Open ( unit = file_out, file = 'rtcoef_1_ascii.out' )
- Call Rttov_writecoef (errorstatus, coef(icoef), file_out)
- Close ( unit = file_out )
-
- ! Open another file and store the coefficents in BINARY format
- file_out = file_out+1
- Call rttov_opencoeff (errorstatus, 'rtcoef_1_binary.out', file_out, for_output, lbinary=.True.)
- Call Rttov_writecoef (errorstatus, coef(icoef), file_out, lbinary=.True.)
- Close ( unit = file_out )
-
- ! Open the previous binary file, read the coefficients and write in an ASCII
- ! file. This allows us to compare the 2 ASCII files
- ! rtcoef_1_ascii.out and rtcoef_1_ascii_2.out which should be the same
- file_id = 0
- icoef = 2
- Call rttov_opencoeff (errorstatus, 'rtcoef_1_binary.out', file_id, lbinary=.True.)
- Call rttov_readcoeffs (errorstatus, coef(icoef), file_id = file_id)
- Call rttov_initcoeffs (errorstatus, coef(icoef))
- Open ( unit = file_out, file = 'rtcoef_1_ascii_2.out' )
- Call Rttov_writecoef (errorstatus, coef(icoef), file_out)
- Close ( unit = file_out )
-
- ! Now open a new ASCII coefficient file with a selection of channels
- Write(*,*) 'enter platform, satid, instrument '
- Read(*,*) instrument
- Write(*,*) 'enter the number of channels '
- Read(*,*) nchannels
- Write(*,*) 'enter a list of channels '
- Allocate ( channels( nchannels ) )
- Read(*,*) channels(:)
-
- icoef = 3
- ! get the file name from instrument triplet
- Call rttov_coeffname (errorstatus, instrument, coeffname)
- ! let the subroutine choose a logical unit for the file
- file_id = 0
-
-
- ! open the file in ASCII mode
- Call rttov_opencoeff (errorstatus, coeffname, file_id)
-
- ! read the coefficients for the selection of channels
- Call rttov_readcoeffs (errorstatus, coef(icoef), file_id = file_id, channels = channels)
- Call rttov_initcoeffs (errorstatus, coef(icoef))
-
- ! Open an output file and store the coefficents in ASCII format
- Open ( unit = file_out, file = 'rtcoef_2_ascii.out' )
- Call Rttov_writecoef (errorstatus, coef(icoef), file_out)
- Close ( unit = file_out )
-
- Stop
-End Program test_coef
diff --git a/src/LIB/RTTOV/src/test_errorhandling.F90 b/src/LIB/RTTOV/src/test_errorhandling.F90
deleted file mode 100644
index 66a8270cc31b4384148ea52afee3b3429c04f601..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/test_errorhandling.F90
+++ /dev/null
@@ -1,258 +0,0 @@
-!
-Program test_errorhandling
- !
- ! Description:
- ! Main code to test functionalities of RTTOV error handling
- ! Start with default values for error logical unit and verbosity
- ! Send messages for all error levels
- ! Change the verboisty level from Max to Min and always send the same
- ! verbosity messages
- ! The user should verify the correct effects of the calls
- !
- ! Copyright:
- ! This software was developed within the context of
- ! the EUMETSAT Satellite Application Facility on
- ! Numerical Weather Prediction (NWP SAF), under the
- ! Cooperation Agreement dated 25 November 1998, between
- ! EUMETSAT and the Met Office, UK, by one or more partners
- ! within the NWP SAF. The partners in the NWP SAF are
- ! the Met Office, ECMWF, KNMI and MeteoFrance.
- !
- ! Copyright 2002, EUMETSAT, All Rights Reserved.
- !
- ! Method:
- !
- ! Current Code Owner: SAF NWP
- !
- ! History:
- ! Version Date Comment
- ! ------- ---- -------
- ! 1.0 10/01/03 Original (P Brunel)
- !
- ! Code Description:
- ! Language: Fortran 90.
- ! Software Standards: "European Standards for Writing and
- ! Documenting Exchangeable Fortran 90 Code".
- !
- ! Declarations:
- ! Modules used:
-
- ! Imported Type Definitions:
- Use rttov_const, Only : &
- & errorstatus_info ,&
- & errorstatus_success ,&
- & errorstatus_fatal ,&
- & errorstatus_warning ,&
- & default_err_unit
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-#include "rttov_errorhandling.interface"
-#include "rttov_errorreport.interface"
-
- !- Local variables
- Integer(Kind=jpim) :: ios
- Integer(Kind=jpim) :: Err_Unit ! Logical error unit
- Integer(Kind=jpim) :: verbosity_level
- Character (len=80) :: errMessage
- Character (len=18) :: NameOfRoutine = 'test_errorhandling'
- !- End of header --------------------------------------------------------
-
- ! 1 Default error unit
- !---------------------
- Write(*,*) 'Test with default error logical unit number ', default_err_unit
- Write(*,*) ' control results on this unit (should be on screen) '
- Write(*,*) 'If no message appears on screen then change the default_err_unit'
- Write(*,*) ' in rttov_const.f90 according to your system'
-
- Err_unit = -1
-
- ! 1.1 default verbosity level
- !----------------------------
- Write(*,*) ' '
- Write(*,*) 'test with default verbosity level '
- verbosity_level = -1
-
- call rttov_errorhandling ( Err_unit, verbosity_level)
-
- Write(*,*) 'now the code will output messages for all error levels '
- errMessage="test"
- Call Rttov_ErrorReport (errorstatus_info , errMessage, NameOfRoutine)
- Call Rttov_ErrorReport (errorstatus_success, errMessage, NameOfRoutine)
- Call Rttov_ErrorReport (errorstatus_fatal , errMessage, NameOfRoutine)
- Call Rttov_ErrorReport (errorstatus_warning, errMessage, NameOfRoutine)
-
-
- ! 1.2 verbosity level 0
- !----------------------
- Write(*,*) ' '
- Write(*,*) 'test with verbosity level 0 (no output)'
- verbosity_level = 0
-
- call rttov_errorhandling ( Err_unit, verbosity_level)
-
- Write(*,*) 'now the code will output messages for all error levels '
- Write(*,*) 'you should see nothing '
- errMessage="test"
- Call Rttov_ErrorReport (errorstatus_info , errMessage, NameOfRoutine)
- Call Rttov_ErrorReport (errorstatus_success, errMessage, NameOfRoutine)
- Call Rttov_ErrorReport (errorstatus_fatal , errMessage, NameOfRoutine)
- Call Rttov_ErrorReport (errorstatus_warning, errMessage, NameOfRoutine)
-
-
- ! 1.3 verbosity level 1
- !----------------------
- Write(*,*) ' '
- Write(*,*) 'test with verbosity level 1 (Fatal only)'
- verbosity_level = 1
-
- call rttov_errorhandling ( Err_unit, verbosity_level)
-
- Write(*,*) 'now the code will output messages for all error levels '
- Write(*,*) 'you should see Fatal message '
- errMessage="test"
- Call Rttov_ErrorReport (errorstatus_info , errMessage, NameOfRoutine)
- Call Rttov_ErrorReport (errorstatus_success, errMessage, NameOfRoutine)
- Call Rttov_ErrorReport (errorstatus_fatal , errMessage, NameOfRoutine)
- Call Rttov_ErrorReport (errorstatus_warning, errMessage, NameOfRoutine)
-
-
- ! 1.4 verbosity level 2
- !----------------------
- Write(*,*) ' '
- Write(*,*) 'test with verbosity level 2 (Warning)'
- verbosity_level = 2
-
- call rttov_errorhandling ( Err_unit, verbosity_level)
-
- Write(*,*) 'now the code will output messages for all error levels '
- Write(*,*) 'you should see Warning and Fatal '
- errMessage="test"
- Call Rttov_ErrorReport (errorstatus_info , errMessage, NameOfRoutine)
- Call Rttov_ErrorReport (errorstatus_success, errMessage, NameOfRoutine)
- Call Rttov_ErrorReport (errorstatus_fatal , errMessage, NameOfRoutine)
- Call Rttov_ErrorReport (errorstatus_warning, errMessage, NameOfRoutine)
-
-
- ! 1.5 verbosity level 3
- !----------------------
- Write(*,*) ' '
- Write(*,*) 'test with verbosity level 3 (Information)'
- verbosity_level = 3
-
- call rttov_errorhandling ( Err_unit, verbosity_level)
-
- Write(*,*) 'now the code will output messages for all error levels '
- Write(*,*) 'you should see all messages '
- errMessage="test"
- Call Rttov_ErrorReport (errorstatus_info , errMessage, NameOfRoutine)
- Call Rttov_ErrorReport (errorstatus_success, errMessage, NameOfRoutine)
- Call Rttov_ErrorReport (errorstatus_fatal , errMessage, NameOfRoutine)
- Call Rttov_ErrorReport (errorstatus_warning, errMessage, NameOfRoutine)
-
- ! 2 error unit number 10
- !-----------------------
- Write(*,*) ' '
- Write(*,*) ' '
- Write(*,*) ' '
- Write(*,*) 'test with error logical unit number 10'
- Write(*,*) 'on file test_errorhandling.lst'
- Write(*,*) 'control results on this unit '
- Err_unit = 10
- Open (unit=Err_unit, file='test_errorhandling.lst',iostat=ios)
- If(ios /= 0 ) Then
- Write(*,*) 'error opening output file test_errorhandling.lst'
- Write(*,*) 'iostatus is ',ios
- Stop
- End If
-
- ! 2.1 default verbosity level
- !----------------------------
- Write(*,*) ' '
- Write(*,*) 'test with default verbosity level '
- Write(Err_unit,*) 'test with default verbosity level '
- verbosity_level = -1
-
- call rttov_errorhandling ( Err_unit, verbosity_level)
-
- Write(*,*) 'now the code will output messages for all error levels '
- errMessage="test"
- Call Rttov_ErrorReport (errorstatus_info , errMessage, NameOfRoutine)
- Call Rttov_ErrorReport (errorstatus_success, errMessage, NameOfRoutine)
- Call Rttov_ErrorReport (errorstatus_fatal , errMessage, NameOfRoutine)
- Call Rttov_ErrorReport (errorstatus_warning, errMessage, NameOfRoutine)
-
-
- ! 2.2 verbosity level 0
- !----------------------
- Write(*,*) ' '
- Write(*,*) 'test with verbosity level 0 (no output)'
- Write(Err_unit,*) 'test with verbosity level 0 (no output)'
- verbosity_level = 0
-
- call rttov_errorhandling ( Err_unit, verbosity_level)
-
- Write(*,*) 'now the code will output messages for all error levels '
- Write(*,*) 'you should see nothing '
- errMessage="test"
- Call Rttov_ErrorReport (errorstatus_info , errMessage, NameOfRoutine)
- Call Rttov_ErrorReport (errorstatus_success, errMessage, NameOfRoutine)
- Call Rttov_ErrorReport (errorstatus_fatal , errMessage, NameOfRoutine)
- Call Rttov_ErrorReport (errorstatus_warning, errMessage, NameOfRoutine)
-
-
- ! 2.3 verbosity level 1
- !----------------------
- Write(*,*) ' '
- Write(*,*) 'test with verbosity level 1 (Fatal only)'
- Write(Err_unit,*) 'test with verbosity level 1 (Fatal only)'
- verbosity_level = 1
-
- call rttov_errorhandling ( Err_unit, verbosity_level)
-
- Write(*,*) 'now the code will output messages for all error levels '
- Write(*,*) 'you should see Fatal message '
- errMessage="test"
- Call Rttov_ErrorReport (errorstatus_info , errMessage, NameOfRoutine)
- Call Rttov_ErrorReport (errorstatus_success, errMessage, NameOfRoutine)
- Call Rttov_ErrorReport (errorstatus_fatal , errMessage, NameOfRoutine)
- Call Rttov_ErrorReport (errorstatus_warning, errMessage, NameOfRoutine)
-
-
- ! 2.4 verbosity level 2
- !----------------------
- Write(*,*) ' '
- Write(*,*) 'test with verbosity level 2 (Warning)'
- Write(Err_unit,*) 'test with verbosity level 2 (Warning)'
- verbosity_level = 2
-
- call rttov_errorhandling ( Err_unit, verbosity_level)
-
- Write(*,*) 'now the code will output messages for all error levels '
- Write(*,*) 'you should see Warning and Fatal '
- errMessage="test"
- Call Rttov_ErrorReport (errorstatus_info , errMessage, NameOfRoutine)
- Call Rttov_ErrorReport (errorstatus_success, errMessage, NameOfRoutine)
- Call Rttov_ErrorReport (errorstatus_fatal , errMessage, NameOfRoutine)
- Call Rttov_ErrorReport (errorstatus_warning, errMessage, NameOfRoutine)
-
-
- ! 2.5 verbosity level 3
- !----------------------
- Write(*,*) ' '
- Write(*,*) 'test with verbosity level 3 (Information)'
- Write(Err_unit,*) 'test with verbosity level 3 (Information)'
- verbosity_level = 3
-
- call rttov_errorhandling ( Err_unit, verbosity_level)
-
- Write(*,*) 'now the code will output messages for all error levels '
- Write(*,*) 'you should see all messages '
- errMessage="test"
- Call Rttov_ErrorReport (errorstatus_info , errMessage, NameOfRoutine)
- Call Rttov_ErrorReport (errorstatus_success, errMessage, NameOfRoutine)
- Call Rttov_ErrorReport (errorstatus_fatal , errMessage, NameOfRoutine)
- Call Rttov_ErrorReport (errorstatus_warning, errMessage, NameOfRoutine)
-
- Stop
-End Program Test_errorhandling
diff --git a/src/LIB/RTTOV/src/test_q2v.F90 b/src/LIB/RTTOV/src/test_q2v.F90
deleted file mode 100644
index b396d6c6c6ca415db8753f20d66401a2c3d25206..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/test_q2v.F90
+++ /dev/null
@@ -1,155 +0,0 @@
-!
-Program test_q2v
- ! Description:
- ! Main code to test functionalities of RTTOV gaz unit conversions
- ! The RTTOV6/7 reference profile is used to validate the tests
- !
- ! Copyright:
- ! This software was developed within the context of
- ! the EUMETSAT Satellite Application Facility on
- ! Numerical Weather Prediction (NWP SAF), under the
- ! Cooperation Agreement dated 25 November 1998, between
- ! EUMETSAT and the Met Office, UK, by one or more partners
- ! within the NWP SAF. The partners in the NWP SAF are
- ! the Met Office, ECMWF, KNMI and MeteoFrance.
- !
- ! Copyright 2002, EUMETSAT, All Rights Reserved.
- !
- ! Method:
- !
- ! Current Code Owner: SAF NWP
- !
- ! History:
- ! Version Date Comment
- ! ------- ---- -------
- ! 1.0 27/01/03 Original (P Brunel)
- !
- ! Code Description:
- ! Language: Fortran 90.
- ! Software Standards: "European Standards for Writing and
- ! Documenting Exchangeable Fortran 90 Code".
- !
- ! Declarations:
- ! Modules used:
- Use rttov_const, Only : &
- gas_id_watervapour ,&
- gas_id_ozone ,&
- gas_unit_specconc ,&
- gas_unit_ppmv
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-#include "rttov_q2v.interface"
-#include "rttov_v2q.interface"
-
- !- Local variables
- Integer(Kind=jpim) :: luin
- Integer(Kind=jpim) :: ios
- Integer(Kind=jpim) :: l,il
- Integer(Kind=jpim) :: nerr
- Integer(Kind=jpim) :: n
- Integer(Kind=jpim) :: List_of_gases(2)
- Real(Kind=jprb) :: ref_h2o(43), ref_o3(43)
- Real(Kind=jprb) :: v_h2o_old(43)
- Real(Kind=jprb) :: v_o3_old(43)
- Real(Kind=jprb) :: q_gas(2)
- Real(Kind=jprb) :: v_gas(2,43)
- Real(Kind=jprb) :: p,t,t1
- !- End of header --------------------------------------------------------
-
- luin = 10
- open( unit=luin, &
- & file='refprof_43.dat',&
- & status='old', &
- & action='read', &
- & iostat=ios)
-
- if(ios /= 0 )then
- write(*,*) 'error opening file refprof_43.dat ios=', ios
- stop
- End if
-
- read(luin,*)
- read(luin,*)
-
- Do l=1,43
-! read(luin,"(19x,e12.6,10x,e12.6)") ref_h2o(l), ref_o3(l)
- read(luin,*) il,p,t, ref_h2o(l),t1, ref_o3(l)
- End Do
-
- ! Converion specific concentration to ppmv with "old" formula
- ! specific concentration == mass mixing ratio
- ! constants extracted from RTTOV6/7 code
- Do l=1,43
- v_h2o_old(l) = ref_h2o(l) * 1.60771704e+6_JPRB
- v_o3_old(l) = ref_o3(l) * 6.03504e+5_JPRB
- End Do
-
-
- ! Converion specific concentration to ppmv with exact formula
- List_of_gases( 1 ) = gas_id_watervapour
- List_of_gases( 2 ) = gas_id_ozone
-
- ! calculate volume mixing ratio (ppmv) for the 2 gases
- Do l=1,43
- q_gas( 1 ) = ref_h2o(l)
- q_gas( 2 ) = ref_o3(l)
- Do n=1,2
- call rttov_q2v( gas_unit_specconc, ref_h2o(l),&
- & List_of_gases(n), q_gas(n), v_gas(n,l))
- End Do
- End Do
-
- ! Print differences between old and new formula
- write(*,*) ' Water Vapour '
- write(*,"(a3,3a12,a8)") 'lev','kg/kg','old ppmv','new ppmv',' %'
- Do l=1,43
- write(*,"(i3,3E12.5,F8.4)") l,&
- & ref_h2o(l), v_h2o_old(l), v_gas(1,l),&
- & 100._JPRB*(v_h2o_old(l) - v_gas(1,l)) / v_h2o_old(l)
- End Do
-
- write(*,*)
- write(*,*) ' Ozone '
- write(*,"(a3,3a12,a8)") 'lev','kg/kg','old ppmv','new ppmv',' %'
- Do l=1,43
- write(*,"(i3,3E12.5,F8.4)") l,&
- & ref_o3(l), v_o3_old(l), v_gas(2,l),&
- & 100._JPRB*(v_o3_old(l) - v_gas(2,l)) / v_o3_old(l)
- End Do
-
-
- ! Verify reverse calculation with rttov_v2q subroutine
- ! and compare to input value
- nerr = 0
- Do l=1,43
- Do n=1,2
- call rttov_v2q( gas_unit_specconc, ref_h2o(l),&
- & List_of_gases(n), v_gas(n,l), q_gas(n))
- End Do
- If( abs( q_gas( 1 ) - ref_h2o(l) ) > ref_h2o(l)*1.e-09_JPRB ) then
- nerr = nerr + 1
- write(*,*) 'H2O conversion error for level',l
- write(*,"(3E20.9)")&
- & ref_h2o(l) ,&
- & v_gas(1,l),&
- & q_gas( 1 )
- End If
- If( abs( q_gas( 2 ) - ref_o3(l) ) > ref_o3(l)*1.e-09_JPRB ) then
- nerr = nerr + 1
- write(*,*) 'O3 conversion error for level',l
- write(*,"(3E20.9)")&
- & ref_o3(l) ,&
- & v_gas(2,l),&
- & q_gas( 2 )
- End If
- End Do
-
- If( nerr == 0 ) then
- write(*,*)
- write(*,*) 'Reverse calculation test successfull (precision 1.e-09)'
- write(*,*)
- End If
-
- Stop
-End Program test_q2v
diff --git a/src/LIB/RTTOV/src/tstrad.F90 b/src/LIB/RTTOV/src/tstrad.F90
deleted file mode 100644
index bf7dac2d33c5c64c085eceba65ce227abf748db1..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/tstrad.F90
+++ /dev/null
@@ -1,939 +0,0 @@
-PROGRAM TSTRAD
- !
- ! This software was developed within the context of
- ! the EUMETSAT Satellite Application Facility on
- ! Numerical Weather Prediction (NWP SAF), under the
- ! Cooperation Agreement dated 25 November 1998, between
- ! EUMETSAT and the Met Office, UK, by one or more partners
- ! within the NWP SAF. The partners in the NWP SAF are
- ! the Met Office, ECMWF, KNMI and MeteoFrance.
- !
- ! Copyright 2002, EUMETSAT, All Rights Reserved.
- !
- ! *************************************************************
- !
- ! TEST PROGRAM FOR RTTOV SUITE.
- ! RTTOV VERSION 8
- !
- ! Description: This program is the test harness for RTTOV-8. There
- ! are 3 options:
- ! option = 0 to test forward model only
- ! option = 1 to test the full model ie TL/AD/K
- ! option = 2 to test the cloudy radiance output
- !
- ! To run this program you must have the following files
- ! either resident in the same directory or set up as a
- ! symbolic link:
- ! refprof.dat -- reference profile
- ! prof.dat -- input profile
- ! input.dat -- file to select channels and surface emis
- ! rtcoef_platform_id_sensor.dat -- coefficient file to match
- ! the sensor you request in the input dialogue
- ! There are unix scripts available to set up the files above and
- ! run this program (e.g. tstrad_full.scr)
- ! The output is generated in a file called print.dat.
- ! This output can be compared with reference output generated
- ! by the code developers and included with the export package.
- !
- ! Current Code Owner: SAF NWP
- !
- ! History:
- ! Version Date Comment
- ! ------- ---- -------
- ! 25/01/2002 Initial version (R. Saunders)
- ! 01/05/2002 Updated for NOAA-17 (R. Saunders)
- ! 01/12/2002 New F90 code with structures (P Brunel A Smith)
- ! 02/01/2003 Comments added (R Saunders)
- ! 10/12/2003 Updated for polarimetric changes (S. English/R.Saunders)
- ! 01/04/2004 Updated for chan setup routines (R.Saunders)
- !
- ! Code Description:
- ! Language: Fortran 90.
- ! Software Standards: "European Standards for Writing and
- ! Documenting Exchangeable Fortran 90 Code".
- !
- Use rttov_const, only : &
- nplatforms ,&
- ninst ,&
- pi ,&
- errorstatus_fatal ,&
- errorstatus_warning ,&
- errorstatus_success ,&
- platform_name ,&
- sensor_id_mw ,&
- inst_name, &
- npolar_return, &
- npolar_compute
-
-
- Use rttov_types, only : &
- rttov_coef ,&
- profile_type ,&
- transmission_Type ,&
- radiance_type
-
- Use mod_tstrad
- !
- Use parkind1, Only : jpim ,jprb
- Implicit None
- !
-#include "rttov_errorreport.interface"
-#include "rttov_setup.interface"
-#include "rttov_setupchan.interface"
-#include "rttov_setupindex.interface"
-#include "rttov_errorhandling.interface"
-#include "rttov_direct.interface"
-!!#include "rttov_readcoeffs.interface"
-!!#include "rttov_initcoeffs.interface"
-#include "rttov_dealloc_coef.interface"
-#include "tstrad_tl.interface"
-#include "tstrad_ad.interface"
-#include "tstrad_k.interface"
- !
- ! Parameter for WV conversion used in all tstrad suite
- Real(Kind=jprb), Parameter :: q_mixratio_to_ppmv = 1.60771704e+6_JPRB
- !
- type( rttov_coef ), allocatable :: coef(:) ! coefficients
- type(profile_type), allocatable :: profiles(:)
- type(transmission_type) :: transmission
- type(radiance_type) :: radiance
- !
- Integer(Kind=jpim), Allocatable :: instrument(:,:) ! instrument id
- Integer(Kind=jpim), Allocatable :: nchan(:,:) ! number of channels per instrument and profile
- Integer(Kind=jpim), Allocatable :: ifull(:) ! full test (with TL,AD,K) per instrument
- Integer(Kind=jpim), Allocatable :: nprof(:) ! number of profiles per instrument
- Integer(Kind=jpim), Allocatable :: nsurf(:) ! surface id number per instrument
- Real(Kind=jprb), Allocatable :: surfem(:,:) ! surface input emissivity per channel , instrument
- Integer(Kind=jpim), Allocatable :: ichan(:,:) ! channel list per instrument
- Real(Kind=jprb), Allocatable :: surfem1(:) ! surface input emissivity per channel for all profiles
- Integer(Kind=jpim), Allocatable :: ichan1(:) ! channel list per instrument
-
- integer(Kind=jpim) :: nbtout
- integer(Kind=jpim) :: nfrequencies
- Integer(Kind=jpim) :: nchannels
- integer(Kind=jpim), Allocatable :: polarisations (:,:)
- integer(Kind=jpim), Allocatable :: frequencies (:)
- Integer(Kind=jpim), Allocatable :: channels (:)
- Integer(Kind=jpim), Allocatable :: lprofiles (:)
- Real(Kind=jprb), Allocatable :: emissivity (:)
- Real(Kind=jprb), Allocatable :: input_emissivity (:)
- logical, Allocatable :: calcemis (:)
-
- Integer(Kind=jpim) :: coef_errorstatus ! read coeffs error return code
- Integer(Kind=jpim), Allocatable :: rttov_errorstatus(:) ! rttov error return code
- Integer(Kind=jpim), Allocatable :: setup_errorstatus(:) ! setup return code
-
- ! min and max satellite id for each platform
- Integer(Kind=jpim), dimension(nplatforms) :: max_satid
- Integer(Kind=jpim), dimension(nplatforms) :: min_satid
-
- ! min and max channel numbers for each instrument
-
- integer(Kind=jpim), dimension(0:ninst-1) :: max_channel_old
- integer(Kind=jpim), dimension(0:ninst-1) :: max_channel_new
- integer(Kind=jpim), dimension(0:ninst-1) :: max_channel
- integer(Kind=jpim), parameter :: mxchn = 500 ! max number of channels per instruments allowed in one run
-
- ! polarisations to be computed and returned
- integer(Kind=jpim), Allocatable :: indexout(:)
-
- ! printing arrays
- real(Kind=jprb), Allocatable :: pr_radcld(:)
- real(Kind=jprb), Allocatable :: pr_trans(:)
- real(Kind=jprb), Allocatable :: pr_emis(:)
- real(Kind=jprb), Allocatable :: pr_trans_lev(:,:)
- real(Kind=jprb), Allocatable :: pr_upclr(:)
- real(Kind=jprb), Allocatable :: pr_dncld(:,:)
- real(Kind=jprb), Allocatable :: pr_refclr(:)
- real(Kind=jprb), Allocatable :: pr_ovcst(:,:)
- integer(Kind=jpim), dimension(1:mxchn) :: pr_pol
-
- data min_satid / 1, 8, 1, 8, 5, 2, 1, 1, 1, 1, 1, 1, 3, 2, 1, 1, 1, 1, 0, 0 /
- data max_satid /18,16, 7,12, 5, 3, 1, 2, 3, 1, 1, 2, 4, 2, 1, 1, 1, 1, 0, 0/
- data max_channel_old / 20, 4, 3, 15, 5, 3, 7, 8, 8, 9,&
- & 24, 2378, 4, 16, 3, 5, 8461,14, 4,22,&
- & 2, 8, 4, 18, 4, 3, 3,1000, 40, 22, &
- & 5, 3000, 0, 0, 0/
- data max_channel_new / 20, 4, 3, 15, 5, 3, 4, 8, 8, 9,&
- & 21, 2378, 4, 16, 3, 5, 8461,14, 4,22,&
- & 2, 8, 4, 18, 4, 3, 3,1000, 40, 22, &
- & 5, 3000, 0, 0, 0/
-
- Character (len=80) :: errMessage
- Character (len=6) :: NameOfRoutine = 'tstrad'
- Character (len=3) :: coeff_version = 'old'
- !
- Integer(Kind=jpim) :: Err_Unit ! Logical error unit (<0 for default)
- Integer(Kind=jpim) :: verbosity_level ! (<0 for default)
-
- Integer(Kind=jpim) :: nrttovid ! maximum number of instruments
- Integer(Kind=jpim) :: no_id ! instrument loop index
- Integer(Kind=jpim) :: nlevels
- Integer(Kind=jpim) :: ios
- integer(Kind=jpim) :: i,pol_id,ich2
- integer(Kind=jpim) :: ichannels, ibtout
- Integer(Kind=jpim) :: j
- Integer(Kind=jpim) :: jjm, ira, jj
- integer(Kind=jpim) :: jch, jpol
- integer(Kind=jpim) :: jn, joff1, joff2, joff3
- Integer(Kind=jpim) :: nprint
- Integer(Kind=jpim) :: np, ilev
- Integer(Kind=jpim) :: n
- Integer(Kind=jpim) :: nch ! intermediate variable
- Integer(Kind=jpim) :: ich ! intermediate variable
- Integer(Kind=jpim) :: ii ! intermediate variable
- Integer(Kind=jpim) :: errorstatus
- Real(Kind=jprb) :: s
- Real(Kind=jprb) :: zenang
- Real(Kind=jprb) :: azang
- logical :: lcloud
-
- Integer(Kind=jpim) :: iua
- Integer(Kind=jpim) :: ioout
- Integer(Kind=jpim) :: iue
-
- ! Unit numbers for input/output
- DATA IUA/1/,IOOUT/2/,IUE/56/
-
- Integer(Kind=jpim) :: alloc_status(40)
-
-
- !- End of header --------------------------------------------------------
-
-
- errorstatus = 0
- alloc_status(:) = 0
-
- !Initialise error management with default value for
- ! the error unit number and
- ! Fatal error message output
- Err_unit = -1
- verbosity_level = 1
- ! All error message output
- verbosity_level = 3
- call rttov_errorhandling(Err_unit, verbosity_level)
-
- ! Beginning of Routine.
- ! ---------------------
-
- OPEN(IOOUT,file='print.dat',status='unknown',form='formatted')
-
- ! For more than one satellite
- ! comment out the next line and uncomment the following two.
-
- NRTTOVID = 1
-
- ! PRINT *, 'How many satellites do you want?'
- ! READ *, NRTTOVID
-
- allocate (coef(nrttovid),stat= alloc_status(1))
-
- allocate (instrument(3,nrttovid),stat= alloc_status(2))
- allocate (ifull(nrttovid),stat= alloc_status(4))
- allocate (nprof(nrttovid),stat= alloc_status(5))
- allocate (nsurf(nrttovid),stat= alloc_status(6))
-
- !maximum number of channels allowed for one instrument is mxchn
- allocate (surfem(mxchn,nrttovid),stat= alloc_status(7))
- allocate (ichan (mxchn,nrttovid),stat= alloc_status(8))
- If( any(alloc_status /= 0) ) then
- errorstatus = errorstatus_fatal
- Write( errMessage, '( "mem allocation error")' )
- Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine)
- Stop
- End If
-
- surfem(:,:) = 0.0_JPRB
- ichan(:,:) = 0
-
- DO NO_ID = 1, NRTTOVID
-
- write(*,*) 'Which satellite platform do you want?'
- WRITE(*,'(4(2x,i3,2x,a8))') (i,platform_name(i), i = 1, nplatforms)
- READ *, Instrument(1,no_id)
- IF ( Instrument(1,no_id) <= 0 .OR. &
- & Instrument(1,no_id) > nplatforms) STOP 'Platform number not allowed'
-
- WRITE(*,*) 'Which satellite id do you want for this platform?'
- WRITE(*,*) 'Noaaxx = xx GOESyy = yy'
- READ *, instrument(2,no_id)
-
- if( instrument(2,no_id) < min_satid(Instrument(1,no_id)) .or. &
- & instrument(2,no_id) > max_satid(Instrument(1,no_id)) ) &
- & STOP 'Satellite id not allowed'
-
- WRITE(*,*) 'Which instrument type do you want for this satellite?'
- write(*, '(4(2x,i3,2x,a8))') (i, inst_name(i), i = 0, ninst-1)
-
- READ *, instrument(3,no_id)
- IF ( instrument(3,no_id) < 0 .OR. &
- & instrument(3,no_id) > ninst-1)&
- & STOP 'instrument number not allowed'
-
- WRITE(*,*) ' Forward model only (0) or full gradient test (1)',&
- & ' or full radiance output (2)?'
- READ *, IFULL(no_id)
- PRINT *, ' Number of profiles to test code? '
- READ *, NPROF(no_id)
- PRINT *, ' Surface type (0=land, 1=sea, 2=ice/snow)? '
- READ *, NSURF(no_id)
- !
- !..SET UP CHANNEL NUMBERS
- !
- ! .. DEFAULT MAXIMUMS
- if (coeff_version == 'old') max_channel(:)=max_channel_old(:)
- if (coeff_version == 'new') max_channel(:)=max_channel_new(:)
- allocate (nchan(nprof(no_id),nrttovid),stat= alloc_status(3))
- nchan(1:nprof(no_id),no_id) = max_channel(instrument(3,no_id))
- !
- ! Note that channels are the same for all instruments
- ! and all profiles because the filename is the same
- OPEN (IUE,FILE='input.dat',status='old')
- READ(IUE,*)
- NCH = 0
- DO ICH = 1 , nchan(1,no_id)
- READ(IUE,*,iostat=ios)I,II,S
- if(ios /= 0 ) then
- write (*,*) ' TOO FEW CHANNELS IN INPUT FILE '
- write (*,*) ' nchan(1,no_id),no_id ',nchan(1,no_id),no_id
- stop
- endif
- IF(II.GT.0)THEN
- NCH = NCH + 1
- ICHAN(nch,no_id) = I
- SURFEM(nch,no_id) = s
- ENDIF
- ENDDO
- !
- CLOSE(IUE)
-
- ! nchan(1,no_id) is now the real number of channels selected
- do j = 1 , nprof(no_id)
- nchan(j,no_id) = MIN(max_channel(instrument(3,no_id)),NCH)
- enddo
- write(6,*)' Number of channels selected = ',nchan(1,no_id)
- allocate (ichan1(nchan(1,no_id)),stat= alloc_status(8))
- ichan1(1:nchan(1,no_id)) = ichan(1:nchan(1,no_id),no_id)
- !
- !---------------------------------------------------------
- ! Beginning of rttov_readcoeffs test
- !---------------------------------------------------------
-!!$ call rttov_readcoeffs (coef_errorstatus, coef(no_id), instrument(:,no_id),&
-!!$ call rttov_initcoeffs (coef_errorstatus, coef(no_id))
-!!$ & channels = ichan(1:nchan(1,no_id) ,no_id) )
-!!$
-!!$ if(coef_errorstatus /= errorstatus_success ) then
-!!$ write ( ioout, * ) 'rttov_readcoeffs fatal error'
-!!$ stop
-!!$ endif
-!!$
-!!$ if( any(coef(no_id)%ff_val_chn( 1 : coef(no_id)%fmv_chn ) /= 1 )) then
-!!$ WRITE(*,*) ' some requested channels have bad validity parameter'
-!!$ do i = 1, nchan(1,no_id)
-!!$ write(*,*) i, coef(no_id)%ff_val_chn(i)
-!!$ end do
-!!$ endif
- !---------------------------------------------------------
- ! End of rttov_readcoeffs test
- !---------------------------------------------------------
- END DO
-
- !---------------------------------------------------------
- ! Beginning of rttov_setup test
- !---------------------------------------------------------
- allocate ( setup_errorstatus(nrttovid),stat= alloc_status(1))
- If( any(alloc_status /= 0) ) then
- errorstatus = errorstatus_fatal
- Write( errMessage, '( "mem allocation error for errorsetup")' )
- Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine)
- Stop
- End If
- Call rttov_setup (&
- & setup_errorstatus, & ! out
- & Err_unit, & ! in
- & verbosity_level, & ! in
- & nrttovid, & ! in
- & coef, & ! out
- & instrument, & ! in
- & ichan ) ! in Optional
-
- if(any(setup_errorstatus(:) /= errorstatus_success ) ) then
- write ( ioout, * ) 'rttov_setup fatal error'
- stop
- endif
-
- deallocate( setup_errorstatus ,stat=alloc_status(1))
- If( any(alloc_status /= 0) ) then
- errorstatus = errorstatus_fatal
- Write( errMessage, '( "mem deallocation error for setup_errorstatus")' )
- Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine)
- Stop
- End If
-
- DO no_id = 1, NRTTOVID
- if( any(coef(no_id)%ff_val_chn( : ) /= 1 )) then
- WRITE(*,*) ' some requested channels have bad validity parameter'
- do i = 1, nchan(1,no_id)
- write(*,*) i, coef(no_id)%ff_val_chn(i)
- end do
- endif
- End Do
- !---------------------------------------------------------
- ! End of rttov_setup test
- !---------------------------------------------------------
- !
- DO no_id = 1, NRTTOVID
- ! Set up various channel numbers required by RTTOV-8
- Call rttov_setupchan(nprof(no_id),nchan(1:nprof(no_id),no_id),coef(no_id),nfrequencies, &
- & nchannels,nbtout)
-
- ! total number of channels
- nlevels = coef(no_id) % nlevels
-
- ! Memory allocation for RTTOV_Direct
- !-----------------------------------
- allocate( channels ( nfrequencies ) ,stat= alloc_status(1))
- allocate( rttov_errorstatus(nprof(no_id)),stat= alloc_status(1))
- allocate( profiles(nprof(no_id)),stat= alloc_status(2))
- allocate (surfem1(nchannels),stat= alloc_status(7))
- allocate( polarisations(nchannels,3),stat= alloc_status(1))
- allocate( frequencies(nbtout),stat= alloc_status(2))
- allocate( indexout(nbtout),stat= alloc_status(3))
- If( any(alloc_status /= 0) ) then
- errorstatus = errorstatus_fatal
- Write( errMessage, '( "mem allocation error")' )
- Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine)
- Stop
- End If
-
- do j = 1, nprof(no_id)
- ! allocate model profiles atmospheric arrays with model levels dimension
- profiles(j) % nlevels = coef(no_id) % nlevels
- allocate( profiles(j) % p ( coef(no_id) % nlevels ) ,stat= alloc_status(4))
- allocate( profiles(j) % t ( coef(no_id) % nlevels ) ,stat= alloc_status(5))
- allocate( profiles(j) % q ( coef(no_id) % nlevels ) ,stat= alloc_status(6))
- allocate( profiles(j) % o3 ( coef(no_id) % nlevels ) ,stat= alloc_status(7))
- allocate( profiles(j) % clw( coef(no_id) % nlevels ) ,stat= alloc_status(8))
- profiles(j) % p(:) = coef(no_id) % ref_prfl_p(:)
- If( any(alloc_status /= 0) ) then
- errorstatus = errorstatus_fatal
- Write( errMessage, '( "mem allocation error")' )
- Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine)
- Stop
- End If
- end do
-
- ! number of channels per RTTOV call is only nchannels
- allocate( lprofiles ( nfrequencies ) ,stat= alloc_status(9))
- allocate( emissivity ( nchannels ) ,stat= alloc_status(10))
- allocate( input_emissivity ( nchannels ) ,stat= alloc_status(11))
- allocate( calcemis ( nchannels ) ,stat= alloc_status(12))
-
- ! allocate transmittance structure
- allocate( transmission % tau_surf ( nchannels ) ,stat= alloc_status(13))
- allocate( transmission % tau_layer ( coef(no_id) % nlevels, nchannels ) ,stat= alloc_status(14))
- allocate( transmission % od_singlelayer( coef(no_id) % nlevels, nchannels ),stat= alloc_status(15))
-
- ! allocate radiance results arrays with number of channels
- allocate( radiance % clear ( nchannels ) ,stat= alloc_status(19))
- allocate( radiance % cloudy ( nchannels ) ,stat= alloc_status(20))
- allocate( radiance % total ( nchannels ) ,stat= alloc_status(21))
- allocate( radiance % bt ( nchannels ) ,stat= alloc_status(22))
- allocate( radiance % bt_clear ( nchannels ) ,stat= alloc_status(23))
- allocate( radiance % upclear ( nchannels ) ,stat= alloc_status(24))
- allocate( radiance % dnclear ( nchannels ) ,stat=alloc_status(25))
- allocate( radiance % reflclear( nchannels ) ,stat= alloc_status(26))
- allocate( radiance % overcast ( coef(no_id) % nlevels, nchannels ) ,stat= alloc_status(27))
-
- ! allocate the cloudy radiances with full size even if not used
- ! Save input values of emissivities for all calculations.
- allocate( radiance % downcld ( coef(no_id) % nlevels, nchannels ) ,stat= alloc_status(28))
- allocate( radiance % out ( nbtout ) ,stat= alloc_status(29))
- allocate( radiance % out_clear( nbtout ) ,stat= alloc_status(30))
- allocate( radiance % total_out( nbtout ) ,stat= alloc_status(31))
- allocate( radiance % clear_out( nbtout ) ,stat= alloc_status(32))
-
- Allocate(pr_radcld(nbtout) ,stat= alloc_status(33))
- Allocate(pr_trans(nbtout) ,stat= alloc_status(34))
- Allocate(pr_emis(nbtout) ,stat= alloc_status(35))
- Allocate(pr_trans_lev(coef(no_id) % nlevels,nbtout) ,stat= alloc_status(36))
- Allocate(pr_upclr(nbtout) ,stat= alloc_status(37))
- Allocate(pr_dncld(coef(no_id) % nlevels,nbtout) ,stat= alloc_status(38))
- Allocate(pr_refclr(nbtout) ,stat= alloc_status(39))
- Allocate(pr_ovcst(coef(no_id) % nlevels,nbtout) ,stat= alloc_status(40))
-
- If( any(alloc_status /= 0) ) then
- errorstatus = errorstatus_fatal
- Write( errMessage, '( "mem allocation error")' )
- Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine)
- Stop
- End If
-
- WRITE(6,*)'Zenith angle (degrees)?'
- READ(5,*)ZENANG
- WRITE(6,*)'Azimuth angle (degrees)?'
- READ(5,*)AZANG
-
- WRITE(6,*)' Number of level =',NLEVELS
- ! Read profile ONE and fill other profiles with profile one
- OPEN (IUA,FILE='prof.dat',status='old')
- !
- JJM = 0
- DO IRA = 1 , 1+(NLEVELS-1)/10
- JJ = 1+JJM
- JJM = MIN(JJ+9,NLEVELS)
- READ(IUA,*) (profiles(1) % t(J),J=JJ,JJM)
- end do
- JJM = 0
- DO IRA = 1 , 1+(NLEVELS-1)/10
- JJ = 1+JJM
- JJM = MIN(JJ+9,NLEVELS)
- READ(IUA,*) (profiles(1) % q(J),J=JJ,JJM)
- end do
- JJM = 0
- DO IRA = 1 , 1+(NLEVELS-1)/10
- JJ = 1+JJM
- JJM = MIN(JJ+9,NLEVELS)
- READ(IUA,*) (profiles(1) % o3(J),J=JJ,JJM)
- end do
- profiles(1) % ozone_data = .true.
- profiles(1) % co2_data = .false.
-
- JJM = 0
- DO IRA = 1 , 1+(NLEVELS-1)/10
- JJ = 1+JJM
- JJM = MIN(JJ+9,NLEVELS)
- READ(IUA,*) (profiles(1) % clw(J),J=JJ,JJM)
- end do
- ! check value of first level
- profiles(1) % clw_data = profiles(1) % clw(1) >= 0.0_JPRB
-
- READ(IUA,*) profiles(1) % s2m % t ,&
- & profiles(1) % s2m % q ,&
- & profiles(1) % s2m % p ,&
- & profiles(1) % s2m % u ,&
- & profiles(1) % s2m % v
-
-
- READ(IUA,*) profiles(1) % skin % t ,&
- & profiles(1) % skin % fastem
-
- READ(IUA,*) profiles(1) % ctp,&
- & profiles(1) % cfraction
- !
- CLOSE(IUA)
- !
- WRITE(IOOUT,*)' INPUT PROFILE'
- WRITE(IOOUT,444) (profiles(1) % t(JJ) ,JJ=1,NLEVELS)
- WRITE(IOOUT,444) (profiles(1) % q(JJ) ,JJ=1,NLEVELS)
- WRITE(IOOUT,444) (profiles(1) % o3(JJ) ,JJ=1,NLEVELS)
- WRITE(IOOUT,444) (profiles(1) % clw(JJ) ,JJ=1,NLEVELS)
- WRITE(IOOUT,444) profiles(1) % s2m % t ,&
- & profiles(1) % s2m % q ,&
- & profiles(1) % s2m % p ,&
- & profiles(1) % s2m % u ,&
- & profiles(1) % s2m % v
- WRITE(IOOUT,444) profiles(1) % skin % t ,&
- & profiles(1) % skin % fastem
- WRITE(IOOUT,444) profiles(1) % ctp,&
- & profiles(1) % cfraction
- WRITE(IOOUT,*)' '
-
- ! Convert lnq to q in ppmv for profile
- !
- profiles(1) % q(:) = (exp(profiles(1) % q(:)) / 1000._JPRB) * q_mixratio_to_ppmv
- profiles(1) % s2m % q = (exp(profiles(1) % s2m % q) / 1000._JPRB) * q_mixratio_to_ppmv
-
- ! Keep Ozone in ppmv
-
- ! viewing geometry
- profiles(1) % zenangle = ZENANG
- profiles(1) % azangle = AZANG
- ! surface type
- profiles(1) % skin % surftype = nsurf(no_id)
-
- !.. Fill profile arrays with the 1 profile NPROF times
- DO J = 1 , NPROF(no_id)
- profiles(j) % p(:) = profiles(1) % p(:)
- profiles(j) % t(:) = profiles(1) % t(:)
- profiles(j) % q(:) = profiles(1) % q(:)
- profiles(j) % o3(:) = profiles(1) % o3(:)
- profiles(j) % clw(:) = profiles(1) % clw(:)
- profiles(j) % s2m = profiles(1) % s2m
- profiles(j) % skin = profiles(1) % skin
- profiles(j) % ctp = profiles(1) % ctp
- profiles(j) % cfraction = profiles(1) % cfraction
- profiles(j) % ozone_data = profiles(1) % ozone_data
- profiles(j) % co2_data = profiles(1) % co2_data
- profiles(j) % clw_data = profiles(1) % clw_data
- profiles(j) % zenangle = profiles(1) % zenangle
- profiles(j) % azangle = profiles(1) % azangle
- end do
-
- ! Build the list of channels/profiles indices
- surfem1(:) = 0.0_JPRB
- nch = 1
- do j = 1 , nprof(no_id)
- surfem1(nch:nch+nchan(j,no_id)-1) = surfem(1:nchan(1,no_id),no_id) !Assume emissivities same as first profile
- nch = nch+nchan(j,no_id)
- enddo
- nch = 0
- Call rttov_setupindex (nchan(1:nprof(no_id),no_id),nprof(no_id),nfrequencies,nchannels,nbtout,coef(no_id),&
- & surfem1,lprofiles,channels,polarisations,emissivity)
- !
- nch = 0
- ibtout=0
- DO J=1,NPROF(no_id)
- DO JCH=1,NCHAN(1,no_id)
- nch = nch +1
- If( coef(no_id) % id_sensor /= sensor_id_mw) then
- frequencies(ibtout+1) = nch
- ibtout=ibtout+1
- End If
- If( coef(no_id) % id_sensor == sensor_id_mw) then
- pol_id = coef(no_id) % fastem_polar(jch) + 1
- Do i=1, npolar_return(pol_id)
- frequencies(ibtout+i)=nch
- End Do
- ibtout=ibtout+npolar_return(pol_id)
- End If
- End Do
- End Do
- write(6,*)' nfreq=',nfrequencies,' nchannels=',nchannels,' nbtout=',nbtout
- !write(6,*)' Channels ',(channels(ich2),ich2=1,nfrequencies)
- !write(6,*)(polarisations(ich2,1),ich2=1,nchannels)
- !write(6,*)(polarisations(ich2,2),ich2=1,nchannels)
- !write(6,*)(polarisations(ich2,3),ich2=1,nchannels)
-
- ! save input values of emissivities for all calculations
- ! calculate emissivity where the input emissivity value is less than 0.01
- input_emissivity(:) = emissivity(:)
- calcemis(:) = emissivity(:) < 0.01_JPRB
-
- WRITE(IOOUT,*)' NUMBER OF PROFILES PROCESSED=',NPROF(no_id)
- WRITE(IOOUT,*)' '
- !
- WRITE(IOOUT,*)'CHANNELS PROCESSED:'
- WRITE(IOOUT,111) (ichan(J,no_id), J = 1,NCHAN(1,no_id))
- WRITE (IOOUT,*)' '
- WRITE(IOOUT,*)'INPUT SURFACE EMISSIVITIES '&
- & ,'SAT =', instrument(2,no_id)
- JOFF1=0
- WRITE(IOOUT,444) (emissivity(J+JOFF1),J=1,NCHAN(1,no_id))
- WRITE(IOOUT,*)' '
-
- IF(IFULL(no_id).EQ.2)THEN
- LCLOUD =.TRUE.
- ELSE
- LCLOUD =.FALSE.
- radiance % downcld(:,:) = 0._JPRB
- ENDIF
- ! PERFORM RADIATIVE TRANSFER CALCULATIONS
- call rttov_direct( &
- rttov_errorstatus, & ! out
- nfrequencies, & ! in
- nchannels, & ! in
- nbtout, & ! in
- nprof(no_id), & ! in
- channels, & ! in
- polarisations,& ! in
- lprofiles, & ! in
- profiles, & ! in
- coef(no_id), & ! in
- lcloud, & ! in
- calcemis, & ! in
- emissivity, & ! inout
- transmission, & ! out
- radiance ) ! inout
-
- If ( any( rttov_errorstatus(:) == errorstatus_warning ) ) Then
- Do j = 1, nprof(no_id)
- If ( rttov_errorstatus(j) == errorstatus_warning ) Then
- write ( ioout, * ) 'rttov warning for profile',j
- End If
- End Do
- End If
-
- If ( any( rttov_errorstatus(:) == errorstatus_fatal ) ) Then
- Do j = 1, nprof(no_id)
- If ( rttov_errorstatus(j) == errorstatus_fatal ) Then
- write ( ioout, * ) 'rttov error for profile',j
- End If
- End Do
- Stop
- End If
-
- ! transfer data to printing arrays
- pr_pol(:) = 0
- pr_radcld(:) = 0.0_JPRB
- pr_trans(:) = 0.0_JPRB
- pr_emis(:) = 0.0_JPRB
- pr_trans_lev(:,:) = 0.0_JPRB
- pr_upclr(:) = 0.0_JPRB
- pr_dncld(:,:) = 0.0_JPRB
- pr_refclr(:) = 0.0_JPRB
- pr_ovcst(:,:) = 0.0_JPRB
- !
- do j = 1 , nchannels
- jpol = polarisations(j,2)
- if (nbtout == nchannels) then
- jpol = j
- endif
- pr_pol(jpol) = jpol
- pr_radcld(jpol) = radiance % cloudy(j)
- pr_trans(jpol) = Transmission % tau_surf(J)
- pr_emis(jpol) = emissivity(j)
- pr_upclr(jpol) = radiance % upclear(J)
- pr_refclr(jpol) = radiance % reflclear(J)
- do ilev = 1 , nlevels
- pr_trans_lev(ilev,jpol) = Transmission % tau_layer(ilev,J)
- pr_dncld(ilev,jpol) = radiance % downcld(ILEV,J)
- pr_ovcst(ilev,jpol) = radiance % overcast(ILEV,J)
- enddo
- enddo
-
- ! OUTPUT RESULTS
- !
- NPRINT = 1+ INT((nbtout-1)/(10*nprof(no_id)))
- DO JN=1,NPROF(no_id)
- WRITE(IOOUT,*)' -----------------'
- WRITE(IOOUT,*)' Profile number ',JN, 'Instrument ',&
- & instrument(3,no_id)
- WRITE(IOOUT,*)' -----------------'
- WRITE(IOOUT,*)' '
-! JOFF=NCHAN(no_id)*(JN-1)
- JOFF1=nbtout/nprof(no_id)*(JN-1)
- JOFF2=nbtout/nprof(no_id)*(JN-1)
- JOFF3=nfrequencies/nprof(no_id)*(JN-1)
- WRITE(IOOUT,777)instrument(2,no_id), profiles(jn)%zenangle,profiles(jn)%azangle,profiles(jn)%skin%surftype
- WRITE(IOOUT,222) (radiance % out(J+JOFF1),J=1,nbtout/nprof(no_id))
- WRITE(IOOUT,*)' '
- WRITE(IOOUT,*)'CALCULATED RADIANCES: SAT =', instrument(2,no_id)
- WRITE(IOOUT,222) (radiance % total_out(J+JOFF1),J=1,nbtout/nprof(no_id))
- WRITE(IOOUT,*)' '
- WRITE(IOOUT,*)'CALCULATED OVERCAST RADIANCES: SAT =', instrument(2,no_id)
- WRITE(IOOUT,222) (pr_radcld(J+JOFF2),J=1,nbtout/nprof(no_id))
- WRITE (IOOUT,*)' '
- WRITE(IOOUT,*)'CALCULATED SURFACE TO SPACE TRANSMITTANCE: S'&
- & ,'AT =',instrument(2,no_id)
- WRITE(IOOUT,4444) (pr_trans(J+JOFF2),J=1,nbtout/nprof(no_id))
- WRITE (IOOUT,*)' '
- WRITE(IOOUT,*)'CALCULATED SURFACE EMISSIVITIES '&
- & ,'SAT =',instrument(2,no_id)
- WRITE(IOOUT,444) (pr_emis(J+JOFF2),J=1,nbtout/nprof(no_id))
- !
- ! Print clear-sky radiance without reflection term and
- ! reflected clear-sky downwelling radiance
- !
- IF(IFULL(no_id) == 2 .AND. nchan(1,no_id) <= 20 )THEN
- WRITE (IOOUT,*)' '
- WRITE(IOOUT,*)'CALCULATED Clear-sky radiance without reflection term'&
- & ,' SAT =',instrument(2,no_id)
- WRITE(IOOUT,444)(pr_upclr(J+JOFF2),J=1,nbtout/nprof(no_id))
- WRITE (IOOUT,*)' '
- WRITE (IOOUT,*)'CALCULATED Reflected clear-sky downwelling radiance'&
- & ,' SAT =',instrument(2,no_id)
- WRITE(IOOUT,444)(pr_refclr(J+JOFF2),J=1,nbtout/nprof(no_id))
- WRITE (IOOUT,*)'CHANNELS '
- WRITE(IOOUT,111) (ichan(j,no_id), J = 1,nbtout/nprof(no_id))
- ENDIF
- !
- IF(JN.EQ.1 .AND. nchan(1,no_id) .LE. 20)THEN
- DO NP = 1 , NPRINT
- WRITE (IOOUT,*)' '
- WRITE (IOOUT,*)'Level to space transmittances for channels'
-! WRITE(IOOUT,1115)(pr_pol(j),&
- WRITE(IOOUT,1115) (ICHAN(J,no_id),&
- & J = 1+(NP-1)*10,MIN(10+(NP-1)*10,nbtout/nprof(no_id)))
- DO ILEV = 1 , NLEVELS
- WRITE(IOOUT,4445)ILEV,(pr_trans_lev(ilev,J+JOFF2),&
- & J = 1+(NP-1)*10,MIN(10+(NP-1)*10,nbtout/nprof(no_id)))
- end do
- WRITE(IOOUT,1115) (ICHAN(J,no_id),&
- & J = 1+(NP-1)*10,MIN(10+(NP-1)*10,nbtout/nprof(no_id)))
- end do
- ENDIF
- !
- ! Print radiance upwelling arrays
- IF(JN==1 .AND. IFULL(no_id)==2 .AND. nchan(1,no_id)<=20)THEN
- DO NP = 1 , NPRINT
- WRITE (IOOUT,*)' '
- WRITE (IOOUT,*)'Level to space upwelling radiances for channels'
- WRITE(IOOUT,1115) (ICHAN(J,no_id),&
- & J = 1+(NP-1)*10,MIN(10+(NP-1)*10,nbtout/nprof(no_id)))
- DO ILEV = 1 , NLEVELS
- WRITE(IOOUT,4446)ILEV,(pr_ovcst(ILEV,J+JOFF2),&
- & J = 1+(NP-1)*10,MIN(10+(NP-1)*10,nbtout/nprof(no_id)))
- end do
- WRITE(IOOUT,1115) (ICHAN(J,no_id),&
- & J = 1+(NP-1)*10,MIN(10+(NP-1)*10,nbtout/nprof(no_id)))
- end do
- ENDIF
- ! Print radiance downwelling arrays
- IF(JN==1 .AND. IFULL(no_id)==2 .AND. nchan(1,no_id)<=20)THEN
- DO NP = 1 , NPRINT
- WRITE (IOOUT,*)' '
- WRITE (IOOUT,*)'Level to space downwelling radiances for channels'
- WRITE(IOOUT,1115) (ICHAN(J,no_id),&
- & J = 1+(NP-1)*10,MIN(10+(NP-1)*10,nbtout/nprof(no_id)))
- DO ILEV = 1 , NLEVELS
- WRITE(IOOUT,4446)ILEV,(pr_dncld(ILEV,J+JOFF2),&
- & J = 1+(NP-1)*10,MIN(10+(NP-1)*10,nbtout/nprof(no_id)))
- end do
- WRITE(IOOUT,1115) (ICHAN(J,no_id),&
- & J = 1+(NP-1)*10,MIN(10+(NP-1)*10,nbtout/nprof(no_id)))
- end do
- ENDIF
- end do
- WRITE(*,*) ' FORWARD MODEL FINISHED'
- !
- IF (IFULL(no_id).GE.1)THEN
- !
- !-----------------------------------------------------------
- ! Test tangent linear
- !-----------------------------------------------------------
- write(*,*) 'Tangent linear'
-
- call TSTRAD_TL( &
- nfrequencies, & ! in
- nchannels, & ! in
- nbtout, & ! in
- nprof(no_id), & ! in
- channels, & ! in
- polarisations, & ! in
- lprofiles, & ! in
- frequencies, & ! in
- profiles, & ! in
- coef(no_id), & ! in
- lcloud, & ! in
- calcemis, & ! in
- input_emissivity) ! in
-
- write(*,*) 'Adjoint'
-
- call TSTRAD_AD( &
- nfrequencies, & ! in
- nchannels, & ! in
- nbtout, & ! in
- nprof(no_id), & ! in
- channels, & ! in
- polarisations, & ! in
- frequencies, & ! in
- lprofiles, & ! in
- profiles, & ! in
- coef(no_id), & ! in
- lcloud, & ! in
- calcemis, & ! in
- input_emissivity) ! in
-
- write(*,*) 'K'
-
- call TSTRAD_K( &
- nfrequencies, & ! in
- nchannels, & ! in
- nbtout, & ! in
- nprof(no_id), & ! in
- channels, & ! in
- polarisations, & ! in
- frequencies, & ! in
- lprofiles, & ! in
- profiles, & ! in
- coef(no_id), & ! in
- lcloud, & ! in
- calcemis, & ! in
- input_emissivity) ! in
-
- deallocate(xkbav ,stat= alloc_status(1))
- deallocate(xkradovu,stat= alloc_status(2))
- deallocate(xkradovd,stat= alloc_status(3))
- deallocate(xkradov1,stat= alloc_status(4))
- deallocate(xkradov2,stat= alloc_status(5))
- deallocate(xkbsav ,stat= alloc_status(6))
- deallocate(xkbem ,stat= alloc_status(7))
- If( any(alloc_status /= 0) ) then
- errorstatus = errorstatus_fatal
- Write( errMessage, '( "mem deallocation error")' )
- Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine)
- Stop
- End If
-
- ENDIF
-
- do j = 1, nprof(no_id)
- ! deallocate model profiles atmospheric arrays
- deallocate( profiles(j) % p ,stat=alloc_status(1))
- deallocate( profiles(j) % t ,stat=alloc_status(2))
- deallocate( profiles(j) % q ,stat=alloc_status(3))
- deallocate( profiles(j) % o3 ,stat=alloc_status(4))
- deallocate( profiles(j) % clw ,stat=alloc_status(5))
- If( any(alloc_status /= 0) ) then
- errorstatus = errorstatus_fatal
- Write( errMessage, '( "mem deallocation error")' )
- Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine)
- Stop
- End If
- end do
- deallocate( profiles,stat=alloc_status(1))
-
- ! number of channels per RTTOV call is only nchannels
- deallocate( channels ,stat=alloc_status(2))
- deallocate( lprofiles ,stat=alloc_status(3))
- deallocate( emissivity ,stat=alloc_status(4))
- deallocate( calcemis ,stat=alloc_status(5))
-
- ! allocate transmittance structure
- deallocate( transmission % tau_surf ,stat= alloc_status(6))
- deallocate( transmission % tau_layer ,stat= alloc_status(7))
- deallocate( transmission % od_singlelayer,stat= alloc_status(8))
-
- ! allocate radiance results arrays with number of channels
- deallocate( radiance % clear ,stat=alloc_status(9))
- deallocate( radiance % cloudy ,stat=alloc_status(10))
- deallocate( radiance % total ,stat=alloc_status(11))
- deallocate( radiance % bt ,stat=alloc_status(12))
- deallocate( radiance % bt_clear ,stat=alloc_status(13))
- deallocate( radiance % upclear ,stat=alloc_status(14))
- deallocate( radiance % dnclear ,stat=alloc_status(15))
- deallocate( radiance % reflclear,stat=alloc_status(16))
- deallocate( radiance % overcast ,stat=alloc_status(17))
- deallocate( radiance % downcld ,stat=alloc_status(18))
- deallocate( radiance % out ,stat= alloc_status(19))
- deallocate( radiance % out_clear ,stat= alloc_status(20))
- deallocate( radiance % total_out ,stat= alloc_status(21))
- deallocate( radiance % clear_out ,stat= alloc_status(22))
- deallocate(pr_radcld ,stat= alloc_status(31))
- deallocate(pr_trans ,stat= alloc_status(32))
- deallocate(pr_emis ,stat= alloc_status(33))
- deallocate(pr_trans_lev ,stat= alloc_status(34))
- If( any(alloc_status /= 0) ) then
- errorstatus = errorstatus_fatal
- Write( errMessage, '( "mem deallocation error")' )
- Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine)
- Stop
- End If
- ENDDO
-
- Do no_id = 1, nrttovid
- Call rttov_dealloc_coef (errorstatus, coef(no_id))
- If(errorstatus /= errorstatus_success) Then
- Write( errMessage, '( "deallocation error")' )
- Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine)
- Endif
- End Do
-
-111 FORMAT(1X,10I8)
-1115 FORMAT(3X,10I8)
-2222 FORMAT(1X,10(1x,F8.6))
-222 FORMAT(1X,10F8.2)
-333 FORMAT(1X,I3,20I5)
-3333 FORMAT(1X,I3,2I5)
-444 FORMAT(1X,10F8.3)
-4444 FORMAT(1X,10F8.4)
-4445 FORMAT(1X,I2,10F8.4)
-4446 FORMAT(1X,I2,10F8.3)
-555 FORMAT(1X,10E8.2)
-777 FORMAT(1X,'CALCULATED BRIGHTNESS TEMPERATURES: SAT =',I2,&
- &' ZENITH ANGLE=',F6.2, &
- &' AZIMUTH ANGLE=',F7.2,' SURFACE TYPE=',I2)
-
-END PROGRAM TSTRAD
diff --git a/src/LIB/RTTOV/src/tstrad_ad.F90 b/src/LIB/RTTOV/src/tstrad_ad.F90
deleted file mode 100644
index e974ff00c99d52e863ac9ec7cdb363f6daaead8d..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/tstrad_ad.F90
+++ /dev/null
@@ -1,808 +0,0 @@
-Subroutine tstrad_ad( &
- & nfrequencies, &! in
- & nchannels, &! in
- & nbtout, &! in
- & nprofiles, &! in
- & channels, &! in
- & polarisations, &! in
- & frequencies, &! in
- & lprofiles, &! in
- & profiles, &! in
- & coef, &! in
- & addcloud, &! in
- & calcemis, &! in
- & input_emissivity) ! in
- !
- ! only the first nchannels/nprofiles are output
- !
-
- Use rttov_const, Only : &
- & errorstatus_success, &
- & errorstatus_fatal
-
- Use rttov_types, Only : &
- & rttov_coef ,&
- & profile_Type ,&
- & transmission_Type ,&
- & radiance_Type
-
- Use mod_tstrad
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
-#include "rttov_errorreport.interface"
-#include "rttov_tl.interface"
-#include "rttov_ad.interface"
-
- !subroutine arguments:
- Integer(Kind=jpim), Intent(in) :: nchannels
- Integer(Kind=jpim), Intent(in) :: nfrequencies
- Integer(Kind=jpim), Intent(in) :: nbtout
- Integer(Kind=jpim), Intent(in) :: nprofiles
- Integer(Kind=jpim), Intent(in) :: channels(nfrequencies)
- Integer(Kind=jpim), Intent(in) :: polarisations(nchannels,3)
- Integer(Kind=jpim), Intent(in) :: frequencies(nbtout)
- Integer(Kind=jpim), Intent(in) :: lprofiles(nfrequencies)
- Logical, Intent(in) :: addcloud
- Type(profile_Type), Intent(in) :: profiles(nprofiles)
- Type(rttov_coef), Intent(in) :: coef
- Logical, Intent(in) :: calcemis(nchannels)
- Real(Kind=jprb), Intent(in) :: input_emissivity(nchannels)
-
-
-
- ! local
- Integer(Kind=jpim), Parameter :: jpnav = 4 ! no. of profile variables
- Integer(Kind=jpim), Parameter :: jpnsav = 5 ! no. of surface air variables
- Integer(Kind=jpim), Parameter :: jpnssv = 6 ! no. of skin variables
- Integer(Kind=jpim), Parameter :: jpncv = 2 ! no. of cloud variables
- Integer(Kind=jpim), Parameter :: sscvar = jpnsav+jpnssv+jpncv ! no of surface,skin,cloud vars
- Integer(Kind=jpim) :: errorstatus
- Character (len=80) :: errMessage
- Character (len=10) :: NameOfRoutine = 'tstrad_ad '
-
- ! forward model outputs
- logical :: switchrad
- Type(transmission_Type) :: transmission
- Type(radiance_Type) :: radiancedata
- Real(Kind=jprb) :: emissivity(nchannels)
-
- ! AD variables for rttov_ad calls
- Type(profile_Type) :: profiles_ad(nprofiles)
- Type(transmission_Type) :: transmission_ad
- Type(radiance_Type) :: radiancedata_ad
- Real(Kind=jprb) :: emissivity_ad(nchannels)
-
- ! TL variables
- Type(profile_Type) :: profiles_tl(nprofiles)
- Type(transmission_Type) :: transmission_tl
- Type(radiance_Type) :: radiancedata_tl
- Real(Kind=jprb) :: emissivity_tl(nchannels)
- Logical :: nocalcemis(nchannels)
-
- Integer(Kind=jpim) :: nlev
- Integer(Kind=jpim) :: ixkav(coef%nlevels,jpnav,nbtout)
-
- Integer(Kind=jpim) :: ixksav(sscvar,nbtout)
-
- ! Adjoint results
- Integer(Kind=jpim) :: ixkdav(coef%nlevels,jpnav,nbtout)
- Real(Kind=jprb) :: xktav (coef%nlevels,jpnav,nbtout)
- Integer(Kind=jpim) :: ixkdsav(sscvar,nbtout)
- Real(Kind=jprb) :: xktsav (sscvar,nbtout)
- Integer(Kind=jpim) :: ixdem(nbtout)
- Real(Kind=jprb) :: xkaem(nbtout)
-
- ! coefficients for printing
- Real(Kind=jprb) :: facpav(coef%nlevels,jpnav)
- Real(Kind=jprb) :: facem = 1._JPRB
-
- Real(Kind=jprb) :: facsav(sscvar) =&
- & (/10000._JPRB,0.1_JPRB,10000._JPRB,10000._JPRB,10000._JPRB, &! 2m
- & 10000._JPRB,100.0_JPRB,100.0_JPRB,100.0_JPRB,100.0_JPRB,100.0_JPRB, &! Skin
- & 10000._JPRB,100._JPRB/) ! cloud
-
- Real(Kind=jprb) :: facdiff = 1.e+10_JPRB
- !Real :: facdiff = 1.
-
- Real(Kind=jprb), Parameter :: q_mixratio_to_ppmv = 1.60771704e+6_JPRB
- Real(Kind=jprb), Parameter :: o3_mixratio_to_ppmv = 6.03504e+5_JPRB
-
- Integer(Kind=jpim) :: ioout = 2
- Integer(Kind=jpim) :: ich, jch, ipol
- Integer(Kind=jpim) :: j, i, ii, jp, joff, freq
- Integer(Kind=jpim) :: prof
- Integer(Kind=jpim) :: nchan_out
- Integer(Kind=jpim) :: lev
- Real(Kind=jprb) :: z
- Real(Kind=jprb) :: sump, sumr
- Real(Kind=jprb) :: eps
-
- Character (len=30) :: title(4) = &
- & (/' lev temperature ', &
- & ' lev water vapour ', &
- & ' lev ozone ', &
- & ' lev liquid water '/)
-
- Integer(Kind=jpim) :: alloc_status(60)
- Integer(Kind=jpim) :: rttov_errorstatus(nprofiles)
-
- !- End of header --------------------------------------------------------
-
- errorstatus = 0
- alloc_status(:) = 0
- rttov_errorstatus(:) = 0
-
- nchan_out = nbtout/nprofiles
- nlev = coef % nlevels
-
- ! coefficients for atmospheric variables
- facpav(:,1) = 10000._JPRB
- facpav(:,2) = 0.1_JPRB
- facpav(:,3) = 0.001_JPRB
- facpav(:,4) = 0.1_JPRB
-
- ! coefficients compatibility with RTTOV7
- facpav(:,2) = facpav(:,2) * q_mixratio_to_ppmv
- facpav(:,3) = facpav(:,3) * o3_mixratio_to_ppmv
- facsav(2) = facsav(2) * q_mixratio_to_ppmv
-
- ! allocate and initialise the reference tl increments
- Do j = 1, nprofiles
- profiles_ad(j) % nlevels = coef % nlevels
- Allocate( profiles_ad(j) % p ( coef % nlevels ) ,stat= alloc_status(1))
- Allocate( profiles_ad(j) % t ( coef % nlevels ) ,stat= alloc_status(2))
- Allocate( profiles_ad(j) % q ( coef % nlevels ) ,stat= alloc_status(3))
- Allocate( profiles_ad(j) % o3 ( coef % nlevels ) ,stat= alloc_status(4))
- Allocate( profiles_ad(j) % clw( coef % nlevels ) ,stat= alloc_status(5))
- If( any(alloc_status /= 0) ) then
- errorstatus = errorstatus_fatal
- Write( errMessage, '( "mem allocation error")' )
- Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine)
- Return
- End If
- End Do
-
- ! allocate radiance results arrays with number of channels
- Allocate( radiancedata % clear ( nchannels ) ,stat= alloc_status(1))
- Allocate( radiancedata % cloudy ( nchannels ) ,stat= alloc_status(2))
- Allocate( radiancedata % total ( nchannels ) ,stat= alloc_status(3))
- Allocate( radiancedata % bt ( nchannels ) ,stat= alloc_status(4))
- Allocate( radiancedata % bt_clear ( nchannels ) ,stat= alloc_status(5))
- Allocate( radiancedata % out ( nchannels ) ,stat= alloc_status(6))
- Allocate( radiancedata % out_clear( nchannels ) ,stat= alloc_status(7))
- Allocate( radiancedata % total_out( nchannels ) ,stat= alloc_status(8))
- Allocate( radiancedata % clear_out( nchannels ) ,stat= alloc_status(9))
- Allocate( radiancedata % upclear ( nchannels ) ,stat= alloc_status(10))
- Allocate( radiancedata % dnclear ( nchannels ) ,stat= alloc_status(34))
- Allocate( radiancedata % reflclear( nchannels ) ,stat= alloc_status(11))
- Allocate( radiancedata % overcast ( coef % nlevels, nchannels ) ,stat= alloc_status(12))
- Allocate( radiancedata % downcld ( coef % nlevels, nchannels ) ,stat= alloc_status(13))
- Allocate( radiancedata_ad % clear ( nchannels ) ,stat= alloc_status(14))
- Allocate( radiancedata_ad % cloudy ( nchannels ) ,stat= alloc_status(15))
- Allocate( radiancedata_ad % total_out ( nchannels ) ,stat= alloc_status(16))
- Allocate( radiancedata_ad % clear_out ( nchannels ) ,stat= alloc_status(17))
- Allocate( radiancedata_ad % total ( nchannels ) ,stat= alloc_status(18))
- Allocate( radiancedata_ad % bt ( nchannels ) ,stat= alloc_status(19))
- Allocate( radiancedata_ad % bt_clear ( nchannels ) ,stat= alloc_status(20))
- Allocate( radiancedata_ad % out ( nchannels ) ,stat= alloc_status(21))
- Allocate( radiancedata_ad % out_clear( nchannels ) ,stat= alloc_status(22))
- Allocate( radiancedata_ad % upclear ( nchannels ) ,stat= alloc_status(23))
- Allocate( radiancedata_ad % reflclear( nchannels ) ,stat= alloc_status(24))
- Allocate( radiancedata_ad % overcast ( coef % nlevels, nchannels ) ,stat= alloc_status(25))
- Allocate( radiancedata_ad % downcld ( coef % nlevels, nchannels ) ,stat= alloc_status(26))
- Allocate( transmission % tau_surf ( nchannels ) ,stat= alloc_status(27))
- Allocate( transmission % tau_layer ( coef % nlevels, nchannels ) ,stat= alloc_status(28))
- Allocate( transmission % od_singlelayer ( coef % nlevels, nchannels ) ,stat= alloc_status(29))
- Allocate( transmission_ad % tau_surf ( nchannels ) ,stat= alloc_status(30))
- Allocate( transmission_ad % tau_layer ( coef % nlevels, nchannels ) ,stat= alloc_status(31))
- Allocate( transmission_ad % od_singlelayer ( coef % nlevels, nchannels ) ,stat= alloc_status(32))
-
- If( any(alloc_status /= 0) ) then
- errorstatus = errorstatus_fatal
- Write( errMessage, '( "mem allocation error")' )
- Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine)
- Return
- End If
-
-
-
- !
- !...do adjoint.....................
- Do ich =1,nbtout
- freq = frequencies(ich)
- prof = lprofiles(freq)
-
- ! initialise AD output profile variables
- Do i = 1, nprofiles
- profiles_ad(i) % ozone_Data = .False. ! no meaning
- profiles_ad(i) % co2_Data = .False. ! no meaning
- profiles_ad(i) % clw_Data = .False. ! no meaning
- profiles_ad(i) % zenangle = -1 ! no meaning
- profiles_ad(i) % p(:) = 0._JPRB ! no AD on pressure levels
- profiles_ad(i) % t(:) = 0._JPRB ! temperarure
- profiles_ad(i) % o3(:) = 0._JPRB ! O3 ppmv
- profiles_ad(i) % clw(:) = 0._JPRB ! clw
- profiles_ad(i) % q(:) = 0._JPRB ! WV
- profiles_ad(i) % s2m % t = 0._JPRB! temperarure
- profiles_ad(i) % s2m % q = 0 ! WV
- profiles_ad(i) % s2m % p = 0._JPRB! pressure
- profiles_ad(i) % s2m % u = 0._JPRB! wind components
- profiles_ad(i) % s2m % v = 0._JPRB! wind components
- profiles_ad(i) % skin % surftype = -1 ! no meaning
- profiles_ad(i) % skin % t = 0._JPRB ! on temperarure
- profiles_ad(i) % skin % fastem = 0._JPRB ! Fastem
- profiles_ad(i) % ctp = 0._JPRB ! cloud top pressure
- profiles_ad(i) % cfraction = 0._JPRB ! cloud fraction
- End Do
-
- ! initialise AD output emissivity
- emissivity_ad(:) = 0._JPRB
-
- ! initialise all radiance increments to 0
- radiancedata_ad % clear(:) = 0._JPRB
- radiancedata_ad % clear_out(:) = 0._JPRB
- radiancedata_ad % cloudy(:) = 0._JPRB
- radiancedata_ad % total(:) = 0._JPRB
- radiancedata_ad % total_out(:) = 0._JPRB
- radiancedata_ad % bt(:) = 0._JPRB
- radiancedata_ad % bt_clear(:) = 0._JPRB
- radiancedata_ad % out(:) = 0._JPRB
- radiancedata_ad % out_clear(:) = 0._JPRB
- radiancedata_ad % upclear(:) = 0._JPRB
- radiancedata_ad % reflclear(:) = 0._JPRB
- radiancedata_ad % overcast(:,:) = 0._JPRB
- radiancedata_ad % downcld(:,:) = 0._JPRB
- transmission_ad % tau_surf(:) = 0._JPRB
- transmission_ad % tau_layer(:,:) = 0._JPRB
- transmission_ad % od_singlelayer(:,:) = 0._JPRB
- radiancedata_ad % out(ich) = 1._JPRB ! increment channel br. temp by 1K
- switchrad= .true.
-
- ! use stored input emmisisvity
- emissivity(:) = input_emissivity(:)
-
- call rttov_ad( &
- & rttov_errorstatus, &! out
- & nfrequencies, &! in
- & nchannels, &! in
- & nbtout, &! in
- & nprofiles, &! in
- & channels, &! in
- & polarisations, &! in
- & lprofiles, &! in
- & profiles, &! in
- & coef, &! in
- & addcloud, &! in
- & switchrad, &! in
- & calcemis, &! in
- & emissivity, &! inout direct model
- & profiles_ad, &! inout adjoint
- & emissivity_ad, &! inout adjoint
- & transmission, &! inout direct model
- & transmission_ad, &! inout adjoint input
- & radiancedata, &! inout direct model (input due to pointers alloc)
- & radiancedata_ad ) ! inout adjoint input (output if converstion Bt -> rad)
-
- If( any( rttov_errorstatus == errorstatus_fatal ) ) then
- Do jp = 1, nprofiles
- If( rttov_errorstatus(jp) == errorstatus_fatal ) then
- Write( errMessage, '( "fatal error in rttov_ad")' )
- Call Rttov_ErrorReport (rttov_errorstatus(jp), errMessage, NameOfRoutine)
- End If
- End Do
- Stop
- End If
- If( any( rttov_errorstatus /= errorstatus_success ) ) then
- Write( errMessage, '( "warning in rttov_ad")' )
- End If
-
- Do j =1,jpnav ! yes clw too!
- Do ii=1,nlev
-
- Select Case (j)
- Case (1_jpim)
- xktav(ii,j,ich) = profiles_ad(prof) % t(ii)
- Case (2_jpim)
- xktav(ii,j,ich) = profiles_ad(prof) % q(ii)
- Case (3_jpim)
- xktav(ii,j,ich) = profiles_ad(prof) % o3(ii)
- Case (4_jpim)
- xktav(ii,j,ich) = profiles_ad(prof) % clw(ii)
- End Select
-
- if(prof == 1) then
- ixkav(ii,j,ich) = nint(xktav(ii,j,ich) * facpav(ii,j))
- ixkdav(ii,j,ich) = nint((xkbav(ii,j,ich)-xktav(ii,j,ich)) *&
- & facpav(ii,j) * facdiff)
- endif
- End Do
- End Do
-
- !.......now do surface, skin and cloud variables
- Do j =1,sscvar
-
- Select Case (j)
- Case (1_jpim)
- ! t 2m
- xktsav(j,ich) = profiles_ad(prof) % s2m % t
- Case (2_jpim)
- ! wv 2m
- xktsav(j,ich) = profiles_ad(prof) % s2m % q
- Case (3_jpim)
- ! surface pressure
- xktsav(j,ich) = profiles_ad(prof) % s2m % p
- Case (4_jpim)
- ! wind speed u component
- xktsav(j,ich) = profiles_ad(prof) % s2m % u
- Case (5_jpim)
- ! wind speed v component
- xktsav(j,ich) = profiles_ad(prof) % s2m % v
- Case (6_jpim)
- ! skin temp
- xktsav(j,ich) = profiles_ad(prof) % skin % t
- Case (7_jpim)
- ! fastem land coef 1
- xktsav(j,ich) = profiles_ad(prof) % skin % fastem(1)
- Case (8_jpim)
- ! fastem land coef 2
- xktsav(j,ich) = profiles_ad(prof) % skin % fastem(2)
- Case (9_jpim)
- ! fastem land coef 3
- xktsav(j,ich) = profiles_ad(prof) % skin % fastem(3)
- Case (10_jpim)
- ! fastem land coef 4
- xktsav(j,ich) = profiles_ad(prof) % skin % fastem(4)
- Case (11_jpim)
- ! fastem land coef 5
- xktsav(j,ich) = profiles_ad(prof) % skin % fastem(5)
- Case (12_jpim)
- ! cloud top pressure
- xktsav(j,ich) = profiles_ad(prof) % ctp
- Case (13_jpim)
- ! cloud fraction
- xktsav(j,ich) = profiles_ad(prof) % cfraction
- End Select
- End Do
- if(prof == 1) then
- ixksav(:,ich) = nint(xktsav(:,ich) * facsav(:))
- ixkdsav(:,ich) = nint((xkbsav(:,ich)-xktsav(:,ich)) *&
- & facsav(:) * facdiff)
- endif
-
- xkaem(ich) = 0.0_JPRB
- Do ipol=1, polarisations(frequencies(ich),3)
- xkaem(ich) = xkaem(ich) + emissivity_ad(polarisations(frequencies(ich),1)+ipol-1)
- End Do
-
- ixdem(ich) = nint(( xkaem(ich) - xkbem(ich)) * facem *1000._JPRB)
- If( coef % fastem_ver >= 1 .and. calcemis(ich) ) Then
- !if(input_emissivity(ich) < 0.0 ) then
- ixdem(ich) = 0._JPRB
- endif
-
- End Do
-
- ! ... and print it.
- Write (ioout,*)' '
- Write (ioout,*)'TL - Adjoint difference*10**10.'
- Write (ioout,*)' '
- Do j = 1 , jpnav
- Write (ioout,'(a30)')title(j)
- Write (ioout,3333)coef%ff_ori_chn(frequencies(1:nchan_out))
- Do i = 1 , nlev
- Write (ioout,333)i,(ixkdav(i,j,jch),jch=1,nchan_out)
- Enddo
- Write (ioout,3333)coef%ff_ori_chn(frequencies(1:nchan_out))
- Write (ioout,*)' '
- Enddo
-
- Write (ioout,*)' surface variables '
- Write (ioout,3333)coef%ff_ori_chn(frequencies(1:nchan_out))
- Write (ioout,*)' '
- Do i = 1 , jpnsav
- Write (ioout,333)i,(ixkdsav(i,jch),jch=1,nchan_out)
- Enddo
- Write (ioout,*)' '
-
- Write (ioout,*)' skin variables '
- Write (ioout,3333)coef%ff_ori_chn(frequencies(1:nchan_out))
- Write (ioout,*)' '
- Do i = jpnsav+1 , jpnsav+jpnssv
- Write (ioout,333)i-jpnsav,(ixkdsav(i,jch),jch=1,nchan_out)
- Enddo
- Write (ioout,*)' '
-
- Write (ioout,*)' cloud variables '
- Write (ioout,3333)coef%ff_ori_chn(frequencies(1:nchan_out))
- Write (ioout,*)' '
- Do i = jpnsav+jpnssv+1 , sscvar
- Write (ioout,333)i-jpnsav-jpnssv,(ixkdsav(i,jch),jch=1,nchan_out)
- Enddo
- Write (ioout,*)' '
-
-
- Write (ioout,*)' surface emissivity '
- Write (ioout,3333)coef%ff_ori_chn(frequencies(1:nchan_out))
- Write (ioout,*)' '
- Do jp = 1, nprofiles
- joff = (jp-1) * nchan_out
- Write (ioout,333)jp,(ixdem(jch+joff),jch=1,nchan_out)
- Enddo
- Write (ioout,*)' '
-
- ! following 3 lines are only for comparison with RTTOV7 reference results
- ! due to adjoint code inside prfinad
- xktav(:,2,:) = xktav(:,2,:) * q_mixratio_to_ppmv
- xktav(:,3,:) = xktav(:,3,:) * o3_mixratio_to_ppmv
- xktsav(2,:) = xktsav(2,:) * q_mixratio_to_ppmv
- do prof = 1, nprofiles
- sump = 0._JPRB
-
- Do jch=1, nbtout
- freq = frequencies(jch)
- If(lprofiles(freq) == prof) Then
- sump = sump + SUM(xktav(:,:,jch))
- sump = sump + SUM(xktsav(:,jch))
- sump = sump + xkaem(jch)
- End If
- End Do
-
- WRITE (IOOUT,1149)prof,SUMP
-1149 FORMAT (1X,'PROFILE NUMBER=',I2,' AD=',E20.10)
- end do
-
- ! CHECK CONSISTENCY OF ADJOINT AND TL FOR FASTEM/ISEM
- !
- ! initialise AD output profile variables
- Do i = 1, nprofiles
- profiles_ad(i) % ozone_Data = .False. ! no meaning
- profiles_ad(i) % co2_Data = .False. ! no meaning
- profiles_ad(i) % clw_Data = .False. ! no meaning
- profiles_ad(i) % zenangle = -1 ! no meaning
- profiles_ad(i) % p(:) = 0._JPRB ! no AD on pressure levels
- profiles_ad(i) % t(:) = 0._JPRB ! temperarure
- profiles_ad(i) % o3(:) = 0._JPRB ! O3 ppmv
- profiles_ad(i) % clw(:) = 0._JPRB ! clw
- profiles_ad(i) % q(:) = 0._JPRB ! WV
- profiles_ad(i) % s2m % t = 0._JPRB! temperarure
- profiles_ad(i) % s2m % q = 0 ! WV
- profiles_ad(i) % s2m % p = 0._JPRB! pressure
- profiles_ad(i) % s2m % u = 0._JPRB! wind components
- profiles_ad(i) % s2m % v = 0._JPRB! wind components
- profiles_ad(i) % skin % surftype = -1 ! no meaning
- profiles_ad(i) % skin % t = 0._JPRB ! on temperarure
- profiles_ad(i) % skin % fastem = 0._JPRB ! Fastem
- profiles_ad(i) % ctp = 0._JPRB ! cloud top pressure
- profiles_ad(i) % cfraction = 0._JPRB ! cloud fraction
- End Do
-
- ! initialise AD output emissivity
- emissivity_ad(:) = 0._JPRB
-
- Do ich =1,nbtout
- CALL RANDOM_NUMBER(Z)
- radiancedata_ad % out(ich) = z ! increment channel br. temp
- End Do
- radiancedata_ad % clear(:) = 0._JPRB
- radiancedata_ad % cloudy(:) = 0._JPRB
- radiancedata_ad % total(:) = 0._JPRB
- radiancedata_ad % bt(:) = 0._JPRB
- radiancedata_ad % bt_clear(:) = 0._JPRB
- radiancedata_ad % out_clear(:) = 0._JPRB
- radiancedata_ad % upclear(:) = 0._JPRB
- radiancedata_ad % reflclear(:) = 0._JPRB
- radiancedata_ad % overcast(:,:) = 0._JPRB
- radiancedata_ad % downcld(:,:) = 0._JPRB
- transmission_ad % tau_surf(:) = 0._JPRB
- transmission_ad % tau_layer(:,:) = 0._JPRB
- transmission_ad % od_singlelayer(:,:) = 0._JPRB
- switchrad= .true.
-
-
- ! do not use stored input emmisisvity but fwd output
- nocalcemis(:) = .false.
-
- call rttov_ad( &
- & rttov_errorstatus, &! out
- & nfrequencies, &! in
- & nchannels, &! in
- & nbtout, &! in
- & nprofiles, &! in
- & channels, &! in
- & polarisations, &! in
- & lprofiles, &! in
- & profiles, &! in
- & coef, &! in
- & addcloud, &! in
- & switchrad, &! in
- & nocalcemis, &! in
- & emissivity, &! inout direct model
- & profiles_ad, &! inout adjoint
- & emissivity_ad, &! inout adjoint
- & transmission, &! inout direct model
- & transmission_ad, &! inout adjoint input
- & radiancedata, &! inout direct model (input due to pointers alloc)
- & radiancedata_ad ) ! inout adjoint input (output if converstion Bt -> rad)
-
- If( any( rttov_errorstatus == errorstatus_fatal ) ) then
- Do jp = 1, nprofiles
- If( rttov_errorstatus(jp) == errorstatus_fatal ) then
- Write( errMessage, '( "fatal error in rttov_ad")' )
- Call Rttov_ErrorReport (rttov_errorstatus(jp), errMessage, NameOfRoutine)
- End If
- End Do
- Stop
- End If
- If( any( rttov_errorstatus /= errorstatus_success ) ) then
- Write( errMessage, '( "warning in rttov_ad")' )
- End If
-
- Do j = 1, nprofiles
- profiles_tl(j) % nlevels = coef % nlevels
- Allocate( profiles_tl(j) % p ( coef % nlevels ) ,stat= alloc_status(1))
- Allocate( profiles_tl(j) % t ( coef % nlevels ) ,stat= alloc_status(2))
- Allocate( profiles_tl(j) % q ( coef % nlevels ) ,stat= alloc_status(3))
- Allocate( profiles_tl(j) % o3 ( coef % nlevels ) ,stat= alloc_status(4))
- Allocate( profiles_tl(j) % clw( coef % nlevels ) ,stat= alloc_status(5))
- If( any(alloc_status /= 0) ) then
- errorstatus = errorstatus_fatal
- Write( errMessage, '( "mem allocation error")' )
- Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine)
- Return
- End If
- End Do
- Allocate( radiancedata_tl % clear ( nchannels ) ,stat= alloc_status(1))
- Allocate( radiancedata_tl % cloudy ( nchannels ) ,stat= alloc_status(2))
- Allocate( radiancedata_tl % total ( nchannels ) ,stat= alloc_status(3))
- Allocate( radiancedata_tl % bt ( nchannels ) ,stat= alloc_status(4))
- Allocate( radiancedata_tl % bt_clear ( nchannels ) ,stat= alloc_status(5))
- Allocate( radiancedata_tl % out ( nchannels ) ,stat= alloc_status(6))
- Allocate( radiancedata_tl % out_clear( nchannels ) ,stat= alloc_status(7))
- Allocate( radiancedata_tl % total_out ( nchannels ) ,stat= alloc_status(8))
- Allocate( radiancedata_tl % clear_out ( nchannels ) ,stat= alloc_status(9))
- Allocate( radiancedata_tl % upclear ( nchannels ) ,stat= alloc_status(10))
- Allocate( radiancedata_tl % reflclear( nchannels ) ,stat= alloc_status(11))
- Allocate( radiancedata_tl % overcast ( coef % nlevels, nchannels ) ,stat= alloc_status(12))
- Allocate( radiancedata_tl % downcld ( coef % nlevels, nchannels ) ,stat= alloc_status(13))
- Allocate( transmission_tl % tau_surf ( nchannels ) ,stat= alloc_status(14))
- Allocate( transmission_tl % tau_layer ( coef % nlevels, nchannels ) ,stat= alloc_status(14))
- Allocate( transmission_tl % od_singlelayer ( coef % nlevels, nchannels ) ,stat= alloc_status(16))
- If( any(alloc_status /= 0) ) then
- errorstatus = errorstatus_fatal
- Write( errMessage, '( "mem allocation error")' )
- Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine)
- Return
- End If
-
-
- Do j = 1, nprofiles
- profiles_tl(j) % ozone_Data = .False. ! no meaning
- profiles_tl(j) % co2_Data = .False. ! no meaning
- profiles_tl(j) % clw_Data = .False. ! no meaning
- profiles_tl(j) % zenangle = -1 ! no meaning
-
- ! increments for atmospheric variables
- profiles_tl(j) % p(:) = 0._JPRB ! no tl on pressure levels
- do lev = 1, profiles_tl(j) % nlevels
- Call random_number( z )
- profiles_tl(j) % t(lev) = -1._JPRB * z ! 1k on temperarure
- Call random_number( z )
- Call random_number( z )
- profiles_tl(j) % o3(lev) = -0.01_JPRB * z ! 0.01 ppmv
- Call random_number( z )
- profiles_tl(j) % clw(lev) = 0.001_JPRB* z ! 1g/kg on clw
- Call random_number( z )
- profiles_tl(j) % q(lev) = -0.1_JPRB * profiles(j) % q(lev) * z ! - 10% on wv
- End Do
-
- ! increments for air surface variables
- Call random_number( z )
- profiles_tl(j) % s2m % t = -1._JPRB *z ! 1k on temperarure
- Call random_number( z )
- profiles_tl(j) % s2m % q = -1.6077_JPRB *z ! ppmv
- Call random_number( z )
- profiles_tl(j) % s2m % p = -10._JPRB *z ! -10 hpa on pressure
- Call random_number( z )
- profiles_tl(j) % s2m % u = 0.1_JPRB *z ! 0.1 m/s on wind components
- Call random_number( z )
- profiles_tl(j) % s2m % v = 0.1_JPRB *z ! 0.1 m/s on wind components
-
- ! increments for skin variables
- profiles_tl(j) % skin % surftype = -1 ! no meaning
- Call random_number( z )
- profiles_tl(j) % skin % t = -1._JPRB *z ! 1k on temperarure
- Call random_number( z )
- profiles_tl(j) % skin % fastem(1) = -0.01_JPRB *z
- Call random_number( z )
- profiles_tl(j) % skin % fastem(2) = -0.01_JPRB *z
- Call random_number( z )
- profiles_tl(j) % skin % fastem(3) = -0.1_JPRB *z
- Call random_number( z )
- profiles_tl(j) % skin % fastem(4) = -0.001_JPRB *z
- Call random_number( z )
- profiles_tl(j) % skin % fastem(5) = -0.001_JPRB *z
-
- ! increments for cloud variables
- Call random_number( z )
- profiles_tl(j) % ctp = -10._JPRB *z ! -10 hpa on pressure
- Call random_number( z )
- profiles_tl(j) % cfraction = 0.1_JPRB *z ! 0.1_JPRB on cloud fraction
- End Do
-
- ! emissivity
- emissivity_tl(:) = -0.01_JPRB
- Do ich =1,nchannels
- CALL RANDOM_NUMBER(Z)
- emissivity_tl(ich) = -0.01_JPRB *z
- End Do
-
- ! do not use stored input emmisisvity but fwd output
- nocalcemis(:) = .false.
-
- Call rttov_tl( &
- & rttov_errorstatus, &! out
- & nfrequencies, &! in
- & nchannels, &! in
- & nbtout, &! in
- & nprofiles, &! in
- & channels, &! in
- & polarisations, &! in
- & lprofiles, &! in
- & profiles, &! in
- & coef, &! in
- & addcloud, &! in
- & nocalcemis, &! in
- & emissivity, &! inout
- & profiles_tl, &! in
- & emissivity_tl, &! inout
- & transmission, &! inout
- & transmission_tl, &! inout
- & radiancedata, &! out
- & radiancedata_tl ) ! inout
-
- If( any( rttov_errorstatus == errorstatus_fatal ) ) then
- Do jp = 1, nprofiles
- If( rttov_errorstatus(jp) == errorstatus_fatal ) then
- Write( errMessage, '( "fatal error in rttov_ad")' )
- Call Rttov_ErrorReport (rttov_errorstatus(jp), errMessage, NameOfRoutine)
- End If
- End Do
- Stop
- End If
- If( any( rttov_errorstatus /= errorstatus_success ) ) then
- Write( errMessage, '( "warning in rttov_ad")' )
- End If
-
- do prof = 1, nprofiles
- sumr = 0._JPRB
- sump = 0._JPRB
- Do jch=1, nbtout
- freq = frequencies(jch)
- If(lprofiles(freq) == prof) Then
- sumr = sumr + radiancedata_ad%out(jch) * radiancedata_tl%out(jch)
- End If
- End Do
-
- sump = sump + SUM(profiles_ad(prof) % t(:) * profiles_tl(prof) % t(:))
- sump = sump + SUM(profiles_ad(prof) % q(:) * profiles_tl(prof) % q(:))
- sump = sump + SUM(profiles_ad(prof) % o3(:) * profiles_tl(prof) % o3(:))
- sump = sump + SUM(profiles_ad(prof) % clw(:) * profiles_tl(prof) % clw(:))
-
- sump = sump + profiles_ad(prof) % skin % t * profiles_tl(prof) % skin % t
- sump = sump + SUM(profiles_ad(prof) % skin % fastem(:) * profiles_tl(prof) % skin % fastem(:))
-
- sump = sump + profiles_ad(prof) % s2m % t * profiles_tl(prof) % s2m % t
- sump = sump + profiles_ad(prof) % s2m % q * profiles_tl(prof) % s2m % q
- sump = sump + profiles_ad(prof) % s2m % p * profiles_tl(prof) % s2m % p
- sump = sump + profiles_ad(prof) % s2m % u * profiles_tl(prof) % s2m % u
- sump = sump + profiles_ad(prof) % s2m % v * profiles_tl(prof) % s2m % v
-
- sump = sump + profiles_ad(prof) % ctp * profiles_tl(prof) % ctp
- sump = sump + profiles_ad(prof) % cfraction * profiles_tl(prof) % cfraction
-
- Do jch=1, nchannels
- freq = polarisations(jch,2)
- If(lprofiles(freq) == prof) Then
- sump = sump + emissivity_ad(jch) * emissivity_tl(jch)
- End If
- End Do
-
- eps = 1._JPRB
- do while ((1+eps) > 1._JPRB)
- eps = eps /2._JPRB
- enddo
-
- Write (ioout, 555) prof, sumr, sump
-555 FORMAT (1X,'PROFILE=',I2,' SUMRAD=',E20.10,' SUMPROF=',E20.10)
-
- End Do
-
-
- Do j = 1, nprofiles
- Deallocate( profiles_ad(j) % p ,stat= alloc_status(1))
- Deallocate( profiles_ad(j) % t ,stat= alloc_status(2))
- Deallocate( profiles_ad(j) % q ,stat= alloc_status(3))
- Deallocate( profiles_ad(j) % o3 ,stat= alloc_status(4))
- Deallocate( profiles_ad(j) % clw ,stat= alloc_status(5))
- Deallocate( profiles_tl(j) % p ,stat= alloc_status(6))
- Deallocate( profiles_tl(j) % t ,stat= alloc_status(7))
- Deallocate( profiles_tl(j) % q ,stat= alloc_status(8))
- Deallocate( profiles_tl(j) % o3 ,stat= alloc_status(9))
- Deallocate( profiles_tl(j) % clw ,stat= alloc_status(10))
- If( any(alloc_status /= 0) ) then
- errorstatus = errorstatus_fatal
- Write( errMessage, '( "mem deallocation error")' )
- Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine)
- Return
- End If
- End Do
-
- ! deallocate radiance results arrays with number of channels
- Deallocate( radiancedata % clear ,stat= alloc_status(1))
- Deallocate( radiancedata % cloudy ,stat= alloc_status(2))
- Deallocate( radiancedata % total ,stat= alloc_status(3))
- Deallocate( radiancedata % bt ,stat= alloc_status(4))
- Deallocate( radiancedata % bt_clear ,stat= alloc_status(5))
- Deallocate( radiancedata % out ,stat= alloc_status(6))
- Deallocate( radiancedata % out_clear ,stat= alloc_status(7))
- Deallocate( radiancedata % total_out ,stat= alloc_status(8))
- Deallocate( radiancedata % clear_out ,stat= alloc_status(9))
- Deallocate( radiancedata % upclear ,stat= alloc_status(10))
- Deallocate( radiancedata % reflclear ,stat= alloc_status(11))
- Deallocate( radiancedata % overcast ,stat= alloc_status(12))
- Deallocate( radiancedata % downcld ,stat= alloc_status(13))
- Deallocate( radiancedata % dnclear ,stat= alloc_status(34))
- Deallocate( radiancedata_ad % clear ,stat= alloc_status(14))
- Deallocate( radiancedata_ad % cloudy ,stat= alloc_status(15))
- Deallocate( radiancedata_ad % total ,stat= alloc_status(16))
- Deallocate( radiancedata_ad % bt ,stat= alloc_status(17))
- Deallocate( radiancedata_ad % bt_clear ,stat= alloc_status(18))
- Deallocate( radiancedata_ad % out ,stat= alloc_status(19))
- Deallocate( radiancedata_ad % out_clear ,stat= alloc_status(20))
- Deallocate( radiancedata_ad % upclear ,stat= alloc_status(21))
- Deallocate( radiancedata_ad % reflclear ,stat= alloc_status(22))
- Deallocate( radiancedata_ad % overcast ,stat= alloc_status(23))
- Deallocate( radiancedata_ad % downcld ,stat= alloc_status(24))
- Deallocate( radiancedata_ad % total_out ,stat= alloc_status(25))
- Deallocate( radiancedata_ad % clear_out ,stat= alloc_status(26))
- Deallocate( radiancedata_tl % clear ,stat= alloc_status(27))
- Deallocate( radiancedata_tl % cloudy ,stat= alloc_status(28))
- Deallocate( radiancedata_tl % total ,stat= alloc_status(29))
- Deallocate( radiancedata_tl % bt ,stat= alloc_status(30))
- Deallocate( radiancedata_tl % bt_clear ,stat= alloc_status(31))
- Deallocate( radiancedata_tl % out ,stat= alloc_status(32))
- Deallocate( radiancedata_tl % out_clear ,stat= alloc_status(33))
- Deallocate( radiancedata_tl % upclear ,stat= alloc_status(34))
- Deallocate( radiancedata_tl % reflclear ,stat= alloc_status(35))
- Deallocate( radiancedata_tl % overcast ,stat= alloc_status(36))
- Deallocate( radiancedata_tl % downcld ,stat= alloc_status(37))
- Deallocate( radiancedata_tl % total_out ,stat= alloc_status(38))
- Deallocate( radiancedata_tl % clear_out ,stat= alloc_status(39))
- DeAllocate( transmission % tau_surf ,stat= alloc_status(40))
- DeAllocate( transmission % tau_layer ,stat= alloc_status(41))
- DeAllocate( transmission % od_singlelayer ,stat= alloc_status(42))
- DeAllocate( transmission_tl % tau_surf ,stat= alloc_status(43))
- DeAllocate( transmission_tl % tau_layer ,stat= alloc_status(44))
- DeAllocate( transmission_tl % od_singlelayer ,stat= alloc_status(45))
- DeAllocate( transmission_ad % tau_surf ,stat= alloc_status(46))
- DeAllocate( transmission_ad % tau_layer ,stat= alloc_status(47))
- DeAllocate( transmission_ad % od_singlelayer ,stat= alloc_status(48))
- If( any(alloc_status /= 0) ) then
- errorstatus = errorstatus_fatal
- Write( errMessage, '( "mem deallocation error")' )
- Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine)
- Return
- End If
-
- Print *, ' Adjoint model test finished'
- Return
-222 Format(1x,10f8.2)
-333 Format(1x,i3,20i5)
-444 Format(1x,10e8.2)
-3333 Format(4x,20i5)
-4444 Format(1x,10f8.3)
-
-
-End Subroutine tstrad_ad
diff --git a/src/LIB/RTTOV/src/tstrad_ad.interface b/src/LIB/RTTOV/src/tstrad_ad.interface
deleted file mode 100644
index 335b9e022c3c36c0e7f91507fc9bee0f541e2fba..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/tstrad_ad.interface
+++ /dev/null
@@ -1,49 +0,0 @@
-Interface
-Subroutine tstrad_ad( &
- nfrequencies, & ! in
- nchannels, & ! in
- nbtout, & ! in
- nprofiles, & ! in
- channels, & ! in
- polarisations, & ! in
- frequencies, & ! in
- lprofiles, & ! in
- profiles, & ! in
- coef, & ! in
- addcloud, & ! in
- calcemis, & ! in
- input_emissivity) ! in
-
- Use rttov_const, Only : &
- errorstatus_success, &
- errorstatus_fatal
-
- Use rttov_types, Only : &
- rttov_coef ,&
- profile_Type ,&
- transmission_Type ,&
- radiance_Type
-
- Use mod_tstrad
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
- Integer(Kind=jpim), Intent(in) :: nfrequencies
- Integer(Kind=jpim), Intent(in) :: nchannels
- Integer(Kind=jpim), Intent(in) :: nbtout
- Integer(Kind=jpim), Intent(in) :: nprofiles
- Integer(Kind=jpim), Intent(in) :: channels(nfrequencies)
- Integer(Kind=jpim), Intent(in) :: polarisations(nchannels,3)
- Integer(Kind=jpim), Intent(in) :: frequencies(nbtout)
- Integer(Kind=jpim), Intent(in) :: lprofiles(nfrequencies)
- Logical, Intent(in) :: addcloud
- Type(profile_Type), Intent(in) :: profiles(nprofiles)
- Type(rttov_coef), Intent(in) :: coef
- Logical, Intent(in) :: calcemis(nchannels)
- Real(Kind=jprb), Intent(in) :: input_emissivity(nchannels)
-
-
-
-End Subroutine tstrad_ad
-End Interface
diff --git a/src/LIB/RTTOV/src/tstrad_chansubset.F90 b/src/LIB/RTTOV/src/tstrad_chansubset.F90
deleted file mode 100644
index d1ae1dee2ff828319dc031fcb5725902643f095b..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/tstrad_chansubset.F90
+++ /dev/null
@@ -1,939 +0,0 @@
-PROGRAM TSTRAD
- !
- ! This software was developed within the context of
- ! the EUMETSAT Satellite Application Facility on
- ! Numerical Weather Prediction (NWP SAF), under the
- ! Cooperation Agreement dated 25 November 1998, between
- ! EUMETSAT and the Met Office, UK, by one or more partners
- ! within the NWP SAF. The partners in the NWP SAF are
- ! the Met Office, ECMWF, KNMI and MeteoFrance.
- !
- ! Copyright 2002, EUMETSAT, All Rights Reserved.
- !
- ! *************************************************************
- !
- ! TEST PROGRAM FOR RTTOV SUITE.
- ! RTTOV VERSION 8
- !
- ! Description: This program is the test harness for RTTOV-8. There
- ! are 3 options:
- ! option = 0 to test forward model only
- ! option = 1 to test the full model ie TL/AD/K
- ! option = 2 to test the cloudy radiance output
- !
- ! To run this program you must have the following files
- ! either resident in the same directory or set up as a
- ! symbolic link:
- ! refprof.dat -- reference profile
- ! prof.dat -- input profile
- ! input.dat -- file to select channels and surface emis
- ! rtcoef_platform_id_sensor.dat -- coefficient file to match
- ! the sensor you request in the input dialogue
- ! There are unix scripts available to set up the files above and
- ! run this program (e.g. tstrad_full.scr)
- ! The output is generated in a file called print.dat.
- ! This output can be compared with reference output generated
- ! by the code developers and included with the export package.
- !
- ! Current Code Owner: SAF NWP
- !
- ! History:
- ! Version Date Comment
- ! ------- ---- -------
- ! 25/01/2002 Initial version (R. Saunders)
- ! 01/05/2002 Updated for NOAA-17 (R. Saunders)
- ! 01/12/2002 New F90 code with structures (P Brunel A Smith)
- ! 02/01/2003 Comments added (R Saunders)
- ! 10/12/2003 Updated for polarimetric changes (S. English/R.Saunders)
- ! 01/04/2004 Updated for chan setup routines (R.Saunders)
- !
- ! Code Description:
- ! Language: Fortran 90.
- ! Software Standards: "European Standards for Writing and
- ! Documenting Exchangeable Fortran 90 Code".
- !
- Use rttov_const, only : &
- nplatforms ,&
- ninst ,&
- pi ,&
- errorstatus_fatal ,&
- errorstatus_warning ,&
- errorstatus_success ,&
- platform_name ,&
- sensor_id_mw ,&
- inst_name, &
- npolar_return, &
- npolar_compute
-
- Use rttov_types, only : &
- rttov_coef ,&
- profile_type ,&
- transmission_Type ,&
- radiance_type
- !
- Use parkind1, Only : jpim ,jprb
- Implicit None
- !
-#include "rttov_errorreport.interface"
-#include "rttov_setup.interface"
-#include "rttov_setupchan.interface"
-#include "rttov_setupindex.interface"
-#include "rttov_errorhandling.interface"
-#include "rttov_direct.interface"
-!!#include "rttov_readcoeffs.interface"
-#include "rttov_dealloc_coef.interface"
-#include "tstrad_tl.interface"
-#include "tstrad_ad.interface"
-#include "tstrad_k.interface"
- !
- ! Parameter for WV conversion used in all tstrad suite
- Real(Kind=jprb), Parameter :: q_mixratio_to_ppmv = 1.60771704e+6_JPRB
- !
- type( rttov_coef ), allocatable :: coef(:) ! coefficients
- type(profile_type), allocatable :: profiles(:)
- type(transmission_type) :: transmission
- type(radiance_type) :: radiance
- !
- Integer(Kind=jpim), Allocatable :: instrument(:,:) ! instrument id
- Integer(Kind=jpim), Allocatable :: nchan(:) ! number of channels per instrument
- Integer(Kind=jpim), Allocatable :: ifull(:) ! full test (with TL,AD,K) per instrument
- Integer(Kind=jpim), Allocatable :: nprof(:) ! number of profiles per instrument
- Integer(Kind=jpim), Allocatable :: nsurf(:) ! surface id number per instrument
- Real(Kind=jprb), Allocatable :: surfem(:,:) ! surface input emissivity per channel , instrument
- Integer(Kind=jpim), Allocatable :: ichan(:,:) ! channel list per instrument
- Real(Kind=jprb), Allocatable :: surfem1(:) ! surface input emissivity per channel , instrument
- Integer(Kind=jpim), Allocatable :: ichan1(:) ! channel list per instrument
-
- integer(Kind=jpim) :: nbtout
- integer(Kind=jpim) :: nfrequencies
- Integer(Kind=jpim) :: nchannels
- integer(Kind=jpim) :: nbtouts
- integer(Kind=jpim) :: nfreqs
- Integer(Kind=jpim) :: nchans
- integer(Kind=jpim), Allocatable :: polarisations (:,:)
- integer(Kind=jpim), Allocatable :: frequencies (:)
- Integer(Kind=jpim), Allocatable :: channels (:)
- Integer(Kind=jpim), Allocatable :: lprofiles (:)
- integer(Kind=jpim), Allocatable :: polar_sub (:,:)
- Integer(Kind=jpim), Allocatable :: chan_sub (:)
- Integer(Kind=jpim), Allocatable :: prof_sub (:)
- Real(Kind=jprb), Allocatable :: emissivity (:)
- Real(Kind=jprb), Allocatable :: input_emissivity (:)
- logical, Allocatable :: calcemis (:)
-
- Integer(Kind=jpim) :: coef_errorstatus ! read coeffs error return code
- Integer(Kind=jpim), Allocatable :: rttov_errorstatus(:) ! rttov error return code
- Integer(Kind=jpim), Allocatable :: setup_errorstatus(:) ! setup return code
-
- ! min and max satellite id for each platform
- Integer(Kind=jpim), dimension(nplatforms) :: max_satid
- Integer(Kind=jpim), dimension(nplatforms) :: min_satid
-
- ! min and max channel numbers for each instrument
-
- integer(Kind=jpim), dimension(0:ninst-1) :: max_channel_old
- integer(Kind=jpim), dimension(0:ninst-1) :: max_channel_new
- integer(Kind=jpim), dimension(0:ninst-1) :: max_channel
- integer(Kind=jpim), parameter :: mxchn = 500 ! max number of channels per instruments allowed in one run
-
- ! polarisations to be computed and returned
- integer(Kind=jpim), Allocatable :: indexout(:)
-
- ! printing arrays
- real(Kind=jprb), Allocatable :: pr_radcld(:)
- real(Kind=jprb), Allocatable :: pr_trans(:)
- real(Kind=jprb), Allocatable :: pr_emis(:)
- real(Kind=jprb), Allocatable :: pr_trans_lev(:,:)
- real(Kind=jprb), Allocatable :: pr_upclr(:)
- real(Kind=jprb), Allocatable :: pr_dncld(:,:)
- real(Kind=jprb), Allocatable :: pr_refclr(:)
- real(Kind=jprb), Allocatable :: pr_ovcst(:,:)
- integer(Kind=jpim), dimension(1:mxchn) :: pr_pol
-
- data min_satid / 1, 8, 1, 8, 5, 2, 1, 1, 1, 1, 1, 1, 3, 2, 1, 1, 1, 1, 0, 0 /
- data max_satid /17,16, 7,12, 5, 2, 1, 2, 3, 1, 1, 1, 4, 2, 1, 1, 1, 1, 0, 0/
- data max_channel_old / 20, 4, 3, 15, 5, 3, 7, 8, 8, 9,&
- & 24, 2378, 4, 16, 3, 5, 8461,14, 4,22,&
- & 2, 8, 4, 18, 3, 2, 3,1000, 40, 22, &
- & 5, 3000, 0, 0, 0/
- data max_channel_new / 20, 4, 3, 15, 5, 3, 4, 8, 8, 9,&
- & 24, 2378, 4, 16, 3, 5, 8461,14, 4,22,&
- & 2, 8, 4, 18, 3, 2, 3,1000, 40, 22, &
- & 5, 3000, 0, 0, 0/
-
- Character (len=80) :: errMessage
- Character (len=6) :: NameOfRoutine = 'tstrad'
- Character (len=3) :: coeff_version = 'old'
- !
- Integer(Kind=jpim) :: Err_Unit ! Logical error unit (<0 for default)
- Integer(Kind=jpim) :: verbosity_level ! (<0 for default)
-
- Integer(Kind=jpim) :: nrttovid ! maximum number of instruments
- Integer(Kind=jpim) :: no_id ! instrument loop index
- Integer(Kind=jpim) :: nlevels
- Integer(Kind=jpim) :: ios
- integer(Kind=jpim) :: i,pol_id,ich2
- integer(Kind=jpim) :: ichannels, ibtout
- Integer(Kind=jpim) :: j
- Integer(Kind=jpim) :: jjm, ira, jj
- integer(Kind=jpim) :: jch, jpol
- integer(Kind=jpim) :: jn, joff1, joff2, joff3
- Integer(Kind=jpim) :: nprint
- Integer(Kind=jpim) :: np, ilev
- Integer(Kind=jpim) :: n
- Integer(Kind=jpim) :: nch ! intermediate variable
- Integer(Kind=jpim) :: ich ! intermediate variable
- Integer(Kind=jpim) :: ii ! intermediate variable
- Integer(Kind=jpim) :: errorstatus
- Real(Kind=jprb) :: s
- Real(Kind=jprb) :: zenang
- Real(Kind=jprb) :: azang
- logical :: lcloud
-
- Integer(Kind=jpim) :: iua
- Integer(Kind=jpim) :: ioout
- Integer(Kind=jpim) :: iue
-
- ! Unit numbers for input/output
- DATA IUA/1/,IOOUT/2/,IUE/56/
-
- Integer(Kind=jpim) :: alloc_status(40)
-
- !- End of header --------------------------------------------------------
-
- errorstatus = 0
- alloc_status(:) = 0
-
- !Initialise error management with default value for
- ! the error unit number and
- ! Fatal error message output
- Err_unit = -1
- verbosity_level = 1
- ! All error message output
- verbosity_level = 3
- call rttov_errorhandling(Err_unit, verbosity_level)
-
- ! Beginning of Routine.
- ! ---------------------
-
- OPEN(IOOUT,file='print.dat',status='unknown',form='formatted')
-
- ! For more than one satellite
- ! comment out the next line and uncomment the following two.
-
- NRTTOVID = 1
-
- ! PRINT *, 'How many satellites do you want?'
- ! READ *, NRTTOVID
-
- allocate (coef(nrttovid),stat= alloc_status(1))
-
- allocate (instrument(3,nrttovid),stat= alloc_status(2))
- allocate (nchan(nrttovid),stat= alloc_status(3))
- allocate (ifull(nrttovid),stat= alloc_status(4))
- allocate (nprof(nrttovid),stat= alloc_status(5))
- allocate (nsurf(nrttovid),stat= alloc_status(6))
-
- !maximum number of channels allowed for one instrument is mxchn
- allocate (surfem(mxchn,nrttovid),stat= alloc_status(7))
- allocate (ichan (mxchn,nrttovid),stat= alloc_status(8))
- If( any(alloc_status /= 0) ) then
- errorstatus = errorstatus_fatal
- Write( errMessage, '( "mem allocation error")' )
- Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine)
- Stop
- End If
-
- surfem(:,:) = 0.0_JPRB
- ichan(:,:) = 0
-
- DO NO_ID = 1, NRTTOVID
-
- write(*,*) 'Which satellite platform do you want?'
- WRITE(*,'(4(2x,i3,2x,a8))') (i,platform_name(i), i = 1, nplatforms)
- READ *, Instrument(1,no_id)
- IF ( Instrument(1,no_id) <= 0 .OR. &
- & Instrument(1,no_id) > nplatforms) STOP 'Platform number not allowed'
-
- WRITE(*,*) 'Which satellite id do you want for this platform?'
- WRITE(*,*) 'Noaaxx = xx GOESyy = yy'
- READ *, instrument(2,no_id)
-
- if( instrument(2,no_id) < min_satid(Instrument(1,no_id)) .or. &
- & instrument(2,no_id) > max_satid(Instrument(1,no_id)) ) &
- & STOP 'Satellite id not allowed'
-
- WRITE(*,*) 'Which instrument type do you want for this satellite?'
- write(*, '(4(2x,i3,2x,a8))') (i, inst_name(i), i = 0, ninst-1)
-
- READ *, instrument(3,no_id)
- IF ( instrument(3,no_id) < 0 .OR. &
- & instrument(3,no_id) > ninst-1)&
- & STOP 'instrument number not allowed'
-
- WRITE(*,*) ' Forward model only (0) or full gradient test (1)',&
- & ' or full radiance output (2)?'
- READ *, IFULL(no_id)
- PRINT *, ' Number of profiles to test code? '
- READ *, NPROF(no_id)
- PRINT *, ' Surface type (0=land, 1=sea, 2=ice/snow)? '
- READ *, NSURF(no_id)
- !
- !..SET UP CHANNEL NUMBERS
- !
- ! .. DEFAULT MAXIMUMS
- if (coeff_version == 'old') max_channel(:)=max_channel_old(:)
- if (coeff_version == 'new') max_channel(:)=max_channel_new(:)
- nchan(no_id) = max_channel(instrument(3,no_id))
- !
- ! Note that channels are the same for all instruments
- ! and all profiles because the filename is the same
- OPEN (IUE,FILE='input.dat',status='old')
- READ(IUE,*)
- NCH = 0
- DO ICH = 1 , nchan(no_id)
- READ(IUE,*,iostat=ios)I,II,S
- if(ios /= 0 ) then
- write (*,*) ' TOO FEW CHANNELS IN INPUT FILE '
- write (*,*) ' nchan(no_id),no_id ',nchan(no_id),no_id
- stop
- endif
- IF(II.GT.0)THEN
- NCH = NCH + 1
- ICHAN(nch,no_id) = I
- SURFEM(nch,no_id) = s
- ENDIF
- ENDDO
- !
- CLOSE(IUE)
-
- ! nchan(no_id) is now the real number of channels selected
- nchan(no_id) = MIN(max_channel(instrument(3,no_id)),NCH)
- write(6,*)' Number of channels selected = ',nchan(no_id)
- allocate (surfem1(nchan(no_id)),stat= alloc_status(7))
- allocate (ichan1(nchan(no_id)),stat= alloc_status(8))
- surfem1(1:nchan(no_id)) = surfem(1:nchan(no_id),no_id)
- ichan1(1:nchan(no_id)) = ichan(1:nchan(no_id),no_id)
- !
- !---------------------------------------------------------
- ! Beginning of rttov_readcoeffs test
- !---------------------------------------------------------
-!!$ call rttov_readcoeffs (coef_errorstatus, coef(no_id), instrument(:,no_id),&
-!!$ & channels = ichan(1:nchan(no_id) ,no_id) )
-!!$
-!!$ if(coef_errorstatus /= errorstatus_success ) then
-!!$ write ( ioout, * ) 'rttov_readcoeffs fatal error'
-!!$ stop
-!!$ endif
-!!$
-!!$ if( any(coef(no_id)%ff_val_chn( 1 : coef(no_id)%fmv_chn ) /= 1 )) then
-!!$ WRITE(*,*) ' some requested channels have bad validity parameter'
-!!$ do i = 1, nchan(no_id)
-!!$ write(*,*) i, coef(no_id)%ff_val_chn(i)
-!!$ end do
-!!$ endif
- !---------------------------------------------------------
- ! End of rttov_readcoeffs test
- !---------------------------------------------------------
- END DO
-
- !---------------------------------------------------------
- ! Beginning of rttov_setup test
- !---------------------------------------------------------
- allocate ( setup_errorstatus(nrttovid),stat= alloc_status(1))
- If( any(alloc_status /= 0) ) then
- errorstatus = errorstatus_fatal
- Write( errMessage, '( "mem allocation error for errorsetup")' )
- Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine)
- Stop
- End If
- Call rttov_setup (&
- & setup_errorstatus, & ! out
- & Err_unit, & ! in
- & verbosity_level, & ! in
- & nrttovid, & ! in
- & coef, & ! out
- & instrument, & ! in
- & ichan ) ! in Optional
-
- if(any(setup_errorstatus(:) /= errorstatus_success ) ) then
- write ( ioout, * ) 'rttov_setup fatal error'
- stop
- endif
-
- deallocate( setup_errorstatus ,stat=alloc_status(1))
- If( any(alloc_status /= 0) ) then
- errorstatus = errorstatus_fatal
- Write( errMessage, '( "mem deallocation error for setup_errorstatus")' )
- Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine)
- Stop
- End If
-
- DO no_id = 1, NRTTOVID
- if( any(coef(no_id)%ff_val_chn( : ) /= 1 )) then
- WRITE(*,*) ' some requested channels have bad validity parameter'
- do i = 1, nchan(no_id)
- write(*,*) i, coef(no_id)%ff_val_chn(i)
- end do
- endif
- End Do
- !---------------------------------------------------------
- ! End of rttov_setup test
- !---------------------------------------------------------
- !
- !
- DO no_id = 1, NRTTOVID
- ! Set up various channel numbers required by RTTOV-8
- Call rttov_setupchan(nprof(no_id),nchan(no_id),coef(no_id),nfrequencies, &
- & nchannels,nbtout)
-
- ! total number of channels
- ! select channel subset by ignoring 1st 3 and last 2 channels
- nfreqs = nfrequencies-5
- nchans = nchannels-10
- nbtouts = nbtout-5
- nlevels = coef(no_id) % nlevels
-
- ! Memory allocation for RTTOV_Direct
- !-----------------------------------
- allocate( channels ( nfrequencies ) ,stat= alloc_status(1))
- allocate( rttov_errorstatus(nprof(no_id)),stat= alloc_status(1))
- allocate( profiles(nprof(no_id)),stat= alloc_status(2))
- If( any(alloc_status /= 0) ) then
- errorstatus = errorstatus_fatal
- Write( errMessage, '( "mem allocation error")' )
- Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine)
- Stop
- End If
- allocate( polarisations(nchannels,3),stat= alloc_status(1))
- allocate( frequencies(nbtout),stat= alloc_status(2))
- allocate( indexout(nbtout),stat= alloc_status(3))
-
- do j = 1, nprof(no_id)
- ! allocate model profiles atmospheric arrays with model levels dimension
- profiles(j) % nlevels = coef(no_id) % nlevels
- allocate( profiles(j) % p ( coef(no_id) % nlevels ) ,stat= alloc_status(4))
- allocate( profiles(j) % t ( coef(no_id) % nlevels ) ,stat= alloc_status(5))
- allocate( profiles(j) % q ( coef(no_id) % nlevels ) ,stat= alloc_status(6))
- allocate( profiles(j) % o3 ( coef(no_id) % nlevels ) ,stat= alloc_status(7))
- allocate( profiles(j) % clw( coef(no_id) % nlevels ) ,stat= alloc_status(8))
- profiles(j) % p(:) = coef(no_id) % ref_prfl_p(:)
- If( any(alloc_status /= 0) ) then
- errorstatus = errorstatus_fatal
- Write( errMessage, '( "mem allocation error")' )
- Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine)
- Stop
- End If
- end do
-
- ! number of channels per RTTOV call is only nchannels
- allocate( lprofiles ( nfrequencies ) ,stat= alloc_status(9))
- allocate( emissivity ( nchannels ) ,stat= alloc_status(10))
- allocate( input_emissivity ( nchannels ) ,stat= alloc_status(11))
- allocate( calcemis ( nchannels ) ,stat= alloc_status(12))
-
- ! allocate transmittance structure
- allocate( transmission % tau_surf ( nchans ) ,stat= alloc_status(13))
- allocate( transmission % tau_layer ( coef(no_id) % nlevels, nchans ) ,stat= alloc_status(14))
- allocate( transmission % od_singlelayer( coef(no_id) % nlevels, nchans ),stat= alloc_status(15))
-
- ! allocate radiance results arrays with number of channels
- allocate( radiance % clear ( nchans ) ,stat= alloc_status(19))
- allocate( radiance % cloudy ( nchans ) ,stat= alloc_status(20))
- allocate( radiance % total ( nchans ) ,stat= alloc_status(21))
- allocate( radiance % bt ( nchans ) ,stat= alloc_status(22))
- allocate( radiance % bt_clear ( nchans ) ,stat= alloc_status(23))
- allocate( radiance % upclear ( nchans ) ,stat= alloc_status(24))
- allocate( radiance % dnclear ( nchans ) ,stat=alloc_status(25))
- allocate( radiance % reflclear( nchans ) ,stat= alloc_status(26))
- allocate( radiance % overcast ( coef(no_id) % nlevels, nchans ) ,stat= alloc_status(27))
-
- ! allocate the cloudy radiances with full size even if not used
- ! Save input values of emissivities for all calculations.
- allocate( radiance % downcld ( coef(no_id) % nlevels, nchans ) ,stat= alloc_status(28))
- allocate( radiance % out ( nbtout ) ,stat= alloc_status(29))
- allocate( radiance % out_clear( nbtout ) ,stat= alloc_status(30))
- allocate( radiance % total_out( nbtout ) ,stat= alloc_status(31))
- allocate( radiance % clear_out( nbtout ) ,stat= alloc_status(32))
-
- Allocate(pr_radcld(nbtout) ,stat= alloc_status(33))
- Allocate(pr_trans(nbtout) ,stat= alloc_status(34))
- Allocate(pr_emis(nbtout) ,stat= alloc_status(35))
- Allocate(pr_trans_lev(coef(no_id) % nlevels,nbtout) ,stat= alloc_status(36))
- Allocate(pr_upclr(nbtout) ,stat= alloc_status(37))
- Allocate(pr_dncld(coef(no_id) % nlevels,nbtout) ,stat= alloc_status(38))
- Allocate(pr_refclr(nbtout) ,stat= alloc_status(39))
- Allocate(pr_ovcst(coef(no_id) % nlevels,nbtout) ,stat= alloc_status(40))
-
- If( any(alloc_status /= 0) ) then
- errorstatus = errorstatus_fatal
- Write( errMessage, '( "mem allocation error")' )
- Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine)
- Stop
- End If
-
- WRITE(6,*)'Zenith angle (degrees)?'
- READ(5,*)ZENANG
- WRITE(6,*)'Azimuth angle (degrees)?'
- READ(5,*)AZANG
-
- WRITE(6,*)' Number of level =',NLEVELS
- ! Read profile ONE and fill other profiles with profile one
- OPEN (IUA,FILE='prof.dat',status='old')
- !
- JJM = 0
- DO IRA = 1 , 1+(NLEVELS-1)/10
- JJ = 1+JJM
- JJM = MIN(JJ+9,NLEVELS)
- READ(IUA,*) (profiles(1) % t(J),J=JJ,JJM)
- end do
- JJM = 0
- DO IRA = 1 , 1+(NLEVELS-1)/10
- JJ = 1+JJM
- JJM = MIN(JJ+9,NLEVELS)
- READ(IUA,*) (profiles(1) % q(J),J=JJ,JJM)
- end do
- JJM = 0
- DO IRA = 1 , 1+(NLEVELS-1)/10
- JJ = 1+JJM
- JJM = MIN(JJ+9,NLEVELS)
- READ(IUA,*) (profiles(1) % o3(J),J=JJ,JJM)
- end do
- profiles(1) % ozone_data = .true.
- profiles(1) % co2_data = .false.
-
- JJM = 0
- DO IRA = 1 , 1+(NLEVELS-1)/10
- JJ = 1+JJM
- JJM = MIN(JJ+9,NLEVELS)
- READ(IUA,*) (profiles(1) % clw(J),J=JJ,JJM)
- end do
- ! check value of first level
- profiles(1) % clw_data = profiles(1) % clw(1) >= 0.0_JPRB
-
- READ(IUA,*) profiles(1) % s2m % t ,&
- & profiles(1) % s2m % q ,&
- & profiles(1) % s2m % p ,&
- & profiles(1) % s2m % u ,&
- & profiles(1) % s2m % v
-
-
- READ(IUA,*) profiles(1) % skin % t ,&
- & profiles(1) % skin % fastem
-
- READ(IUA,*) profiles(1) % ctp,&
- & profiles(1) % cfraction
- !
- CLOSE(IUA)
- !
- WRITE(IOOUT,*)' INPUT PROFILE'
- WRITE(IOOUT,444) (profiles(1) % t(JJ) ,JJ=1,NLEVELS)
- WRITE(IOOUT,444) (profiles(1) % q(JJ) ,JJ=1,NLEVELS)
- WRITE(IOOUT,444) (profiles(1) % o3(JJ) ,JJ=1,NLEVELS)
- WRITE(IOOUT,444) (profiles(1) % clw(JJ) ,JJ=1,NLEVELS)
- WRITE(IOOUT,444) profiles(1) % s2m % t ,&
- & profiles(1) % s2m % q ,&
- & profiles(1) % s2m % p ,&
- & profiles(1) % s2m % u ,&
- & profiles(1) % s2m % v
- WRITE(IOOUT,444) profiles(1) % skin % t ,&
- & profiles(1) % skin % fastem
- WRITE(IOOUT,444) profiles(1) % ctp,&
- & profiles(1) % cfraction
- WRITE(IOOUT,*)' '
-
-
-
- ! Convert lnq to q in ppmv for profile
- !
- profiles(1) % q(:) = (exp(profiles(1) % q(:)) / 1000._JPRB) * q_mixratio_to_ppmv
- profiles(1) % s2m % q = (exp(profiles(1) % s2m % q) / 1000._JPRB) * q_mixratio_to_ppmv
-
- ! Keep Ozone in ppmv
-
- ! viewing geometry
- profiles(1) % zenangle = ZENANG
- profiles(1) % azangle = AZANG
- ! surface type
- profiles(1) % skin % surftype = nsurf(no_id)
-
- !.. Fill profile arrays with the 1 profile NPROF times
- DO J = 1 , NPROF(no_id)
- profiles(j) % p(:) = profiles(1) % p(:)
- profiles(j) % t(:) = profiles(1) % t(:)
- profiles(j) % q(:) = profiles(1) % q(:)
- profiles(j) % o3(:) = profiles(1) % o3(:)
- profiles(j) % clw(:) = profiles(1) % clw(:)
- profiles(j) % s2m = profiles(1) % s2m
- profiles(j) % skin = profiles(1) % skin
- profiles(j) % ctp = profiles(1) % ctp
- profiles(j) % cfraction = profiles(1) % cfraction
- profiles(j) % ozone_data = profiles(1) % ozone_data
- profiles(j) % co2_data = profiles(1) % co2_data
- profiles(j) % clw_data = profiles(1) % clw_data
- profiles(j) % zenangle = profiles(1) % zenangle
- profiles(j) % azangle = profiles(1) % azangle
- end do
-
- ! Build the list of channels/profiles indices
- Call rttov_setupindex (nchan(no_id),nprof(no_id),nfrequencies,nchannels,nbtout,coef(no_id),&
- & surfem1,lprofiles,channels,polarisations,emissivity)
- !
- nch = 0
- ibtout=0
- DO J=1,NPROF(no_id)
- DO JCH=1,NCHAN(no_id)
- nch = nch +1
- If( coef(no_id) % id_sensor /= sensor_id_mw) then
- frequencies(ibtout+1) = nch
- ibtout=ibtout+1
- End If
- If( coef(no_id) % id_sensor == sensor_id_mw) then
- pol_id = coef(no_id) % fastem_polar(jch) + 1
- Do i=1, npolar_return(pol_id)
- frequencies(ibtout+i)=nch
- End Do
- ibtout=ibtout+npolar_return(pol_id)
- End If
- End Do
- End Do
- ! select channel subset by ignoring 1st 3 and last 2 channels
- nfreqs = nfrequencies-5
- nchans = nchannels-10
- nbtouts = nbtout-5
- allocate( chan_sub( nfreqs ) ,stat= alloc_status(1))
- allocate( polar_sub( nchans,3 ) ,stat= alloc_status(1))
- allocate( prof_sub( nfreqs ) ,stat= alloc_status(1))
-
- chan_sub(:) = 0
- prof_sub(:) = 0
- polar_sub(:,:) = 0
-
- chan_sub(1:nfreqs) = channels(4:nfrequencies-2)
- prof_sub(1:nfreqs) = 1
- polar_sub(1:nfreqs,1)= polarisations(4:nfrequencies-2,1)-6
- polar_sub(1:nchans,2)= polarisations(7:nchannels-4,2)-3
- polar_sub(1:nfreqs,3)= polarisations(4:nfrequencies-2,3)
-
- write(6,*)' nfreq=',nfreqs,' nchans=',nchans,' nbtout=',nbtouts
- write(6,*)' Channels ',(chan_sub(ich2),ich2=1,nfreqs)
- write(6,*)(polar_sub(ich2,1),ich2=1,nchans)
- write(6,*)(polar_sub(ich2,2),ich2=1,nchans)
- write(6,*)(polar_sub(ich2,3),ich2=1,nchans)
-
- ! save input values of emissivities for all calculations
- ! calculate emissivity where the input emissivity value is less than 0.01
- input_emissivity(:) = emissivity(:)
- calcemis(:) = emissivity(:) < 0.01_JPRB
-
- WRITE(IOOUT,*)' NUMBER OF PROFILES PROCESSED=',NPROF(no_id)
- WRITE(IOOUT,*)' '
- !
- WRITE(IOOUT,*)'CHANNELS PROCESSED:'
- WRITE(IOOUT,111) (ichan(J,no_id), J = 1,NCHAN(no_id))
- WRITE (IOOUT,*)' '
- WRITE(IOOUT,*)'INPUT SURFACE EMISSIVITIES '&
- & ,'SAT =', instrument(2,no_id)
- JOFF1=0
- WRITE(IOOUT,444) (emissivity(J+JOFF1),J=1,NCHAN(no_id))
- WRITE(IOOUT,*)' '
-
- IF(IFULL(no_id).EQ.2)THEN
- LCLOUD =.TRUE.
- ELSE
- LCLOUD =.FALSE.
- radiance % downcld(:,:) = 0._JPRB
- ENDIF
- ! PERFORM RADIATIVE TRANSFER CALCULATIONS
- call rttov_direct( &
- rttov_errorstatus, & ! out
- nfreqs, & ! in
- nchans, & ! in
- nbtouts, & ! in
- nprof(no_id), & ! in
- chan_sub, & ! in
- polar_sub, & ! in
- prof_sub, & ! in
- profiles, & ! in
- coef(no_id), & ! in
- lcloud, & ! in
- calcemis, & ! in
- emissivity, & ! inout
- transmission, & ! out
- radiance ) ! inout
-
- If ( any( rttov_errorstatus(:) == errorstatus_warning ) ) Then
- Do j = 1, nprof(no_id)
- If ( rttov_errorstatus(j) == errorstatus_warning ) Then
- write ( ioout, * ) 'rttov warning for profile',j
- End If
- End Do
- End If
-
- If ( any( rttov_errorstatus(:) == errorstatus_fatal ) ) Then
- Do j = 1, nprof(no_id)
- If ( rttov_errorstatus(j) == errorstatus_fatal ) Then
- write ( ioout, * ) 'rttov error for profile',j
- End If
- End Do
- Stop
- End If
-
- ! transfer data to printing arrays
- pr_pol(:) = 0
- pr_radcld(:) = 0.0_JPRB
- pr_trans(:) = 0.0_JPRB
- pr_emis(:) = 0.0_JPRB
- pr_trans_lev(:,:) = 0.0_JPRB
- pr_upclr(:) = 0.0_JPRB
- pr_dncld(:,:) = 0.0_JPRB
- pr_refclr(:) = 0.0_JPRB
- pr_ovcst(:,:) = 0.0_JPRB
- !
- do j = 1 , nchans
- jpol = polarisations(j,2)
- pr_pol(jpol) = jpol
- pr_radcld(jpol) = radiance % cloudy(j)
- pr_trans(jpol) = Transmission % tau_surf(J)
- pr_emis(jpol) = emissivity(j)
- pr_upclr(jpol) = radiance % upclear(J)
- pr_refclr(jpol) = radiance % reflclear(J)
- do ilev = 1 , nlevels
- pr_trans_lev(ilev,jpol) = Transmission % tau_layer(ilev,J)
- pr_dncld(ilev,jpol) = radiance % downcld(ILEV,J)
- pr_ovcst(ilev,jpol) = radiance % overcast(ILEV,J)
- enddo
- enddo
-
- ! OUTPUT RESULTS
- !
- NPRINT = 1+ INT((nbtouts-1)/(10*nprof(no_id)))
- DO JN=1,NPROF(no_id)
- WRITE(IOOUT,*)' -----------------'
- WRITE(IOOUT,*)' Profile number ',JN, 'Instrument ',&
- & instrument(3,no_id)
- WRITE(IOOUT,*)' -----------------'
- WRITE(IOOUT,*)' '
-! JOFF=NCHAN(no_id)*(JN-1)
- JOFF1=nbtouts/nprof(no_id)*(JN-1)
- JOFF2=nbtouts/nprof(no_id)*(JN-1)
- JOFF3=nfreqs/nprof(no_id)*(JN-1)
- WRITE(IOOUT,777)instrument(2,no_id), profiles(jn)%zenangle,profiles(jn)%azangle,profiles(jn)%skin%surftype
- WRITE(IOOUT,222) (radiance % out(J+JOFF1),J=1,nbtouts/nprof(no_id))
- WRITE(IOOUT,*)' '
- WRITE(IOOUT,*)'CALCULATED RADIANCES: SAT =', instrument(2,no_id)
- WRITE(IOOUT,222) (radiance % total_out(J+JOFF1),J=1,nbtouts/nprof(no_id))
- WRITE(IOOUT,*)' '
- WRITE(IOOUT,*)'CALCULATED OVERCAST RADIANCES: SAT =', instrument(2,no_id)
- WRITE(IOOUT,222) (pr_radcld(J+JOFF2),J=1,nbtouts/nprof(no_id))
- WRITE (IOOUT,*)' '
- WRITE(IOOUT,*)'CALCULATED SURFACE TO SPACE TRANSMITTANCE: S'&
- & ,'AT =',instrument(2,no_id)
- WRITE(IOOUT,4444) (pr_trans(J+JOFF2),J=1,nbtouts/nprof(no_id))
- WRITE (IOOUT,*)' '
- WRITE(IOOUT,*)'CALCULATED SURFACE EMISSIVITIES '&
- & ,'SAT =',instrument(2,no_id)
- WRITE(IOOUT,444) (pr_emis(J+JOFF2),J=1,nbtouts/nprof(no_id))
- !
- ! Print clear-sky radiance without reflection term and
- ! reflected clear-sky downwelling radiance
- !
- IF(IFULL(no_id) == 2 .AND. nchan(no_id) <= 20 )THEN
- WRITE (IOOUT,*)' '
- WRITE(IOOUT,*)'CALCULATED Clear-sky radiance without reflection term'&
- & ,' SAT =',instrument(2,no_id)
- WRITE(IOOUT,444)(pr_upclr(J+JOFF2),J=1,nbtouts/nprof(no_id))
- WRITE (IOOUT,*)' '
- WRITE (IOOUT,*)'CALCULATED Reflected clear-sky downwelling radiance'&
- & ,' SAT =',instrument(2,no_id)
- WRITE(IOOUT,444)(pr_refclr(J+JOFF2),J=1,nbtouts/nprof(no_id))
- WRITE (IOOUT,*)'CHANNELS '
- WRITE(IOOUT,111) (ichan(j,no_id), J = 1,nbtouts/nprof(no_id))
- ENDIF
- !
- IF(JN.EQ.1 .AND. nchan(no_id) .LE. 20)THEN
- DO NP = 1 , NPRINT
- WRITE (IOOUT,*)' '
- WRITE (IOOUT,*)'Level to space transmittances for channels'
-! WRITE(IOOUT,1115)(pr_pol(j),&
- WRITE(IOOUT,1115) (ICHAN(J,no_id),&
- & J = 1+(NP-1)*10,MIN(10+(NP-1)*10,nbtouts/nprof(no_id)))
- DO ILEV = 1 , NLEVELS
- WRITE(IOOUT,4445)ILEV,(pr_trans_lev(ilev,J+JOFF2),&
- & J = 1+(NP-1)*10,MIN(10+(NP-1)*10,nbtouts/nprof(no_id)))
- end do
- WRITE(IOOUT,1115) (ICHAN(J,no_id),&
- & J = 1+(NP-1)*10,MIN(10+(NP-1)*10,nbtouts/nprof(no_id)))
- end do
- ENDIF
- !
- ! Print radiance upwelling arrays
- IF(JN==1 .AND. IFULL(no_id)==2 .AND. nchan(no_id)<=20)THEN
- DO NP = 1 , NPRINT
- WRITE (IOOUT,*)' '
- WRITE (IOOUT,*)'Level to space upwelling radiances for channels'
- WRITE(IOOUT,1115) (ICHAN(J,no_id),&
- & J = 1+(NP-1)*10,MIN(10+(NP-1)*10,nbtout/nprof(no_id)))
- DO ILEV = 1 , NLEVELS
- WRITE(IOOUT,4446)ILEV,(pr_ovcst(ILEV,J+JOFF2),&
- & J = 1+(NP-1)*10,MIN(10+(NP-1)*10,nbtout/nprof(no_id)))
- end do
- WRITE(IOOUT,1115) (ICHAN(J,no_id),&
- & J = 1+(NP-1)*10,MIN(10+(NP-1)*10,nbtout/nprof(no_id)))
- end do
- ENDIF
- ! Print radiance downwelling arrays
- IF(JN==1 .AND. IFULL(no_id)==2 .AND. nchan(no_id)<=20)THEN
- DO NP = 1 , NPRINT
- WRITE (IOOUT,*)' '
- WRITE (IOOUT,*)'Level to space downwelling radiances for channels'
- WRITE(IOOUT,1115) (ICHAN(J,no_id),&
- & J = 1+(NP-1)*10,MIN(10+(NP-1)*10,nbtout/nprof(no_id)))
- DO ILEV = 1 , NLEVELS
- WRITE(IOOUT,4446)ILEV,(pr_dncld(ILEV,J+JOFF2),&
- & J = 1+(NP-1)*10,MIN(10+(NP-1)*10,nbtout/nprof(no_id)))
- end do
- WRITE(IOOUT,1115) (ICHAN(J,no_id),&
- & J = 1+(NP-1)*10,MIN(10+(NP-1)*10,nbtout/nprof(no_id)))
- end do
- ENDIF
- end do
- WRITE(*,*) ' FORWARD MODEL FINISHED'
- !
- IF (IFULL(no_id).GE.1)THEN
- !
- !-----------------------------------------------------------
- ! Test tangent linear
- !-----------------------------------------------------------
- write(*,*) 'Tangent linear'
-
- call TSTRAD_TL( &
- nfrequencies, & ! in
- nchannels, & ! in
- nbtout, & ! in
- nprof(no_id), & ! in
- channels, & ! in
- polarisations, & ! in
- lprofiles, & ! in
- frequencies, & ! in
- profiles, & ! in
- coef(no_id), & ! in
- lcloud, & ! in
- calcemis, & ! in
- input_emissivity) ! in
-
- write(*,*) 'Adjoint'
-
- call TSTRAD_AD( &
- nfrequencies, & ! in
- nchannels, & ! in
- nbtout, & ! in
- nprof(no_id), & ! in
- channels, & ! in
- polarisations, & ! in
- frequencies, & ! in
- lprofiles, & ! in
- profiles, & ! in
- coef(no_id), & ! in
- lcloud, & ! in
- calcemis, & ! in
- input_emissivity) ! in
-
- write(*,*) 'K'
-
- call TSTRAD_K( &
- nfrequencies, & ! in
- nchannels, & ! in
- nbtout, & ! in
- nprof(no_id), & ! in
- channels, & ! in
- polarisations, & ! in
- frequencies, & ! in
- lprofiles, & ! in
- profiles, & ! in
- coef(no_id), & ! in
- lcloud, & ! in
- calcemis, & ! in
- input_emissivity) ! in
-
- ENDIF
-
-
- do j = 1, nprof(no_id)
- ! deallocate model profiles atmospheric arrays
- deallocate( profiles(j) % p ,stat=alloc_status(1))
- deallocate( profiles(j) % t ,stat=alloc_status(2))
- deallocate( profiles(j) % q ,stat=alloc_status(3))
- deallocate( profiles(j) % o3 ,stat=alloc_status(4))
- deallocate( profiles(j) % clw ,stat=alloc_status(5))
- If( any(alloc_status /= 0) ) then
- errorstatus = errorstatus_fatal
- Write( errMessage, '( "mem deallocation error")' )
- Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine)
- Stop
- End If
- end do
- deallocate( profiles,stat=alloc_status(1))
-
- ! number of channels per RTTOV call is only nchannels
- deallocate( channels ,stat=alloc_status(2))
- deallocate( lprofiles ,stat=alloc_status(3))
- deallocate( emissivity ,stat=alloc_status(4))
- deallocate( calcemis ,stat=alloc_status(5))
-
- ! allocate transmittance structure
- deallocate( transmission % tau_surf ,stat= alloc_status(6))
- deallocate( transmission % tau_layer ,stat= alloc_status(7))
- deallocate( transmission % od_singlelayer,stat= alloc_status(8))
-
- ! allocate radiance results arrays with number of channels
- deallocate( radiance % clear ,stat=alloc_status(9))
- deallocate( radiance % cloudy ,stat=alloc_status(10))
- deallocate( radiance % total ,stat=alloc_status(11))
- deallocate( radiance % bt ,stat=alloc_status(12))
- deallocate( radiance % bt_clear ,stat=alloc_status(13))
- deallocate( radiance % upclear ,stat=alloc_status(14))
- deallocate( radiance % dnclear ,stat=alloc_status(15))
- deallocate( radiance % reflclear,stat=alloc_status(16))
- deallocate( radiance % overcast ,stat=alloc_status(17))
- deallocate( radiance % downcld ,stat=alloc_status(18))
- deallocate( radiance % out ,stat= alloc_status(19))
- deallocate( radiance % out_clear ,stat= alloc_status(20))
- deallocate( radiance % total_out ,stat= alloc_status(21))
- deallocate( radiance % clear_out ,stat= alloc_status(22))
- deallocate(pr_radcld ,stat= alloc_status(31))
- deallocate(pr_trans ,stat= alloc_status(32))
- deallocate(pr_emis ,stat= alloc_status(33))
- deallocate(pr_trans_lev ,stat= alloc_status(34))
- If( any(alloc_status /= 0) ) then
- errorstatus = errorstatus_fatal
- Write( errMessage, '( "mem deallocation error")' )
- Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine)
- Stop
- End If
- ENDDO
-
- Do no_id = 1, nrttovid
- Call rttov_dealloc_coef (errorstatus, coef(no_id))
- If(errorstatus /= errorstatus_success) Then
- Write( errMessage, '( "deallocation error")' )
- Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine)
- Endif
- End Do
-
-111 FORMAT(1X,10I8)
-1115 FORMAT(3X,10I8)
-2222 FORMAT(1X,10(1x,F8.6))
-222 FORMAT(1X,10F8.2)
-333 FORMAT(1X,I3,20I5)
-3333 FORMAT(1X,I3,2I5)
-444 FORMAT(1X,10F8.3)
-4444 FORMAT(1X,10F8.4)
-4445 FORMAT(1X,I2,10F8.4)
-4446 FORMAT(1X,I2,10F8.3)
-555 FORMAT(1X,10E8.2)
-777 FORMAT(1X,'CALCULATED BRIGHTNESS TEMPERATURES: SAT =',I2,&
- &' ZENITH ANGLE=',F6.2, &
- &' AZIMUTH ANGLE=',F7.2,' SURFACE TYPE=',I2)
-
-END PROGRAM TSTRAD
diff --git a/src/LIB/RTTOV/src/tstrad_k.F90 b/src/LIB/RTTOV/src/tstrad_k.F90
deleted file mode 100644
index 532fab38fa0d0f62fa805ba64657d29e6fe08f64..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/tstrad_k.F90
+++ /dev/null
@@ -1,475 +0,0 @@
-Subroutine tstrad_k( &
- & nfrequencies, &! in
- & nchannels, &! in
- & nbtout, &! in
- & nprofiles, &! in
- & channels, &! in
- & polarisations, &! in
- & frequencies, &! in
- & lprofiles, &! in
- & profiles, &! in
- & coef, &! in
- & addcloud, &! in
- & calcemis, &! in
- & input_emissivity) ! in
- !
- ! only the first nchannels/nprofiles are output
- !
-
- Use rttov_const, Only : &
- & errorstatus_success ,&
- & errorstatus_fatal
-
- Use rttov_types, Only : &
- & rttov_coef ,&
- & profile_Type ,&
- & transmission_Type ,&
- & radiance_Type
-
- Use mod_tstrad
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
-#include "rttov_errorreport.interface"
-#include "rttov_k.interface"
-
- !subroutine arguments:
- Integer(Kind=jpim), Intent(in) :: nfrequencies
- Integer(Kind=jpim), Intent(in) :: nchannels
- Integer(Kind=jpim), Intent(in) :: nbtout
- Integer(Kind=jpim), Intent(in) :: nprofiles
- Integer(Kind=jpim), Intent(in) :: channels(nfrequencies)
- Integer(Kind=jpim), Intent(in) :: polarisations(nchannels,3)
- Integer(Kind=jpim), Intent(in) :: frequencies(nbtout)
- Integer(Kind=jpim), Intent(in) :: lprofiles(nfrequencies)
- Logical, Intent(in) :: addcloud
- Type(profile_Type), Intent(in) :: profiles(nprofiles)
- Type(rttov_coef), Intent(in) :: coef
- Logical, Intent(in) :: calcemis(nchannels)
- Real(Kind=jprb), Intent(in) :: input_emissivity(nchannels)
-
-
-
- ! local
- Integer(Kind=jpim), Parameter :: jpnav = 4 ! no. of profile variables
- Integer(Kind=jpim), Parameter :: jpnsav = 5 ! no. of surface air variables
- Integer(Kind=jpim), Parameter :: jpnssv = 6 ! no. of skin variables
- Integer(Kind=jpim), Parameter :: jpncv = 2 ! no. of cloud variables
- Integer(Kind=jpim), Parameter :: sscvar = jpnsav+jpnssv+jpncv ! no of surface,skin,cloud vars
-
- Integer(Kind=jpim) :: errorstatus
- Character (len=80) :: errMessage
- Character (len=10) :: NameOfRoutine = 'tstrad_k '
-
- ! forward model outputs
- logical :: switchrad
- Type(transmission_Type) :: transmission
- Type(radiance_Type) :: radiancedata
- Real(Kind=jprb) :: emissivity(nchannels)
-
-
- ! AD variables for rttov_k calls
- Type(profile_Type) :: profiles_k(nchannels)
- Type(transmission_Type) :: transmission_k
- Real(Kind=jprb) :: emissivity_k(nchannels)
-
-
- Integer(Kind=jpim) :: nlev
- Integer(Kind=jpim) :: ixkav(coef%nlevels,jpnav,nbtout)
-
- Integer(Kind=jpim) :: ixksav(sscvar,nbtout)
-
- ! Adjoint results
- Integer(Kind=jpim) :: ixkdav(coef%nlevels,jpnav,nbtout)
- Real(Kind=jprb) :: xktav (coef%nlevels,jpnav,nbtout)
- Integer(Kind=jpim) :: ixkdsav(sscvar,nbtout)
- Real(Kind=jprb) :: xktsav (sscvar,nbtout)
- Integer(Kind=jpim) :: ixdem(nbtout)
- Real(Kind=jprb) :: xkaem(nbtout)
-
- ! coefficients for printing
- Real(Kind=jprb) :: facpav(coef%nlevels,jpnav)
- Real(Kind=jprb) :: facovu(coef%nlevels)
- Real(Kind=jprb) :: facovd(coef%nlevels)
- Real(Kind=jprb) :: facem = 1._JPRB
-
- Real(Kind=jprb) :: facsav(sscvar) =&
- & (/10000._JPRB,0.1_JPRB,10000._JPRB,10000._JPRB,10000._JPRB, &! 2m
- & 10000._JPRB,100.0_JPRB,100.0_JPRB,100.0_JPRB,100.0_JPRB,100.0_JPRB, &! Skin
- & 10000._JPRB,100._JPRB/) ! cloud
-
- Real(Kind=jprb) :: facdiff = 1.e+10_JPRB
- ! Real :: facdiff = 1.
-
- Real(Kind=jprb), Parameter :: q_mixratio_to_ppmv = 1.60771704e+6_JPRB
- Real(Kind=jprb), Parameter :: o3_mixratio_to_ppmv = 6.03504e+5_JPRB
-
- Integer(Kind=jpim) :: ioout = 2
- Integer(Kind=jpim) :: ich, jch
- Integer(Kind=jpim) :: j, i, ii, jp, joff, freq, ipol
- Integer(Kind=jpim) :: nchan_out
-
- Character (len=30) :: title(4) = &
- & (/' lev temperature ', &
- & ' lev water vapour ', &
- & ' lev ozone ', &
- & ' lev liquid water '/)
-
- Integer(Kind=jpim) :: alloc_status(30)
- Integer(Kind=jpim) :: rttov_errorstatus(nprofiles)
-
- !- End of header --------------------------------------------------------
-
- errorstatus = 0
- alloc_status(:) = 0
-
- nchan_out = nbtout/nprofiles
- nlev = coef % nlevels
-
- ! coefficients for atmospheric variables
- facpav(:,1) = 10000._JPRB
- facpav(:,2) = 0.1_JPRB
- facpav(:,3) = 0.001_JPRB
- facpav(:,4) = 0.1_JPRB
- facovu(:) = 10000._JPRB
- facovd(:) = 100000._JPRB
-
- ! coefficients compatibility with RTTOV7
- facpav(:,2) = facpav(:,2) * q_mixratio_to_ppmv
- facpav(:,3) = facpav(:,3) * o3_mixratio_to_ppmv
- facsav(2) = facsav(2) * q_mixratio_to_ppmv
-
- ! allocate and initialise the reference tl increments
- Do j = 1, nbtout
- profiles_k(j) % nlevels = coef % nlevels
- Allocate( profiles_k(j) % p ( coef % nlevels ) ,stat= alloc_status(1))
- Allocate( profiles_k(j) % t ( coef % nlevels ) ,stat= alloc_status(2))
- Allocate( profiles_k(j) % q ( coef % nlevels ) ,stat= alloc_status(3))
- Allocate( profiles_k(j) % o3 ( coef % nlevels ) ,stat= alloc_status(4))
- Allocate( profiles_k(j) % clw( coef % nlevels ) ,stat= alloc_status(5))
- If( any(alloc_status /= 0) ) then
- errorstatus = errorstatus_fatal
- Write( errMessage, '( "mem allocation error")' )
- Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine)
- Return
- End If
- End Do
-
- ! allocate radiance results arrays with number of channels
- Allocate( radiancedata % clear ( nchannels ) ,stat= alloc_status(1))
- Allocate( radiancedata % cloudy ( nchannels ) ,stat= alloc_status(2))
- Allocate( radiancedata % total ( nchannels ) ,stat= alloc_status(3))
- Allocate( radiancedata % bt ( nchannels ) ,stat= alloc_status(4))
- Allocate( radiancedata % bt_clear ( nchannels ) ,stat= alloc_status(5))
- Allocate( radiancedata % out ( nchannels ) ,stat= alloc_status(4))
- Allocate( radiancedata % out_clear( nchannels ) ,stat= alloc_status(5))
- Allocate( radiancedata % upclear ( nchannels ) ,stat= alloc_status(6))
- Allocate( radiancedata % dnclear ( nchannels ) ,stat= alloc_status(18))
- Allocate( radiancedata % reflclear( nchannels ) ,stat= alloc_status(7))
- Allocate( radiancedata % overcast ( coef % nlevels, nchannels ) ,stat= alloc_status(8))
- Allocate( radiancedata % downcld ( coef % nlevels, nchannels ) ,stat= alloc_status(9))
- Allocate( radiancedata % total_out ( nchannels ) ,stat= alloc_status(10))
- Allocate( radiancedata % clear_out ( nchannels ) ,stat= alloc_status(11))
- ! allocate transmission structures
- Allocate( transmission % tau_surf ( nchannels ) ,stat= alloc_status(12))
- Allocate( transmission % tau_layer ( coef % nlevels, nchannels ) ,stat= alloc_status(13))
- Allocate( transmission % od_singlelayer ( coef % nlevels, nchannels ) ,stat= alloc_status(14))
- Allocate( transmission_k % tau_surf ( nchannels ) ,stat= alloc_status(15))
- Allocate( transmission_k % tau_layer ( coef % nlevels, nchannels ) ,stat= alloc_status(16))
- Allocate( transmission_k % od_singlelayer ( coef % nlevels, nchannels ) ,stat= alloc_status(17))
- If( any(alloc_status /= 0) ) then
- errorstatus = errorstatus_fatal
- Write( errMessage, '( "mem allocation error")' )
- Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine)
- Return
- End If
-
-
-
- !
- !...do K.....................
-
-
- ! use stored input emmisisvity
- emissivity(:) = input_emissivity(:)
-
- Do i = 1, nbtout
- profiles_k(i) % ozone_Data = .False. ! no meaning
- profiles_k(i) % co2_Data = .False. ! no meaning
- profiles_k(i) % clw_Data = .False. ! no meaning
- profiles_k(i) % zenangle = -1 ! no meaning
-
- ! increments for atmospheric variables
- profiles_k(i) % p(:) = 0._JPRB ! no AD on pressure levels
- profiles_k(i) % t(:) = 0._JPRB ! temperarure
- profiles_k(i) % o3(:) = 0._JPRB ! O3 ppmv
- profiles_k(i) % clw(:) = 0._JPRB ! clw
- profiles_k(i) % q(:) = 0._JPRB ! WV
-
- ! increments for air surface variables
- profiles_k(i) % s2m % t = 0._JPRB ! temperarure
- profiles_k(i) % s2m % q = 0 ! WV
- profiles_k(i) % s2m % p = 0._JPRB ! pressure
- profiles_k(i) % s2m % u = 0._JPRB ! wind components
- profiles_k(i) % s2m % v = 0._JPRB ! wind components
-
- ! increments for skin variables
- profiles_k(i) % skin % surftype = -1 ! no meaning
- profiles_k(i) % skin % t = 0._JPRB ! on temperarure
- profiles_k(i) % skin % fastem = 0._JPRB
-
- ! increments for cloud variables
- profiles_k(i) % ctp = 0._JPRB ! pressure
- profiles_k(i) % cfraction = 0._JPRB ! cloud fraction
- End Do
-
- emissivity_k(:) = 0._JPRB
- transmission_k % tau_surf(:) = 0._JPRB
- transmission_k % tau_layer(:,:) = 0._JPRB
- transmission_k % od_singlelayer(:,:) = 0._JPRB
-
- switchrad= .true.
- call rttov_k( &
- & rttov_errorstatus, &! out
- & nfrequencies, &! in
- & nchannels, &! in
- & nbtout, &! in
- & nprofiles, &! in
- & channels, &! in
- & polarisations, &! in
- & lprofiles, &! in
- & profiles, &! in
- & coef, &! in
- & addcloud, &! in
- & switchrad, &! in
- & calcemis, &! in
- & emissivity, &! inout direct model
- & profiles_k, &! inout adjoint
- & emissivity_k, &! inout adjoint
- & transmission, &! inout adjoint
- & transmission_k, &! inout adjoint
- & radiancedata) ! inout direct model
- ! (input due to pointers alloc)
-
- If( any( rttov_errorstatus == errorstatus_fatal ) ) then
- Do jp = 1, nprofiles
- If( rttov_errorstatus(jp) == errorstatus_fatal ) then
- Write( errMessage, '( "fatal error in rttov_k")' )
- Call Rttov_ErrorReport (rttov_errorstatus(jp), errMessage, NameOfRoutine)
- End If
- End Do
- Stop
- End If
- If( any( rttov_errorstatus /= errorstatus_success ) ) then
- Write( errMessage, '( "warning in rttov_k")' )
- End If
-
-
- Do ich =1, nbtout
- freq = frequencies(Ich)
- Do j =1,jpnav ! yes clw too!
- !Write(0,*) 'adjoint de la variable atmosphere ',j
- ii = 1
- xktav(ii,j,ich) = profiles_k(ich) % t(ii)
- Do ii=1,nlev
-
- Select Case (j)
- Case (1_jpim)
- xktav(ii,j,ich) = profiles_k(ich) % t(ii)
- !Write(0,*) 'T ',profiles_k(prof) % t(ii)
- Case (2_jpim)
- xktav(ii,j,ich) = profiles_k(ich) % q(ii)
- !Write(0,*) 'Q ',profiles_k(prof) % q(ii)
- Case (3_jpim)
- xktav(ii,j,ich) = profiles_k(ich) % o3(ii)
- Case (4_jpim)
- xktav(ii,j,ich) = profiles_k(ich) % clw(ii)
- End Select
-
- if(lprofiles(freq) == 1) then
- !Write(0,*) 'level xkb, xkt ',ii,xkbav(ii,j,ich),xktav(ii,j,ich)
-
- ixkav(ii,j,ich) = nint(xktav(ii,j,ich) * facpav(ii,j))
- ixkdav(ii,j,ich) = nint((xkbav(ii,j,ich)-xktav(ii,j,ich)) *&
- & facpav(ii,j) * facdiff)
- endif
- End Do
- End Do
-
- !.......now do surface, skin and cloud variables
- Do j =1,sscvar
-
- Select Case (j)
- Case (1_jpim)
- ! t 2m
- xktsav(j,ich) = profiles_k(ich) % s2m % t
- Case (2_jpim)
- ! wv 2m
- xktsav(j,ich) = profiles_k(ich) % s2m % q
- Case (3_jpim)
- ! surface pressure
- xktsav(j,ich) = profiles_k(ich) % s2m % p
- Case (4_jpim)
- ! wind speed u component
- xktsav(j,ich) = profiles_k(ich) % s2m % u
- Case (5_jpim)
- ! wind speed v component
- xktsav(j,ich) = profiles_k(ich) % s2m % v
- Case (6_jpim)
- ! skin temp
- xktsav(j,ich) = profiles_k(ich) % skin % t
- Case (7_jpim)
- ! fastem land coef 1
- xktsav(j,ich) = profiles_k(ich) % skin % fastem(1)
- Case (8_jpim)
- ! fastem land coef 2
- xktsav(j,ich) = profiles_k(ich) % skin % fastem(2)
- Case (9_jpim)
- ! fastem land coef 3
- xktsav(j,ich) = profiles_k(ich) % skin % fastem(3)
- Case (10_jpim)
- ! fastem land coef 4
- xktsav(j,ich) = profiles_k(ich) % skin % fastem(4)
- Case (11_jpim)
- ! fastem land coef 5
- xktsav(j,ich) = profiles_k(ich) % skin % fastem(5)
- Case (12_jpim)
- ! cloud top pressure
- xktsav(j,ich) = profiles_k(ich) % ctp
- Case (13_jpim)
- ! cloud fraction
- xktsav(j,ich) = profiles_k(ich) % cfraction
- End Select
- End Do
-
- if(lprofiles(freq) == 1) then
- ixksav(:,ich) = nint(xktsav(:,ich) * facsav(:))
- ixkdsav(:,ich) = nint((xkbsav(:,ich)-xktsav(:,ich)) *&
- & facsav(:) * facdiff)
- endif
-
- xkaem(ich) = 0.0_JPRB
- Do ipol=1, polarisations(frequencies(ich),3)
- xkaem(ich) = xkaem(ich) + emissivity_k(polarisations(frequencies(ich),1)+ipol-1)
- End Do
-
- ixdem(ich) = nint(( xkaem(ich) - xkbem(ich)) * facem *1000._JPRB)
-
- If( coef % fastem_ver >= 1 .and. calcemis(ich) ) Then
- !if(input_emissivity(ich) < 0.0_JPRB ) then
- ixdem(ich) = 0._JPRB
- endif
-
- end do
-
- ! ... and print it.
- Write (ioout,*)' '
- Write (ioout,*)'TL - K difference*10**10.'
- Write (ioout,*)' '
- Do j = 1 , jpnav
- Write (ioout,'(a30)')title(j)
- Write (ioout,3333)coef%ff_ori_chn(frequencies(1:nchan_out))
- Do i = 1 , nlev
- Write (ioout,333)i,(ixkdav(i,j,jch),jch=1,nchan_out)
- Enddo
- Write (ioout,3333)coef%ff_ori_chn(frequencies(1:nchan_out))
- Write (ioout,*)' '
- Enddo
-
- Write (ioout,*)' surface variables '
- Write (ioout,3333)coef%ff_ori_chn(frequencies(1:nchan_out))
- Write (ioout,*)' '
- Do i = 1 , jpnsav
- Write (ioout,333)i,(ixkdsav(i,jch),jch=1,nchan_out)
- Enddo
- Write (ioout,*)' '
-
- Write (ioout,*)' skin variables '
- Write (ioout,3333)coef%ff_ori_chn(frequencies(1:nchan_out))
- Write (ioout,*)' '
- Do i = jpnsav+1 , jpnsav+jpnssv
- Write (ioout,333)i-jpnsav,(ixkdsav(i,jch),jch=1,nchan_out)
- Enddo
- Write (ioout,*)' '
-
- Write (ioout,*)' cloud variables '
- Write (ioout,3333)coef%ff_ori_chn(frequencies(1:nchan_out))
- Write (ioout,*)' '
- Do i = jpnsav+jpnssv+1 , sscvar
- Write (ioout,333)i-jpnsav-jpnssv,(ixkdsav(i,jch),jch=1,nchan_out)
- Enddo
- Write (ioout,*)' '
-
-
- Write (ioout,*)' surface emissivity '
- Write (ioout,3333)coef%ff_ori_chn(frequencies(1:nchan_out))
- Write (ioout,*)' '
- Do jp = 1, nprofiles
- joff = (jp-1) * nchan_out
- Write (ioout,333)jp,(ixdem(jch+joff),jch=1,nchan_out)
- Enddo
- Write (ioout,*)' '
-
- write(ioout,*)' calculated br. temps in rttovk'
- write(ioout,222) (radiancedata % out (1:nchan_out))
- write(ioout,*)' '
- write(ioout,*)' calculated radiances in rttovk'
- write(ioout,222) (radiancedata % total_out (1:nchan_out))
- write(ioout,*)' '
- write (ioout,*)' '
-
-
- Do j = 1, nbtout
- Deallocate( profiles_k(j) % p ,stat= alloc_status(1))
- Deallocate( profiles_k(j) % t ,stat= alloc_status(2))
- Deallocate( profiles_k(j) % q ,stat= alloc_status(3))
- Deallocate( profiles_k(j) % o3 ,stat= alloc_status(4))
- Deallocate( profiles_k(j) % clw ,stat= alloc_status(5))
- If( any(alloc_status /= 0) ) then
- errorstatus = errorstatus_fatal
- Write( errMessage, '( "mem deallocation error")' )
- Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine)
- Return
- End If
- End Do
-
- ! deallocate radiance results arrays with number of channels
- Deallocate( radiancedata % clear ,stat= alloc_status(1))
- Deallocate( radiancedata % cloudy ,stat= alloc_status(2))
- Deallocate( radiancedata % total ,stat= alloc_status(3))
- Deallocate( radiancedata % bt ,stat= alloc_status(4))
- Deallocate( radiancedata % bt_clear ,stat= alloc_status(5))
- Deallocate( radiancedata % out ,stat= alloc_status(4))
- Deallocate( radiancedata % out_clear ,stat= alloc_status(5))
- Deallocate( radiancedata % upclear ,stat= alloc_status(6))
- Deallocate( radiancedata % dnclear ,stat= alloc_status(18))
- Deallocate( radiancedata % reflclear ,stat= alloc_status(7))
- Deallocate( radiancedata % overcast ,stat= alloc_status(8))
- Deallocate( radiancedata % downcld ,stat= alloc_status(9))
- Deallocate( radiancedata % total_out ,stat= alloc_status(10))
- Deallocate( radiancedata % clear_out ,stat= alloc_status(11))
- ! deallocate transmission structures
- Deallocate( transmission % tau_surf ,stat= alloc_status(12))
- Deallocate( transmission % tau_layer ,stat= alloc_status(13))
- Deallocate( transmission % od_singlelayer,stat= alloc_status(14))
- Deallocate( transmission_k % tau_surf ,stat= alloc_status(15))
- Deallocate( transmission_k % tau_layer ,stat= alloc_status(16))
- Deallocate( transmission_k % od_singlelayer,stat= alloc_status(17))
- If( any(alloc_status /= 0) ) then
- errorstatus = errorstatus_fatal
- Write( errMessage, '( "mem deallocation error")' )
- Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine)
- Return
- End If
-
- Print *, ' K matrix test finished'
- Return
-222 Format(1x,10f8.2)
-333 Format(1x,i3,20i5)
-444 Format(1x,10e8.2)
-3333 Format(4x,20i5)
-4444 Format(1x,10f8.3)
-
-
-End Subroutine tstrad_k
diff --git a/src/LIB/RTTOV/src/tstrad_k.interface b/src/LIB/RTTOV/src/tstrad_k.interface
deleted file mode 100644
index 7de3b8a4d641b498dce7031f80417cca651f6511..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/tstrad_k.interface
+++ /dev/null
@@ -1,49 +0,0 @@
-Interface
-Subroutine tstrad_k( &
- nfrequencies, & ! in
- nchannels, & ! in
- nbtout, & ! in
- nprofiles, & ! in
- channels, & ! in
- polarisations, & ! in
- frequencies, & ! in
- lprofiles, & ! in
- profiles, & ! in
- coef, & ! in
- addcloud, & ! in
- calcemis, & ! in
- input_emissivity) ! in
-
- Use rttov_const, Only : &
- errorstatus_success ,&
- errorstatus_fatal
-
- Use rttov_types, Only : &
- rttov_coef ,&
- profile_Type ,&
- transmission_Type ,&
- radiance_Type
-
- Use mod_tstrad
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
- Integer(Kind=jpim), Intent(in) :: nfrequencies
- Integer(Kind=jpim), Intent(in) :: nchannels
- Integer(Kind=jpim), Intent(in) :: nbtout
- Integer(Kind=jpim), Intent(in) :: nprofiles
- Integer(Kind=jpim), Intent(in) :: channels(nfrequencies)
- Integer(Kind=jpim), Intent(in) :: polarisations(nchannels,3)
- Integer(Kind=jpim), Intent(in) :: frequencies(nbtout)
- Integer(Kind=jpim), Intent(in) :: lprofiles(nfrequencies)
- Logical, Intent(in) :: addcloud
- Type(profile_Type), Intent(in) :: profiles(nprofiles)
- Type(rttov_coef), Intent(in) :: coef
- Logical, Intent(in) :: calcemis(nchannels)
- Real(Kind=jprb), Intent(in) :: input_emissivity(nchannels)
-
-
-
-End Subroutine tstrad_k
-End Interface
diff --git a/src/LIB/RTTOV/src/tstrad_rttov7.F90 b/src/LIB/RTTOV/src/tstrad_rttov7.F90
deleted file mode 100644
index df759b2fa8a31c2360bd782ce7c45a0596381614..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/tstrad_rttov7.F90
+++ /dev/null
@@ -1,508 +0,0 @@
-PROGRAM TSTRAD_RTTOV7
- !
- ! This software was developed within the context of
- ! the EUMETSAT Satellite Application Facility on
- ! Numerical Weather Prediction (NWP SAF), under the
- ! Cooperation Agreement dated 25 November 1998, between
- ! EUMETSAT and the Met Office, UK, by one or more partners
- ! within the NWP SAF. The partners in the NWP SAF are
- ! the Met Office, ECMWF, KNMI and MeteoFrance.
- !
- ! Copyright 2002, EUMETSAT, All Rights Reserved.
- !
- ! *************************************************************
- !
- ! TEST PROGRAM FOR RTTOV SUITE.
- ! RTTOV VERSION 7
- !
- ! Description: This program is the test harness for RTTOV-7. There
- ! are 3 options one to test only the forward model
- ! (option = 0) one to test the full model ie TL/AD/K
- ! (option=1) and one to test the cloudy radiance
- ! output (option=2)
- !
- !
- ! To run this program you must have the following files
- ! either resident in the same directory or set up as a
- ! symbolic link:
- ! refprof.dat -- reference profile
- ! prof.dat -- input profile
- ! input.dat -- file to select channels and surface emis
- ! rtcoef_platform_id_sensor.dat -- coefficient file
- ! (depends on which sensor)
- ! There are unix scripts available to set up the files above and
- ! run this program (e.g. tstrad_all.scr)
- !
- ! Current Code Owner: SAF NWP
- !
- ! History:
- ! Version Date Comment
- ! ------- ---- -------
- ! 25/01/2002 Initial version (R. Saunders)
- ! 01/05/2002 Updated for NOAA-17 (R. Saunders)
- ! 29/03/2005 Add end of header (J. Cameron)
- ! 29/03/2005 Add implicit none (J. Cameron)
- !
- ! Code Description:
- ! Language: Fortran 90.
- ! Software Standards: "European Standards for Writing and
- ! Documenting Exchangeable Fortran 90 Code".
- !
- Use parkind1, Only : jpim ,jprb
-
- USE MOD_CPARAM, ONLY : &
- ! Imported Paramters:
- jpnsat ,& ! Total max sats to be used
- jplev ,& ! No. of pressure levels
- jpnav ,& ! No. of profile variables
- jpnsav ,& ! No. of surface air variables
- jpnssv ,& ! No. of skin variables
- jpncv ,& ! No. of cloud variables
- jppf ,& ! Max no. profiles
- jpch ,& ! Max. no. of tovs channels
- jpchus ,& ! Max. no. of channels used tovs
- jpchpf ,& ! Max no. of profs * chans used
- rcnv ! kg/kg--> ppmv
-
- IMPLICIT NONE
-
-#include "rttvi.interface"
-#include "rttov.interface"
-
- REAL(Kind=jprb):: PPRES(JPLEV),PAV(JPLEV,JPNAV,JPPF),PSAV(JPNSAV,JPPF)
- REAL(Kind=jprb):: PSSV(JPNSSV,JPPF),PCV(JPNCV,JPPF)
- REAL(Kind=jprb):: PEMIS(JPCHPF),PEMIN(JPCHPF)
- REAL(Kind=jprb):: PANGL(JPPF),PANGS(JPPF)
- REAL(Kind=jprb):: PRAD(JPCHPF),PTB(JPCHPF)
- INTEGER(Kind=jpim):: KSURF(JPPF),JERR(JPPF,JPNSAT),JERRTL(JPPF,JPNSAT)
- INTEGER(Kind=jpim):: KCHAN(JPCHPF),KPROF(JPCHPF)
- REAL(Kind=jprb):: UP(JPLEV),UTMX(JPLEV),UTMN(JPLEV),UQMX(JPLEV)
- REAL(Kind=jprb):: UQMN(JPLEV),UOMX(JPLEV),UOMN(JPLEV)
- !
- integer(Kind=jpim), parameter :: max_platform=13 ! max platform number
- integer(Kind=jpim), parameter :: max_instrument=26 ! max instrument number
- integer(Kind=jpim), dimension(jpnsat) :: platform ! platform id
- integer(Kind=jpim), dimension(jpnsat) :: satellite ! satellite id
- integer(Kind=jpim), dimension(jpnsat) :: instrument ! instrument id
- integer(Kind=jpim), dimension(jpnsat) :: numchans ! No. of chans required for insrtrument
- integer(Kind=jpim), dimension(jpnsat) :: fileunit ! Fileunit for coeffs. for insrtrument
- ! min and max satellite id for each platform
- integer(Kind=jpim), dimension(max_platform) :: max_satid
- integer(Kind=jpim), dimension(max_platform) :: min_satid
-
- ! min and max channel numbers for each instrument
- integer(Kind=jpim), dimension(0:max_instrument) :: max_channel
-
- INTEGER(Kind=jpim) :: IOOUT, NRTTOVID, NO_ID, IFULL, NPROF, NSURF
- INTEGER(Kind=jpim) :: IUE, NCH, ICH, I, II, IERR
- INTEGER(Kind=jpim) :: KPNSAT, KPLEV, KPCH, KPCHUS, KPNAV, KPNSAV, KPNSSV
- INTEGER(Kind=jpim) :: KPNCV, ICH1, KSAT, KNPF, KNCHPF, KNCHAN, KLENPF, KNAV
- INTEGER(Kind=jpim) :: KNSAV, KNSSV, KNCV, J, JCH, IREF, ILEV, IL, IUA
- INTEGER(Kind=jpim) :: JJM, IRA, JJ, JP, JL, NLEV, JOFF, NPRINT, JN, NP, KPPF
- REAL(Kind=jprb) :: D, AZANG, ZENANG
-
- data min_satid / 1, 8, 5, 8, 5, 2, 1, 1, 1, 1, 1, 1, 3/
- data max_satid /17,16, 7,12, 5, 2, 1, 2, 3, 1, 1, 1, 4/
- data max_channel / 20, 4, 3, 15, 5, 3, 7, 8, 8, 9, 24,&
- & 2378, 4, 16, 3, 5, 8461,14, 0, 0, 2, 8, 4, 18, 3, 2, 3/
-
- REAL(Kind=jprb) :: SURFEM(JPCH)
- INTEGER(Kind=jpim) :: ICHAN(jpnsat,JPCH) ! Max of six series so far
- INTEGER(Kind=jpim) :: NCHAN(jpnsat)
- INTEGER(Kind=jpim) :: IVCH(JPCH,JPNSAT)
- LOGICAL :: LCLOUD
- !
- REAL(Kind=jprb), ALLOCATABLE :: RADOV(:,:),RADO(:)
- REAL(Kind=jprb), ALLOCATABLE :: TAU(:,:),TAUSFC(:)
- !
- DATA NLEV/JPLEV/
- !
- DATA IUA/1/,IOOUT/2/,IREF/55/,IUE/56/
-
- !- End of header --------------------------------------------------------
-
- ! Beginning of Routine.
- ! ---------------------
- PAV(:,:,:) = 0.
- PSAV(:,:) = 0.
- PSSV(:,:) = 0.
- PCV(:,:) = 0.
- PEMIS(:) = 0.
- PEMIN(:) = 0.
- numchans(:) = 0
- Fileunit(:) = 0
- IVCH(:,:) = 0
-
- OPEN(IOOUT,file='print.dat',status='unknown',form='formatted')
-
- ! For more than one satellite
- ! comment out the next line and uncomment the following two.
-
- NRTTOVID = 1
-
- ! PRINT *, 'How many satellites do you want?'
- ! READ *, NRTTOVID
-
- DO NO_ID = 1, NRTTOVID
-
- PRINT *, 'Which satellite platform do you want?'
- PRINT *, 'NOAA=1 DMSP=2 METEOSAT=3 GOES=4: '
- PRINT *, 'GMS=5 FY-2=6 TRMM=7 ERS=8: '
- PRINT *, 'EOS=9 METOP=10 ENVISAT=11 MSG=12 FY-1=13: '
- READ *, Platform(no_id)
- IF ( Platform(no_id) <= 0 .OR. &
- & Platform(no_id) > max_platform) STOP 'Platform number not allowed'
-
- PRINT *, 'Which satellite id do you want for this platform?'
- PRINT *, 'Noaaxx = xx GOESyy = yy'
- READ *, satellite(no_id)
-
- if( satellite(no_id) < min_satid(Platform(no_id)) .or. &
- & satellite(no_id) > max_satid(Platform(no_id)) ) &
- & STOP 'Satellite id not allowed'
-
- PRINT *, 'Which instrument type do you want for this satellite?'
- print *, 'HIRS=0, MSU=1, SSU=2, AMSU-A=3, AMSU-B=4, AVHRR=5'
- print *, 'SSMI=6, VTPR1=7, VTPR2=8, TMI=9, SSMIS=10, AIRS=11'
- print *, 'HSB=12, MODIS=13,ATSR=14, MHS=15, IASI=16, MVIRI=20'
- print *, 'SEVIRI=21, GOES-imager=22 GOES-sounder=23 '
- print *, 'GMS imager=24 FY2-VISSR=25 FY1-mvisr=26'
-
- READ *, instrument(no_id)
- IF ( instrument(no_id) < 0 .OR. &
- & instrument(no_id) > max_instrument)&
- & STOP 'instrument number not allowed'
-
- PRINT *, ' Forward model only (0) or full gradient test (1)',&
- & ' or full radiance output (2)?'
- READ *, IFULL
- IF(IFULL.EQ.2)THEN
- LCLOUD =.TRUE.
- ELSE
- LCLOUD =.FALSE.
- ENDIF
- PRINT *, ' Number of profiles to test code? '
- READ *, NPROF
- NPROF = MIN(JPPF, NPROF)
- PRINT *, ' Surface type (0=land, 1=sea, 2=ice/snow)? '
- READ *, NSURF
- !
- !..SET UP CHANNEL NUMBERS
- !
- ! .. DEFAULT MAXIMUMS
- nchan(no_id) = max_channel(instrument(no_id))
- !
- OPEN (IUE,FILE='input.dat',status='old')
- READ(IUE,*)
- NCH = 0
- DO ICH = 1 , nchan(no_id)
- READ(IUE,*,END=909)I,II,SURFEM(ICH)
- IF(II.GT.0)THEN
- NCH = NCH + 1
- ICHAN(no_id,NCH) = I
-! IVCH(NCH,no_id) = ICH ! Normally comment out use to test AIRS
- ENDIF ! channel selection option
- ENDDO
- !
- CLOSE(IUE)
- nchan(no_id) = MIN(max_channel(instrument(no_id)),NCH)
- write(6,*)' Number of channels selected = ',nchan(no_id)
- !
-
- END DO
-
- CALL RTTVI(IERR,KPPF,KPNSAT,KPLEV,KPCH,KPCHUS,KPNAV,KPNSAV,&
- & KPNSSV,KPNCV,&
- & NRTTOVID, platform, satellite, instrument, numchans, &
- & UP,UTMN,UTMX,UQMN,UQMX,UOMN,&
- & UOMX,IVCH,FileUnit)
- !
-
- IF (IERR.NE.0 ) THEN
- WRITE (IOOUT,*) 'RTTVI: IERR =',IERR
- STOP
- ENDIF
- IF ( KPNSAT.NE.JPNSAT .OR.&
- & KPLEV.NE.JPLEV .OR. KPCH.NE.JPCH .OR. KPCHUS.NE.JPCHUS .OR.&
- & KPNAV.NE.JPNAV .OR. KPNSAV.NE.JPNSAV .OR. KPNSSV.NE.JPNSSV&
- & .OR. KPNCV.NE.JPNCV ) THEN
- WRITE (IOOUT,*) 'Mismatch in cparam.h and tstrad parameters'
- STOP
- ENDIF
- !
- ! Check Channel numbers are correct
- !
- DO ICH = 1 , nchan(1)
- DO ICH1 = 1 , JPCH
- IF (ICHAN(1,ICH) .EQ. IVCH(ICH1,1))GO TO 202
- IF (ICH1 .EQ. JPCH)THEN
- PRINT *,' BAD CHANNEL NUMBER REQUESTED'
- PRINT *,' EDIT input.dat'
- STOP
- ENDIF
- ENDDO
-202 ENDDO
- !
- !
- DO no_id = 1, NRTTOVID
-
- ! Convert from position in required list to KSAT pointer used
- ! in rttov coefficient arrays - for only one satellite KSAT = 1
- ! This reflects the order in which coefficients are loaded in RTTVI
-
- KSAT = no_id
-
- KNPF=NPROF
- KNCHPF=0
- KNCHAN=NCHAN(no_id)
- KLENPF=JPLEV
- KNAV = 3
- KNSAV = JPNSAV
- KNSSV = JPNSSV
- KNCV = JPNCV
-
- WRITE(6,*)'Zenith angle (degrees)?'
- READ(5,*)ZENANG
- WRITE(6,*)'Azimuth angle (degrees)?'
- READ(5,*)AZANG
-
- DO J=1,NPROF
- PANGS(J)=0.
- KSURF(J)=NSURF
- PANGL(J) = ZENANG
- DO JCH=1,NCHAN(no_id)
- KNCHPF=KNCHPF+1
- KCHAN(KNCHPF)=ICHAN(no_id,JCH)
- KPROF(KNCHPF)=J
- PEMIS(KNCHPF)=SURFEM(KCHAN(KNCHPF))
- PEMIN(KNCHPF)=SURFEM(KCHAN(KNCHPF))
- end do
- end do
- !
- OPEN(unit=iref,file='refprof.dat',status='old')
- !
- ! Get 43 level pressures
- !
- READ(IREF,*)
- READ(IREF,*)
- DO ILEV = 1 , jplev
- READ(IREF,*)IL,PPRES(ILEV),D,D,D,D
- end do
- CLOSE(IREF)
- !
- OPEN (IUA,FILE='prof.dat',status='old')
- !
- JJM = 0
- DO IRA = 1 , 1+(JPLEV-1)/10
- JJ = 1+JJM
- JJM = MIN(JJ+9,JPLEV)
- READ(IUA,*)(PAV(J,1,1),J=JJ,JJM)
- end do
- JJM = 0
- DO IRA = 1 , 1+(JPLEV-1)/10
- JJ = 1+JJM
- JJM = MIN(JJ+9,JPLEV)
- READ(IUA,*)(PAV(J,2,1),J=JJ,JJM)
- end do
- JJM = 0
- DO IRA = 1 , 1+(JPLEV-1)/10
- JJ = 1+JJM
- JJM = MIN(JJ+9,JPLEV)
- READ(IUA,*)(PAV(J,3,1),J=JJ,JJM)
- end do
- JJM = 0
- DO IRA = 1 , 1+(JPLEV-1)/10
- JJ = 1+JJM
- JJM = MIN(JJ+9,JPLEV)
- READ(IUA,*)(PAV(J,4,1),J=JJ,JJM)
- end do
- READ(IUA,*)(PSAV(JJ,1),JJ=1,JPNSAV)
- READ(IUA,*)(PSSV(JJ,1),JJ=1,JPNSSV)
- READ(IUA,*)(PCV(JJ,1),JJ=1,JPNCV)
- !
- CLOSE(IUA)
- !
- WRITE(IOOUT,*)' INPUT PROFILE'
- WRITE(IOOUT,444)(PAV(JJ,1,1),JJ=1,JPLEV)
- WRITE(IOOUT,444)(PAV(JJ,2,1),JJ=1,JPLEV)
- WRITE(IOOUT,444)(PAV(JJ,3,1),JJ=1,JPLEV)
- WRITE(IOOUT,444)(PAV(JJ,4,1),JJ=1,JPLEV)
- WRITE(IOOUT,444)(PSAV(JJ,1),JJ=1,JPNSAV)
- WRITE(IOOUT,444)(PSSV(JJ,1),JJ=1,JPNSSV)
- WRITE(IOOUT,444)(PCV(JJ,1),JJ=1,JPNCV)
- WRITE(IOOUT,*)' '
- !
- ! Convert lnq to q in kg/kg for profile
- !
- DO J = 1 , JPLEV
- PAV(J,2,1) = EXP(PAV(J,2,1))/1000.
- ENDDO
- PSAV(2,1) = EXP(PSAV(2,1))/1000.
- ! convert from ppmv to kg/kg
- DO J = 1 , JPLEV
- PAV(J,3,1) = PAV(J,3,1)/RCNV
- ENDDO
- !
- !.. Fill profile arrays with the 1 profile NPROF times
- DO JP = 1 , NPROF
- ! IF(PSSV(1,1).LT.271.5)KSURF(JP)=2
- DO JL = 1 , NLEV
- PAV(JL,1,JP) = PAV(JL,1,1)
- PAV(JL,2,JP) = PAV(JL,2,1)
- PAV(JL,3,JP) = PAV(JL,3,1)
- PAV(JL,4,JP) = PAV(JL,4,1)
- end do
- PSAV(1,JP) = PSAV(1,1)
- PSAV(2,JP) = PSAV(2,1)
- PSAV(3,JP) = PSAV(3,1)
- PSAV(4,JP) = PSAV(4,1)
- PSAV(5,JP) = PSAV(5,1)
- PSSV(1,JP) = PSSV(1,1)
- PSSV(2,JP) = PSSV(2,1)
- PSSV(3,JP) = PSSV(3,1)
- PSSV(4,JP) = PSSV(4,1)
- PSSV(5,JP) = PSSV(5,1)
- PSSV(6,JP) = PSSV(6,1)
- PCV(1,JP) = PCV(1,1)
- PCV(2,JP) = PCV(2,1)
- end do
-
- !
- WRITE(IOOUT,*)' NUMBER OF PROFILES PROCESSED=',NPROF
- WRITE(IOOUT,*)' '
- !
- WRITE(IOOUT,*)'CHANNELS PROCESSED:'
- WRITE(IOOUT,111) (ICHAN(no_id,J), J = 1,NCHAN(no_id))
- WRITE (IOOUT,*)' '
- WRITE(IOOUT,*)'INPUT SURFACE EMISSIVITIES '&
- & ,'SAT =', satellite(no_id)
- JOFF=0
- WRITE(IOOUT,444) (PEMIS(J+JOFF),J=1,NCHAN(no_id))
- WRITE(IOOUT,*)' '
- !
- ALLOCATE(TAU(KNCHPF,JPLEV))
- ALLOCATE(TAUSFC(KNCHPF))
- ALLOCATE(RADOV(KNCHPF,2*JPLEV+2))
- ALLOCATE(RADO(KNCHPF))
- !
- ! PERFORM RADIATIVE TRANSFER CALCULATIONS
- CALL RTTOV(KNPF,KLENPF,PPRES,PANGL, &
- & PANGS,KSURF,KSAT,KNCHPF,KCHAN,KPROF,&
- & PAV,PSAV,PSSV,PCV,PEMIS,JERR,PRAD,PTB,RADOV,RADO,TAU,&
- & TAUSFC,LCLOUD)
- !
- ! OUTPUT RESULTS
- !
- NPRINT = 1+ INT((NCHAN(no_id)-1)/10)
- DO JN=1,NPROF
- WRITE(IOOUT,*)' -----------------'
- WRITE(IOOUT,*)' Profile number ',JN, 'Instrument ',&
- & instrument(no_id)
- WRITE(IOOUT,*)' -----------------'
- IF(JERR(JN,1).NE.0)WRITE(IOOUT,*)' RTTOV ERROR CODE=',JERR(JN,1)
- IF(JERR(JN,1).GE.20)STOP
- WRITE(IOOUT,*)' '
- JOFF=NCHAN(no_id)*(JN-1)
- WRITE(IOOUT,777)satellite(no_id),PANGL(JN),AZANG,KSURF(1)
- WRITE(IOOUT,222) (PTB(J+JOFF),J=1,NCHAN(no_id))
- WRITE(IOOUT,*)' '
- WRITE(IOOUT,*)'CALCULATED RADIANCES: SAT =', satellite(no_id)
- WRITE(IOOUT,222) (PRAD(J+JOFF),J=1,NCHAN(no_id))
- WRITE(IOOUT,*)' '
- WRITE(IOOUT,*)'CALCULATED OVERCAST RADIANCES: SAT =', satellite(no_id)
- WRITE(IOOUT,222) (RADO(J+JOFF),J=1,NCHAN(no_id))
- WRITE (IOOUT,*)' '
- WRITE(IOOUT,*)'CALCULATED SURFACE TO SPACE TRANSMITTANCE: S'&
- & ,'AT =',satellite(no_id)
- WRITE(IOOUT,4444) (TAUSFC(J+JOFF),J=1,NCHAN(no_id))
- WRITE (IOOUT,*)' '
- WRITE(IOOUT,*)'CALCULATED SURFACE EMISSIVITIES '&
- & ,'SAT =',satellite(no_id)
- WRITE(IOOUT,444) (PEMIS(J+JOFF),J=1,NCHAN(no_id))
- !
- ! Print clear-sky radiance without reflection term and
- ! reflected clear-sky downwelling radiance
- !
- IF(IFULL.EQ.2 .AND. nchan(no_id) .LE. 20 )THEN
- WRITE (IOOUT,*)' '
- WRITE(IOOUT,*)'CALCULATED Clear-sky radiance without reflection term'&
- & ,' SAT =',satellite(no_id)
- WRITE(IOOUT,444)(RADOV(J+JOFF,JPLEV*2+1),J=1,NCHAN(no_id))
- WRITE (IOOUT,*)' '
- WRITE (IOOUT,*)'CALCULATED Reflected clear-sky downwelling radiance'&
- & ,' SAT =',satellite(no_id)
- WRITE(IOOUT,444)(RADOV(J+JOFF,JPLEV*2+2),J=1,NCHAN(no_id))
- WRITE (IOOUT,*)'CHANNELS '
- WRITE(IOOUT,111) (ICHAN(no_id,J), J = 1,NCHAN(no_id))
- ENDIF
-!
- IF(JN.EQ.1 .AND. nchan(no_id) .LE. 20)THEN
- DO NP = 1 , NPRINT
- WRITE (IOOUT,*)' '
- WRITE (IOOUT,*)'Level to space transmittances for channels'
- WRITE(IOOUT,1115)(ICHAN(no_id,J),&
- & J = 1+(NP-1)*10,MIN(10+(NP-1)*10,NCHAN(no_id)))
- DO ILEV = 1 , JPLEV
- WRITE(IOOUT,4445)ILEV,(TAU(J+JOFF,ILEV),&
- & J = 1+(NP-1)*10,MIN(10+(NP-1)*10,NCHAN(no_id)))
- end do
- WRITE(IOOUT,1115)(ICHAN(no_id,J),&
- & J = 1+(NP-1)*10,MIN(10+(NP-1)*10,NCHAN(no_id)))
- end do
- ENDIF
- !
- ! Print radiance upwelling arrays
- IF(JN.EQ.1.AND.IFULL.EQ.2 .AND. nchan(no_id) .LE. 20)THEN
- DO NP = 1 , NPRINT
- WRITE (IOOUT,*)' '
- WRITE (IOOUT,*)'Level to space upwelling radiances for channels'
- WRITE(IOOUT,1115)(ICHAN(no_id,J),&
- & J = 1+(NP-1)*10,MIN(10+(NP-1)*10,NCHAN(no_id)))
- DO ILEV = 1 , JPLEV
- WRITE(IOOUT,4446)ILEV,(RADOV(J+JOFF,ILEV),&
- & J = 1+(NP-1)*10,MIN(10+(NP-1)*10,NCHAN(no_id)))
- end do
- WRITE(IOOUT,1115)(ICHAN(no_id,J),&
- & J = 1+(NP-1)*10,MIN(10+(NP-1)*10,NCHAN(no_id)))
- end do
- ENDIF
- ! Print radiance downwelling arrays
- IF(JN.EQ.1.AND.IFULL.EQ.2 .AND. nchan(no_id) .LE. 20)THEN
- DO NP = 1 , NPRINT
- WRITE (IOOUT,*)' '
- WRITE (IOOUT,*)'Level to space downwelling radiances for channels'
- WRITE(IOOUT,1115)(ICHAN(no_id,J),&
- & J = 1+(NP-1)*10,MIN(10+(NP-1)*10,NCHAN(no_id)))
- DO ILEV = 1 , JPLEV
- WRITE(IOOUT,4446)ILEV,(RADOV(J+JOFF,ILEV+JPLEV),&
- & J = 1+(NP-1)*10,MIN(10+(NP-1)*10,NCHAN(no_id)))
- end do
- WRITE(IOOUT,1115)(ICHAN(no_id,J),&
- & J = 1+(NP-1)*10,MIN(10+(NP-1)*10,NCHAN(no_id)))
- end do
- ENDIF
- end do
- PRINT *,' FORWARD MODEL FINISHED'
- !
- ENDDO
-
-
- !
-111 FORMAT(1X,10I8)
-1115 FORMAT(3X,10I8)
-2222 FORMAT(1X,10(1x,F8.6))
-222 FORMAT(1X,10F8.2)
-333 FORMAT(1X,I3,20I5)
-3333 FORMAT(1X,I3,2I5)
-444 FORMAT(1X,10F8.3)
-4444 FORMAT(1X,10F8.4)
-4445 FORMAT(1X,I2,10F8.4)
-4446 FORMAT(1X,I2,10F8.3)
-555 FORMAT(1X,10E8.2)
-777 FORMAT(1X,'CALCULATED BRIGHTNESS TEMPERATURES: SAT =',I2,&
- &' ZENITH ANGLE=',F6.2, &
- &' AZIMUTH ANGLE=',F7.2,' SURFACE TYPE=',I2)
- STOP
-909 PRINT *,' TOO FEW CHANNELS IN INPUT FILE '
- STOP
-END PROGRAM TSTRAD_RTTOV7
diff --git a/src/LIB/RTTOV/src/tstrad_sx6.F90 b/src/LIB/RTTOV/src/tstrad_sx6.F90
deleted file mode 100644
index 05c47592c536f578f9b22e98f29368330e3f1d20..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/tstrad_sx6.F90
+++ /dev/null
@@ -1,962 +0,0 @@
-PROGRAM TSTRAD_SX6
- !
- ! This software was developed within the context of
- ! the EUMETSAT Satellite Application Facility on
- ! Numerical Weather Prediction (NWP SAF), under the
- ! Cooperation Agreement dated 25 November 1998, between
- ! EUMETSAT and the Met Office, UK, by one or more partners
- ! within the NWP SAF. The partners in the NWP SAF are
- ! the Met Office, ECMWF, KNMI and MeteoFrance.
- !
- ! Copyright 2002, EUMETSAT, All Rights Reserved.
- !
- ! *************************************************************
- !
- ! TEST PROGRAM FOR RTTOV SUITE.
- ! RTTOV VERSION 8 TEST FOR SX6
- !
- ! Description: This program is the test harness for RTTOV-8. There
- ! are 3 options:
- ! option = 0 to test forward model only
- ! option = 1 to test the full model ie TL/AD/K
- ! option = 2 to test the cloudy radiance output
- !
- ! To run this program you must have the following files
- ! either resident in the same directory or set up as a
- ! symbolic link:
- ! refprof.dat -- reference profile
- ! prof.dat -- input profile
- ! input.dat -- file to select channels and surface emis
- ! rtcoef_platform_id_sensor.dat -- coefficient file to match
- ! the sensor you request in the input dialogue
- ! There are unix scripts available to set up the files above and
- ! run this program (e.g. tstrad_full.scr)
- ! The output is generated in a file called print.dat.
- ! This output can be compared with reference output generated
- ! by the code developers and included with the export package.
- !
- ! Current Code Owner: SAF NWP
- !
- ! History:
- ! Version Date Comment
- ! ------- ---- -------
- ! 25/01/2002 Initial version (R. Saunders)
- ! 01/05/2002 Updated for NOAA-17 (R. Saunders)
- ! 01/12/2002 New F90 code with structures (P Brunel A Smith)
- ! 02/01/2003 Comments added (R Saunders)
- ! 10/12/2003 Updated for polarimetric changes (S. English/R.Saunders)
- ! 01/04/2004 Updated for chan setup routines (R.Saunders)
- !
- ! Code Description:
- ! Language: Fortran 90.
- ! Software Standards: "European Standards for Writing and
- ! Documenting Exchangeable Fortran 90 Code".
- !
- Use rttov_const, only : &
- nplatforms ,&
- ninst ,&
- pi ,&
- errorstatus_fatal ,&
- errorstatus_warning ,&
- errorstatus_success ,&
- platform_name ,&
- sensor_id_mw ,&
- inst_name, &
- npolar_return, &
- npolar_compute
-
-
- Use rttov_types, only : &
- rttov_coef ,&
- profile_type ,&
- transmission_Type ,&
- radiance_type
-
- Use mod_tstrad
- !
- Use parkind1, Only : jpim ,jprb
- Implicit None
- !
-#include "rttov_errorreport.interface"
-#include "rttov_setup.interface"
-#include "rttov_setupchan.interface"
-#include "rttov_setupindex.interface"
-#include "rttov_errorhandling.interface"
-#include "rttov_direct.interface"
-!!#include "rttov_readcoeffs.interface"
-!!#include "rttov_initcoeffs.interface"
-#include "rttov_dealloc_coef.interface"
-#include "tstrad_tl.interface"
-#include "tstrad_ad.interface"
-#include "tstrad_k.interface"
- !
- ! Parameter for WV conversion used in all tstrad suite
- Real(Kind=jprb), Parameter :: q_mixratio_to_ppmv = 1.60771704e+6_JPRB
- !
- type( rttov_coef ), allocatable :: coef(:) ! coefficients
- type(profile_type), allocatable :: profiles(:)
- type(transmission_type) :: transmission
- type(radiance_type) :: radiance
- !
- Integer(Kind=jpim), Allocatable :: instrument(:,:) ! instrument id
- Integer(Kind=jpim), Allocatable :: nchan(:,:) ! number of channels per instrument and profile
- Integer(Kind=jpim), Allocatable :: ifull(:) ! full test (with TL,AD,K) per instrument
- Integer(Kind=jpim), Allocatable :: nprof(:) ! number of profiles per instrument
- Integer(Kind=jpim), Allocatable :: nsurf(:) ! surface id number per instrument
- Real(Kind=jprb), Allocatable :: surfem(:,:) ! surface input emissivity per channel , instrument
- Integer(Kind=jpim), Allocatable :: ichan(:,:) ! channel list per instrument
- Real(Kind=jprb), Allocatable :: surfem1(:) ! surface input emissivity per channel for all profiles
- Integer(Kind=jpim), Allocatable :: ichan1(:) ! channel list per instrument
-
- integer(Kind=jpim) :: nbtout
- integer(Kind=jpim) :: nfrequencies
- Integer(Kind=jpim) :: nchannels
- integer(Kind=jpim), Allocatable :: polarisations (:,:)
- integer(Kind=jpim), Allocatable :: frequencies (:)
- Integer(Kind=jpim), Allocatable :: channels (:)
- Integer(Kind=jpim), Allocatable :: lprofiles (:)
- Real(Kind=jprb), Allocatable :: emissivity (:)
- Real(Kind=jprb), Allocatable :: input_emissivity (:)
- logical, Allocatable :: calcemis (:)
-
- Integer(Kind=jpim) :: coef_errorstatus ! read coeffs error return code
- Integer(Kind=jpim), Allocatable :: rttov_errorstatus(:) ! rttov error return code
- Integer(Kind=jpim), Allocatable :: setup_errorstatus(:) ! setup return code
-
- ! min and max satellite id for each platform
- Integer(Kind=jpim), dimension(nplatforms) :: max_satid
- Integer(Kind=jpim), dimension(nplatforms) :: min_satid
-
- ! min and max channel numbers for each instrument
-
- integer(Kind=jpim), dimension(0:ninst-1) :: max_channel_old
- integer(Kind=jpim), dimension(0:ninst-1) :: max_channel_new
- integer(Kind=jpim), dimension(0:ninst-1) :: max_channel
- integer(Kind=jpim), parameter :: mxchn = 6000 ! max number of channels per instruments allowed in one run
-
- ! polarisations to be computed and returned
- integer(Kind=jpim), Allocatable :: indexout(:)
-
- ! printing arrays
- real(Kind=jprb), Allocatable :: pr_radcld(:)
- real(Kind=jprb), Allocatable :: pr_trans(:)
- real(Kind=jprb), Allocatable :: pr_emis(:)
- real(Kind=jprb), Allocatable :: pr_trans_lev(:,:)
- real(Kind=jprb), Allocatable :: pr_upclr(:)
- real(Kind=jprb), Allocatable :: pr_dncld(:,:)
- real(Kind=jprb), Allocatable :: pr_refclr(:)
- real(Kind=jprb), Allocatable :: pr_ovcst(:,:)
- integer(Kind=jpim), dimension(1:mxchn) :: pr_pol
-
- data min_satid / 1, 8, 1, 8, 5, 2, 1, 1, 1, 1, 1, 1, 3, 2, 1, 1, 1, 1, 0, 0 /
- data max_satid /17,16, 7,12, 5, 2, 1, 2, 3, 1, 1, 1, 4, 2, 1, 1, 1, 1, 0, 0/
- data max_channel_old / 20, 4, 3, 15, 5, 3, 7, 8, 8, 9,&
- & 24, 2378, 4, 16, 3, 5, 8461,14, 4,22,&
- & 2, 8, 4, 18, 3, 2, 3,1000, 40, 22, &
- & 5, 3000, 0, 0, 0/
- data max_channel_new / 20, 4, 3, 15, 5, 3, 4, 8, 8, 9,&
- & 24, 2378, 4, 16, 3, 5, 8461,14, 4,22,&
- & 2, 8, 4, 18, 3, 2, 3,1000, 40, 22, &
- & 5, 3000, 0, 0, 0/
-
- Character (len=80) :: errMessage
- Character (len=6) :: NameOfRoutine = 'tstrad'
- Character (len=3) :: coeff_version = 'old'
- !
- Integer(Kind=jpim) :: Err_Unit ! Logical error unit (<0 for default)
- Integer(Kind=jpim) :: verbosity_level ! (<0 for default)
-
- Integer(Kind=jpim) :: nrttovid ! maximum number of instruments
- Integer(Kind=jpim) :: no_id ! instrument loop index
- Integer(Kind=jpim) :: nlevels
- Integer(Kind=jpim) :: ios
- integer(Kind=jpim) :: i,pol_id,ich2
- integer(Kind=jpim) :: ichannels, ibtout
- Integer(Kind=jpim) :: j
- Integer(Kind=jpim) :: jjm, ira, jj
- integer(Kind=jpim) :: jch, jpol
- integer(Kind=jpim) :: jn, joff1, joff2, joff3
- Integer(Kind=jpim) :: nprint
- Integer(Kind=jpim) :: np, ilev
- Integer(Kind=jpim) :: n
- Integer(Kind=jpim) :: nch ! intermediate variable
- Integer(Kind=jpim) :: ich ! intermediate variable
- Integer(Kind=jpim) :: ii ! intermediate variable
- Integer(Kind=jpim) :: errorstatus
- Real(Kind=jprb) :: s
- Real(Kind=jprb) :: zenang
- Real(Kind=jprb) :: azang
- logical :: lcloud
-
- Integer(Kind=jpim) :: iua
- Integer(Kind=jpim) :: ioout
- Integer(Kind=jpim) :: iue
-
- ! Unit numbers for input/output
- DATA IUA/1/,IOOUT/2/,IUE/56/
-
- Integer(Kind=jpim) :: alloc_status(40)
-
-
- !- End of header --------------------------------------------------------
-
-
- errorstatus = 0
- alloc_status(:) = 0
-
- !Initialise error management with default value for
- ! the error unit number and
- ! Fatal error message output
- Err_unit = -1
- verbosity_level = 1
- ! All error message output
- verbosity_level = 3
- call rttov_errorhandling(Err_unit, verbosity_level)
-
- ! Beginning of Routine.
- ! ---------------------
-
- OPEN(IOOUT,file='print.dat',status='unknown',form='formatted')
-
- ! For more than one satellite
- ! comment out the next line and uncomment the following two.
-
- NRTTOVID = 1
-
- ! PRINT *, 'How many satellites do you want?'
- ! READ *, NRTTOVID
-
- allocate (coef(nrttovid),stat= alloc_status(1))
-
- allocate (instrument(3,nrttovid),stat= alloc_status(2))
- allocate (ifull(nrttovid),stat= alloc_status(4))
- allocate (nprof(nrttovid),stat= alloc_status(5))
- allocate (nsurf(nrttovid),stat= alloc_status(6))
-
- !maximum number of channels allowed for one instrument is mxchn
- allocate (surfem(mxchn,nrttovid),stat= alloc_status(7))
- allocate (ichan (mxchn,nrttovid),stat= alloc_status(8))
- If( any(alloc_status /= 0) ) then
- errorstatus = errorstatus_fatal
- Write( errMessage, '( "mem allocation error")' )
- Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine)
- Stop
- End If
-
- surfem(:,:) = 0.0_JPRB
- ichan(:,:) = 0
-
- DO NO_ID = 1, NRTTOVID
-
- write(*,*) 'Which satellite platform do you want?'
- WRITE(*,'(4(2x,i3,2x,a8))') (i,platform_name(i), i = 1, nplatforms)
- READ *, Instrument(1,no_id)
- IF ( Instrument(1,no_id) <= 0 .OR. &
- & Instrument(1,no_id) > nplatforms) STOP 'Platform number not allowed'
-
- WRITE(*,*) 'Which satellite id do you want for this platform?'
- WRITE(*,*) 'Noaaxx = xx GOESyy = yy'
- READ *, instrument(2,no_id)
-
- if( instrument(2,no_id) < min_satid(Instrument(1,no_id)) .or. &
- & instrument(2,no_id) > max_satid(Instrument(1,no_id)) ) &
- & STOP 'Satellite id not allowed'
-
- WRITE(*,*) 'Which instrument type do you want for this satellite?'
- write(*, '(4(2x,i3,2x,a8))') (i, inst_name(i), i = 0, ninst-1)
-
- READ *, instrument(3,no_id)
- IF ( instrument(3,no_id) < 0 .OR. &
- & instrument(3,no_id) > ninst-1)&
- & STOP 'instrument number not allowed'
-
- WRITE(*,*) ' Forward model only (0) or full gradient test (1)',&
- & ' or full radiance output (2)?'
- READ *, IFULL(no_id)
- PRINT *, ' Number of profiles to test code? '
- READ *, NPROF(no_id)
- PRINT *, ' Surface type (0=land, 1=sea, 2=ice/snow)? '
- READ *, NSURF(no_id)
- !
- !..SET UP CHANNEL NUMBERS
- !
- ! .. DEFAULT MAXIMUMS
- if (coeff_version == 'old') max_channel(:)=max_channel_old(:)
- if (coeff_version == 'new') max_channel(:)=max_channel_new(:)
- allocate (nchan(nprof(no_id),nrttovid),stat= alloc_status(3))
- nchan(1:nprof(no_id),no_id) = max_channel(instrument(3,no_id))
- !
- ! Note that channels are the same for all instruments
- ! and all profiles because the filename is the same
- OPEN (IUE,FILE='input.dat',status='old')
- READ(IUE,*)
- NCH = 0
- DO ICH = 1 , nchan(1,no_id)
- READ(IUE,*,iostat=ios)I,II,S
- if(ios /= 0 ) then
- write (*,*) ' TOO FEW CHANNELS IN INPUT FILE '
- write (*,*) ' nchan(1,no_id),no_id ',nchan(1,no_id),no_id
- stop
- endif
- IF(II.GT.0)THEN
- NCH = NCH + 1
- ICHAN(nch,no_id) = I
- SURFEM(nch,no_id) = s
- ENDIF
- ENDDO
- !
- CLOSE(IUE)
-
- ! nchan(1,no_id) is now the real number of channels selected
- do j = 1 , nprof(no_id)
- nchan(j,no_id) = MIN(max_channel(instrument(3,no_id)),NCH)
- enddo
- write(6,*)' Number of channels selected = ',nchan(1,no_id)
- allocate (ichan1(nchan(1,no_id)),stat= alloc_status(8))
- ichan1(1:nchan(1,no_id)) = ichan(1:nchan(1,no_id),no_id)
- !
- !---------------------------------------------------------
- ! Beginning of rttov_readcoeffs test
- !---------------------------------------------------------
-!!$ call rttov_readcoeffs (coef_errorstatus, coef(no_id), instrument(:,no_id),&
-!!$ call rttov_initcoeffs (coef_errorstatus, coef(no_id))
-!!$ & channels = ichan(1:nchan(1,no_id) ,no_id) )
-!!$
-!!$ if(coef_errorstatus /= errorstatus_success ) then
-!!$ write ( ioout, * ) 'rttov_readcoeffs fatal error'
-!!$ stop
-!!$ endif
-!!$
-!!$ if( any(coef(no_id)%ff_val_chn( 1 : coef(no_id)%fmv_chn ) /= 1 )) then
-!!$ WRITE(*,*) ' some requested channels have bad validity parameter'
-!!$ do i = 1, nchan(1,no_id)
-!!$ write(*,*) i, coef(no_id)%ff_val_chn(i)
-!!$ end do
-!!$ endif
- !---------------------------------------------------------
- ! End of rttov_readcoeffs test
- !---------------------------------------------------------
- END DO
-
- !---------------------------------------------------------
- ! Beginning of rttov_setup test
- !---------------------------------------------------------
- allocate ( setup_errorstatus(nrttovid),stat= alloc_status(1))
- If( any(alloc_status /= 0) ) then
- errorstatus = errorstatus_fatal
- Write( errMessage, '( "mem allocation error for errorsetup")' )
- Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine)
- Stop
- End If
- Call rttov_setup (&
- & setup_errorstatus, & ! out
- & Err_unit, & ! in
- & verbosity_level, & ! in
- & nrttovid, & ! in
- & coef, & ! out
- & instrument, & ! in
- & ichan ) ! in Optional
-
- if(any(setup_errorstatus(:) /= errorstatus_success ) ) then
- write ( ioout, * ) 'rttov_setup fatal error'
- stop
- endif
-
- deallocate( setup_errorstatus ,stat=alloc_status(1))
- If( any(alloc_status /= 0) ) then
- errorstatus = errorstatus_fatal
- Write( errMessage, '( "mem deallocation error for setup_errorstatus")' )
- Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine)
- Stop
- End If
-
- DO no_id = 1, NRTTOVID
- if( any(coef(no_id)%ff_val_chn( : ) /= 1 )) then
- WRITE(*,*) ' some requested channels have bad validity parameter'
- do i = 1, nchan(1,no_id)
- write(*,*) i, coef(no_id)%ff_val_chn(i)
- end do
- endif
- End Do
- !---------------------------------------------------------
- ! End of rttov_setup test
- !---------------------------------------------------------
- !
- DO no_id = 1, NRTTOVID
- ! Set up various channel numbers required by RTTOV-8
- Call rttov_setupchan(nprof(no_id),nchan(1:nprof(no_id),no_id),coef(no_id),nfrequencies, &
- & nchannels,nbtout)
-
- ! total number of channels
- nlevels = coef(no_id) % nlevels
-
- ! Memory allocation for RTTOV_Direct
- !-----------------------------------
- allocate( channels ( nfrequencies ) ,stat= alloc_status(1))
- allocate( rttov_errorstatus(nprof(no_id)),stat= alloc_status(1))
- allocate( profiles(nprof(no_id)),stat= alloc_status(2))
- allocate (surfem1(nchannels),stat= alloc_status(7))
- allocate( polarisations(nchannels,3),stat= alloc_status(1))
- allocate( frequencies(nbtout),stat= alloc_status(2))
- allocate( indexout(nbtout),stat= alloc_status(3))
- If( any(alloc_status /= 0) ) then
- errorstatus = errorstatus_fatal
- Write( errMessage, '( "mem allocation error")' )
- Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine)
- Stop
- End If
-
- do j = 1, nprof(no_id)
- ! allocate model profiles atmospheric arrays with model levels dimension
- profiles(j) % nlevels = coef(no_id) % nlevels
- allocate( profiles(j) % p ( coef(no_id) % nlevels ) ,stat= alloc_status(4))
- allocate( profiles(j) % t ( coef(no_id) % nlevels ) ,stat= alloc_status(5))
- allocate( profiles(j) % q ( coef(no_id) % nlevels ) ,stat= alloc_status(6))
- allocate( profiles(j) % o3 ( coef(no_id) % nlevels ) ,stat= alloc_status(7))
- allocate( profiles(j) % clw( coef(no_id) % nlevels ) ,stat= alloc_status(8))
- profiles(j) % p(:) = coef(no_id) % ref_prfl_p(:)
- If( any(alloc_status /= 0) ) then
- errorstatus = errorstatus_fatal
- Write( errMessage, '( "mem allocation error")' )
- Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine)
- Stop
- End If
- end do
-
- ! number of channels per RTTOV call is only nchannels
- allocate( lprofiles ( nfrequencies ) ,stat= alloc_status(9))
- allocate( emissivity ( nchannels ) ,stat= alloc_status(10))
- allocate( input_emissivity ( nchannels ) ,stat= alloc_status(11))
- allocate( calcemis ( nchannels ) ,stat= alloc_status(12))
-
- ! allocate transmittance structure
- allocate( transmission % tau_surf ( nchannels ) ,stat= alloc_status(13))
- allocate( transmission % tau_layer ( coef(no_id) % nlevels, nchannels ) ,stat= alloc_status(14))
- allocate( transmission % od_singlelayer( coef(no_id) % nlevels, nchannels ),stat= alloc_status(15))
-
- ! allocate radiance results arrays with number of channels
- allocate( radiance % clear ( nchannels ) ,stat= alloc_status(19))
- allocate( radiance % cloudy ( nchannels ) ,stat= alloc_status(20))
- allocate( radiance % total ( nchannels ) ,stat= alloc_status(21))
- allocate( radiance % bt ( nchannels ) ,stat= alloc_status(22))
- allocate( radiance % bt_clear ( nchannels ) ,stat= alloc_status(23))
- allocate( radiance % upclear ( nchannels ) ,stat= alloc_status(24))
- allocate( radiance % dnclear ( nchannels ) ,stat=alloc_status(25))
- allocate( radiance % reflclear( nchannels ) ,stat= alloc_status(26))
- allocate( radiance % overcast ( coef(no_id) % nlevels, nchannels ) ,stat= alloc_status(27))
-
- ! allocate the cloudy radiances with full size even if not used
- ! Save input values of emissivities for all calculations.
- allocate( radiance % downcld ( coef(no_id) % nlevels, nchannels ) ,stat= alloc_status(28))
- allocate( radiance % out ( nbtout ) ,stat= alloc_status(29))
- allocate( radiance % out_clear( nbtout ) ,stat= alloc_status(30))
- allocate( radiance % total_out( nbtout ) ,stat= alloc_status(31))
- allocate( radiance % clear_out( nbtout ) ,stat= alloc_status(32))
-
- Allocate(pr_radcld(nbtout) ,stat= alloc_status(33))
- Allocate(pr_trans(nbtout) ,stat= alloc_status(34))
- Allocate(pr_emis(nbtout) ,stat= alloc_status(35))
- Allocate(pr_trans_lev(coef(no_id) % nlevels,nbtout) ,stat= alloc_status(36))
- Allocate(pr_upclr(nbtout) ,stat= alloc_status(37))
- Allocate(pr_dncld(coef(no_id) % nlevels,nbtout) ,stat= alloc_status(38))
- Allocate(pr_refclr(nbtout) ,stat= alloc_status(39))
- Allocate(pr_ovcst(coef(no_id) % nlevels,nbtout) ,stat= alloc_status(40))
-
- If( any(alloc_status /= 0) ) then
- errorstatus = errorstatus_fatal
- Write( errMessage, '( "mem allocation error")' )
- Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine)
- Stop
- End If
-
- WRITE(6,*)'Zenith angle (degrees)?'
- READ(5,*)ZENANG
- WRITE(6,*)'Azimuth angle (degrees)?'
- READ(5,*)AZANG
-
- WRITE(6,*)' Number of level =',NLEVELS
- ! Read profile ONE and fill other profiles with profile one
- OPEN (IUA,FILE='prof.dat',status='old')
- !
- JJM = 0
- DO IRA = 1 , 1+(NLEVELS-1)/10
- JJ = 1+JJM
- JJM = MIN(JJ+9,NLEVELS)
- READ(IUA,*) (profiles(1) % t(J),J=JJ,JJM)
- end do
- JJM = 0
- DO IRA = 1 , 1+(NLEVELS-1)/10
- JJ = 1+JJM
- JJM = MIN(JJ+9,NLEVELS)
- READ(IUA,*) (profiles(1) % q(J),J=JJ,JJM)
- end do
- JJM = 0
- DO IRA = 1 , 1+(NLEVELS-1)/10
- JJ = 1+JJM
- JJM = MIN(JJ+9,NLEVELS)
- READ(IUA,*) (profiles(1) % o3(J),J=JJ,JJM)
- end do
- profiles(1) % ozone_data = .true.
- profiles(1) % co2_data = .false.
-
- JJM = 0
- DO IRA = 1 , 1+(NLEVELS-1)/10
- JJ = 1+JJM
- JJM = MIN(JJ+9,NLEVELS)
- READ(IUA,*) (profiles(1) % clw(J),J=JJ,JJM)
- end do
- ! check value of first level
- profiles(1) % clw_data = profiles(1) % clw(1) >= 0.0_JPRB
-
- READ(IUA,*) profiles(1) % s2m % t ,&
- & profiles(1) % s2m % q ,&
- & profiles(1) % s2m % p ,&
- & profiles(1) % s2m % u ,&
- & profiles(1) % s2m % v
-
-
- READ(IUA,*) profiles(1) % skin % t ,&
- & profiles(1) % skin % fastem
-
- READ(IUA,*) profiles(1) % ctp,&
- & profiles(1) % cfraction
- !
- CLOSE(IUA)
- !
- WRITE(IOOUT,*)' INPUT PROFILE'
- WRITE(IOOUT,444) (profiles(1) % t(JJ) ,JJ=1,NLEVELS)
- WRITE(IOOUT,444) (profiles(1) % q(JJ) ,JJ=1,NLEVELS)
- WRITE(IOOUT,444) (profiles(1) % o3(JJ) ,JJ=1,NLEVELS)
- WRITE(IOOUT,444) (profiles(1) % clw(JJ) ,JJ=1,NLEVELS)
- WRITE(IOOUT,444) profiles(1) % s2m % t ,&
- & profiles(1) % s2m % q ,&
- & profiles(1) % s2m % p ,&
- & profiles(1) % s2m % u ,&
- & profiles(1) % s2m % v
- WRITE(IOOUT,444) profiles(1) % skin % t ,&
- & profiles(1) % skin % fastem
- WRITE(IOOUT,444) profiles(1) % ctp,&
- & profiles(1) % cfraction
- WRITE(IOOUT,*)' '
-
- ! Convert lnq to q in ppmv for profile
- !
- profiles(1) % q(:) = (exp(profiles(1) % q(:)) / 1000._JPRB) * q_mixratio_to_ppmv
- profiles(1) % s2m % q = (exp(profiles(1) % s2m % q) / 1000._JPRB) * q_mixratio_to_ppmv
-
- ! Keep Ozone in ppmv
-
- ! viewing geometry
- profiles(1) % zenangle = ZENANG
- profiles(1) % azangle = AZANG
- ! surface type
- profiles(1) % skin % surftype = nsurf(no_id)
-
- !.. Fill profile arrays with the 1 profile NPROF times
- DO J = 1 , NPROF(no_id)
- profiles(j) % p(:) = profiles(1) % p(:)
- profiles(j) % t(:) = profiles(1) % t(:)
- profiles(j) % q(:) = profiles(1) % q(:)
- profiles(j) % o3(:) = profiles(1) % o3(:)
- profiles(j) % clw(:) = profiles(1) % clw(:)
- profiles(j) % s2m = profiles(1) % s2m
- profiles(j) % skin = profiles(1) % skin
- profiles(j) % ctp = profiles(1) % ctp
- profiles(j) % cfraction = profiles(1) % cfraction
- profiles(j) % ozone_data = profiles(1) % ozone_data
- profiles(j) % co2_data = profiles(1) % co2_data
- profiles(j) % clw_data = profiles(1) % clw_data
- profiles(j) % zenangle = profiles(1) % zenangle
- profiles(j) % azangle = profiles(1) % azangle
- end do
-
- ! Build the list of channels/profiles indices
- surfem1(:) = 0.0_JPRB
- nch = 1
- do j = 1 , nprof(no_id)
- surfem1(nch:nch+nchan(j,no_id)-1) = surfem(1:nchan(1,no_id),no_id) !Assume emissivities same as first profile
- nch = nch+nchan(j,no_id)
- enddo
- nch = 0
- Call rttov_setupindex (nchan(1:nprof(no_id),no_id),nprof(no_id),nfrequencies,nchannels,nbtout,coef(no_id),&
- & surfem1,lprofiles,channels,polarisations,emissivity)
- !
- nch = 0
- ibtout=0
- DO J=1,NPROF(no_id)
- DO JCH=1,NCHAN(1,no_id)
- nch = nch +1
- If( coef(no_id) % id_sensor /= sensor_id_mw) then
- frequencies(ibtout+1) = nch
- ibtout=ibtout+1
- End If
- If( coef(no_id) % id_sensor == sensor_id_mw) then
- pol_id = coef(no_id) % fastem_polar(jch) + 1
- Do i=1, npolar_return(pol_id)
- frequencies(ibtout+i)=nch
- End Do
- ibtout=ibtout+npolar_return(pol_id)
- End If
- End Do
- End Do
- write(6,*)' nfreq=',nfrequencies,' nchannels=',nchannels,' nbtout=',nbtout
- !write(6,*)' Channels ',(channels(ich2),ich2=1,nfrequencies)
- !write(6,*)(polarisations(ich2,1),ich2=1,nchannels)
- !write(6,*)(polarisations(ich2,2),ich2=1,nchannels)
- !write(6,*)(polarisations(ich2,3),ich2=1,nchannels)
-
- ! save input values of emissivities for all calculations
- ! calculate emissivity where the input emissivity value is less than 0.01
- input_emissivity(:) = emissivity(:)
- calcemis(:) = emissivity(:) < 0.01_JPRB
-
- WRITE(IOOUT,*)' NUMBER OF PROFILES PROCESSED=',NPROF(no_id)
- WRITE(IOOUT,*)' '
- !
- WRITE(IOOUT,*)'CHANNELS PROCESSED:'
- WRITE(IOOUT,111) (ichan(J,no_id), J = 1,NCHAN(1,no_id))
- WRITE (IOOUT,*)' '
- WRITE(IOOUT,*)'INPUT SURFACE EMISSIVITIES '&
- & ,'SAT =', instrument(2,no_id)
- JOFF1=0
- WRITE(IOOUT,444) (emissivity(J+JOFF1),J=1,NCHAN(1,no_id))
- WRITE(IOOUT,*)' '
-
- IF(IFULL(no_id).EQ.2)THEN
- LCLOUD =.TRUE.
- ELSE
- LCLOUD =.FALSE.
- radiance % downcld(:,:) = 0._JPRB
- ENDIF
- if(nprof(no_id).gt.1)THEN
- call rttov_direct( &
- rttov_errorstatus, & ! out
- nfrequencies, & ! in
- nchannels, & ! in
- nbtout, & ! in
- nprof(no_id), & ! in
- channels, & ! in
- polarisations,& ! in
- lprofiles, & ! in
- profiles, & ! in
- coef(no_id), & ! in
- lcloud, & ! in
- calcemis, & ! in
- emissivity, & ! inout
- transmission, & ! out
- radiance ) ! inout
- ELSE
-!##################################################
-! extra do loop to increase run time for SX-6 tests
-!##################################################
- do j = 1 , 1000
- ! PERFORM RADIATIVE TRANSFER CALCULATIONS
- call rttov_direct( &
- rttov_errorstatus, & ! out
- nfrequencies, & ! in
- nchannels, & ! in
- nbtout, & ! in
- nprof(no_id), & ! in
- channels, & ! in
- polarisations,& ! in
- lprofiles, & ! in
- profiles, & ! in
- coef(no_id), & ! in
- lcloud, & ! in
- calcemis, & ! in
- emissivity, & ! inout
- transmission, & ! out
- radiance ) ! inout
- enddo
- ENDIF
- If ( any( rttov_errorstatus(:) == errorstatus_warning ) ) Then
- Do j = 1, nprof(no_id)
- If ( rttov_errorstatus(j) == errorstatus_warning ) Then
- write ( ioout, * ) 'rttov warning for profile',j
- End If
- End Do
- End If
-
- If ( any( rttov_errorstatus(:) == errorstatus_fatal ) ) Then
- Do j = 1, nprof(no_id)
- If ( rttov_errorstatus(j) == errorstatus_fatal ) Then
- write ( ioout, * ) 'rttov error for profile',j
- End If
- End Do
- Stop
- End If
-
- ! transfer data to printing arrays
- pr_pol(:) = 0
- pr_radcld(:) = 0.0_JPRB
- pr_trans(:) = 0.0_JPRB
- pr_emis(:) = 0.0_JPRB
- pr_trans_lev(:,:) = 0.0_JPRB
- pr_upclr(:) = 0.0_JPRB
- pr_dncld(:,:) = 0.0_JPRB
- pr_refclr(:) = 0.0_JPRB
- pr_ovcst(:,:) = 0.0_JPRB
- !
- do j = 1 , nchannels
- jpol = polarisations(j,2)
- if (nbtout == nchannels) then
- jpol = j
- endif
- pr_pol(jpol) = jpol
- pr_radcld(jpol) = radiance % cloudy(j)
- pr_trans(jpol) = Transmission % tau_surf(J)
- pr_emis(jpol) = emissivity(j)
- pr_upclr(jpol) = radiance % upclear(J)
- pr_refclr(jpol) = radiance % reflclear(J)
- do ilev = 1 , nlevels
- pr_trans_lev(ilev,jpol) = Transmission % tau_layer(ilev,J)
- pr_dncld(ilev,jpol) = radiance % downcld(ILEV,J)
- pr_ovcst(ilev,jpol) = radiance % overcast(ILEV,J)
- enddo
- enddo
-
- ! OUTPUT RESULTS
- !
- NPRINT = 1+ INT((nbtout-1)/(10*nprof(no_id)))
- DO JN=1,NPROF(no_id)
- WRITE(IOOUT,*)' -----------------'
- WRITE(IOOUT,*)' Profile number ',JN, 'Instrument ',&
- & instrument(3,no_id)
- WRITE(IOOUT,*)' -----------------'
- WRITE(IOOUT,*)' '
-! JOFF=NCHAN(no_id)*(JN-1)
- JOFF1=nbtout/nprof(no_id)*(JN-1)
- JOFF2=nbtout/nprof(no_id)*(JN-1)
- JOFF3=nfrequencies/nprof(no_id)*(JN-1)
- WRITE(IOOUT,777)instrument(2,no_id), profiles(jn)%zenangle,profiles(jn)%azangle,profiles(jn)%skin%surftype
- WRITE(IOOUT,222) (radiance % out(J+JOFF1),J=1,nbtout/nprof(no_id))
- WRITE(IOOUT,*)' '
- WRITE(IOOUT,*)'CALCULATED RADIANCES: SAT =', instrument(2,no_id)
- WRITE(IOOUT,222) (radiance % total_out(J+JOFF1),J=1,nbtout/nprof(no_id))
- WRITE(IOOUT,*)' '
- WRITE(IOOUT,*)'CALCULATED OVERCAST RADIANCES: SAT =', instrument(2,no_id)
- WRITE(IOOUT,222) (pr_radcld(J+JOFF2),J=1,nbtout/nprof(no_id))
- WRITE (IOOUT,*)' '
- WRITE(IOOUT,*)'CALCULATED SURFACE TO SPACE TRANSMITTANCE: S'&
- & ,'AT =',instrument(2,no_id)
- WRITE(IOOUT,4444) (pr_trans(J+JOFF2),J=1,nbtout/nprof(no_id))
- WRITE (IOOUT,*)' '
- WRITE(IOOUT,*)'CALCULATED SURFACE EMISSIVITIES '&
- & ,'SAT =',instrument(2,no_id)
- WRITE(IOOUT,444) (pr_emis(J+JOFF2),J=1,nbtout/nprof(no_id))
- !
- ! Print clear-sky radiance without reflection term and
- ! reflected clear-sky downwelling radiance
- !
- IF(IFULL(no_id) == 2 .AND. nchan(1,no_id) <= 20 )THEN
- WRITE (IOOUT,*)' '
- WRITE(IOOUT,*)'CALCULATED Clear-sky radiance without reflection term'&
- & ,' SAT =',instrument(2,no_id)
- WRITE(IOOUT,444)(pr_upclr(J+JOFF2),J=1,nbtout/nprof(no_id))
- WRITE (IOOUT,*)' '
- WRITE (IOOUT,*)'CALCULATED Reflected clear-sky downwelling radiance'&
- & ,' SAT =',instrument(2,no_id)
- WRITE(IOOUT,444)(pr_refclr(J+JOFF2),J=1,nbtout/nprof(no_id))
- WRITE (IOOUT,*)'CHANNELS '
- WRITE(IOOUT,111) (ichan(j,no_id), J = 1,nbtout/nprof(no_id))
- ENDIF
- !
- IF(JN.EQ.1 .AND. nchan(1,no_id) .LE. 20)THEN
- DO NP = 1 , NPRINT
- WRITE (IOOUT,*)' '
- WRITE (IOOUT,*)'Level to space transmittances for channels'
-! WRITE(IOOUT,1115)(pr_pol(j),&
- WRITE(IOOUT,1115) (ICHAN(J,no_id),&
- & J = 1+(NP-1)*10,MIN(10+(NP-1)*10,nbtout/nprof(no_id)))
- DO ILEV = 1 , NLEVELS
- WRITE(IOOUT,4445)ILEV,(pr_trans_lev(ilev,J+JOFF2),&
- & J = 1+(NP-1)*10,MIN(10+(NP-1)*10,nbtout/nprof(no_id)))
- end do
- WRITE(IOOUT,1115) (ICHAN(J,no_id),&
- & J = 1+(NP-1)*10,MIN(10+(NP-1)*10,nbtout/nprof(no_id)))
- end do
- ENDIF
- !
- ! Print radiance upwelling arrays
- IF(JN==1 .AND. IFULL(no_id)==2 .AND. nchan(1,no_id)<=20)THEN
- DO NP = 1 , NPRINT
- WRITE (IOOUT,*)' '
- WRITE (IOOUT,*)'Level to space upwelling radiances for channels'
- WRITE(IOOUT,1115) (ICHAN(J,no_id),&
- & J = 1+(NP-1)*10,MIN(10+(NP-1)*10,nbtout/nprof(no_id)))
- DO ILEV = 1 , NLEVELS
- WRITE(IOOUT,4446)ILEV,(pr_ovcst(ILEV,J+JOFF2),&
- & J = 1+(NP-1)*10,MIN(10+(NP-1)*10,nbtout/nprof(no_id)))
- end do
- WRITE(IOOUT,1115) (ICHAN(J,no_id),&
- & J = 1+(NP-1)*10,MIN(10+(NP-1)*10,nbtout/nprof(no_id)))
- end do
- ENDIF
- ! Print radiance downwelling arrays
- IF(JN==1 .AND. IFULL(no_id)==2 .AND. nchan(1,no_id)<=20)THEN
- DO NP = 1 , NPRINT
- WRITE (IOOUT,*)' '
- WRITE (IOOUT,*)'Level to space downwelling radiances for channels'
- WRITE(IOOUT,1115) (ICHAN(J,no_id),&
- & J = 1+(NP-1)*10,MIN(10+(NP-1)*10,nbtout/nprof(no_id)))
- DO ILEV = 1 , NLEVELS
- WRITE(IOOUT,4446)ILEV,(pr_dncld(ILEV,J+JOFF2),&
- & J = 1+(NP-1)*10,MIN(10+(NP-1)*10,nbtout/nprof(no_id)))
- end do
- WRITE(IOOUT,1115) (ICHAN(J,no_id),&
- & J = 1+(NP-1)*10,MIN(10+(NP-1)*10,nbtout/nprof(no_id)))
- end do
- ENDIF
- end do
- WRITE(*,*) ' FORWARD MODEL FINISHED'
- !
- IF (IFULL(no_id).GE.1)THEN
- !
- !-----------------------------------------------------------
- ! Test tangent linear
- !-----------------------------------------------------------
- write(*,*) 'Tangent linear'
-
- call TSTRAD_TL( &
- nfrequencies, & ! in
- nchannels, & ! in
- nbtout, & ! in
- nprof(no_id), & ! in
- channels, & ! in
- polarisations, & ! in
- lprofiles, & ! in
- frequencies, & ! in
- profiles, & ! in
- coef(no_id), & ! in
- lcloud, & ! in
- calcemis, & ! in
- input_emissivity) ! in
-
- write(*,*) 'Adjoint'
-
- call TSTRAD_AD( &
- nfrequencies, & ! in
- nchannels, & ! in
- nbtout, & ! in
- nprof(no_id), & ! in
- channels, & ! in
- polarisations, & ! in
- frequencies, & ! in
- lprofiles, & ! in
- profiles, & ! in
- coef(no_id), & ! in
- lcloud, & ! in
- calcemis, & ! in
- input_emissivity) ! in
-
- write(*,*) 'K'
-
- call TSTRAD_K( &
- nfrequencies, & ! in
- nchannels, & ! in
- nbtout, & ! in
- nprof(no_id), & ! in
- channels, & ! in
- polarisations, & ! in
- frequencies, & ! in
- lprofiles, & ! in
- profiles, & ! in
- coef(no_id), & ! in
- lcloud, & ! in
- calcemis, & ! in
- input_emissivity) ! in
-
- deallocate(xkbav ,stat= alloc_status(1))
- deallocate(xkradovu,stat= alloc_status(2))
- deallocate(xkradovd,stat= alloc_status(3))
- deallocate(xkradov1,stat= alloc_status(4))
- deallocate(xkradov2,stat= alloc_status(5))
- deallocate(xkbsav ,stat= alloc_status(6))
- deallocate(xkbem ,stat= alloc_status(7))
- If( any(alloc_status /= 0) ) then
- errorstatus = errorstatus_fatal
- Write( errMessage, '( "mem deallocation error")' )
- Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine)
- Stop
- End If
-
- ENDIF
-
- do j = 1, nprof(no_id)
- ! deallocate model profiles atmospheric arrays
- deallocate( profiles(j) % p ,stat=alloc_status(1))
- deallocate( profiles(j) % t ,stat=alloc_status(2))
- deallocate( profiles(j) % q ,stat=alloc_status(3))
- deallocate( profiles(j) % o3 ,stat=alloc_status(4))
- deallocate( profiles(j) % clw ,stat=alloc_status(5))
- If( any(alloc_status /= 0) ) then
- errorstatus = errorstatus_fatal
- Write( errMessage, '( "mem deallocation error")' )
- Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine)
- Stop
- End If
- end do
- deallocate( profiles,stat=alloc_status(1))
-
- ! number of channels per RTTOV call is only nchannels
- deallocate( channels ,stat=alloc_status(2))
- deallocate( lprofiles ,stat=alloc_status(3))
- deallocate( emissivity ,stat=alloc_status(4))
- deallocate( calcemis ,stat=alloc_status(5))
-
- ! allocate transmittance structure
- deallocate( transmission % tau_surf ,stat= alloc_status(6))
- deallocate( transmission % tau_layer ,stat= alloc_status(7))
- deallocate( transmission % od_singlelayer,stat= alloc_status(8))
-
- ! allocate radiance results arrays with number of channels
- deallocate( radiance % clear ,stat=alloc_status(9))
- deallocate( radiance % cloudy ,stat=alloc_status(10))
- deallocate( radiance % total ,stat=alloc_status(11))
- deallocate( radiance % bt ,stat=alloc_status(12))
- deallocate( radiance % bt_clear ,stat=alloc_status(13))
- deallocate( radiance % upclear ,stat=alloc_status(14))
- deallocate( radiance % dnclear ,stat=alloc_status(15))
- deallocate( radiance % reflclear,stat=alloc_status(16))
- deallocate( radiance % overcast ,stat=alloc_status(17))
- deallocate( radiance % downcld ,stat=alloc_status(18))
- deallocate( radiance % out ,stat= alloc_status(19))
- deallocate( radiance % out_clear ,stat= alloc_status(20))
- deallocate( radiance % total_out ,stat= alloc_status(21))
- deallocate( radiance % clear_out ,stat= alloc_status(22))
- deallocate(pr_radcld ,stat= alloc_status(31))
- deallocate(pr_trans ,stat= alloc_status(32))
- deallocate(pr_emis ,stat= alloc_status(33))
- deallocate(pr_trans_lev ,stat= alloc_status(34))
- If( any(alloc_status /= 0) ) then
- errorstatus = errorstatus_fatal
- Write( errMessage, '( "mem deallocation error")' )
- Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine)
- Stop
- End If
- ENDDO
-
- Do no_id = 1, nrttovid
- Call rttov_dealloc_coef (errorstatus, coef(no_id))
- If(errorstatus /= errorstatus_success) Then
- Write( errMessage, '( "deallocation error")' )
- Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine)
- Endif
- End Do
-
-111 FORMAT(1X,10I8)
-1115 FORMAT(3X,10I8)
-2222 FORMAT(1X,10(1x,F8.6))
-222 FORMAT(1X,10F8.2)
-333 FORMAT(1X,I3,20I5)
-3333 FORMAT(1X,I3,2I5)
-444 FORMAT(1X,10F8.3)
-4444 FORMAT(1X,10F8.4)
-4445 FORMAT(1X,I2,10F8.4)
-4446 FORMAT(1X,I2,10F8.3)
-555 FORMAT(1X,10E8.2)
-777 FORMAT(1X,'CALCULATED BRIGHTNESS TEMPERATURES: SAT =',I2,&
- &' ZENITH ANGLE=',F6.2, &
- &' AZIMUTH ANGLE=',F7.2,' SURFACE TYPE=',I2)
-
-END PROGRAM TSTRAD_SX6
diff --git a/src/LIB/RTTOV/src/tstrad_tl.F90 b/src/LIB/RTTOV/src/tstrad_tl.F90
deleted file mode 100644
index 9fb4cb0c12bcff32db80a7f38ad05545f5b5f40f..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/tstrad_tl.F90
+++ /dev/null
@@ -1,1393 +0,0 @@
-Subroutine tstrad_tl( &
- & nfrequencies, &! in
- & nchannels, &! in
- & nbtout, &! in
- & nprofiles, &! in
- & channels, &! in
- & polarisations, &! in
- & lprofiles, &! in
- & frequencies, &! in
- & profiles, &! in
- & coef, &! in
- & addcloud, &! in
- & calcemis, &! in
- & input_emissivity) ! in
- !
- ! only the first nchannels/nprofiles are output
- !
- Use rttov_const, Only : &
- & errorstatus_success, &
- & errorstatus_fatal, &
- & sensor_id_mw
-
- Use rttov_types, Only : &
- & rttov_coef ,&
- & profile_Type ,&
- & transmission_Type ,&
- & radiance_Type
-
- Use mod_tstrad
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
-
-#include "rttov_errorreport.interface"
-#include "rttov_direct.interface"
-#include "rttov_tl.interface"
-
- !subroutine arguments:
- Integer(Kind=jpim), Intent(in) :: nchannels
- Integer(Kind=jpim), Intent(in) :: nfrequencies
- Integer(Kind=jpim), Intent(in) :: nbtout
- Integer(Kind=jpim), Intent(in) :: nprofiles
- Integer(Kind=jpim), Intent(in) :: channels(nfrequencies)
- Integer(Kind=jpim), Intent(in) :: polarisations(nchannels,3)
- Integer(Kind=jpim), Intent(in) :: lprofiles(nfrequencies)
- Logical, Intent(in) :: addcloud
- Type(profile_Type), Intent(in) :: profiles(nprofiles)
- Type(rttov_coef), Intent(in) :: coef
- Logical, Intent(in) :: calcemis(nchannels)
- Real(Kind=jprb), Intent(in) :: input_emissivity(nchannels)
- Integer(Kind=jpim), Intent(in) :: frequencies(nbtout)
-
-
-
- ! local
- Integer(Kind=jpim), Parameter :: jpnav = 4 ! no. of profile variables
- Integer(Kind=jpim), Parameter :: jpnsav = 5 ! no. of surface air variables
- Integer(Kind=jpim), Parameter :: jpnssv = 6 ! no. of skin variables
- Integer(Kind=jpim), Parameter :: jpncv = 2 ! no. of cloud variables
- Integer(Kind=jpim), Parameter :: sscvar = jpnsav+jpnssv+jpncv ! no of surface,skin,cloud vars
-
- Character (len=80) :: errMessage
- Character (len=10) :: NameOfRoutine = 'tstrad_tl '
-
- ! forward model outputs
- Type(transmission_Type) :: transmission
- Type(radiance_Type) :: radiancedata
- Type(radiance_Type) :: radiance_fwd
- Real(Kind=jprb) :: emissivity_fwd(nchannels)
- Real(Kind=jprb) :: emissivity(nchannels)
-
-
- ! tl increments
- Type(profile_Type) :: prof_inc(nprofiles)
- Type(profile_Type) :: null_inc(nprofiles) ! all increments set to 0
- Real(Kind=jprb) :: emissivity_inc(nchannels)
- Real(Kind=jprb) :: null_emissivity_inc(nchannels)
-
- ! tl variables for rttov_tl calls
- Type(profile_Type) :: profiles_tl(nprofiles)
- Type(transmission_Type) :: transmission_tl
- Type(radiance_Type) :: radiancedata_tl
- Real(Kind=jprb) :: emissivity_tl(nchannels)
-
- ! Brute force
- Type(profile_Type) :: profiles_bf(nprofiles)
- Real(Kind=jprb) :: emissivity_bf(nchannels)
- Logical :: calcemis_bf(nchannels)
-
-
-
- Integer(Kind=jpim) :: nlev
-
- Integer(Kind=jpim) :: ixkav(coef%nlevels,jpnav,nbtout)
- Integer(Kind=jpim) :: ixkov(coef%nlevels,nbtout)
- Real(Kind=jprb) :: pktav(coef%nlevels,jpnav,nbtout)
-
- Integer(Kind=jpim) :: ixkem(nbtout)
-
- Integer(Kind=jpim) :: ixksav(sscvar,nbtout)
- Real(Kind=jprb) :: pktsav(sscvar,nbtout)
-
- ! Brute force results
- Integer(Kind=jpim) :: ixkdav(coef%nlevels,jpnav,nbtout)
- Real(Kind=jprb) :: xktav (coef%nlevels,jpnav,nbtout)
- Integer(Kind=jpim) :: ixkdsav(sscvar,nbtout)
- Real(Kind=jprb) :: xktsav (sscvar,nbtout)
- Integer(Kind=jpim) :: ixkdem(nbtout)
- Real(Kind=jprb) :: xktem (nbtout)
-
- ! coefficients for printing
- Real(Kind=jprb) :: facpav(coef%nlevels,jpnav)
- Real(Kind=jprb) :: facovu(coef%nlevels)
- Real(Kind=jprb) :: facovd(coef%nlevels)
- Real(Kind=jprb) :: facem = 1._JPRB
-
- Real(Kind=jprb) :: facsav(sscvar) =&
- & (/10000._JPRB,0.1_JPRB,10000._JPRB,10000._JPRB,10000._JPRB, &! 2m
- & 10000._JPRB,100.0_JPRB,100.0_JPRB,100.0_JPRB,100.0_JPRB,100.0_JPRB, &! Skin
- & 10000._JPRB,100._JPRB/) ! cloud
-
- Real(Kind=jprb), Parameter :: q_mixratio_to_ppmv = 1.60771704e+6_JPRB
- Real(Kind=jprb), Parameter :: o3_mixratio_to_ppmv = 6.03504e+5_JPRB
-
- Real(Kind=jprb) :: inc_val ! increment value
- Real(Kind=jprb) :: inc_val_p ! increment value for printing (ppmv -> kg/kg)
- Real(Kind=jprb) :: diffr
- Real(Kind=jprb) :: sumr
- Real(Kind=jprb) :: sumrr
- Real(Kind=jprb) :: fac
- Integer(Kind=jpim) :: ioout = 2
- Integer(Kind=jpim) :: jch
- Integer(Kind=jpim) :: j, i, ii, jp, joff, ipol
- Integer(Kind=jpim) :: prof
- Integer(Kind=jpim) :: nchan_out
-
- Character (len=30) :: title(4) = &
- & (/' lev temperature ', &
- & ' lev water vapour ', &
- & ' lev ozone ', &
- & ' lev liquid water '/)
-
- Integer(Kind=jpim) :: errorstatus
- Integer(Kind=jpim) :: rttov_errorstatus(nprofiles)
- Integer(Kind=jpim) :: alloc_status(60)
-
- !- End of header --------------------------------------------------------
-
- errorstatus = 0
- alloc_status(:) = 0
- rttov_errorstatus(:) = 0
-
- nchan_out = nbtout/nprofiles
- nlev = coef % nlevels
-
- ! coefficients for atmospheric variables
- facpav(:,1) = 10000._JPRB
- facpav(:,2) = 0.1_JPRB
- facpav(:,3) = 0.001_JPRB
- facpav(:,4) = 0.1_JPRB
- facovu(:) = 10000._JPRB
- facovd(:) = 100000._JPRB
-
- allocate(xkbav(coef%nlevels,jpnav,nbtout),stat= alloc_status(1))
- allocate(xkradovu(coef%nlevels,nchannels),stat= alloc_status(2))
- allocate(xkradovd(coef%nlevels,nchannels),stat= alloc_status(3))
- allocate(xkradov1(coef%nlevels,nchannels),stat= alloc_status(4))
- allocate(xkradov2(coef%nlevels,nchannels),stat= alloc_status(5))
- allocate(xkbsav(sscvar,nbtout),stat= alloc_status(6))
- allocate(xkbem(nbtout),stat= alloc_status(7))
- If( any(alloc_status /= 0) ) then
- errorstatus = errorstatus_fatal
- Write( errMessage, '( "mem allocation error")' )
- Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine)
- Return
- End If
-
-
- xkbav(:,:,:)=0._JPRB
- pktav(:,:,:)=0._JPRB
-
- ! allocate and initialise the reference tl increments
- Do j = 1, nprofiles
- prof_inc(j) % nlevels = coef % nlevels
- null_inc(j) % nlevels = coef % nlevels
- profiles_tl(j) % nlevels = coef % nlevels
- profiles_bf(j) % nlevels = coef % nlevels
- Allocate( prof_inc(j) % p ( coef % nlevels ) ,stat= alloc_status(1))
- Allocate( prof_inc(j) % t ( coef % nlevels ) ,stat= alloc_status(2))
- Allocate( prof_inc(j) % q ( coef % nlevels ) ,stat= alloc_status(3))
- Allocate( prof_inc(j) % o3 ( coef % nlevels ) ,stat= alloc_status(4))
- Allocate( prof_inc(j) % clw( coef % nlevels ) ,stat= alloc_status(5))
- Allocate( null_inc(j) % p ( coef % nlevels ) ,stat= alloc_status(6))
- Allocate( null_inc(j) % t ( coef % nlevels ) ,stat= alloc_status(7))
- Allocate( null_inc(j) % q ( coef % nlevels ) ,stat= alloc_status(8))
- Allocate( null_inc(j) % o3 ( coef % nlevels ) ,stat= alloc_status(9))
- Allocate( null_inc(j) % clw( coef % nlevels ) ,stat= alloc_status(10))
- Allocate( profiles_tl(j) % p ( coef % nlevels ) ,stat= alloc_status(11))
- Allocate( profiles_tl(j) % t ( coef % nlevels ) ,stat= alloc_status(12))
- Allocate( profiles_tl(j) % q ( coef % nlevels ) ,stat= alloc_status(13))
- Allocate( profiles_tl(j) % o3 ( coef % nlevels ) ,stat= alloc_status(14))
- Allocate( profiles_tl(j) % clw( coef % nlevels ) ,stat= alloc_status(15))
- Allocate( profiles_bf(j) % p ( coef % nlevels ) ,stat= alloc_status(16))
- Allocate( profiles_bf(j) % t ( coef % nlevels ) ,stat= alloc_status(17))
- Allocate( profiles_bf(j) % q ( coef % nlevels ) ,stat= alloc_status(18))
- Allocate( profiles_bf(j) % o3 ( coef % nlevels ) ,stat= alloc_status(19))
- Allocate( profiles_bf(j) % clw( coef % nlevels ) ,stat= alloc_status(20))
- If( any(alloc_status /= 0) ) then
- errorstatus = errorstatus_fatal
- Write( errMessage, '( "mem allocation error")' )
- Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine)
- Return
- End If
- End Do
-
- ! allocate radiance results arrays with number of channels
- Allocate( radiancedata % clear ( nchannels ) ,stat= alloc_status(1))
- Allocate( radiancedata % cloudy ( nchannels ) ,stat= alloc_status(2))
- Allocate( radiancedata % total ( nchannels ) ,stat= alloc_status(3))
- Allocate( radiancedata % bt ( nchannels ) ,stat= alloc_status(4))
- Allocate( radiancedata % bt_clear ( nchannels ) ,stat= alloc_status(5))
- Allocate( radiancedata % upclear ( nchannels ) ,stat= alloc_status(6))
- Allocate( radiancedata % dnclear ( nchannels ) ,stat= alloc_status(34))
- Allocate( radiancedata % reflclear( nchannels ) ,stat= alloc_status(7))
- Allocate( radiancedata % overcast ( coef % nlevels, nchannels ) ,stat= alloc_status(8))
- Allocate( radiancedata % downcld ( coef % nlevels, nchannels ) ,stat= alloc_status(9))
- Allocate( radiancedata % out ( nbtout ) ,stat= alloc_status(10))
- Allocate( radiancedata % out_clear( nbtout ) ,stat= alloc_status(11))
- Allocate( radiancedata % total_out( nbtout ) ,stat= alloc_status(12))
- Allocate( radiancedata % clear_out( nbtout ) ,stat= alloc_status(13))
- Allocate( radiancedata_tl % clear ( nchannels ) ,stat= alloc_status(14))
- Allocate( radiancedata_tl % cloudy ( nchannels ) ,stat= alloc_status(15))
- Allocate( radiancedata_tl % total ( nchannels ) ,stat= alloc_status(16))
- Allocate( radiancedata_tl % bt ( nchannels ) ,stat= alloc_status(17))
- Allocate( radiancedata_tl % bt_clear ( nchannels ) ,stat= alloc_status(18))
- Allocate( radiancedata_tl % upclear ( nchannels ) ,stat= alloc_status(19))
- Allocate( radiancedata_tl % reflclear( nchannels ) ,stat= alloc_status(20))
- Allocate( radiancedata_tl % overcast ( coef % nlevels, nchannels ) ,stat= alloc_status(21))
- Allocate( radiancedata_tl % downcld ( coef % nlevels, nchannels ) ,stat= alloc_status(22))
- Allocate( radiancedata_tl % out ( nbtout ) ,stat= alloc_status(23))
- Allocate( radiancedata_tl % out_clear( nbtout ) ,stat= alloc_status(24))
- Allocate( radiancedata_tl % total_out( nbtout ) ,stat= alloc_status(25))
- Allocate( radiancedata_tl % clear_out( nbtout ) ,stat= alloc_status(26))
- Allocate( radiance_fwd % clear ( nchannels ) ,stat= alloc_status(27))
- Allocate( radiance_fwd % cloudy ( nchannels ) ,stat= alloc_status(28))
- Allocate( radiance_fwd % total ( nchannels ) ,stat= alloc_status(29))
- Allocate( radiance_fwd % bt ( nchannels ) ,stat= alloc_status(30))
- Allocate( radiance_fwd % bt_clear ( nchannels ) ,stat= alloc_status(31))
- Allocate( radiance_fwd % upclear ( nchannels ) ,stat= alloc_status(32))
- Allocate( radiance_fwd % reflclear( nchannels ) ,stat= alloc_status(33))
- Allocate( radiance_fwd % overcast ( coef % nlevels, nchannels ) ,stat= alloc_status(34))
- Allocate( radiance_fwd % downcld ( coef % nlevels, nchannels ) ,stat= alloc_status(35))
- Allocate( radiance_fwd % out ( nbtout ) ,stat= alloc_status(36))
- Allocate( radiance_fwd % out_clear( nbtout ) ,stat= alloc_status(37))
- Allocate( radiance_fwd % total_out ( nbtout ) ,stat= alloc_status(38))
- Allocate( radiance_fwd % clear_out ( nbtout ) ,stat= alloc_status(39))
- Allocate( transmission % tau_surf ( nchannels ) ,stat= alloc_status(40))
- Allocate( transmission % tau_layer ( coef % nlevels, nchannels ) ,stat= alloc_status(41))
- Allocate( transmission % od_singlelayer( coef % nlevels, nchannels ) ,stat= alloc_status(42))
- Allocate( transmission_tl % tau_surf ( nchannels ) ,stat= alloc_status(46))
- Allocate( transmission_tl % tau_layer ( coef % nlevels, nchannels ) ,stat= alloc_status(47))
- Allocate( transmission_tl % od_singlelayer( coef % nlevels, nchannels ) ,stat= alloc_status(48))
-
- If( any(alloc_status /= 0) ) then
- errorstatus = errorstatus_fatal
- Write( errMessage, '( "mem allocation error")' )
- Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine)
- Return
- End If
-
- Do j = 1, nprofiles
- prof_inc(j) % ozone_Data = .False. ! no meaning
- prof_inc(j) % co2_Data = .False. ! no meaning
- prof_inc(j) % clw_Data = .False. ! no meaning
- prof_inc(j) % zenangle = -1 ! no meaning
-
- ! increments for atmospheric variables
- prof_inc(j) % p(:) = 0._JPRB ! no tl on pressure levels
- prof_inc(j) % t(:) = -1._JPRB ! 1k on temperarure
- prof_inc(j) % o3(:) = -0.01_JPRB ! 0.01_JPRB ppmv
- prof_inc(j) % clw(:) = 0.001_JPRB ! 1g/kg on clw
- prof_inc(j) % q(:) = -0.1_JPRB * profiles(j) % q(:) ! - 10% on wv
-
- ! increments for air surface variables
- prof_inc(j) % s2m % t = -1._JPRB ! 1k on temperarure
- prof_inc(j) % s2m % q = -1.6077_JPRB ! ppmv
- prof_inc(j) % s2m % p = -10._JPRB ! -10 hpa on pressure
- prof_inc(j) % s2m % u = 0.01_JPRB ! 0.01_JPRB m/s on wind components
- prof_inc(j) % s2m % v = 0.01_JPRB ! 0.01_JPRB m/s on wind components
-
- ! increments for skin variables
- prof_inc(j) % skin % surftype = -1 ! no meaning
- prof_inc(j) % skin % t = -1._JPRB ! 1k on temperarure
- prof_inc(j) % skin % fastem = (/-0.01_JPRB,-0.01_JPRB,-0.1_JPRB,-0.001_JPRB,-0.001_JPRB/)
-
- ! increments for cloud variables
- prof_inc(j) % ctp = -10._JPRB ! -10 hpa on pressure
- prof_inc(j) % cfraction = 0.1_JPRB ! 0.1_JPRB on cloud fraction
- End Do
-
- ! emissivity
- emissivity_inc(:) = -0.01_JPRB
-
-
- Do j = 1, nprofiles
- null_inc(j) % ozone_Data = .False. ! no meaning
- null_inc(j) % co2_Data = .False. ! no meaning
- null_inc(j) % clw_Data = .False. ! no meaning
- null_inc(j) % zenangle = -1 ! no meaning
- null_inc(j) % p(:) = 0._JPRB
- null_inc(j) % t(:) = 0._JPRB
- null_inc(j) % q(:) = 0._JPRB
- null_inc(j) % o3(:) = 0._JPRB
- null_inc(j) % clw(:) = 0._JPRB
- null_inc(j) % s2m % t = 0._JPRB
- null_inc(j) % s2m % q = 0._JPRB
- null_inc(j) % s2m % p = 0._JPRB
- null_inc(j) % s2m % u = 0._JPRB
- null_inc(j) % s2m % v = 0._JPRB
- null_inc(j) % skin % surftype = -1 ! no meaning
- null_inc(j) % skin % t = 0._JPRB
- null_inc(j) % skin % fastem = (/0._JPRB, 0._JPRB, 0._JPRB, 0._JPRB, 0._JPRB/)
- null_inc(j) % ctp = 0._JPRB
- null_inc(j) % cfraction = 0._JPRB
- End Do
- null_emissivity_inc(:) = 0._JPRB
-
- !..print out increments
- Write(ioout,*)' '
- Write(ioout,*)' input profile increments for tl'
- Write(ioout,444) prof_inc(1) % t(:)
- Write(ioout,444) prof_inc(1) % q(:) /q_mixratio_to_ppmv
- Write(ioout,444) prof_inc(1) % o3(:) /o3_mixratio_to_ppmv
- Write(ioout,444) prof_inc(1) % clw(:)
- Write(ioout,444)&
- & prof_inc(1) % s2m % t, &
- & prof_inc(1) % s2m % q /q_mixratio_to_ppmv, &
- & prof_inc(1) % s2m % p, &
- & prof_inc(1) % s2m % u, &
- & prof_inc(1) % s2m % v
- Write(ioout,444)&
- & prof_inc(1) % skin % t, &
- & prof_inc(1) % skin % fastem
- Write(ioout,444)&
- & prof_inc(1) % ctp,&
- & prof_inc(1) % cfraction
- Write(ioout,*)' '
- !
- !...first do profile variables.....................
- Do j =1,jpnav ! yes clw too!
- Do ii=1,nlev
-
- ! initialise all increments to 0
- Do jp = 1, nprofiles
- profiles_tl(jp) % p(:) = null_inc(jp) % p(:)
- profiles_tl(jp) % t(:) = null_inc(jp) % t(:)
- profiles_tl(jp) % q(:) = null_inc(jp) % q(:)
- profiles_tl(jp) % o3(:) = null_inc(jp) % o3(:)
- profiles_tl(jp) % clw(:) = null_inc(jp) % clw(:)
- profiles_tl(jp) % s2m = null_inc(jp) % s2m
- profiles_tl(jp) % skin = null_inc(jp) % skin
- profiles_tl(jp) % ctp = null_inc(jp) % ctp
- profiles_tl(jp) % cfraction = null_inc(jp) % cfraction
- profiles_tl(jp) % ozone_Data = null_inc(jp) % ozone_Data
- profiles_tl(jp) % co2_Data = null_inc(jp) % co2_Data
- profiles_tl(jp) % clw_Data = null_inc(jp) % clw_Data
- profiles_tl(jp) % zenangle = null_inc(jp) % zenangle
-
- End Do
- emissivity_tl(:) = null_emissivity_inc(:)
-
-
- Do jp = 1, nprofiles
- ! except the considered level/variable
- Select Case (j)
- Case (1_jpim)
- profiles_tl(jp) % t(ii) = prof_inc(jp) % t(ii)
- inc_val = prof_inc(1) % t(ii)
- inc_val_p = inc_val
- Case (2_jpim)
- profiles_tl(jp) % q(ii) = prof_inc(jp) % q(ii)
- inc_val = prof_inc(1) % q(ii)
- inc_val_p = inc_val / q_mixratio_to_ppmv
- Case (3_jpim)
- profiles_tl(jp) % o3(ii) = prof_inc(jp) % o3(ii)
- inc_val = prof_inc(1) % o3(ii)
- inc_val_p = inc_val / o3_mixratio_to_ppmv
- Case (4_jpim)
- profiles_tl(jp) % clw(ii) = prof_inc(jp) % clw(ii)
- inc_val = prof_inc(1) % clw(ii)
- inc_val_p = inc_val
- End Select
- End Do
-
- ! use stored input emmisisvity
- emissivity(:) = input_emissivity(:)
-
- Call rttov_tl( &
- & rttov_errorstatus, &! out
- & nfrequencies, &! in
- & nchannels, &! in
- & nbtout, &! in
- & nprofiles, &! in
- & channels, &! in
- & polarisations, &! in
- & lprofiles, &! in
- & profiles, &! in
- & coef, &! in
- & addcloud, &! in
- & calcemis, &! in
- & emissivity, &! inout
- & profiles_tl, &! in
- & emissivity_tl, &! inout
- & transmission, &! inout
- & transmission_tl, &! inout
- & radiancedata, &! out
- & radiancedata_tl ) ! inout
-
- If( any( rttov_errorstatus == errorstatus_fatal ) ) then
- Do jp = 1, nprofiles
- If( rttov_errorstatus(jp) == errorstatus_fatal ) then
- Write( errMessage, '( "fatal error in rttov_tl")' )
- Call Rttov_ErrorReport (rttov_errorstatus(jp), errMessage, NameOfRoutine)
- End If
- End Do
- Stop
- End If
- If( any( rttov_errorstatus /= errorstatus_success ) ) then
- Write( errMessage, '( "warning in rttov_tl")' )
- End If
-
- If (inc_val == 0._JPRB) Then
- xkbav(ii,j,:)=0._JPRB
- pktav(ii,j,:)=0._JPRB
- Else
- pktav(ii,j,:)=radiancedata_tl%out(:)
- xkbav(ii,j,:)=radiancedata_tl%out(:) / inc_val
- If(addcloud .And. j==1)Then
- xkradovu(ii,:)=radiancedata_tl%overcast(ii,:)/inc_val
- xkradovd(ii,:)=radiancedata_tl%downcld (ii,:)/inc_val
- xkradov1(ii,:)=radiancedata_tl%upclear(:)/inc_val
- xkradov2(ii,:)=radiancedata_tl%reflclear(:)/inc_val
- Endif
- Endif
- ixkav(ii,j,:)=Nint(radiancedata_tl%out(:)*facpav(ii,j)/ inc_val_p)
-
- End Do
- End Do
-
- ! ... and print it.
- Write (ioout,*)' '
- Write (ioout,*)'k-matrix: tangent linear.'
-!!$ Do jch=1,nchannels
-!!$ ixkav(:,:,jch)=Nint(xkbav(:,:,jch)*facpav(:,:))
-!!$ End Do
- Write (ioout,*)' '
- Do j = 1 , jpnav ! lwp on
- Write (ioout,'(a30)')title(j)
- Write (ioout,3333)coef%ff_ori_chn(frequencies(1:nchan_out))
- Do i = 1 , nlev
- Write (ioout,333)i,(ixkav(i,j,jch),jch=1,nchan_out)
- Enddo
- Write (ioout,3333)coef%ff_ori_chn(frequencies(1:nchan_out))
- Write (ioout,*)' '
- Enddo
-
-
- ! optionally print full radiance arrays
- If(addcloud)Then
- Write (ioout,*)' '
- Write (ioout,*)'k-matrix: upwelling radiance tl '
- Do jch=1,nbtout
- ixkov(:,jch)=Nint(xkradovu(:,jch)*facovu(:))
- End Do
- Write (ioout,3333)coef%ff_ori_chn(frequencies(1:nchan_out))
- Do i = 1 , nlev
- Write (ioout,333)i,(ixkov(i,jch),jch=1,nchan_out)
- Enddo
- Write (ioout,3333)coef%ff_ori_chn(frequencies(1:nchan_out))
- Write (ioout,*)' '
- Write (ioout,*)'k-matrix: downwelling radiance tl '
- Do jch=1,nbtout
- ixkov(:,jch)=Nint(xkradovd(:,jch)*facovd(:))
- End Do
- Write (ioout,3333)coef%ff_ori_chn(frequencies(1:nchan_out))
- Do i = 1 , nlev
- Write (ioout,333)i,(ixkov(i,jch),jch=1,nchan_out)
- Enddo
- Write (ioout,3333)coef%ff_ori_chn(frequencies(1:nchan_out))
- Write (ioout,*)' '
- Write (ioout,*)'k-matrix: clear-sky radiance without reflection term tl '
- Do jch=1,nbtout
- ixkov(:,jch)=Nint(xkradov1(:,jch)*facovu(:))
- End Do
- Write (ioout,3333)coef%ff_ori_chn(frequencies(1:nchan_out))
- Do i = 1 , nlev
- Write (ioout,333)i,(ixkov(i,jch),jch=1,nchan_out)
- Enddo
- Write (ioout,3333)coef%ff_ori_chn(frequencies(1:nchan_out))
- Write (ioout,*)' '
- Write (ioout,*)' '
- Write (ioout,*)'k-matrix: reflected clear-sky downwelling radiance tl '
- Do jch=1,nbtout
- ixkov(:,jch)=Nint(xkradov2(:,jch)*facovd(:))*10._JPRB
- End Do
- Write (ioout,3333)coef%ff_ori_chn(frequencies(1:nchan_out))
- Do i = 1 , nlev
- Write (ioout,333)i,(ixkov(i,jch),jch=1,nchan_out)
- Enddo
- Write (ioout,3333)coef%ff_ori_chn(frequencies(1:nchan_out))
- Write (ioout,*)' '
- Endif
-
-
- ! initialise all increments to 0
- Do jp = 1, nprofiles
- profiles_tl(jp) % p(:) = null_inc(jp) % p(:)
- profiles_tl(jp) % t(:) = null_inc(jp) % t(:)
- profiles_tl(jp) % q(:) = null_inc(jp) % q(:)
- profiles_tl(jp) % o3(:) = null_inc(jp) % o3(:)
- profiles_tl(jp) % clw(:) = null_inc(jp) % clw(:)
- profiles_tl(jp) % s2m = null_inc(jp) % s2m
- profiles_tl(jp) % skin = null_inc(jp) % skin
- profiles_tl(jp) % ctp = null_inc(jp) % ctp
- profiles_tl(jp) % cfraction = null_inc(jp) % cfraction
- profiles_tl(jp) % ozone_Data = null_inc(jp) % ozone_Data
- profiles_tl(jp) % co2_Data = null_inc(jp) % co2_Data
- profiles_tl(jp) % clw_Data = null_inc(jp) % clw_Data
- profiles_tl(jp) % zenangle = null_inc(jp) % zenangle
- End Do
- emissivity_tl(:) = null_emissivity_inc(:)
-
- !.......now do surface, skin and cloud variables
- Do j =1,sscvar
-
- Do jp = 1, nprofiles
- ! except the considered level/variable
- Select Case (j)
- Case (1_jpim)
- ! t 2m
- inc_val = prof_inc(jp) % s2m % t
- profiles_tl(jp) % s2m % t = inc_val
- Case (2_jpim)
- ! wv 2m
- inc_val = prof_inc(jp) % s2m % q
- profiles_tl(jp) % s2m % q = inc_val
- Case (3_jpim)
- ! surface pressure
- inc_val = prof_inc(jp) % s2m % p
- profiles_tl(jp) % s2m % p = inc_val
- Case (4_jpim)
- ! wind speed u component
- inc_val = prof_inc(jp) % s2m % u
- profiles_tl(jp) % s2m % u = inc_val
- Case (5_jpim)
- ! wind speed v component
- inc_val = prof_inc(jp) % s2m % v
- profiles_tl(jp) % s2m % v = inc_val
- Case (6_jpim)
- ! skin temp
- inc_val = prof_inc(jp) % skin % t
- profiles_tl(jp) % skin % t = inc_val
- Case (7_jpim)
- ! fastem land coef 1
- inc_val = prof_inc(jp) % skin % fastem(1)
- profiles_tl(jp) % skin % fastem(1) = inc_val
- Case (8_jpim)
- ! fastem land coef 2
- inc_val = prof_inc(jp) % skin % fastem(2)
- profiles_tl(jp) % skin % fastem(2) = inc_val
- Case (9_jpim)
- ! fastem land coef 3
- inc_val = prof_inc(jp) % skin % fastem(3)
- profiles_tl(jp) % skin % fastem(3) = inc_val
- Case (10_jpim)
- ! fastem land coef 4
- inc_val = prof_inc(jp) % skin % fastem(4)
- profiles_tl(jp) % skin % fastem(4) = inc_val
- Case (11_jpim)
- ! fastem land coef 5
- inc_val = prof_inc(jp) % skin % fastem(5)
- profiles_tl(jp) % skin % fastem(5) = inc_val
- Case (12_jpim)
- ! cloud top pressure
- inc_val = prof_inc(jp) % ctp
- profiles_tl(jp) % ctp = inc_val
- Case (13_jpim)
- ! cloud fraction
- inc_val = prof_inc(jp) % cfraction
- profiles_tl(jp) % cfraction = inc_val
- End Select
- End Do
-
- ! use stored input emmisisvity
- emissivity(:) = input_emissivity(:)
- emissivity_tl(:) = null_emissivity_inc(:)
-
- Call rttov_tl( &
- & rttov_errorstatus, &! out
- & nfrequencies, &! in
- & nchannels, &! in
- & nbtout, &! in
- & nprofiles, &! in
- & channels, &! in
- & polarisations, &! in
- & lprofiles, &! in
- & profiles, &! in
- & coef, &! in
- & addcloud, &! in
- & calcemis, &! in
- & emissivity, &! inout
- & profiles_tl, &! in
- & emissivity_tl, &! inout
- & transmission, &! inout
- & transmission_tl, &! inout
- & radiancedata, &! inout
- & radiancedata_tl ) ! inout
-
- If( any( rttov_errorstatus == errorstatus_fatal ) ) then
- Do jp = 1, nprofiles
- If( rttov_errorstatus(jp) == errorstatus_fatal ) then
- Write( errMessage, '( "fatal error in rttov_tl")' )
- Call Rttov_ErrorReport (rttov_errorstatus(jp), errMessage, NameOfRoutine)
- End If
- End Do
- Stop
- End If
- If( any( rttov_errorstatus /= errorstatus_success ) ) then
- Write( errMessage, '( "warning in rttov_tl")' )
- End If
-
- Do jp = 1, nprofiles
- ! reset profile for next variable
- Select Case (j)
- Case (1_jpim)
- ! t 2m
- profiles_tl(jp) % s2m % t = null_inc(jp) % s2m % t
- Case (2_jpim)
- ! wv 2m
- profiles_tl(jp) % s2m % q = null_inc(jp) % s2m % q
- Case (3_jpim)
- ! surface pressure
- profiles_tl(jp) % s2m % p = null_inc(jp) % s2m % p
- Case (4_jpim)
- ! wind speed u component
- profiles_tl(jp) % s2m % u = null_inc(jp) % s2m % u
- Case (5_jpim)
- ! wind speed v component
- profiles_tl(jp) % s2m % v = null_inc(jp) % s2m % v
- Case (6_jpim)
- ! skin temp
- profiles_tl(jp) % skin % t = null_inc(jp) % skin % t
- Case (7_jpim)
- ! fastem land coef 1
- profiles_tl(jp) % skin % fastem(1) = null_inc(jp) % skin % fastem(1)
- Case (8_jpim)
- ! fastem land coef 2
- profiles_tl(jp) % skin % fastem(2) = null_inc(jp) % skin % fastem(2)
- Case (9_jpim)
- ! fastem land coef 3
- profiles_tl(jp) % skin % fastem(3) = null_inc(jp) % skin % fastem(3)
- Case (10_jpim)
- ! fastem land coef 4
- profiles_tl(jp) % skin % fastem(4) = null_inc(jp) % skin % fastem(4)
- Case (11_jpim)
- ! fastem land coef 5
- profiles_tl(jp) % skin % fastem(5) = null_inc(jp) % skin % fastem(5)
- Case (12_jpim)
- ! cloud top pressure
- profiles_tl(jp) % ctp = null_inc(jp) % ctp
- Case (13_jpim)
- ! cloud fraction
- profiles_tl(jp) % cfraction = null_inc(jp) % cfraction
- End Select
- End Do
-
- If( inc_val == 0._JPRB ) Then
- pktsav(j,:) = 0._JPRB
- xkbsav(j,:) = 0._JPRB
- Else
- pktsav(j,:) = radiancedata_tl%out(:)
- xkbsav(j,:) = radiancedata_tl%out(:) / inc_val
- End If
-
- End Do
-
- Do jch=1,nbtout
- ixksav(:,jch)=Nint(xkbsav(:,jch)*facsav(:))
- End Do
-
- ! ... and print it.
- Write (ioout,*)' surface variables '
- Write (ioout,3333)coef%ff_ori_chn(frequencies(1:nchan_out))
- Write (ioout,*)' '
- Do i = 1 , jpnsav
- Write (ioout,333)i,(ixksav(i,jch),jch=1,nchan_out)
- Enddo
- Write (ioout,*)' '
-
- Write (ioout,*)' skin variables '
- Write (ioout,3333)coef%ff_ori_chn(frequencies(1:nchan_out))
- Write (ioout,*)' '
- Do i = jpnsav+1 , jpnsav+jpnssv
- Write (ioout,333)i-jpnsav,(ixksav(i,jch),jch=1,nchan_out)
- Enddo
- Write (ioout,*)' '
-
- Write (ioout,*)' cloud variables '
- Write (ioout,3333)coef%ff_ori_chn(frequencies(1:nchan_out))
- Write (ioout,*)' '
- Do i = jpnsav+jpnssv+1 , sscvar
- Write (ioout,333)i-jpnsav-jpnssv,(ixksav(i,jch),jch=1,nchan_out)
- Enddo
- Write (ioout,*)' '
-
- !.......now do surface emissivity
- Do j =1,nbtout
-
- ! use stored input emmisisvity
- emissivity(:) = input_emissivity(:)
-
- ! increment for only one channel
- emissivity_tl(:) = null_emissivity_inc(:)
- Do ipol=1, polarisations(frequencies(j),3)
- inc_val = emissivity_inc(polarisations(frequencies(j),1)+ipol-1)
- emissivity_tl(polarisations(frequencies(j),1)+ipol-1) = inc_val
- End Do
-
- Call rttov_tl( &
- & rttov_errorstatus, &! out
- & nfrequencies, &! in
- & nchannels, &! in
- & nbtout, &! in
- & nprofiles, &! in
- & channels, &! in
- & polarisations, &! in
- & lprofiles, &! in
- & profiles, &! in
- & coef, &! in
- & addcloud, &! in
- & calcemis, &! in
- & emissivity, &! inout
- & profiles_tl, &! in
- & emissivity_tl, &! inout
- & transmission, &! inout
- & transmission_tl, &! inout
- & radiancedata, &! inout
- & radiancedata_tl ) ! inout
-
- If( any( rttov_errorstatus == errorstatus_fatal ) ) then
- Do jp = 1, nprofiles
- If( rttov_errorstatus(jp) == errorstatus_fatal ) then
- Write( errMessage, '( "fatal error in rttov_tl")' )
- Call Rttov_ErrorReport (rttov_errorstatus(jp), errMessage, NameOfRoutine)
- End If
- End Do
- Stop
- End If
- If( any( rttov_errorstatus /= errorstatus_success ) ) then
- Write( errMessage, '( "warning in rttov_tl")' )
- End If
-
- !.......Except for FASTEM-2 (input <0)
- !If( emissivity_tl(j) == 0. .Or. input_emissivity(j)<0.) Then
- If( emissivity_tl(polarisations(frequencies(j),1)) == 0._JPRB .Or. &
- & ( coef % fastem_ver >= 2 .and. calcemis(j)) ) Then
- xkbem(j) = 0._JPRB
- Else
- xkbem(j) = radiancedata_tl%out(j) / inc_val
- End If
-
- End Do
- ixkem(:)=Nint(xkbem(:)*facem)
-
- Write (ioout,*)' surface emissivity '
- Write (ioout,3333)coef%ff_ori_chn(frequencies(1:nchan_out))
- Write (ioout,*)' '
- Do jp = 1, nprofiles
- joff = (jp-1) * nchan_out
- Write (ioout,333)jp,(ixkem(jch+joff),jch=1,nchan_out)
- Enddo
- Write (ioout,*)' '
-
- !
- ! Now compute Brute force matrix
- !
- !save forward model radiances and emissivities
- ! do not consider overcast radiances
- radiance_fwd % clear(:) = radiancedata % clear(:)
- radiance_fwd % cloudy(:) = radiancedata % cloudy(:)
- radiance_fwd % total_out(:) = radiancedata % total_out(:)
- radiance_fwd % out(:) = radiancedata % out(:)
- radiance_fwd % out_clear(:) = radiancedata % out_clear(:)
- emissivity_fwd(:) = emissivity(:)
-
- Do j =1,jpnav ! yes clw too!
- Do ii=1,nlev
-
- ! initialise profile with input profile
- Do jp = 1, nprofiles
- profiles_bf(jp) % p(:) = profiles(jp) % p(:)
- profiles_bf(jp) % t(:) = profiles(jp) % t(:)
- profiles_bf(jp) % q(:) = profiles(jp) % q(:)
- profiles_bf(jp) % o3(:) = profiles(jp) % o3(:)
- profiles_bf(jp) % clw(:) = profiles(jp) % clw(:)
- profiles_bf(jp) % s2m = profiles(jp) % s2m
- profiles_bf(jp) % skin = profiles(jp) % skin
- profiles_bf(jp) % ctp = profiles(jp) % ctp
- profiles_bf(jp) % cfraction = profiles(jp) % cfraction
- profiles_bf(jp) % ozone_Data = profiles(jp) % ozone_Data
- profiles_bf(jp) % co2_Data = profiles(jp) % co2_Data
- profiles_bf(jp) % clw_Data = profiles(jp) % clw_Data
- profiles_bf(jp) % zenangle = profiles(jp) % zenangle
- profiles_bf(jp) % azangle = profiles(jp) % azangle
- End Do
-
- Do jp = 1, nprofiles
- ! except the considered level/variable
- Select Case (j)
- Case (1_jpim)
- inc_val = prof_inc(1) % t(ii)
- profiles_bf(jp) % t(ii) = profiles_bf(jp) % t(ii) + inc_val
- Case (2_jpim)
- inc_val = prof_inc(1) % q(ii)
- profiles_bf(jp) % q(ii) = profiles_bf(jp) % q(ii) + inc_val
- ! change increment for output compatibilty
- inc_val = prof_inc(1) % q(ii)/q_mixratio_to_ppmv
- Case (3_jpim)
- inc_val = prof_inc(1) % o3(ii)
- profiles_bf(jp) % o3(ii) = profiles_bf(jp) % o3(ii) + inc_val
- ! change increment for output compatibilty
- inc_val = prof_inc(1) % o3(ii)/o3_mixratio_to_ppmv
- Case (4_jpim)
- inc_val = prof_inc(1) % clw(ii)
- profiles_bf(jp) % clw(ii) = profiles_bf(jp) % clw(ii) + inc_val
- End Select
- End Do
-
- ! use stored input emmisisvity
- emissivity(:) = input_emissivity(:)
-
- Call rttov_direct( &
- & rttov_errorstatus, &! out
- & nfrequencies, &! in
- & nchannels, &! in
- & nbtout, &! in
- & nprofiles, &! in
- & channels, &! in
- & polarisations, &! in
- & lprofiles, &! in
- & profiles_bf, &! in
- & coef, &! in
- & addcloud, &! in
- & calcemis, &! in
- & emissivity, &! inout
- & transmission, &! out
- & radiancedata) ! inout
-
- If( any( rttov_errorstatus == errorstatus_fatal ) ) then
- Do jp = 1, nprofiles
- If( rttov_errorstatus(jp) == errorstatus_fatal ) then
- Write( errMessage, '( "fatal error in rttov_tl")' )
- Call Rttov_ErrorReport (rttov_errorstatus(jp), errMessage, NameOfRoutine)
- End If
- End Do
- Stop
- End If
- If( any( rttov_errorstatus /= errorstatus_success ) ) then
- Write( errMessage, '( "warning in rttov_tl")' )
- End If
-
- If (inc_val == 0._JPRB) Then
- xktav(ii,j,:)=0._JPRB
- Else
- xktav(ii,j,:)=( radiancedata%out(:) - radiance_fwd%out(:) )/ inc_val
- Endif
-
- End Do
- End Do
- Do jch=1,nbtout
- ixkdav(:,:,jch)=Nint(xktav(:,:,jch)*facpav(:,:))
- End Do
-
- ! initialise profile with input profile
- Do jp = 1, nprofiles
- profiles_bf(jp) % p(:) = profiles(jp) % p(:)
- profiles_bf(jp) % t(:) = profiles(jp) % t(:)
- profiles_bf(jp) % q(:) = profiles(jp) % q(:)
- profiles_bf(jp) % o3(:) = profiles(jp) % o3(:)
- profiles_bf(jp) % clw(:) = profiles(jp) % clw(:)
- profiles_bf(jp) % s2m = profiles(jp) % s2m
- profiles_bf(jp) % skin = profiles(jp) % skin
- profiles_bf(jp) % ctp = profiles(jp) % ctp
- profiles_bf(jp) % cfraction = profiles(jp) % cfraction
- profiles_bf(jp) % ozone_Data = profiles(jp) % ozone_Data
- profiles_bf(jp) % co2_Data = profiles(jp) % co2_Data
- profiles_bf(jp) % clw_Data = profiles(jp) % clw_Data
- profiles_bf(jp) % zenangle = profiles(jp) % zenangle
- End Do
-
-
- !.......now do surface, skin and cloud variables
- Do j =1,sscvar
-
-
- Do jp = 1, nprofiles
- ! except the considered level/variable
- Select Case (j)
- Case (1_jpim)
- ! t 2m
- inc_val = prof_inc(jp) % s2m % t
- profiles_bf(jp) % s2m % t = profiles_bf(jp) % s2m % t + inc_val
- Case (2_jpim)
- ! wv 2m
- inc_val = prof_inc(jp) % s2m % q
- profiles_bf(jp) % s2m % q = profiles_bf(jp) % s2m % q + inc_val
- Case (3_jpim)
- ! surface pressure
- inc_val = prof_inc(jp) % s2m % p
- profiles_bf(jp) % s2m % p = profiles_bf(jp) % s2m % p + inc_val
- Case (4_jpim)
- ! wind speed u component
- inc_val = prof_inc(jp) % s2m % u
- profiles_bf(jp) % s2m % u = profiles_bf(jp) % s2m % u + inc_val
- Case (5_jpim)
- ! wind speed v component
- inc_val = prof_inc(jp) % s2m % v
- profiles_bf(jp) % s2m % v = profiles_bf(jp) % s2m % v + inc_val
- Case (6_jpim)
- ! skin temp
- inc_val = prof_inc(jp) % skin % t
- profiles_bf(jp) % skin % t = profiles_bf(jp) % skin % t + inc_val
- Case (7_jpim)
- ! fastem land coef 1
- inc_val = prof_inc(jp) % skin % fastem(1)
- profiles_bf(jp) % skin % fastem(1) = profiles_bf(jp) % skin % fastem(1) + inc_val
- Case (8_jpim)
- ! fastem land coef 2
- inc_val = prof_inc(jp) % skin % fastem(2)
- profiles_bf(jp) % skin % fastem(2) = profiles_bf(jp) % skin % fastem(2) + inc_val
- Case (9_jpim)
- ! fastem land coef 3
- inc_val = prof_inc(jp) % skin % fastem(3)
- profiles_bf(jp) % skin % fastem(3) = profiles_bf(jp) % skin % fastem(3) + inc_val
- Case (10_jpim)
- ! fastem land coef 4
- inc_val = prof_inc(jp) % skin % fastem(4)
- profiles_bf(jp) % skin % fastem(4) = profiles_bf(jp) % skin % fastem(4) + inc_val
- Case (11_jpim)
- ! fastem land coef 5
- inc_val = prof_inc(jp) % skin % fastem(5)
- profiles_bf(jp) % skin % fastem(5) = profiles_bf(jp) % skin % fastem(5) + inc_val
- Case (12_jpim)
- ! cloud top pressure
- inc_val = prof_inc(jp) % ctp
- profiles_bf(jp) % ctp = profiles_bf(jp) % ctp + inc_val
- Case (13_jpim)
- ! cloud fraction
- inc_val = prof_inc(jp) % cfraction
- profiles_bf(jp) % cfraction = profiles_bf(jp) % cfraction + inc_val
- End Select
- End Do
-
- ! use stored input emmisisvity
- emissivity(:) = input_emissivity(:)
-
- Call rttov_direct( &
- & rttov_errorstatus, &! out
- & nfrequencies, &! in
- & nchannels, &! in
- & nbtout, &! in
- & nprofiles, &! in
- & channels, &! in
- & polarisations, &! in
- & lprofiles, &! in
- & profiles_bf, &! in
- & coef, &! in
- & addcloud, &! in
- & calcemis, &! in
- & emissivity, &! inout
- & transmission, &! out
- & radiancedata) ! inout
-
- If( any( rttov_errorstatus == errorstatus_fatal ) ) then
- Do jp = 1, nprofiles
- If( rttov_errorstatus(jp) == errorstatus_fatal ) then
- Write( errMessage, '( "fatal error in rttov_tl")' )
- Call Rttov_ErrorReport (rttov_errorstatus(jp), errMessage, NameOfRoutine)
- End If
- End Do
- Stop
- End If
- If( any( rttov_errorstatus /= errorstatus_success ) ) then
- Write( errMessage, '( "warning in rttov_tl")' )
- End If
-
- Do jp = 1, nprofiles
- ! reset profile for next variable
- Select Case (j)
- Case (1_jpim)
- ! t 2m
- profiles_bf(jp) % s2m % t = profiles(jp) % s2m % t
- Case (2_jpim)
- ! wv 2m
- profiles_bf(jp) % s2m % q = profiles(jp) % s2m % q
- Case (3_jpim)
- ! surface pressure
- profiles_bf(jp) % s2m % p = profiles(jp) % s2m % p
- Case (4_jpim)
- ! wind speed u component
- profiles_bf(jp) % s2m % u = profiles(jp) % s2m % u
- Case (5_jpim)
- ! wind speed v component
- profiles_bf(jp) % s2m % v = profiles(jp) % s2m % v
- Case (6_jpim)
- ! skin temp
- profiles_bf(jp) % skin % t = profiles(jp) % skin % t
- Case (7_jpim)
- ! fastem land coef 1
- profiles_bf(jp) % skin % fastem(1) = profiles(jp) % skin % fastem(1)
- Case (8_jpim)
- ! fastem land coef 2
- profiles_bf(jp) % skin % fastem(2) = profiles(jp) % skin % fastem(2)
- Case (9_jpim)
- ! fastem land coef 3
- profiles_bf(jp) % skin % fastem(3) = profiles(jp) % skin % fastem(3)
- Case (10_jpim)
- ! fastem land coef 4
- profiles_bf(jp) % skin % fastem(4) = profiles(jp) % skin % fastem(4)
- Case (11_jpim)
- ! fastem land coef 5
- profiles_bf(jp) % skin % fastem(5) = profiles(jp) % skin % fastem(5)
- Case (12_jpim)
- ! cloud top pressure
- profiles_bf(jp) % ctp = profiles(jp) % ctp
- Case (13_jpim)
- ! cloud fraction
- profiles_bf(jp) % cfraction = profiles(jp) % cfraction
- End Select
- End Do
-
- If( inc_val == 0._JPRB ) Then
- xktsav(j,:) = 0._JPRB
- Else
- xktsav(j,:)=( radiancedata%out(:) - radiance_fwd%out(:) )/ inc_val
- End If
-
- End Do
-
- Do jch=1,nbtout
- ixkdsav(:,jch)=Nint(xktsav(:,jch)*facsav(:))
- End Do
-
-
- !.......now do surface emissivity
- Do j =1,nbtout
-
- ! increment for only one channel
- ! use emissivity from FWD model output
- emissivity_bf(:) = emissivity_fwd(:)
- calcemis_bf(:) = .False.
- Do ipol=1, polarisations(frequencies(j),3)
- inc_val = emissivity_inc(polarisations(frequencies(j),1)+ipol-1)
- emissivity_bf(polarisations(frequencies(j),1)+ipol-1) = &
- & emissivity_bf(polarisations(frequencies(j),1)+ipol-1) + inc_val
- End Do
-
- Call rttov_direct( &
- & rttov_errorstatus, &! out
- & nfrequencies, &! in
- & nchannels, &! in
- & nbtout, &! in
- & nprofiles, &! in
- & channels, &! in
- & polarisations, &! in
- & lprofiles, &! in
- & profiles, &! in
- & coef, &! in
- & addcloud, &! in
- & calcemis_bf, &! in
- & emissivity_bf, &! inout
- & transmission, &! out
- & radiancedata) ! inout
-
- If( any( rttov_errorstatus == errorstatus_fatal ) ) then
- Do jp = 1, nprofiles
- If( rttov_errorstatus(jp) == errorstatus_fatal ) then
- Write( errMessage, '( "fatal error in rttov_tl")' )
- Call Rttov_ErrorReport (rttov_errorstatus(jp), errMessage, NameOfRoutine)
- End If
- End Do
- Stop
- End If
- If( any( rttov_errorstatus /= errorstatus_success ) ) then
- Write( errMessage, '( "warning in rttov_tl")' )
- End If
-
- If( emissivity_bf(j) == 0._JPRB ) Then
- xktem(j) = 0._JPRB
- Else
- xktem(j)=( radiancedata%out(j) - radiance_fwd%out(j) )/ inc_val
- End If
-
- End Do
- ixkdem(:)=Nint(xktem(:)*facem)
-
- ! ... and print it.
- Write (ioout,*)' '
- Write (ioout,*)'k-matrix: brute force '
-
- Write (ioout,*)' '
- Do j = 1 , jpnav ! lwp on
- Write (ioout,'(a30)')title(j)
- Write (ioout,3333)coef%ff_ori_chn(frequencies(1:nchan_out))
- Do i = 1 , nlev
- Write (ioout,333)i,(ixkdav(i,j,jch),jch=1,nchan_out)
- Enddo
- Write (ioout,3333)coef%ff_ori_chn(frequencies(1:nchan_out))
- Write (ioout,*)' '
- Enddo
-
- Write (ioout,*)' surface variables '
- Write (ioout,3333)coef%ff_ori_chn(frequencies(1:nchan_out))
- Write (ioout,*)' '
- Do i = 1 , jpnsav
- Write (ioout,333)i,(ixkdsav(i,jch),jch=1,nchan_out)
- Enddo
- Write (ioout,*)' '
-
- Write (ioout,*)' skin variables '
- Write (ioout,3333)coef%ff_ori_chn(frequencies(1:nchan_out))
- Write (ioout,*)' '
- Do i = jpnsav+1 , jpnsav+jpnssv
- Write (ioout,333)i-jpnsav,(ixkdsav(i,jch),jch=1,nchan_out)
- Enddo
- Write (ioout,*)' '
-
- Write (ioout,*)' cloud variables '
- Write (ioout,3333)coef%ff_ori_chn(frequencies(1:nchan_out))
- Write (ioout,*)' '
- Do i = jpnsav+jpnssv+1 , sscvar
- Write (ioout,333)i-jpnsav-jpnssv,(ixkdsav(i,jch),jch=1,nchan_out)
- Enddo
- Write (ioout,*)' '
- Write (ioout,*)' surface emissivity '
- Write (ioout,3333)coef%ff_ori_chn(frequencies(1:nchan_out))
- Write (ioout,*)' '
- Do jp = 1, nprofiles
- joff = (jp-1) * nchan_out
- Write (ioout,333)jp,(ixkdem(jch+joff),jch=1,nchan_out)
- Enddo
- Write (ioout,*)' '
-
-
- !--------- CHECK CONSISTENCY BETWEEN TL AND BRUTE FORCE------------
- ! run TL with increments on all variables
- !
- emissivity(:) = input_emissivity(:)
- emissivity_tl(:) = emissivity_inc(:)
- !
- ! if micro waves and "calcemis" then mask out FASTEM2 (input <0)
- If (coef % id_sensor == sensor_id_mw .And.&
- & coef % fastem_ver >= 2 ) Then
- !Where (input_emissivity(:) < 0.0)
- Where ( calcemis )
- emissivity_tl(:) = 0._JPRB
- End Where
- Endif
-
- Call rttov_tl( &
- & rttov_errorstatus, &! out
- & nfrequencies, &! in
- & nchannels, &! in
- & nbtout, &! in
- & nprofiles, &! in
- & channels, &! in
- & polarisations, &! in
- & lprofiles, &! in
- & profiles, &! in
- & coef, &! in
- & addcloud, &! in
- & calcemis, &! in
- & emissivity, &! inout
- & prof_inc, &! in
- & emissivity_tl, &! inout
- & transmission, &! inout
- & transmission_tl, &! inout
- & radiancedata, &! inout
- & radiancedata_tl ) ! out
-
- If( any( rttov_errorstatus == errorstatus_fatal ) ) then
- Do jp = 1, nprofiles
- If( rttov_errorstatus(jp) == errorstatus_fatal ) then
- Write( errMessage, '( "fatal error in rttov_tl")' )
- Call Rttov_ErrorReport (rttov_errorstatus(jp), errMessage, NameOfRoutine)
- End If
- End Do
- Stop
- End If
- If( any( rttov_errorstatus /= errorstatus_success ) ) then
- Write( errMessage, '( "warning in rttov_tl")' )
- End If
-
- Do prof = 1, nprofiles
- sumrr = 0._JPRB
- Do jch=1,nbtout
- If(lprofiles(frequencies(jch)) == prof) Then
- sumrr = sumrr + radiancedata_tl % out(jch)
- Endif
- End Do
- Write (IOOUT,149)prof,SUMRR
-149 Format (1X,'PROFILE NUMBER=',I2,' TL=',E20.10)
- End Do
-
-
- Do ii =1,15
-
- fac = 10.0_JPRB**(ii-1)
-
- ! initialise profile with input profile
- Do jp = 1, nprofiles
- profiles_bf(jp) % p(:) = profiles(jp) % p(:)
- profiles_bf(jp) % t(:) = profiles(jp) % t(:) + prof_inc(jp) % t(:) / fac
- profiles_bf(jp) % q(:) = profiles(jp) % q(:) + prof_inc(jp) % q(:) / fac
- profiles_bf(jp) % o3(:) = profiles(jp) % o3(:) + prof_inc(jp) % o3(:) / fac
- profiles_bf(jp) % clw(:) = profiles(jp) % clw(:) + prof_inc(jp) % clw(:) / fac
- profiles_bf(jp) % s2m = profiles(jp) % s2m
- profiles_bf(jp) % s2m % t = profiles(jp) % s2m % t + prof_inc(jp) % s2m % t / fac
- profiles_bf(jp) % s2m % q = profiles(jp) % s2m % q + prof_inc(jp) % s2m % q / fac
- profiles_bf(jp) % s2m % p = profiles(jp) % s2m % p + prof_inc(jp) % s2m % p / fac
- profiles_bf(jp) % s2m % u = profiles(jp) % s2m % u + prof_inc(jp) % s2m % u / fac
- profiles_bf(jp) % s2m % v = profiles(jp) % s2m % v + prof_inc(jp) % s2m % v / fac
- profiles_bf(jp) % skin = profiles(jp) % skin
- profiles_bf(jp) % skin % t = profiles(jp) % skin % t + prof_inc(jp) % skin % t / fac
- profiles_bf(jp) % skin % fastem = profiles(jp) % skin % fastem + prof_inc(jp) % skin % fastem / fac
- profiles_bf(jp) % ctp = profiles(jp) % ctp + prof_inc(jp) % ctp / fac
- profiles_bf(jp) % cfraction = profiles(jp) % cfraction + prof_inc(jp) % cfraction / fac
- profiles_bf(jp) % ozone_Data = profiles(jp) % ozone_Data
- profiles_bf(jp) % co2_Data = profiles(jp) % co2_Data
- profiles_bf(jp) % clw_Data = profiles(jp) % clw_Data
- profiles_bf(jp) % zenangle = profiles(jp) % zenangle
- End Do
-
- ! use emissivity from FWD model output
- emissivity_bf(:) = emissivity_fwd(:) + emissivity_inc(:) / fac
- calcemis_bf(:) = .False.
-
- ! if micro waves then mask out FASTEM2
- If (coef % id_sensor == sensor_id_mw .And.&
- & coef % fastem_ver >= 2 ) Then
- !Where (input_emissivity(:) < 0.0)
- Where ( calcemis )
- emissivity_bf(:) = input_emissivity(:)
- calcemis_bf(:) = calcemis(:)
- End Where
- Endif
-
- Call rttov_direct( &
- & rttov_errorstatus, &! out
- & nfrequencies, &! in
- & nchannels, &! in
- & nbtout, &! in
- & nprofiles, &! in
- & channels, &! in
- & polarisations, &! in
- & lprofiles, &! in
- & profiles_bf, &! in
- & coef, &! in
- & addcloud, &! in
- & calcemis_bf, &! in
- & emissivity_bf, &! inout
- & transmission, &! out
- & radiancedata) ! inout
-
- If( any( rttov_errorstatus == errorstatus_fatal ) ) then
- Do jp = 1, nprofiles
- If( rttov_errorstatus(jp) == errorstatus_fatal ) then
- Write( errMessage, '( "fatal error in rttov_tl")' )
- Call Rttov_ErrorReport (rttov_errorstatus(jp), errMessage, NameOfRoutine)
- End If
- End Do
- Stop
- End If
- If( any( rttov_errorstatus /= errorstatus_success ) ) then
- Write( errMessage, '( "warning in rttov_tl")' )
- End If
-
- sumr = 0._JPRB
- prof = 1 ! tests only first profile
- Do jch=1, nbtout
- If(lprofiles(frequencies(jch)) == prof) Then
- sumr = sumr + radiancedata%out(jch) - radiance_fwd%out(jch)
- End If
- End Do
- sumr = sumr*fac
- DIFFR=SUMR/SUMRR
- Write (IOOUT,148) SUMR,DIFFR,II
-148 Format (1X,'BRUTE FORCE: ',2E20.10,I10)
-
- End Do
-
- Do j = 1, nprofiles
- Deallocate( prof_inc(j) % p ,stat= alloc_status(1))
- Deallocate( prof_inc(j) % t ,stat= alloc_status(2))
- Deallocate( prof_inc(j) % q ,stat= alloc_status(3))
- Deallocate( prof_inc(j) % o3 ,stat= alloc_status(4))
- Deallocate( prof_inc(j) % clw ,stat= alloc_status(5))
- Deallocate( null_inc(j) % p ,stat= alloc_status(6))
- Deallocate( null_inc(j) % t ,stat= alloc_status(7))
- Deallocate( null_inc(j) % q ,stat= alloc_status(8))
- Deallocate( null_inc(j) % o3 ,stat= alloc_status(9))
- Deallocate( null_inc(j) % clw ,stat= alloc_status(10))
- Deallocate( profiles_tl(j) % p ,stat= alloc_status(11))
- Deallocate( profiles_tl(j) % t ,stat= alloc_status(12))
- Deallocate( profiles_tl(j) % q ,stat= alloc_status(13))
- Deallocate( profiles_tl(j) % o3 ,stat= alloc_status(14))
- Deallocate( profiles_tl(j) % clw ,stat= alloc_status(15))
- Deallocate( profiles_bf(j) % p ,stat= alloc_status(16))
- Deallocate( profiles_bf(j) % t ,stat= alloc_status(17))
- Deallocate( profiles_bf(j) % q ,stat= alloc_status(18))
- Deallocate( profiles_bf(j) % o3 ,stat= alloc_status(19))
- Deallocate( profiles_bf(j) % clw ,stat= alloc_status(20))
- If( any(alloc_status /= 0) ) then
- errorstatus = errorstatus_fatal
- Write( errMessage, '( "mem deallocation error")' )
- Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine)
- Return
- End If
- End Do
-
- ! deallocate radiance results arrays with number of channels
- Deallocate( radiancedata % clear ,stat= alloc_status(1))
- Deallocate( radiancedata % cloudy ,stat= alloc_status(2))
- Deallocate( radiancedata % total ,stat= alloc_status(3))
- Deallocate( radiancedata % bt ,stat= alloc_status(4))
- Deallocate( radiancedata % bt_clear ,stat= alloc_status(5))
- Deallocate( radiancedata % upclear ,stat= alloc_status(6))
- Deallocate( radiancedata % dnclear ,stat= alloc_status(34))
- Deallocate( radiancedata % reflclear ,stat= alloc_status(7))
- Deallocate( radiancedata % overcast ,stat= alloc_status(8))
- Deallocate( radiancedata % downcld ,stat= alloc_status(9))
- Deallocate( radiancedata % out ,stat= alloc_status(10))
- Deallocate( radiancedata % out_clear ,stat= alloc_status(11))
- Deallocate( radiancedata % total_out ,stat= alloc_status(12))
- Deallocate( radiancedata % clear_out ,stat= alloc_status(13))
- Deallocate( radiancedata_tl % clear ,stat= alloc_status(14))
- Deallocate( radiancedata_tl % cloudy ,stat= alloc_status(15))
- Deallocate( radiancedata_tl % total ,stat= alloc_status(16))
- Deallocate( radiancedata_tl % bt ,stat= alloc_status(17))
- Deallocate( radiancedata_tl % bt_clear ,stat= alloc_status(18))
- Deallocate( radiancedata_tl % upclear ,stat= alloc_status(19))
- Deallocate( radiancedata_tl % reflclear ,stat= alloc_status(20))
- Deallocate( radiancedata_tl % overcast ,stat= alloc_status(21))
- Deallocate( radiancedata_tl % downcld ,stat= alloc_status(22))
- Deallocate( radiancedata_tl % out ,stat= alloc_status(23))
- Deallocate( radiancedata_tl % out_clear ,stat= alloc_status(24))
- Deallocate( radiancedata_tl % total_out ,stat= alloc_status(25))
- Deallocate( radiancedata_tl % clear_out ,stat= alloc_status(26))
- Deallocate( radiance_fwd % clear ,stat= alloc_status(27))
- Deallocate( radiance_fwd % cloudy ,stat= alloc_status(28))
- Deallocate( radiance_fwd % total ,stat= alloc_status(29))
- Deallocate( radiance_fwd % bt ,stat= alloc_status(30))
- Deallocate( radiance_fwd % bt_clear ,stat= alloc_status(31))
- Deallocate( radiance_fwd % upclear ,stat= alloc_status(32))
- Deallocate( radiance_fwd % reflclear ,stat= alloc_status(33))
- Deallocate( radiance_fwd % overcast ,stat= alloc_status(34))
- Deallocate( radiance_fwd % downcld ,stat= alloc_status(35))
- Deallocate( radiance_fwd % out ,stat= alloc_status(36))
- Deallocate( radiance_fwd % out_clear ,stat= alloc_status(37))
- Deallocate( radiance_fwd % total_out ,stat= alloc_status(38))
- Deallocate( radiance_fwd % clear_out ,stat= alloc_status(39))
- Deallocate( transmission % tau_surf ,stat= alloc_status(40))
- Deallocate( transmission % tau_layer ,stat= alloc_status(41))
- Deallocate( transmission % od_singlelayer,stat= alloc_status(42))
- Deallocate( transmission_tl % tau_surf ,stat= alloc_status(43))
- Deallocate( transmission_tl % tau_layer ,stat= alloc_status(44))
- Deallocate( transmission_tl % od_singlelayer,stat= alloc_status(45))
- If( any(alloc_status /= 0) ) then
- errorstatus = errorstatus_fatal
- Write( errMessage, '( "mem deallocation error")' )
- Call Rttov_ErrorReport (errorstatus, errMessage, NameOfRoutine)
- Return
- End If
-
- Print *, ' tangent linear model test finished'
-222 Format(1x,10f8.2)
-333 Format(1x,i3,20i5)
-444 Format(1x,10e8.2)
-3333 Format(4x,20i5)
-4444 Format(1x,10f8.3)
-
-
-End Subroutine tstrad_tl
diff --git a/src/LIB/RTTOV/src/tstrad_tl.interface b/src/LIB/RTTOV/src/tstrad_tl.interface
deleted file mode 100644
index a76811f9d2d6b33c1b2683f7d7cfc0fd41b15e79..0000000000000000000000000000000000000000
--- a/src/LIB/RTTOV/src/tstrad_tl.interface
+++ /dev/null
@@ -1,49 +0,0 @@
-Interface
-Subroutine tstrad_tl( &
- nfrequencies, & ! in
- nchannels, & ! in
- nbtout, & ! in
- nprofiles, & ! in
- channels, & ! in
- polarisations, & ! in
- lprofiles, & ! in
- frequencies, & ! in
- profiles, & ! in
- coef, & ! in
- addcloud, & ! in
- calcemis, & ! in
- input_emissivity) ! in
-
- Use rttov_const, Only : &
- errorstatus_success, &
- errorstatus_fatal, &
- sensor_id_mw
-
- Use rttov_types, Only : &
- rttov_coef ,&
- profile_Type ,&
- transmission_Type ,&
- radiance_Type
-
- Use mod_tstrad
-
- Use parkind1, Only : jpim ,jprb
- Implicit None
- Integer(Kind=jpim), Intent(in) :: nchannels
- Integer(Kind=jpim), Intent(in) :: nfrequencies
- Integer(Kind=jpim), Intent(in) :: nbtout
- Integer(Kind=jpim), Intent(in) :: nprofiles
- Integer(Kind=jpim), Intent(in) :: channels(nfrequencies)
- Integer(Kind=jpim), Intent(in) :: polarisations(nchannels,3)
- Integer(Kind=jpim), Intent(in) :: lprofiles(nfrequencies)
- Integer(Kind=jpim), Intent(in) :: frequencies(nbtout)
- Logical, Intent(in) :: addcloud
- Type(profile_Type), Intent(in) :: profiles(nprofiles)
- Type(rttov_coef), Intent(in) :: coef
- Logical, Intent(in) :: calcemis(nchannels)
- Real(Kind=jprb), Intent(in) :: input_emissivity(nchannels)
-
-
-
-End Subroutine tstrad_tl
-End Interface