!--------------------------------------- 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 --------------------------------------
Module emissivities 1,3
!************************************************************************
!*
!* COMDECK EMISSIVITIES
!* --------------------
!*
!* PURPOSE: VARIABLES FOR IR EMISSIVITIES COMPUTATION
!*
!* SURFACE TYPE AND WATER FRACTION ARE FROM CERES DATA.
!*
!*
!* AUTHOR: A. BEAULNE (CMDA/SMC) February 2006
!*
!* REVISION: A. BEAULNE (CMDA/SMC) July 2013
!* Only keep information from Ceres,
!* so removing albedo, ice and snow.
!*
!************************************************************************
use tovs_nl_mod
use multi_ir_bgck_mod
use hir_chans
implicit none
save
private
! public procedures
public :: EMIS_GET_IR_EMISSIVITY, EMIS_READ_CLIMATOLOGY
! CERES file dimension in grid points
INTEGER, PARAMETER :: KSLON=2160, KSLAT=1080
! Variables on standard files
INTEGER :: JTYPE(KSLON,KSLAT) ! surface type
REAL(8) :: WATERF(KSLON,KSLAT) ! water fraction
contains
SUBROUTINE COMP_IR_EMISS (EMISS, wind,angle,nchn,np,mchannel) 1
!
!**ID COMP_IR_EMISS -- INFRARED EMISSIVITY COMPUTATION
!
! AUTHOR: Thomas J. Kleespies 8 February 1998
! Physics Branch
! Satellite Research Laboratory
! Office of Research and Applications
! NOAA/NESDIS
! 301-763-8136 x126
! 301-763-8108 FAX
! Mailing Address: 810 NSC E/RA-14
! NOAA/NESDIS
! Washington, D.C. 20233
! Email: TKleespies@nesdis.noaa.gov
!
! L. GARAND modified for NP points
! A. BEAULNE (CMDA/SMC) April 2006 (ADAPT TO 3DVAR)
!
! REVISION:
!
! OBJECT: COMPUTES WATER INFRARED EMISSIVITY FOR A SPECIFIC SET OF
! CHANNEL INDICES, WIND SPEED AND ZENITH ANGLE.
!
! Restrictions: Must be compiled with /EXTEND_SOURCE or it's equivalent
!
! ARGUMENTS:
! INPUT:
! -WIND(NP) : SURFACE WIND SPEED (M/S)
! -ANGLE(NP) : VIEWING ANGLE (DEG)
! -NCHN : NUMBER OF CHANNELS TO PROCESS
! -NP : NUMBER OF LOCATIONS
! -MCHANNEL(NCHN) : VECTOR OF CHANNEL INDICES TO PROCESS
!
! OUTPUT:
! -EMISS(NCHN,NP) : EMISSIVITIES (0.-1.)
!
Implicit None
integer ,intent(in) :: nchn,np
Real (8) ,intent(out):: Emiss(Nchn,NP)
Real (8) ,intent(in) :: Wind(NP),Angle(NP)
Integer ,intent(in) :: Mchannel(Nchn)
!***********************************************
Integer ,parameter :: MaxWn = 19
Integer ,parameter :: Nparm=3
Integer ,parameter :: MaxChan=19
Real (8) Theta(Nparm,MaxWn)
Real (8) C(Nparm,2,MaxWn)
Real (8) A(MaxChan),B(MaxChan),CC(MaxChan) ! local variable
real (8) WW
Integer Index,Ichan,IP
Data Theta / &
1700.381d0, 25.28534d0, 144.1023d0, &
1738.149d0, 25.67787d0, 146.6139d0, &
1769.553d0, 26.05250d0, 148.6586d0, &
1778.610d0, 26.12333d0, 149.5127d0, &
1794.245d0, 26.18523d0, 150.5874d0, &
1791.904d0, 26.19991d0, 150.7076d0, &
1806.872d0, 26.37132d0, 151.7191d0, &
1926.078d0, 27.63825d0, 160.7103d0, &
1969.155d0, 28.02767d0, 163.6069d0, &
1975.549d0, 27.86465d0, 164.6228d0, &
1991.288d0, 27.94312d0, 166.2924d0, &
2082.691d0, 28.93558d0, 172.4025d0, &
2182.872d0, 29.89974d0, 179.5839d0, &
2338.510d0, 31.27507d0, 191.2063d0, &
2164.615d0, 28.97152d0, 182.6279d0, &
2099.714d0, 29.91868d0, 178.4015d0, &
1857.644d0, 29.13640d0, 160.9822d0, &
1610.696d0, 26.48602d0, 142.2768d0, &
1503.969d0, 24.97931d0, 133.4392d0 /
Data C / &
0.9715104043561414d0,-1.2034233230944147D-06, &
-5.8742655960993913D-07, &
0.9263932848727608d0,-9.4908630939690859D-04, &
2.2831134823358876D-05, &
0.9732503924722753d0,-1.2007007329295099D-06, &
-5.8767355551283423D-07, &
0.9290947860585505d0,-9.5233413988900161D-04, &
2.2640835623043761D-05, &
0.9745005204317289d0, 1.2857517639804244D-06, &
-7.1356127087301190D-07, &
0.9310852809117095d0,-9.5453509182819095D-04, &
2.2562638663187251D-05, &
0.9756204829761132d0, 1.2979181109743976D-06, &
-7.1406809362820139D-07, &
0.9329073568177888d0,-9.5627536945214183D-04, &
2.2442358508999558D-05, &
0.9764012672766408d0,-2.0826654381361387D-06, &
-4.9103920569405721D-07, &
0.9341937281933334d0,-9.5764423928102976D-04, &
2.2326701573603621D-05, &
0.9770513558720460d0, 4.1867599593267133D-07, &
-6.1768073971231931D-07, &
0.9352981872014672d0,-9.5833614545300181D-04, &
2.2261996883974513D-05, &
0.9775970810179080d0,-1.2289690625562906D-06, &
-5.2953762169985775D-07, &
0.9362188153954743d0,-9.5950872922696905D-04, &
2.2251301675423482D-05, &
0.9830610391451819d0, 2.7693589475690676D-07, &
-5.1580217018207558D-07, &
0.9461121192685766d0,-9.5718115604053031D-04, &
2.1087308573177295D-05, &
0.9840097930773377d0,-1.4987900189155091D-06, &
-3.8281408128977038D-07, &
0.9479758694804105d0,-9.5451252460440695D-04, &
2.0800627740862229D-05, &
0.9851056150728580d0,-6.5768237152417477D-07, &
-4.2053769829400935D-07, &
0.9502084544618980d0,-9.4965534997704157D-04, &
2.0326602209199427D-05, &
0.9862706396188835d0,-2.3713068057993353D-06, &
-2.8671134918457728D-07, &
0.9526580467595886d0,-9.4614505430749598D-04, &
2.0001856872595840D-05, &
0.9875307221489201d0, 1.3003462826947714D-07, &
-4.1335288320283954D-07, &
0.9554195617948236d0,-9.3806678196435643D-04, &
1.9407754748128057D-05, &
0.9891153260567763d0,-8.0730206675976713D-07, &
-3.1811320626834656D-07, &
0.9590558393678170d0,-9.2716287670223167D-04, &
1.8690586764925213D-05, &
0.9913304557147524d0,-2.1153391229093421D-08, &
-3.1094269595901165D-07, &
0.9644162604969492d0,-9.0342753739935612D-04, &
1.7274993357160937D-05, &
0.9925188366950193d0,-4.6365959315123653D-07, &
-2.7020120347068712D-07, &
0.9667877170960085d0,-9.0665804037922043D-04, &
1.7083616616646458D-05, &
0.9919408379810360d0,-2.0563508815953840D-06, &
-1.8066722718403761D-07, &
0.9627535343397309d0,-9.7537134133678965D-04, &
1.9698263973541952D-05, &
0.9889406296815972d0,-2.3713068057993353D-06, &
-2.8671134918457728D-07, &
0.9506051906192242d0,-1.0642902225813857D-03, &
2.4235485973033298D-05, &
0.9828819693848310d0,-7.4086701870172759D-07, &
-6.2949258820534062D-07, &
0.9329616683158125d0,-1.0728027288012200D-03, &
2.7209071863380586D-05, &
0.9767410313266288d0,-9.1750038410238915D-07, &
-7.9177921107781349D-07, &
0.9192775350344998d0,-1.0369254272157462D-03, &
2.8000594542037504D-05 &
/
Save Theta,C
Do Ichan = 1 , Nchn
Index = Mchannel(Ichan)
DO IP=1,NP
WW=WIND(IP)
A(Ichan) = C(1,1,Index) + C(2,1,Index)*WW &
+ C(3,1,Index)*WW*WW
B(Ichan) = C(1,2,Index) + C(2,2,Index)*WW &
+ C(3,2,Index)*WW*WW
CC(Ichan) = Theta(1,Index) + Theta(2,Index)*WW
Emiss(Ichan,IP) = A(Ichan) + (B(Ichan)-A(Ichan)) * &
Exp(( (Theta(3,Index)-60.d0)**2.d0 &
- (Angle(IP)-Theta(3,Index))**2.d0 )/CC(Ichan))
ENDDO
EndDo
Return
End SUBROUTINE COMP_IR_EMISS
SUBROUTINE PCNT_BOX(F_LOW, f_high,nprf,ilat,ilon,klat,klon,ireduc) 1
!
!**ID PCNT_BOX -- COMPUTES A LOW_RESOLUTION FEATURE FROM HIGH RESOLUTION
!
! AUTHOR: L. GARAND (ARMA) AND A. BEAULNE (CMDA/SMC) June 2006
!
! REVISION:
!
! OBJECT: COMPUTES A LOW RESOLUTION FEATURE FORM A HIGH
! RESOLUTION ONE BY AVERAGING.
! EXAMPLE: USE FOR PERCENTAGE OF WATER
!
!
! ARGUMENTS:
! INPUT:
! -F_HIGH(KLON,KLAT) : HIGH RESOLUTION FIELD
! -NPRF : NUMBER OF PROFILES
! -ILAT(NPRF) : Y-COORDINATE OF PROFILE
! -ILON(NPRF) : X-COORDINATE OF PROFILE
! -KLAT : MAX VALUE OF LATITUDE INDICES
! -KLON : MAX VALUE OF LONGITUDE INDICES
! -IREDUC : MEANS A 2xIREDUC+1 BY 2xIREDUC+1 AVERAGING
!
! OUTPUT:
! -FLOW(NPRF) : LOW RESOLUTION FIELD
!
IMPLICIT NONE
integer ,intent(in) :: NPRF,KLON,KLAT,ireduc
INTEGER ,intent(in) :: ILAT(NPRF), ILON(NPRF)
REAL (8),intent(in) :: F_HIGH(KLON,KLAT)
REAL (8),intent(out) :: F_LOW(NPRF)
!*************************************************************
INTEGER :: NPLON, JDLO1, JDLO2, JLON1, JLON2
INTEGER :: NX, ILAT1, ILAT2, ILON1, ILON2, JN, ii, jj
profiles : DO JN = 1,NPRF
NPLON=0
! normal limits
ilat1=max(ilat(JN)-IREDUC,1)
ilat2=min(ilat(JN)+IREDUC,KLAT)
ilon1=max(ilon(JN)-IREDUC,1)
ilon2=min(ilon(JN)+IREDUC,KLON)
IF(ilon1==1.or.ilon2==klon) then
! border cases for longitudes
JDLO1 = ILON(JN)-IREDUC
JDLO2 = ILON(JN)+IREDUC
IF ( JDLO1.LE.0 ) THEN
NPLON=1
JLON1= KLON+JDLO1
JLON2= KLON
ELSE IF ( JDLO2.gt.KLON ) THEN
NPLON=1
JLON1=1
JLON2=JDLO2-KLON
END IF
endif
NX=0
F_LOW(JN)=0.d0
DO JJ = ILAT1, ILAT2
DO II = ILON1, ILON2
NX=NX+1
F_LOW(JN)=F_LOW(JN)+F_HIGH(II,JJ)
END DO
IF (NPLON.eq.1) THEN
! additional cases at border 1-KLON
DO II = JLON1, JLON2
NX=NX+1
F_LOW(JN)=F_LOW(JN)+F_HIGH(II,JJ)
END DO
END IF
END DO
F_LOW(JN)=F_LOW(JN)/dble(NX)
END DO profiles
END SUBROUTINE PCNT_BOX
SUBROUTINE emis_read_climatology 1,2
!
!**ID emis_read_climatology -- READ INFORMATION FOR IR SURFACE EMISSIVITIES COMPUTATION
!
! AUTHOR: A. BEAULNE (CMDA/SMC) March 2006
!
! OBJECT: READ INFORMATION ABOUT CERES SURFACE TYPE AND WATER FRACTION.
!
! REVISION: A. Beaulne (CMDA/SMC) July 2013
! Use only for reading Ceres information,
! so albedo, ice and snow now done in interp_sfc.ftn90.
! ARGUMENTS:
! INPUT: NONE
! OUTPUT: NONE
!
IMPLICIT NONE
INTEGER :: NISF,NJSF,NKSF
INTEGER :: NIWA,NJWA,NKWA
CHARACTER(len=100) :: CFILE
INTEGER,EXTERNAL :: FNOM,FSTOUV,VFSTLIR,FSTFRM,FCLOS,FSTLIR
integer :: isftest
integer :: iv1,iv2,iv3,iv4,iv5,iv6
isftest = 0
!* get surface type and water fraction
CFILE='ceres_global.std'
IV1=FNOM(ISFTEST,CFILE,'RND+R/O',0)
IV2=FSTOUV(ISFTEST,'RND')
IV3=FSTLIR(JTYPE,ISFTEST,NISF,NJSF,NKSF,-1,'SFC-TYPE',-1,-1,-1,'','TY')
IV4=VFSTLIR(WATERF,ISFTEST,NIWA,NJWA,NKWA,-1,'WATER_FR',-1,-1,-1,'','W%')
IV5=FSTFRM(ISFTEST)
IV6=FCLOS(ISFTEST)
if (iv1.lt.0.or.iv2.lt.0.or.iv3.lt.0.or.iv4.lt.0.or.iv5.lt.0.or.iv6.lt.0) then
write(*,*) 'LES IV DE CERES ',iv1,iv2,iv3,iv4,iv5,iv6
write(*,*) 'THESE NUMBER SHOULD NOT BE NEGATIVE WHEN DOING AIRS BACKGROUND CHECK'
call abort3d('Problem with file ceres_global.std in emis_read_climatology ')
endif
END SUBROUTINE emis_read_climatology
SUBROUTINE EMIS_GET_IR_EMISSIVITY ( SURFEM1, nchn,krtid,nprf,nchannels_max,iptobs) 1,7
!
!* 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.
!*
!* - Continue the "find the bands (central) wavenumber" IF loop
!* for your specific instrument
!
!**ID EMIS_GET_IR_EMISSIVITY -- ASSIGN NEW IR SURFACE EMISSIVITIES
!
! SCIENCE: L. GARAND
! AUTHOR: A. BEAULNE (CMDA/SMC) June 2006
!
! 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)
!
IMPLICIT NONE
INTEGER,intent(in) :: NPRF,NCHANNELS_MAX
INTEGER,intent(in) :: NCHN,IPTOBS(NPRF),KRTID
REAL(8),intent(out) :: SURFEM1(NCHANNELS_MAX)
!****************************************************
INTEGER :: JC,JN,ICHN
INTEGER :: KSURF(NPRF), LTYPE(NPRF)
INTEGER :: ILAT(NPRF), ILON(NPRF)
REAL(8) :: ALBEDO(NPRF), ICE(NPRF), SNOW(NPRF), PCNT_WAT(NPRF)
REAL(8) :: ZLAT(NPRF), ZLON(NPRF), UWIND(NPRF), VWIND(NPRF), SATZANG(NPRF)
REAL (8) :: WIND_SFC(NPRF), F_LOW(NPRF)
REAL (8),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 ( INSTRUMENT(KRTID) == 11 ) THEN !! --AIRS--
DO JC = 1, NCHN
ICHN = ICHAN(JC,KRTID)
WAVEN(JC) = hir_get_wavn("AIRS",ICHN)
END DO
ELSE IF ( INSTRUMENT(KRTID) == 16 ) THEN !! --IASI--
DO JC = 1, NCHN
ICHN = ICHAN(JC,KRTID)
WAVEN(JC) = hir_get_wavn("IASI",ICHN)
END DO
ELSE IF ( INSTRUMENT(KRTID) == 27 ) THEN !! --CrIS--
DO JC = 1, NCHN
ICHN = ICHAN(JC,KRTID)
WAVEN(JC) = hir_get_wavn("CRIS",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(UWIND(JN)**2 + VWIND(JN)**2 + 1.d-12),15.d0)
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,satzang,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 EMIS_GET_IR_EMISSIVITY
SUBROUTINE INTERP_SFC (ILAT,ILON, nprf,zlat,zlon,iptobs) 1,5
!
!**ID INTERP_SFC -- ASSOCIATE SURFACE FIELDS TO OBSERVATION PROFILES
!
! AUTHOR: L. GARAND
! A. BEAULNE (CMDA/SMC) March 2006 (ADAPT TO 3DVAR)
!
! OBJECT: ASSOCIATE SURFACE ALBEDO, ICE FRACTION, SNOW DEPTH
! AND CERES SURFACE TYPE AND WATER FRACTION TO OBSERVATIONS PROFILES.
!
! REVISION: A. BEAULNE (CMDA/SMC) July 2013
! - GRID COMPUTATION PREVIOUSLY DONE IN SFC_EMISS FOR
! ICE,SNOW AND ALBEDO NOW DONE HERE FOR
! GENERALIZATION IN ACCEPTING ANY KIND OF GRID
!
! ARGUMENTS:
! INPUT:
! -NPRF : NUMBER OF PROFILES
! -ZLAT(NPRF) : LATITUDE (-90S TO 90N)
! -ZLON(NPRF) : LONGITUDE (0 TO 360)
!
! OUTPUT:
! -ILAT(NPRF) : Y-COORDINATE OF PROFILE
! -ILON(NPRF) : X-COORDINATE OF PROFILE
!
IMPLICIT NONE
INTEGER,intent(in) :: NPRF, IPTOBS(NPRF)
REAL(8),intent(in) :: ZLAT(NPRF), ZLON(NPRF)
INTEGER,intent(out):: ILAT(NPRF), ILON(NPRF)
!**********************************************************
CHARACTER(len=100) :: CFILE3,CFILE5
INTEGER :: iun3,iun5
INTEGER :: IV6,IV7
INTEGER :: IX1,IX2,IX3,IX4,IX5, IX8,IX9,IX10,IX11,IX12
INTEGER :: IY3,IY4,IY5, IY8,IY9,IY10
INTEGER :: IZ1,IZ2,IZ3,IZ4,IZ5, IZ8,IZ9,IZ10,IZ11,IZ12
INTEGER :: NI3,NJ3,NK3
INTEGER :: NI4,NJ4,NK4
INTEGER :: NI5,NJ5,NK5
INTEGER :: DATEO,DEET,NPAS,NBITS,DATYP
INTEGER :: IP1,IP2,IP3
INTEGER :: IG13,IG23,IG33,IG43
INTEGER :: IG14,IG24,IG34,IG44
INTEGER :: IG15,IG25,IG35,IG45
INTEGER :: SWA,LNG,DLTF,UBC,EX1,EX2,EX3
INTEGER :: JN
CHARACTER(len=1) :: TYPVAR
CHARACTER(len=1) :: GRTYP3,GRTYP4,GRTYP5
CHARACTER(len=2) :: NOMVAR, snowvar
CHARACTER(len=8) :: ETIKET
INTEGER,EXTERNAL :: FNOM,FSTOUV,FSTINF,FSTPRM,FSTFRM,FCLOS
INTEGER,EXTERNAL :: ezsetopt,ezqkdef,ezdefset
INTEGER :: vfstlir,vezgdef,vezsint
REAL(8) :: zig1,zig2,zig3,zig4
INTEGER :: ig1obs,ig2obs,ig3obs,ig4obs
REAL (8) :: ALAT, ALON, ZZLAT, ZZLON
!! fields on input grid
REAL(8),ALLOCATABLE,DIMENSION(:,:) :: GLACE, NEIGE, ALB
!! fields on output grid
REAL(8),DIMENSION(NPRF) :: GLACE_INTRPL, NEIGE_INTRPL, ALB_INTRPL
! printout header
write(*,*)
write(*,*) 'SUBROUTINE INTERP_SFC'
write(*,*) '---------------------'
write(*,*) ' called multiple time by bunch of ',nprf,' profiles'
write(*,*) ' <RETURN CODES> SHOULD NOT BE NEGATIVE'
write(*,*) '---------------------------------------------------'
!* --- FOR CERES VARIABLES -------------
!* get number of pixels per degree of lat or lon
ALAT = DBLE(KSLAT)/180.d0
ALON = DBLE(KSLON)/360.d0
DO JN=1,NPRF
!* get lat and lon within limits if necessary
ZZLAT = MIN(ZLAT(JN),89.999d0)
ZZLAT = MAX(ZZLAT,-89.999d0)
ZZLON = MIN(ZLON(JN),359.999d0)
ZZLON = MAX(ZZLON,0.d0)
!* find in which surface field pixel is located the observation profile
!* Note : CERES grid at 1/6 resolution
!* N-S : starts at N pole and excludes S pole
!* W-E : starts at longitude 0 and excludes longitude 360
ILAT(JN) = MAX(NINT((ZZLAT+90.d0)*ALAT),1)
ILON(JN) = NINT(ZZLON*ALON)+1
IF(ILON(JN)>KSLON) ILON(JN)=1
!* assign surface caracteristics to observation profiles
PROFILES_QC(IPTOBS(JN))%LTYPE = JTYPE(ILON(JN),ILAT(JN))
PROFILES_QC(IPTOBS(JN))%PCNT_WAT = WATERF(ILON(JN),ILAT(JN))
END DO
!* --- FOR ICE, SNOW AND ALBEDO VARIABLES -------------
iun3 = 0
iun5 = 0
! files name
CFILE3 = 'sfc4airs' ! for ice fraction and snow cover
CFILE5 = 'sfc4airs_newalb' ! for albedo
! FNOM: make the connections with the external files name
! success = 0
write(*,*)
IX1 = FNOM(iun3,CFILE3,'RND+R/O',0)
write(*,*) 'file = sfc4airs : FNOM : return = ', IX1
IZ1 = FNOM(iun5,CFILE5,'RND+R/O',0)
write(*,*) 'file = sfc4airs_newalb : FNOM : return = ', IZ1
! FSTOUV: open the standard files
! success = number of records found in the file
write(*,*)
IX2 = FSTOUV(iun3,'RND')
write(*,*) 'file = sfc4airs : FSTOUV : return = ', IX2
IZ2 = FSTOUV(iun5,'RND')
write(*,*) 'file = sfc4airs_newalb : FSTOUV : return = ', IZ2
! FSTINF: locate the records that matches the search keys
! success = handle of the record found after the search
! desired output = handle
write(*,*)
IX3 = FSTINF(iun3,NI3,NJ3,NK3,-1,'',-1,-1,-1,'','LG')
write(*,*) 'variable = LG : FSTINF : return = ', IX3
snowvar='SD'
IY3 = FSTINF(iun3,NI4,NJ4,NK4,-1,'',-1,-1,-1,'',snowvar)
write(*,*) 'variable = ', snowvar, ' : FSTINF : return = ', IY3
if ( IY3 .lt. 0 ) then
write(*,*) 'did not find ''SD'' so look for ''NE'''
snowvar='NE'
IY3 = FSTINF(iun3,NI4,NJ4,NK4,-1,'',-1,-1,-1,'',snowvar)
write(*,*) 'variable = ', snowvar, ' : FSTINF : return = ', IY3
end if
IZ3 = FSTINF(iun5,NI5,NJ5,NK5,-1,'',-1,-1,-1,'','AL')
write(*,*) 'variable = AL : FSTINF : return = ', IZ3
! FSTPRM: get the description informations of the record given the key
! success = 0
! desired output = NIx,NJx,GRTYPx,IGxx,IG1x,IG2x,IG3x,IG4x
write(*,*)
IX4 = FSTPRM(ix3, DATEO,DEET,NPAS,NI3,NJ3,NK3,NBITS,DATYP, &
IP1,IP2,IP3,TYPVAR,NOMVAR,ETIKET,GRTYP3, &
IG13,IG23,IG33,IG43,SWA,LNG,DLTF,UBC,EX1,EX2,EX3)
write(*,*) 'variable = LG : FSTPRM : return = ', IX4
IY4 = FSTPRM(iy3, DATEO,DEET,NPAS,NI4,NJ4,NK4,NBITS,DATYP, &
IP1,IP2,IP3,TYPVAR,NOMVAR,ETIKET,GRTYP4, &
IG14,IG24,IG34,IG44,SWA,LNG,DLTF,UBC,EX1,EX2,EX3)
write(*,*) 'variable = ', snowvar, ' : FSTPRM : return = ', IY4
IZ4 = FSTPRM(iz3, DATEO,DEET,NPAS,NI5,NJ5,NK5,NBITS,DATYP, &
IP1,IP2,IP3,TYPVAR,NOMVAR,ETIKET,GRTYP5, &
IG15,IG25,IG35,IG45,SWA,LNG,DLTF,UBC,EX1,EX2,EX3)
write(*,*) 'variable = AL : FSTPRM : return = ', IZ4
! allocation of the field on the grid
ALLOCATE ( GLACE (NI3,NJ3) )
ALLOCATE ( NEIGE (NI4,NJ4) )
ALLOCATE ( ALB (NI5,NJ5) )
! VFSTLIR: read records data (field on the grid) given the key
! success = handle of the record
! desired output = FIELD
write(*,*)
IX5 = vfstlir(GLACE, iun3,NI3,NJ3,NK3,-1,'',-1,-1,-1,'','LG')
write(*,*) 'variable = LG : VFSTLIR : return = ', IX5
IY5 = vfstlir(NEIGE, iun3,NI4,NJ4,NK4,-1,'',-1,-1,-1,'',snowvar)
write(*,*) 'variable = ', snowvar, ' : VFSTLIR : return = ', IY5
IZ5 = vfstlir(ALB, iun5,NI5,NJ5,NK5,-1,'',-1,-1,-1,'','AL')
write(*,*) 'variable = AL : VFSTLIR : return = ', IZ5
! EZSETOPT: set nearest neighbor interpolation option within EZSCINT package
! success = 0
write(*,*)
IV6 = ezsetopt('INTERP_DEGREE','NEAREST')
write(*,*) 'apply to all variables : ezsetopt : return = ', IV6
! VCXGAIG: define the grid descriptors (integer form) of the
! observation profile output grid
! desired output = IG1OBS, IG2OBS, IG3OBS, IG4OBS
zig1 = 0.0D0
zig2 = 0.0D0
zig3 = 1.0D0
zig4 = 1.0D0
call vcxgaig('L',IG1OBS,IG2OBS,IG3OBS,IG4OBS,zig1,zig2,zig3,zig4)
! VEZGDEF: define the grid of the observations profiles (output grid)
! of type Y containing the lat-lon of profiles
! success = token to identify the grid
! desired output = token
write(*,*)
IV7 = vezgdef(nprf,1,'Y','L',ig1obs,ig2obs,ig3obs,ig4obs,zlon,zlat)
write(*,*) 'apply to all variables : VEZGDEF : return = ', IV7
! EZQKDEF: define the grid of the records data (input grid)
! success = token to identify the grid
! desired output = token
! EZDEFSET: interpolate from input grids to output grid
! success = key
! VEZSINT: interpolation of the field on the input grid to observation profiles
! success = 0
! desired output = FIELD_INTRPL
write(*,*)
IX8 = ezqkdef(ni3,nj3,grtyp3,ig13,ig23,ig33,ig43,iun3)
write(*,*) 'variable = LG : ezqkdef : return = ', IX8
IX9 = ezdefset(iv7,ix8)
write(*,*) 'variable = LG : ezdefset : return = ', IX9
IX10 = vezsint(GLACE_INTRPL,glace,nprf,1,1,ni3,nj3,1)
write(*,*) 'variable = LG : vezsint : return = ', IX10
write(*,*)
IY8 = ezqkdef(ni4,nj4,grtyp4,ig14,ig24,ig34,ig44,iun3)
write(*,*) 'variable = ', snowvar, ' : ezqkdef : return = ', IY8
IY9 = ezdefset(iv7,iy8)
write(*,*) 'variable = ', snowvar, ' : ezdefset : return = ', IY9
IY10 = vezsint(NEIGE_INTRPL,neige,nprf,1,1,ni4,nj4,1)
write(*,*) 'variable = ', snowvar, ' : vezsint : return = ', IY10
write(*,*)
IZ8 = ezqkdef(ni5,nj5,grtyp5,ig15,ig25,ig35,ig45,iun5)
write(*,*) 'variable = AL : ezqkdef : return = ', IZ8
IZ9 = ezdefset(iv7,iz8)
write(*,*) 'variable = AL : ezdefset : return = ', IZ9
IZ10 = vezsint(ALB_INTRPL,alb,nprf,1,1,ni5,nj5,1)
write(*,*) 'variable = AL : vezsint : return = ', IZ10
! FSTFRM: close the standard files
! success = 0
write(*,*)
IX11 = FSTFRM(iun3)
write(*,*) 'file = sfc4airs : FSTFRM : return = ', IX11
IZ11 = FSTFRM(iun5)
write(*,*) 'file = sfc4airs_newalb : FSTFRM : return = ', IZ11
! FCLOS: release the connections with the external files name
! success = 0
write(*,*)
IX12 = FCLOS(iun3)
write(*,*) 'file = sfc4airs : FCLOS : return = ', IX12
IZ12 = FCLOS(iun5)
write(*,*) 'file = sfc4airs_newalb : FCLOS : return = ', IZ12
! assign surface caracteristics to observation profiles
DO JN=1,NPRF
PROFILES_QC(IPTOBS(JN))%ICE = GLACE_INTRPL(JN)
PROFILES_QC(IPTOBS(JN))%SNOW = NEIGE_INTRPL(JN)
PROFILES_QC(IPTOBS(JN))%ALBEDO = ALB_INTRPL(JN)
END DO
DEALLOCATE(GLACE,NEIGE,ALB)
END SUBROUTINE INTERP_SFC
SUBROUTINE CERES_EMATRIX(EMI_MAT, waven,nchn) 1
!
!**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)
!
IMPLICIT NONE
integer ,intent(in) :: NCHN
REAL (8),intent(in) :: WAVEN(NCHN)
REAL (8),intent(out):: EMI_MAT(NCHN,20)
!*********************************************
INTEGER :: I, NC, NT
REAL (8) :: DUM
! CERES bands central wavenumber (covers 3.7 micron to 71.4 mic)
Integer ,parameter :: NB=14
REAL (8) :: MID(NB)
! CERES emissivity per wavenumber and surface types
REAL (8) :: EMI_TAB(NB,20)
DATA MID / &
2675.d0, 2350.d0, 2050.d0, 1800.d0, 1550.d0, 1325.d0, 1175.d0, 1040.d0, &
890.d0, 735.d0, 605.d0, 470.d0, 340.d0, 140.d0 /
DATA EMI_TAB / &
0.951d0, 0.989d0, 0.989d0, 0.989d0, 0.990d0, 0.991d0, 0.991d0, 0.990d0, &
0.990d0, 0.995d0, 1.000d0, 1.000d0, 1.000d0, 1.000d0, &
0.956d0, 0.989d0, 0.989d0, 0.989d0, 0.990d0, 0.991d0, 0.991d0, 0.990d0, &
0.990d0, 0.995d0, 1.000d0, 1.000d0, 1.000d0, 1.000d0, &
0.929d0, 0.985d0, 0.985d0, 0.986d0, 0.984d0, 0.983d0, 0.979d0, 0.980d0, &
0.973d0, 0.987d0, 1.000d0, 1.000d0, 1.000d0, 1.000d0, &
0.943d0, 0.985d0, 0.985d0, 0.986d0, 0.984d0, 0.983d0, 0.979d0, 0.980d0, &
0.973d0, 0.987d0, 1.000d0, 1.000d0, 1.000d0, 1.000d0, &
0.945d0, 0.987d0, 0.987d0, 0.987d0, 0.987d0, 0.987d0, 0.985d0, 0.985d0, &
0.982d0, 0.991d0, 1.000d0, 1.000d0, 1.000d0, 1.000d0, &
0.933d0, 0.949d0, 0.949d0, 0.970d0, 0.974d0, 0.971d0, 0.947d0, 0.958d0, &
0.966d0, 0.975d0, 0.984d0, 0.984d0, 0.984d0, 0.984d0, &
0.873d0, 0.873d0, 0.873d0, 0.934d0, 0.944d0, 0.939d0, 0.873d0, 0.904d0, &
0.936d0, 0.942d0, 0.951d0, 0.951d0, 0.951d0, 0.951d0, &
0.930d0, 0.987d0, 0.987d0, 0.990d0, 0.992d0, 0.993d0, 0.983d0, 0.975d0, &
0.985d0, 0.993d0, 1.000d0, 1.000d0, 1.000d0, 1.000d0, &
0.926d0, 0.987d0, 0.987d0, 0.990d0, 0.992d0, 0.993d0, 0.983d0, 0.975d0, &
0.985d0, 0.993d0, 1.000d0, 1.000d0, 1.000d0, 1.000d0, &
0.899d0, 0.987d0, 0.987d0, 0.990d0, 0.992d0, 0.993d0, 0.983d0, 0.975d0, &
0.985d0, 0.993d0, 1.000d0, 1.000d0, 1.000d0, 1.000d0, &
0.951d0, 0.983d0, 0.983d0, 0.987d0, 0.987d0, 0.988d0, 0.983d0, 0.981d0, &
0.987d0, 0.982d0, 0.986d0, 0.986d0, 0.986d0, 0.986d0, &
0.924d0, 0.987d0, 0.987d0, 0.990d0, 0.992d0, 0.993d0, 0.983d0, 0.975d0, &
0.985d0, 0.993d0, 1.000d0, 1.000d0, 1.000d0, 1.000d0, &
0.929d0, 1.000d0, 1.000d0, 1.000d0, 1.000d0, 1.000d0, 1.000d0, 1.000d0, &
1.000d0, 1.000d0, 1.000d0, 1.000d0, 1.000d0, 1.000d0, &
0.926d0, 0.987d0, 0.987d0, 0.989d0, 0.989d0, 0.990d0, 0.984d0, 0.980d0, &
0.983d0, 0.992d0, 1.000d0, 1.000d0, 1.000d0, 1.000d0, &
0.972d0, 1.000d0, 1.000d0, 1.000d0, 1.000d0, 1.000d0, 1.000d0, 1.000d0, &
1.000d0, 0.999d0, 0.999d0, 0.999d0, 0.999d0, 0.999d0, &
0.866d0, 0.835d0, 0.835d0, 0.916d0, 0.934d0, 0.923d0, 0.835d0, 0.877d0, &
0.921d0, 0.926d0, 0.934d0, 0.934d0, 0.934d0, 0.934d0, &
0.973d0, 0.979d0, 0.979d0, 0.983d0, 0.982d0, 0.982d0, 0.984d0, 0.987d0, &
0.989d0, 0.972d0, 0.972d0, 0.972d0, 0.972d0, 0.972d0, &
0.968d0, 0.947d0, 0.947d0, 0.967d0, 0.988d0, 0.979d0, 0.975d0, 0.977d0, &
0.992d0, 0.989d0, 0.989d0, 0.989d0, 0.989d0, 0.989d0, &
0.984d0, 0.988d0, 0.988d0, 0.988d0, 0.988d0, 0.988d0, 0.988d0, 0.988d0, &
0.988d0, 0.988d0, 0.988d0, 0.988d0, 0.988d0, 0.988d0, &
0.964d0, 0.979d0, 0.979d0, 0.979d0, 0.979d0, 0.979d0, 0.979d0, 0.979d0, &
0.979d0, 0.979d0, 0.979d0, 0.979d0, 0.979d0, 0.979d0 /
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(NB) ) THEN
EMI_MAT(NC,NT) = EMI_TAB(NB,NT)
ELSE
DO I = 1, NB-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
SUBROUTINE EMI_SEA(EM_OC, wnum,angle,wind,np,nc) 1,1
!
!**ID EMI_SEA -- GET OCEAN SURFACE EMISSIVITY
!
! AUTHOR: L. GARAND March 1999
! improved with IMEM 2004
! A. BEAULNE (CMDA/SMC) April 2006 (ADAPT TO 3DVAR)
!
! REVISION:
!
! OBJECT: GET OCEAN SURFACE EMISSIVITY
!
! Note:
! IMEM(NC), set to zero initially, on next call IMEM will have the
! right boundary channel to save search time in interpolation.
! IOPT=1 means activate IMEM option (all calls ask for same channels)
!
! To get surface ocean emissivity for a group of channels with
! wavenumbers WNUM (cm-1) looking at one point with surface
! wind speed WIND from angle ANGLE.
! Based on Masuda,1988, Remote Sens. of Envir, 313-329.
! Coded emissivity routine based on Masuda's data by Tom Kleespies
! Covers 650-2857 cm-1 or 3.1-15.4 microns
!
! CAUTION: extrapolated values from 769-650 cm-1
! and interpolated values between 2439-1250 cm-1
!
! ARGUMENTS:
! INPUT:
! -WNUM(NC) : CHANNEL WAVENUMBERS (CM-1)
! -ANGLE : VIEWING ANGLE (DEG)
! -WIND : SURFACE WIND SPEED (M/S)
! -NP : NUMBER OF PROFILES
! -NC : NUMBER OF CHANNELS
!
! OUTPUT:
! -EM_OC(NC,NP) : OCEAN EMISSIVITIES (0.-1.)
!
IMPLICIT NONE
INTEGER,intent(in) :: NC,NP
REAL (8),intent(in) :: WNUM(NC),ANGLE(NP),WIND(NP)
REAL (8),intent(out) :: EM_OC(NC,NP)
!*******************************************************
INTEGER :: I,K,L
INTEGER :: IMEM(NC),IOPT
INTEGER :: MCHAN(2)
REAL (8) :: DUM
REAL (8) :: REFW(19),EMI2(2,NP)
!* Masuda's 19 wavelengths converted to wavenumber
DATA REFW/ 2857.1d0, 2777.7d0, 2702.7d0, 2631.6d0, 2564.1d0, &
2500.0d0, 2439.0d0, 1250.0d0, 1190.5d0, 1136.3d0, &
1087.0d0, 1041.7d0, 1000.0d0, 952.38d0, 909.09d0, &
869.57d0, 833.33d0, 800.00d0, 769.23d0/
!* IMEM options
IOPT = 1
IMEM(:) = 0
DO I = 1, NC
IF ( IMEM(I) > 0 .AND. IOPT == 1 ) GO TO 50
!* out of range
IF ( WNUM(I) < 645.d0 .OR. WNUM(I) > REFW(1) ) THEN
WRITE(*,44) WNUM(I)
44 FORMAT(' fatal: wavenumber out of range in emi_sea',e12.4)
STOP
END IF
!* extrapolated from 769 cm-1 to 645 cm-1: NOT FROM REAL DATA
!* nevertheless thought to be much better than unity
!* this is a region of relatively rapid emissivity change
!* worst estimates for 700-645 cm-1, but these channels do not
!* see the surface (strong co2 absorption).
IF ( WNUM(I) <= REFW(19) .AND. WNUM(I) > 645.d0 ) THEN
IMEM(I) = 18
GO TO 50
END IF
!* CAUTION interpolation on large interval 1250-2439 cm-1
!* where no data is available except that of ASTER. ASTER
!* shows a relatively smooth variation with wavelength except
!* for a sharp drop at 1600 cm-1 with highs at 1550 and 1650 cm-1
!* with peak-to-peak variation of 1.5% in that narrow range.
!* Worst estimates would be between 1400-1800 cm-1 in HIRS ch 12
!* which only in very cold atmospheres sees the surface.
DO K = 1, 18
IF ( WNUM(I) > REFW(K+1) .AND. WNUM(I) <= REFW(K) ) THEN
IMEM(I) = K
GO TO 50
END IF
END DO
50 CONTINUE
MCHAN(1)= IMEM(I)
MCHAN(2)= IMEM(I)+1
DUM = ( WNUM(I) - REFW(MCHAN(1)) ) / ( REFW(MCHAN(2)) - REFW(MCHAN(1)) )
CALL COMP_IR_EMISS(EMI2, wind,angle,2,np,mchan)
!* INTERPOLATION/EXTRAPOLATION in wavenumber
DO L = 1, NP
EM_OC(I,L) = EMI2(1,L) + ( EMI2(2,L) - EMI2(1,L) ) * DUM
END DO
END DO
END SUBROUTINE EMI_SEA
End module emissivities