!-------------------------------------- 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 --------------------------------------
!
!* This is a subroutine that can apply to any instrument.
!* However, due to the necessity of specifying the instrument
!* bands wavenumbers, the use of this subroutine for a new instrument
!* would require the minor following changes.
!*
!* - Add a .cdk containing wavenumber information for all channels
!* Example: airsch.cdk for AIRS, variable AIRSSWN
!* - Continue the "find the bands (central) wavenumber" IF loop
!* for your specific instrument
SUBROUTINE NEW_EMISS ( SURFEM1, nchn,krtid,nprf,nchannels_max,iptobs) 1,8
#if defined (DOC)
!***********************************************************************
!
!**ID NEW_EMISS -- ASSIGN NEW IR SURFACE EMISSIVITIES
!
! SCIENCE: L. GARAND
! AUTHOR: A. BEAULNE (CMDA/SMC) June 2006
!
! REVISION:
!
! OBJECT: ASSIGN NEW IR SURFACE EMISSIVITIES BASED ON
! CMC ANALYSIS SURFACE ALBEDO, SEA ICE FRACTION AND SNOW MASK
! IN ADDITION TO CERES SURFACE TYPE AND WATER FRACTION
!
!
! ARGUMENTS:
! INPUT:
! -NCHN : NUMBER OF CHANNELS
! -KRTID : SENSOR NUMBER
! -NPRF : NUMBER OF PROFILES
! -NCHANNELS_MAX : TOTAL NUMBER OF OBSERVATIONS TREATED
! -IPTOBS(NPRF) : PROFILE POSITION NUMBER
!
! OUTPUT:
! -SURFEM1(NCHANNELS_MAX) : IR SURFACE EMISSIVITY ESTIMATE (0-1)
!
!***********************************************************************
#endif
use mod_tovs
use airsch
use iasich
use emissivities
IMPLICIT NONE
!implicits
#include "partov.cdk"
#include "comtov.cdk"
#include "comlun.cdk"
INTEGER :: JC,JN,NPRF,NCHANNELS_MAX,ICHN
INTEGER :: NCHN,IPTOBS(NPRF),KRTID
INTEGER :: KSURF(NPRF), LTYPE(NPRF)
INTEGER :: ILAT(NPRF), ILON(NPRF)
REAL :: ALBEDO(NPRF), ICE(NPRF), SNOW(NPRF), PCNT_WAT(NPRF)
REAL(8) :: ZLAT(NPRF), ZLON(NPRF), UWIND(NPRF), VWIND(NPRF), SATZANG(NPRF)
REAL(8) :: SURFEM1(NCHANNELS_MAX)
REAL :: WIND_SFC(NPRF),ANGLE(NPRF), F_LOW(NPRF)
REAL,ALLOCATABLE :: EM_OC(:,:),EMI_SFC(:,:),EMI_MAT(:,:),WAVEN(:)
!* information to extract (transvidage)
!--------------------------------------
!
! ZLAT(NPRF) -- latitude (-90 to 90)
! ZLON(NPRF) -- longitude (0 to 360)
! KSURF(NPRF) -- surface type (0, 1)
! UWIND(NPRF) -- surface u-component wind vector (m/s)
! VWIND(NPRF) -- surface v-component wind vector (m/s)
! SATZANG(NPRF) -- satellite zenith angle (deg)
DO JN = 1, NPRF
ZLAT(JN) = PROFILES_QC(IPTOBS(JN))%LAT
ZLON(JN) = PROFILES_QC(IPTOBS(JN))%LON
KSURF(JN) = PROFILES(IPTOBS(JN))%SKIN%SURFTYPE
UWIND(JN) = PROFILES(IPTOBS(JN))%S2M%U
VWIND(JN) = PROFILES(IPTOBS(JN))%S2M%V
SATZANG(JN) = PROFILES(IPTOBS(JN))%ZENANGLE
END DO
! assign surface properties from grid to profiles
CALL INTERP_SFC(ILAT,ILON, nprf,zlat,zlon,iptobs)
! ALBEDO(NPRF) -- surface albedo (0-1)
! ICE(NPRF) -- ice cover (0-1)
! SNOW(NPRF) -- snow cover (0-1)
! LTYPE(NPRF) -- surface type (1,...,20)
! PCNT_WAT(NPRF) -- water percentage in pixel containing profile (0-1)
DO JN = 1, NPRF
ALBEDO(JN) = PROFILES_QC(IPTOBS(JN))%ALBEDO
ICE(JN) = PROFILES_QC(IPTOBS(JN))%ICE
SNOW(JN) = PROFILES_QC(IPTOBS(JN))%SNOW
LTYPE(JN) = PROFILES_QC(IPTOBS(JN))%LTYPE
PCNT_WAT(JN) = PROFILES_QC(IPTOBS(JN))%PCNT_WAT
END DO
!* find the sensor bands (central) wavenumbers
ALLOCATE(WAVEN(NCHN))
IF ( PLATFORM(KRTID) == 9 .and. &
& SATELLITE(KRTID) == 2 .and. &
& INSTRUMENT(KRTID) == 11 ) THEN !! --AIRS--
DO JC = 1, NCHN
ICHN = ICHAN(JC,KRTID)
WAVEN(JC) = AIRSSWN(AIRSSCH(ICHN))
END DO
ELSE IF ( PLATFORM(KRTID) == 10 .and. &
& SATELLITE(KRTID) == 2 .and. &
& INSTRUMENT(KRTID) == 16 ) THEN !! --IASI--
DO JC = 1, NCHN
ICHN = ICHAN(JC,KRTID)
WAVEN(JC) = IASISWN(IASISCH(ICHN))
END DO
END IF
!* get the CERES emissivity matrix for all sensor wavenumbers and surface types
ALLOCATE(EMI_MAT(NCHN,20))
CALL CERES_EMATRIX(EMI_MAT, waven,nchn)
!* refine water emissivities
ALLOCATE(EM_OC(NCHN,NPRF))
DO JN = 1, NPRF
! find surface wind
WIND_SFC(JN) = MIN(SQRT(REAL(UWIND(JN)**2) + REAL(VWIND(JN)**2) + 1.E-12),15.)
! find satellite viewing angle
ANGLE(JN) = REAL(SATZANG(JN))
END DO
! find new ocean emissivities
DO JC = 1, NCHN
EM_OC(JC,:)= EMI_MAT(JC,17)
END DO
CALL EMI_SEA (EM_OC, waven,angle,wind_sfc,nprf,nchn)
!* get surface emissivities
ALLOCATE(EMI_SFC(NCHN,NPRF))
DO JN = 1, NPRF
! set albedo to 0.6 where snow is present
IF ( KSURF(JN) == 0 .AND. SNOW(JN) > 0.999 ) ALBEDO(JN) = 0.6
! if albedo too high no water
IF ( ALBEDO(JN) >= 0.55 ) PCNT_WAT(JN) = 0.
! if water and CMC ice present then sea ice
IF ( KSURF(JN) == 1 .and. ICE(JN) > 0.001 ) LTYPE(JN) = 20
! if land and CMC snow present then snow
IF ( KSURF(JN) == 0 .and. SNOW(JN) > 0.999 ) LTYPE(JN) = 15
DO JC=1,NCHN
EMI_SFC(JC,JN) = PCNT_WAT(JN) * EM_OC(JC,JN) + &
& ( 1. - PCNT_WAT(JN) ) * EMI_MAT(JC,LTYPE(JN))
SURFEM1((JN-1)*NCHN+JC) = EMI_SFC(JC,JN)
END DO
END DO
DEALLOCATE (WAVEN,EMI_MAT,EM_OC,EMI_SFC)
!* update profiles
DO JN = 1, NPRF
PROFILES_QC(IPTOBS(JN))%ALBEDO = ALBEDO(JN)
PROFILES_QC(IPTOBS(JN))%PCNT_WAT = PCNT_WAT(JN)
PROFILES_QC(IPTOBS(JN))%LTYPE = LTYPE(JN)
END DO
!* find the regional water fraction (here in a 15x15 pixel box centered on profile)
CALL PCNT_BOX (F_LOW, waterf,nprf,ilat,ilon,kslat,kslon,7)
DO JN = 1, NPRF
PROFILES_QC(IPTOBS(JN))%PCNT_REG = F_LOW(JN)
END DO
END SUBROUTINE NEW_EMISS