!-------------------------------------- LICENCE BEGIN ------------------------------------
!Environment Canada - Atmospheric Science and Technology License/Disclaimer,
! version 3; Last Modified: May 7, 2008.
!This is free but copyrighted software; you can use/redistribute/modify it under the terms
!of the Environment Canada - Atmospheric Science and Technology License/Disclaimer
!version 3 or (at your option) any later version that should be found at:
!http://collaboration.cmc.ec.gc.ca/science/rpn.comm/license.html
!
!This software is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY;
!without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
!See the above mentioned License/Disclaimer for more details.
!You should have received a copy of the License/Disclaimer along with this software;
!if not, you can write to: EC-RPN COMM Group, 2121 TransCanada, suite 500, Dorval (Quebec),
!CANADA, H9P 1J3; or send e-mail to service.rpn@ec.gc.ca
!-------------------------------------- LICENCE END --------------------------------------
!
SUBROUTINE CERES_EMATRIX(EMI_MAT, waven,nchn) 1
#if defined (DOC)
!***********************************************************************
!
!**ID CERES_EMATRIX -- SET UP EMISSIVITIES
!
! AUTHOR: L. GARAND Sept 2004
! A. BEAULNE (CMDA/SMC) March 2006 (ADAPT TO 3DVAR)
!
! REVISION:
!
! OBJECT: SET UP EMISSIVITY VERSUS FIXED WAVENUMBERS AND SURFACE TYPES
!
! CERES
! -----
! Emissivity data available at low spectral resolution: only 14 values
! to cover the entire spectrum. Thus, this can be used as a nominal value.
! The error associated with this emissivity can roughly be estimated to
! increase with lower emissivity as : (1-EMI)*0.5
! (i.e. as large as 0.10 for EMI=0.80 but better than 0.01 for EMI > 0.98)
! -No dependence on viewing angle is assumed.
! -Not to be used for oceans uncovered by ice.
!
! Longwave Emmissivities in 12 original Fu bands + 2 extra to cover the range
! ---------------------------------------------------------------------------
! Longwave spectral intervals [cm-1] for the Fu & Liou code:
!
! Band 1 2 3 4 5 6
! 2200-1900, 1900-1700, 1700-1400, 1400-1250, 1250-1100, 1100-980,
! Band 7 8 9 10 11 12
! 980-800, 800-670, 670-540, 540-400, 400-280, 280-0
!
! Two additional LW spectral intervals have been added in beyond 2200cm-1.
! Band 13 14
! 2500-2200 2850-2500
!
! Emissivity ems(band(1)) from April data, Table2 of Chen et al
! 11th Conf Sat Met, Madison, WI, p 514
! here regoganized as 14 13 1 2 ... 12 above
!
! 20 surface types
! ----------------
! 1= evergreen nleaf 2= evergreen bleaf 3= deciduous nleaf 4= deciduous bleaf
! 5= mixed forests 6= closed shrubs 7= open shrubs 8= woody savanna
! 9= savanna 10= grasslands 11= perma wet 12= croplands
! 13= urban 14= mosaic 15= snow 16= barren (deserts)
! 17= water 18= toundra 19= fresh snow 20= sea ice
!
!
! ARGUMENTS:
! INPUT:
! -WAVEN(NCHN) : WAVENUMBERS (CM-1)
! -NCHN : NUMBER OF BANDS FOR WHICH EMISSIVITY IS NEEDED
!
! OUTPUT:
! -EMI_MAT(NCHN,NTYPE) : EMISSIVITY (0.0-1.0)
!
!***********************************************************************
#endif
IMPLICIT NONE
INTEGER :: I, NC, NT, NCHN
REAL :: WAVEN(NCHN), EMI_MAT(NCHN,20), DUM
! CERES bands central wavenumber (covers 3.7 micron to 71.4 mic)
REAL :: MID(14)
! CERES emissivity per wavenumber and surface types
REAL :: EMI_TAB(14,20)
DATA MID / &
& 2675., 2350., 2050., 1800., 1550., 1325., 1175., 1040., &
& 890., 735., 605., 470., 340., 140. /
DATA EMI_TAB / &
& 0.951, 0.989, 0.989, 0.989, 0.990, 0.991, 0.991, 0.990, &
& 0.990, 0.995, 1.000, 1.000, 1.000, 1.000, &
& 0.956, 0.989, 0.989, 0.989, 0.990, 0.991, 0.991, 0.990, &
& 0.990, 0.995, 1.000, 1.000, 1.000, 1.000, &
& 0.929, 0.985, 0.985, 0.986, 0.984, 0.983, 0.979, 0.980, &
& 0.973, 0.987, 1.000, 1.000, 1.000, 1.000, &
& 0.943, 0.985, 0.985, 0.986, 0.984, 0.983, 0.979, 0.980, &
& 0.973, 0.987, 1.000, 1.000, 1.000, 1.000, &
& 0.945, 0.987, 0.987, 0.987, 0.987, 0.987, 0.985, 0.985, &
& 0.982, 0.991, 1.000, 1.000, 1.000, 1.000, &
& 0.933, 0.949, 0.949, 0.970, 0.974, 0.971, 0.947, 0.958, &
& 0.966, 0.975, 0.984, 0.984, 0.984, 0.984, &
& 0.873, 0.873, 0.873, 0.934, 0.944, 0.939, 0.873, 0.904, &
& 0.936, 0.942, 0.951, 0.951, 0.951, 0.951, &
& 0.930, 0.987, 0.987, 0.990, 0.992, 0.993, 0.983, 0.975, &
& 0.985, 0.993, 1.000, 1.000, 1.000, 1.000, &
& 0.926, 0.987, 0.987, 0.990, 0.992, 0.993, 0.983, 0.975, &
& 0.985, 0.993, 1.000, 1.000, 1.000, 1.000, &
& 0.899, 0.987, 0.987, 0.990, 0.992, 0.993, 0.983, 0.975, &
& 0.985, 0.993, 1.000, 1.000, 1.000, 1.000, &
& 0.951, 0.983, 0.983, 0.987, 0.987, 0.988, 0.983, 0.981, &
& 0.987, 0.982, 0.986, 0.986, 0.986, 0.986, &
& 0.924, 0.987, 0.987, 0.990, 0.992, 0.993, 0.983, 0.975, &
& 0.985, 0.993, 1.000, 1.000, 1.000, 1.000, &
& 0.929, 1.000, 1.000, 1.000, 1.000, 1.000, 1.000, 1.000, &
& 1.000, 1.000, 1.000, 1.000, 1.000, 1.000, &
& 0.926, 0.987, 0.987, 0.989, 0.989, 0.990, 0.984, 0.980, &
& 0.983, 0.992, 1.000, 1.000, 1.000, 1.000, &
& 0.972, 1.000, 1.000, 1.000, 1.000, 1.000, 1.000, 1.000, &
& 1.000, 0.999, 0.999, 0.999, 0.999, 0.999, &
& 0.866, 0.835, 0.835, 0.916, 0.934, 0.923, 0.835, 0.877, &
& 0.921, 0.926, 0.934, 0.934, 0.934, 0.934, &
& 0.973, 0.979, 0.979, 0.983, 0.982, 0.982, 0.984, 0.987, &
& 0.989, 0.972, 0.972, 0.972, 0.972, 0.972, &
& 0.968, 0.947, 0.947, 0.967, 0.988, 0.979, 0.975, 0.977, &
& 0.992, 0.989, 0.989, 0.989, 0.989, 0.989, &
& 0.984, 0.988, 0.988, 0.988, 0.988, 0.988, 0.988, 0.988, &
& 0.988, 0.988, 0.988, 0.988, 0.988, 0.988, &
& 0.964, 0.979, 0.979, 0.979, 0.979, 0.979, 0.979, 0.979, &
& 0.979, 0.979, 0.979, 0.979, 0.979, 0.979 /
DO NT = 1, 20
DO NC = 1, NCHN
IF ( WAVEN(NC) > MID(1) ) THEN
EMI_MAT(NC,NT) = EMI_TAB(1,NT)
ELSE IF ( WAVEN(NC) < MID(14) ) THEN
EMI_MAT(NC,NT) = EMI_TAB(14,NT)
ELSE
DO I = 1, 14-1
IF ( WAVEN(NC) <= MID(I) .AND. WAVEN(NC) >= MID(I+1) ) THEN
DUM = ( WAVEN(NC) - MID(I) ) / ( MID(I+1) - MID(I) )
EMI_MAT(NC,NT) = EMI_TAB(I,NT) + ( EMI_TAB(I+1,NT) - EMI_TAB(I,NT) ) * DUM
EXIT
END IF
END DO
END IF
END DO
END DO
END SUBROUTINE CERES_EMATRIX