!--------------------------------------- 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 multi_ir_bgck_mod 5,1
!************************************************************************
!*
!* MODULE MULTI_IR_BGCHECK
!* -------------------
!*
!* PURPOSE: VARIABLES FOR MULTISPECTRAL INFRARED BACKGROUND CHECK
!* AND QUALITY CONTROL
!*
!* AUTHOR: A. BEAULNE (CMDA/SMC) February 2006
!*
!* REVISION: adapted to IASI and CrIS by S. Heilliette
!*
!*
!************************************************************************
Use tovs_nl_mod
, only : jplev,rttov_coefs,transmission_Type,tvs_Is_idburp_tovs, &
tvs_Is_idburp_inst, &
radiance_d,lsensor,coefs,nchan,NSENSORS,PLATFORM,SATELLITE,INSTRUMENT,NOBTOV
implicit none
save
private
! Public functions (methods)
public :: hirqc,BGCK_IR_SETUP
! Public parameters (constants)
public :: NCLASSAVHRR,NIR,NVIS,NCHANAVHRR,NCO2,BITFLAG
! Public variables ("global")
public ::coefs_avhrr,avhrr_bgck,profiles_qc,transmission,transmission_d, emissivity
!public types
public :: avhrr_bgck_iasi,prof_qc
INTEGER ,PARAMETER :: NCLASSAVHRR=7
INTEGER ,PARAMETER :: NIR=3,NVIS=3
INTEGER ,PARAMETER :: NCHANAVHRR=NIR+NVIS
! Reference (and alternate) window channel for clear / cloudy profile detection
! (subroutine cloud_height)
INTEGER, PARAMETER :: IWINDOW_AIRS = 787, IWINDOW_ALT_AIRS = 950
INTEGER, PARAMETER :: IWINDOW_IASI = 1090, IWINDOW_ALT_IASI = 1133
INTEGER, PARAMETER :: IWINDOW_CRIS = 427, IWINDOW_ALT_CRIS = 529
! Number of channels (and their values) to use for cloud top height detection
! with the "background profile matching" method (subroutine cloud_top)
INTEGER, PARAMETER :: NCH_HE = 4
INTEGER, PARAMETER :: ILIST1_AIRS(NCH_HE) = (/ 528, 787, 950, 2209 /)
INTEGER, PARAMETER :: ILIST1_IASI(NCH_HE) = (/ 705, 1090, 1133, 7475 /)
INTEGER, PARAMETER :: ILIST1_CRIS(NCH_HE) = (/ 279, 427, 529, 1290 /)
! Number of channels (and their values) to use for cloud top height detection
! with the CO2-slicing method. IREFR is the reference channel number (and alternate).
! (subroutine co2_slicing)
INTEGER, PARAMETER :: NCO2 = 13
INTEGER, PARAMETER :: ILIST2_AIRS(NCO2) = (/ 204, 221, 232, 252, 262, 272, &
299, 305, 310, 355, 362, 375, 375 /)
INTEGER, PARAMETER :: ILIST2_PAIR_AIRS(NCO2) = (/ 252, 262, 272, 299, 305, 310, &
355, 362, 375, 375, 262, 252, 204/)
INTEGER, PARAMETER :: ILIST2_IASI(NCO2) = (/ 252, 269, 285, 309, 320, 332, &
363, 371, 375, 433, 442, 459, 459 /)
INTEGER, PARAMETER :: ILIST2_PAIR_IASI(NCO2) = (/ 309, 320, 332,363, 371, 375, &
433, 442, 459, 459, 320, 309, 252 /)
INTEGER, PARAMETER :: ILIST2_CRIS(NCO2) = (/ 99, 116, 138, 133, 158, 154, &
123, 143, 168, 163, 175, 198, 198 /)
INTEGER, PARAMETER :: ILIST2_PAIR_CRIS(NCO2) = (/ 133, 158, 154, 123, 143, 168, &
163, 175, 198, 198, 158, 133, 99 /)
! Cloud top units : (1) mb, (2) meters
! (subroutines cloud_height (IOPT1) and cloud_top (IOPT2))
INTEGER, PARAMETER :: IOPT1 = 2 ! verify subr input if iopt1 changes
INTEGER, PARAMETER :: IOPT2 = 1
! Cloud top based on which background profile matching (subroutine cloud_top)
! (0) brightness temperature, (1) radiance, (2) both
INTEGER, PARAMETER :: IHGT = 2
! Maximum delta temperature allowed between guess and true skin temperature
! over water (DTW) and land (DTL) (subroutine airsqc)
REAL(8), PARAMETER :: DTW = 1.5D0
REAL(8), PARAMETER :: DTL = 4.0D0
! Minimum and maximum RTTOV levels for LEV_START variable entering CO2 slicing
! In mb, between 50mb and 325mb (subroutine co2_slicing)
Real(8), PARAMETER :: PCO2MIN = 56.73D0, PCO2MAX = 321.5D0
! First channel affected by sun (for channels used only at night)
! (subroutine airsqc)
INTEGER, PARAMETER :: ICHN_SUN_AIRS = 1865
INTEGER, PARAMETER :: ICHN_SUN_IASI = 5446
INTEGER, PARAMETER :: ICHN_SUN_CRIS = 1147
! Minimum solar zenith angle for night (between 90 and 180)
! (subroutine airsqc)
REAL(8), PARAMETER :: NIGHT_ANG = 100.D0
! Highest flag in post files (value of N in 2^N)
! Currently 21
INTEGER, PARAMETER :: BITFLAG = 29
Real(8),parameter :: seuilalb_static(NIR,0:2)= reshape( (/ 70.0,67.0,50.0, &
40.0,37.0,37.0, &
70.0,57.0,40. /),(/3,3/) )
Real(8),parameter :: seuilalb_homog(NIR,0:2)= reshape( (/ 15.0,18.0,13.0, &
9.0,10.0,10.0, &
18.0,16.0,10.0 /),(/3,3/) )
Real(8) :: seuilbt_homog(NVIS+1:NVIS+NIR,0:2,1:2)= reshape( (/5.d0, 4.d0, 4.d0, 4.d0, 3.d0, 3.d0, &
5.d0, 4.d0, 4.d0, 5.d0, 5.d0, 5.d0, &
4.d0, 3.d0, 3.d0, 5.d0, 5.d0, 5.d0/), (/3,3,2/) )
type( rttov_coefs ) :: coefs_avhrr
TYPE avhrr_bgck_iasi
SEQUENCE
REAL(8) :: RADMOY(NCLASSAVHRR,NCHANAVHRR)
REAL(8) :: RADSTD(NCLASSAVHRR,NCHANAVHRR)
REAL(8) :: CFRAC(NCLASSAVHRR)
REAL(8) :: TBMOY(NCLASSAVHRR,NVIS+1:NVIS+NIR)
REAL(8) :: TBSTD(NCLASSAVHRR,NVIS+1:NVIS+NIR)
REAL(8) :: ALBEDMOY(NCLASSAVHRR,1:NVIS)
REAL(8) :: ALBEDSTD(NCLASSAVHRR,1:NVIS)
REAL(8) :: TBSTD_PIXELIASI(NVIS+1:NVIS+NIR)
REAL(8) :: ALBSTD_PIXELIASI(1:NVIS)
REAL(8) :: RADCLEARCALC(NVIS+1:NVIS+NIR)
REAL(8) :: TBCLEARCALC(NVIS+1:NVIS+NIR)
REAL(8) :: RADOVCALC(jplev,NVIS+1:NVIS+NIR)
REAL(8) :: TRANSMCALC(jplev,NVIS+1:NVIS+NIR)
REAL(8) :: TRANSMSURF(NVIS+1:NVIS+NIR)
REAL(8) :: EMISS(NVIS+1:NVIS+NIR)
END TYPE avhrr_bgck_iasi
TYPE prof_qc
SEQUENCE
REAL(8) :: LAT ! latitude (-90 to 90)
REAL(8) :: LON ! longitude (0 to 360)
REAL(8), POINTER :: Z(:) ! height field (m)
REAL(8) :: SUNZA ! sun zenith angle (deg)
REAL(8) :: ALBEDO ! surface albedo (0-1)
REAL(8) :: ICE ! ice cover (0-1)
REAL(8) :: SNOW ! snow cover (0-1)
REAL(8) :: PCNT_WAT ! water percentage in pixel containing profile (0-1)
REAL(8) :: PCNT_REG ! water percentage in an area around profile (0-1)
INTEGER :: LTYPE ! surface type (1,...,20)
END TYPE prof_qc
type(avhrr_bgck_iasi) , allocatable :: avhrr_bgck(:) ! avhrr parameters for IASI quality control
type( prof_qc ) , allocatable :: profiles_qc(:) ! profiles buffer used in airsqc call
type(transmission_Type) :: transmission ! transmissions full structure buffer used in rttov calls
type(transmission_Type) , allocatable :: transmission_d(:) ! transmissions organized by profile
real(8) , allocatable :: emissivity(:,:) ! surface emissivities organized by profiles and channels
contains
SUBROUTINE BGCK_IR_SETUP(lobsSpaceData) 1,11
#if defined (DOC)
!
! s/r BGCK_IR_SETUP : Memory allocation for the Hyperspectral Infrared
! background check variables
! (original name of routine: sutovalo)
!
! Revision:
! S. Heilliette
! - creation from tovs_setup_allo December 2013
#endif
use obsSpaceData_mod
IMPLICIT NONE
!implicits
type(struct_obs) :: lobsSpaceData
Integer :: alloc_status(2)
INTEGER :: KRTID
INTEGER :: JO, IDATYP,NCMAX
INTEGER :: ISENS, NC, NL
INTEGER :: ICHN
INTEGER :: NOBIASI
integer :: index_header
! 1. Determine the number of IASI profiles to be assimilated.
! . ---------------------------------------------------
NOBIASI = 0
! loop over all header indices of the 'TO' family
! Set the header list
! (& start at the beginning of the list)
call obs_set_current_header_list(lobsSpaceData,'TO')
HEADER: do
index_header = obs_getHeaderIndex(lobsSpaceData)
if (index_header < 0) exit HEADER
IDATYP = obs_headElem_i(lobsSpaceData,OBS_ITY,index_header)
IF ( .not. tvs_Is_idburp_tovs(IDATYP) ) cycle HEADER ! Proceed to the next header_index
IF ( tvs_Is_idburp_inst(IDATYP,"IASI") ) NOBIASI = NOBIASI + 1
ENDDO HEADER
write(*,*) ' BGCK_IR_SETUP: nobiasi = ', nobiasi
!-----------------------------------------------------------------------
! 2. Memory allocation for background check related variables
! . -----------------------------------------------------
allocate(profiles_qc(NOBTOV) , stat= alloc_status(1))
If( alloc_status(1) /= 0) then
WRITE(*,FMT=9201)
9201 FORMAT(' BGCK_IR_SETUP: Memory Allocation Error')
CALL ABORT3D('BGCK_IR_SETUP')
End If
do jo = 1, NOBTOV
isens = lsensor(jo)
nl = coefs(isens)%coef % nlevels
allocate( profiles_qc(jo) % z ( nl ) ,stat= alloc_status(1))
If( alloc_status(1)/=0 ) then
WRITE(*,FMT=9201)
CALL ABORT3D('BGCK_IR_SETUP')
End If
end do
!___ radiance by profile
alloc_status(:) = 0
do jo = 1, NOBTOV
isens = lsensor(jo)
nc = nchan(isens)
nl = coefs(isens) % coef % nlevels
allocate( radiance_d(jo) % overcast (nl-1,nc) ,stat= alloc_status(1))
radiance_d(jo) % overcast (:,:) = 0.d0
If( alloc_status(1) /= 0 ) then
WRITE(*,FMT=9201)
CALL ABORT3D('BGCK_IR_SETUP')
End If
end do
!___ transmission by profile
alloc_status(:) = 0
allocate( transmission_d(NOBTOV),stat= alloc_status(1))
do jo = 1, NOBTOV
isens = lsensor(jo)
nc = nchan(isens)
nl = coefs(isens) % coef % nlevels
!! allocate transmittance from surface and from pressure levels
allocate( transmission_d(jo) % tau_total ( nc ) ,stat= alloc_status(1))
allocate( transmission_d(jo) % tau_levels(nl,nc) ,stat= alloc_status(2))
If( any(alloc_status /= 0) ) then
WRITE(*,FMT=9201)
CALL ABORT3D('BGCK_IR_SETUP')
End If
end do
!___ emissivity by profile
ncmax = 1
do jo = 1, NOBTOV
isens = lsensor(jo)
nc = nchan(isens)
if (nc>ncmax) ncmax=nc
end do
allocate( emissivity (ncmax,NOBTOV) ,stat=alloc_status(1))
If( alloc_status(1) /= 0 ) then
WRITE(*,FMT=9201)
CALL ABORT3D('BGCK_IR_SETUP')
End If
DO KRTID = 1, NSENSORS
IF ( PLATFORM(KRTID) == 10 .AND. &
INSTRUMENT(KRTID) == 16 ) THEN
allocate ( avhrr_bgck(NOBIASI), stat= alloc_status(1))
If( alloc_status(1)/=0 ) then
WRITE(*,FMT=9201)
CALL ABORT3D('BGCK_IR_SETUP')
End If
EXIT
END IF
END DO
END SUBROUTINE BGCK_IR_SETUP
SUBROUTINE BGCK_GET_QCPARAM(CINSTR,IWINDOW,IWINDOW_ALT,ILIST1,ILIST2,ILIST2_PAIR,ICHN_SUN) 1,1
IMPLICIT NONE
character (len=*),intent(in) :: CINSTR
integer ,intent (out) :: IWINDOW,IWINDOW_ALT,ILIST1(NCH_HE),ILIST2(NCO2),ILIST2_PAIR(NCO2),ICHN_SUN
select case(trim(cinstr))
case ("AIRS","airs")
IWINDOW=IWINDOW_AIRS
IWINDOW_ALT=IWINDOW_ALT_AIRS
ILIST1=ILIST1_AIRS
ILIST2=ILIST2_AIRS
ILIST2_PAIR=ILIST2_PAIR_AIRS
ICHN_SUN=ICHN_SUN_AIRS
case("IASI","iasi")
IWINDOW=IWINDOW_IASI
IWINDOW_ALT=IWINDOW_ALT_IASI
ILIST1=ILIST1_IASI
ILIST2=ILIST2_IASI
ILIST2_PAIR=ILIST2_PAIR_IASI
ICHN_SUN=ICHN_SUN_IASI
case("CRIS","cris")
IWINDOW=IWINDOW_CRIS
IWINDOW_ALT=IWINDOW_ALT_CRIS
ILIST1=ILIST1_CRIS
ILIST2=ILIST2_CRIS
ILIST2_PAIR=ILIST2_PAIR_CRIS
ICHN_SUN=ICHN_SUN_CRIS
case default
Write(*,*) "Unknown instrument ",CINSTR
CALL ABORT3D('BGCK_GET_QCPARAM')
end select
END SUBROUTINE BGCK_GET_QCPARAM
SUBROUTINE HIRQC ( lcolumnhr, lobsSpaceData,CINST,id_in) 3,98
!
!**ID HIRQC -- QUALITY CONTROL OF HYPERSPECTRAL INFRARED OBSERVATIONS
!
! SCIENCE: L. GARAND
! AUTHOR: A. BEAULNE (CMDA/SMC) August 2004
! A. BEAULNE (CMDA/SMC) June 2006 (ADAPT TO 3DVAR)
! S. HEILLIETTE February 2008 (adaptation to IASI)
! S. MACPHERSON, S.HEILLIETTE (ARMA) February 2013
! -- modify test pour detecter le isatzen manquant ou anormal
!
! REVISION:
!
! OBJECT: ASSIGN ASSIMILATION FLAGS TO OBSERVATIONS
!
! ARGUMENTS:
! INPUT:
! -LOOP_DONE : NUMBER OF PREVIOUS CALLS TO HIRQC
!
! OUTPUT:
! -LEND : AT THE END OF THIS CALL TO HIRQC, DO ALL
! PROFILES BEEN TREATED (true) OR NOT (false)
!
use EarthConstants_mod
use MathPhysConstants_mod
use tovs_nl_mod
use hir_chans
use columnData_mod
use obsSpaceData_mod
use verticalCoord_mod
IMPLICIT NONE
integer,intent(in),optional :: id_in
type(struct_columnData),intent(in) :: lcolumnhr
type(struct_obs),intent(inout) :: lobsSpaceData
character (len=*),intent(in) :: CINST
!******************************************************************
type(struct_vco), pointer :: vco_trl
INTEGER :: JC,NCHN,JCH,JF,JL,NLEV,NLEVB,iextr,NPRF,NFLG,ICHN
INTEGER :: IWINDO,IWINDO_ALT
INTEGER :: INDEX_BODY,IDATA,IDATEND,INDEX_HEADER
INTEGER :: IDATYP
INTEGER :: DIFFTOP_MIN
INTEGER ,SAVE :: IMODTOP
INTEGER :: count
REAL(8) :: T_EFFECTIVE
integer :: alloc_status(30)
real(8) :: ZTG,ZPS,ZTS
real(8), allocatable :: ZT(:),ZHT(:),ZLQ(:),ZVLEV(:)
real(8), allocatable :: ZLEVMOD(:)
real(8), allocatable :: BTOBSERR(:),BTOBS(:),BTCALC(:),RCAL_CLR(:),SFCTAU(:)
real(8), allocatable :: ROBS(:),RCLD(:,:),TRANSM(:,:),EMI_SFC(:)
real(8), allocatable :: TOEXT(:),ZHOEXT(:)
real(8), allocatable :: PTOP_BT(:),PTOP_RD(:)
real(8), allocatable :: PMIN(:),DTAUDP1(:),MAXWF(:)
real(8), allocatable :: RCLD_AVHRR(:,:)
integer, allocatable :: REJFLAG(:,:)
integer, allocatable :: NTOP_BT(:),NTOP_RD(:)
integer, allocatable :: MINP(:),FATE(:)
real(8), allocatable :: xpres(:)
real(8) :: CLFR,SUNZA,SATAZIM,SATZEN,SUNAZIM
real(8) :: ALBEDO,ICE,PCNT_WAT,PCNT_REG
real(8) :: PTOP_EQ,PTOP_MB
real(8) :: PTOP_CO2(NCO2),FCLOUD_CO2(NCO2)
real(8) :: ETOP,VTOP,ECF,VCF,HE
real(8) :: TAMPON,CFSUB
real(8) :: ZTS_AVHRR(NCLASSAVHRR),SFCTAU_AVHRR(NIR),EMI_SFC_AVHRR(NIR),RCAL_CLR_AVHRR(NIR)
real(8) :: PTOP_BT_AVHRR(NIR,NCLASSAVHRR),PTOP_RD_AVHRR(NIR,NCLASSAVHRR)
real(8) :: BTOBS_AVHRR(NIR,NCLASSAVHRR),ROBS_AVHRR(NIR,NCLASSAVHRR),PTOP_EQ_AVHRR(NCLASSAVHRR)
real(8) :: CFRAC_AVHRR
real(8) :: avhrr_surfem1(NIR)
Real(8) :: seuil_albed(NIR)
integer :: KSURF,LTYPE
integer :: CLDFLAG,LEV_START
integer :: GNCLDFLAG
integer :: ICHREF,INDX(1)
integer :: NTOP_EQ,NTOP_MB
integer :: NGOOD
integer :: NTOP_CO2(NCO2)
integer :: CLDFLAG_AVHRR(NCLASSAVHRR),LEV_START_AVHRR(NCLASSAVHRR),ICHREF_AVHRR(NCLASSAVHRR),NTOP_RD_AVHRR(NIR,NCLASSAVHRR)
integer :: NTOP_BT_AVHRR(NIR,NCLASSAVHRR),NTOP_EQ_AVHRR(NCLASSAVHRR)
integer :: ICL
logical :: ASSIM_ALL
integer ,parameter :: nn=2
integer ,parameter :: ilist_avhrr(nn)=(/ 2 ,3 /)
integer :: cpt,iclass
logical :: bad
Real(8),parameter :: sunzenmax=87.12d0
Real(8) :: minpavhrr(2:3)
Real(8) :: anisot,zlamb,zcloud,scos,del,deltaphi
Integer :: ier,ijour,iloc(2:3),co2min(1),co2max(1),iobs
integer :: isatzen
integer :: chan_indx,ILIST_SUN,ilist_co2(NCO2),ilist_co2_pair(NCO2),ilist_he(NCH_HE)
!********************************************************************************************
integer :: nlv_T,nch_sel,id,KRTID
integer :: IWINDOW,IWINDOW_ALT,ILIST1(NCH_HE),ILIST2(NCO2),ILIST2_PAIR(NCO2),ICHN_SUN
logical :: liasi,lairs,lcris
!****************************************
liasi= ( trim(cinst)=="IASI" .or. trim(cinst)=="iasi")
lairs= ( trim(cinst)=="AIRS" .or. trim(cinst)=="airs")
lcris= ( trim(cinst)=="CRIS" .or. trim(cinst)=="cris")
call BGCK_GET_QCPARAM(cinst,IWINDOW,IWINDOW_ALT,ILIST1,ILIST2,ILIST2_PAIR,ICHN_SUN)
vco_trl => col_getVco(lcolumnhr)
if (present(id_in)) then
id=id_in
else
! ** find sensor number corresponding to the desired instrument
ID =-1
DO KRTID = 1, NSENSORS
IF ( trim(CINSTRUMENTID(KRTID)) .EQ. TRIM(CINST)) THEN
ID = KRTID
EXIT
END IF
END DO
IF (ID<0) Call abort3d("hirqc: should not happen !")
endif
! ** find number of profiles
count = 0
! loop over all header indices of the 'TO' family
call obs_set_current_header_list(lobsSpaceData,'TO')
HEADER: do
index_header = obs_getHeaderIndex(lobsSpaceData)
if (index_header < 0) exit HEADER
IDATYP = obs_headElem_i(lobsSpaceData,OBS_ITY,INDEX_HEADER)
IF ( tvs_Is_idburp_inst(IDATYP,CINST) .and. lsensor(ltovsno (index_header))==id ) THEN
count = count + 1
END IF
END DO HEADER
if ( count == 0 ) return
! ** find number of channels and RTTOV levels
NCHN = coefs(id)%coef%fmv_chn
NLEV = coefs(id)%coef%nlevels
allocate (xpres(NLEV))
xpres(1:NLEV)=coefs(id)% coef% ref_prfl_p(1:NLEV)
iextr=0
if (nlev==44) iextr=1
if (nlev==51) iextr=2
if (nlev /= 43 .and. nlev/=44 .and. nlev/= 51) then
Write(*,*) "Attention: modification necessaire dans HIRQC"
call abort3d('hirqc')
endif
NLEVB=NLEV-iextr
write(*,*) ' HIRQC - nchn ', nchn
nlv_T= col_getNumLev(lcolumnhr,'TH')
nch_sel= hir_get_nchan_selected(cinst)
! information to extract (transvidage)
! ------------------------------------
!
! ZTG -- guess skin temperatures (deg K)
! ZPS(NPRF) -- surface pressure (hPa)
! ZT(nlv_T) -- temperature profiles on NWP model levels (deg K)
! ZHT(nlv_T) -- height profiles on NWP model levels (m)
! ZLQ(nlv_T) -- surface specific humidity in ln q (kg/kg)
! BTOBSERR(nch_sel) -- observation error standard deviation
! BTOBS(nch_sel) -- observed brightness temperatures (deg K)
! BTCALC(nch_sel) -- computed brightness temperatures (deg K)
! RCAL_CLR(nch_sel) -- computed clear radiances (mw/m2/sr/cm-1)
! SFCTAU(nch_sel) -- surface to space transmittances (0-1)
! RCLD(nch_sel,NLEV) -- overcast cloudy radiances (mw/m2/sr/cm-1)
! TRANSM(nch_sel,NLEV) -- layer to space transmittances (0-1)
! EMI_SFC(nch_sel) -- surface emissivities (0-1)
! KSURF -- surface type in obs file (0, 1)
! CLFR -- cloud fraction (%)
! TOEXT(NLEV) -- temperature profiles on RT model levels (deg K)
! ZHOEXT(NLEV) -- height profiles on RT model levels (m)
! SUNZA -- sun zenith angle (deg)
! SATAZIM -- satellite azimuth angle (deg)
! SATZEN -- satellite zenith angle (deg)
! ALBEDO -- surface albedo (0-1)
! ICE -- ice fraction (0-1)
! LTYPE -- surface type (1,...,20)
! PCNT_WAT -- water fraction (0-1)
! PCNT_REG -- water fraction in the area (0-1)
! ROBS(nch_sel) -- observed radiances (mW/m2/sr/cm-1)
alloc_status(:) = 0
allocate ( BTOBSERR(nch_sel), stat= alloc_status(1) )
allocate ( BTOBS(nch_sel), stat= alloc_status(2) )
allocate ( BTCALC(nch_sel), stat= alloc_status(3) )
allocate ( RCAL_CLR(nch_sel), stat= alloc_status(4) )
allocate ( SFCTAU(nch_sel), stat= alloc_status(5))
allocate ( RCLD(nch_sel,NLEVB), stat= alloc_status(6))
allocate ( TRANSM(nch_sel,NLEVB), stat= alloc_status(7))
allocate ( EMI_SFC(nch_sel), stat= alloc_status(8))
allocate ( TOEXT(NLEVB), stat= alloc_status(9))
allocate ( ZHOEXT(NLEVB), stat= alloc_status(10))
allocate ( ROBS(nch_sel), stat= alloc_status(11))
allocate ( REJFLAG(nch_sel,0:BITFLAG),stat= alloc_status(12))
allocate ( NTOP_BT(nch_sel), stat= alloc_status(13))
allocate ( NTOP_RD(nch_sel), stat= alloc_status(14))
allocate ( PTOP_BT(nch_sel), stat= alloc_status(15))
allocate ( PTOP_RD(nch_sel), stat= alloc_status(16))
allocate ( MINP(nch_sel), stat= alloc_status(17))
allocate ( PMIN(nch_sel), stat= alloc_status(18))
allocate ( DTAUDP1(nch_sel), stat= alloc_status(19))
allocate ( FATE(nch_sel), stat= alloc_status(20))
if (liasi) allocate ( RCLD_AVHRR(NIR,NLEVB), stat= alloc_status(21))
allocate ( maxwf(nch_sel), stat= alloc_status(22))
allocate ( ZVLEV(NLEVB), stat= alloc_status(23))
allocate ( ZLEVMOD(nlv_T), stat= alloc_status(24))
allocate ( ZT(nlv_T), stat= alloc_status(25))
allocate ( ZHT(nlv_T), stat= alloc_status(26))
allocate ( ZLQ(nlv_T), stat= alloc_status(27))
if( any(alloc_status /= 0) ) then
write(*,*) ' hirqc : memory allocation error'
call abort3d('hirqc')
end if
DO JL = 1, NLEVB
ZVLEV(JL) = XPRES(JL+iextr)
END DO
DIFFTOP_MIN = 100000.d0
IMODTOP = 1
DO JL = 1, NLEVB
IF ( ABS(vco_trl%DPT_M-100.d0*ZVLEV(JL)) < DIFFTOP_MIN ) THEN
DIFFTOP_MIN = ABS(vco_trl%DPT_M-100.d0*ZVLEV(JL))
IMODTOP = JL
END IF
END DO
!* -- FIND RADIATIVE TRANSFER MODEL LEVEL NEAREST TO TRIAL TOP (only compute one time)
write(*,*) 'TOIT DU MODELE (MB)'
write(*,*) 0.01d0*vco_trl%DPT_M
write(*,*) 'NIVEAU DU MODELE DE TRANSFERT RADIATIF LE PLUS PRES DU TOIT DU MODELE'
write(*,*) IMODTOP
CO2MIN=minloc( abs( ZVLEV(:) - pco2min ) )
CO2MAX=minloc( abs( ZVLEV(:) - pco2max ) )
NOBTOV = 0
! loop over all header indices of the 'TO' family
call obs_set_current_header_list(lobsSpaceData,'TO')
HEADER_2: do
index_header = obs_getHeaderIndex(lobsSpaceData)
if (index_header < 0) exit HEADER_2
IDATYP = obs_headElem_i(lobsSpaceData,OBS_ITY,INDEX_HEADER)
IF ( tvs_Is_idburp_tovs(idatyp) ) NOBTOV = NOBTOV + 1
IF ( tvs_Is_idburp_inst(IDATYP,CINST) .and. lsensor(ltovsno (index_header))==id) THEN
BTOBS(:) = -1.d0
BTCALC(:) = -1.d0
RCAL_CLR(:) = -1.d0
SFCTAU(:) = -1.d0
RCLD(:,:) = -1.d0
TRANSM(:,:) = -1.d0
EMI_SFC(:) = -1.d0
REJFLAG(:,:) = 0
if (liasi) then
INDX=index_header
iclass=1
do iobs=OBS_CF1,OBS_CF7
avhrr_bgck(INDEX_HEADER)%CFRAC(iclass)=obs_headElem_i(lobsSpaceData,iobs,index_header)
iclass=iclass+1
enddo
iclass=1
ichn=1
do iobs=OBS_M1C1,OBS_M7C6
avhrr_bgck(INDEX_HEADER)%radmoy(iclass,ichn)=obs_headElem_r(lobsSpaceData,iobs,index_header)
ichn=ichn+1
if (ichn>NCHANAVHRR) then
ichn=1
iclass=iclass+1
endif
enddo
iclass=1
ichn=1
do iobs=OBS_S1C1,OBS_S7C6
avhrr_bgck(INDEX_HEADER)%radstd(iclass,ichn)=obs_headElem_r(lobsSpaceData,iobs,index_header)
ichn=ichn+1
if (ichn>NCHANAVHRR) then
ichn=1
iclass=iclass+1
endif
enddo
SUNAZIM = 0.01d0 * obs_headElem_i(lobsSpaceData,OBS_SAZ,index_header)
end if
ZTG = col_getElem(lcolumnhr,1,INDEX_HEADER,'TG')
ZPS = col_getElem(lcolumnhr,1,INDEX_HEADER,'P0') &
* MPC_MBAR_PER_PA_R8
DO JL = 1, nlv_T
ZT(JL) = col_getElem(lcolumnhr,JL,INDEX_HEADER,'TT')
ZHT(JL) = col_getHeight(lcolumnhr,JL,INDEX_HEADER,'TH') / RG
ZLQ(JL) = col_getElem(lcolumnhr,JL,INDEX_HEADER,'HU')
ZLEVMOD(JL)= col_getPressure(lcolumnhr,JL,INDEX_HEADER,'TH') &
* MPC_MBAR_PER_PA_R8
END DO
IDATA = obs_headElem_i(lobsSpaceData,OBS_RLN,index_header)
IDATEND = obs_headElem_i(lobsSpaceData,OBS_NLV,index_header) + IDATA - 1
BAD=.false.
if (lcris) BAD=( obs_headElem_i(lobsSpaceData,OBS_GQF,index_header)/=0 .or. &
obs_headElem_i(lobsSpaceData,OBS_GQL,index_header) /=0)
if (liasi) BAD=( obs_headElem_i(lobsSpaceData,OBS_GQF,index_header)/=0 .or. &
obs_headElem_i(lobsSpaceData,OBS_GQL,index_header) >1)
DO INDEX_BODY= IDATA, IDATEND
IF ( obs_bodyElem_i(lobsSpaceData,OBS_ASS,INDEX_BODY).EQ.1 ) THEN
ICHN = NINT(obs_bodyElem_r(lobsSpaceData,OBS_PPP,INDEX_BODY))
ICHN = MAX(0,MIN(ICHN,JPCHMAX+1))
chan_indx=hir_get_chindx_fr_chn(CINST,ichn)
BTOBSERR(chan_indx) = obs_bodyElem_r(lobsSpaceData,OBS_OER,INDEX_BODY)
BTOBS(chan_indx) = obs_bodyElem_r(lobsSpaceData,OBS_VAR,INDEX_BODY)
! *** Flag check on observed BTs ***
IF (.not.liasi .and. BTEST(obs_bodyElem_i(lobsSpaceData,OBS_FLG,INDEX_BODY),2)) REJFLAG(chan_indx,9) = 1
IF (BAD) REJFLAG(chan_indx,9) = 1
! *** Gross check on observed BTs ***
IF (BTOBS(chan_indx)<150.d0) REJFLAG(chan_indx,9) = 1
IF (BTOBS(chan_indx)>350.d0) REJFLAG(chan_indx,9) = 1
END IF
END DO
DO JC = 1, NCHN
ICHN = ichan(JC,ID)
chan_indx=hir_get_chindx_fr_chn(CINST,ichn)
BTCALC(chan_indx) = radiance_d(nobtov)%bt(jc)
RCAL_CLR(chan_indx) = radiance_d(nobtov)%clear(jc)
SFCTAU(chan_indx) = transmission_d(nobtov)%tau_total(jc)
DO JL = 1, NLEVB
RCLD(chan_indx,JL) = radiance_d(nobtov)%overcast(jl+iextr-1,jc)
TRANSM(chan_indx,JL) = transmission_d(nobtov)%tau_levels(jl+iextr,jc)
END DO
EMI_SFC(chan_indx) = emissivity(JC,NOBTOV)
! *** Gross check on computed BTs ***
IF (BTCALC(chan_indx)<150.d0) REJFLAG(chan_indx,9) = 1
IF (BTCALC(chan_indx)>350.d0) REJFLAG(chan_indx,9) = 1
END DO
KSURF = profiles(nobtov)%skin%surftype
!Test pour detecter le isatzen manquant (-1) ou anormal
! (angle negatif ou superieur a 75 degres )
isatzen= obs_headElem_i(lobsSpaceData,OBS_SZA,INDEX_HEADER)
if ( isatzen < 9000 .or. &
isatzen > 16500 ) then
DO JC = 1, NCHN
ICHN = ichan(JC,ID)
chan_indx=hir_get_chindx_fr_chn(CINST,ichn)
REJFLAG(chan_indx,9) = 1
ENDDO
endif
!**************************************************************
CLFR = 0.
if (lairs) CLFR = obs_headElem_i(lobsSpaceData,OBS_CLF,INDEX_HEADER)
DO JL = 1, NLEVB
TOEXT(JL) = profiles(nobtov)%t(jl+iextr)
ZHOEXT(JL) = profiles_qc(nobtov)%z(jl+iextr)
END DO
SUNZA = profiles_qc(nobtov)%sunza
if (liasi) then
SATAZIM = profiles(nobtov)%azangle
SATZEN = profiles(nobtov)%zenangle
endif
ALBEDO = profiles_qc(nobtov)%albedo
ICE = profiles_qc(nobtov)%ice
LTYPE = profiles_qc(nobtov)%ltype
IF(LTYPE.EQ.20) KSURF=2
PCNT_WAT = profiles_qc(nobtov)%pcnt_wat
PCNT_REG = profiles_qc(nobtov)%pcnt_reg
! ** find TOA radiances converted from observed BT's
ROBS(:) = -1.d0
channels: DO JC = 1, NCHN
ICHN = ichan(JC,ID)
chan_indx=hir_get_chindx_fr_chn(CINST,ichn)
IF ( REJFLAG(chan_indx,9) == 1 ) CYCLE channels
t_effective = coefs(id)%coef%ff_bco(jc) &
+ coefs(id)%coef%ff_bcs(jc) * BTOBS(chan_indx)
ROBS(chan_indx) = coefs(id)%coef%planck1(jc) / &
( Exp( coefs(id)%coef%planck2(jc)/t_effective ) - 1.d0 )
END DO channels
! ** set height fields to 'height above ground' fields
DO JL = 1, NLEVB
ZHOEXT(JL) = ZHOEXT(JL) - ZHT(nlv_T)
END DO
DO JL = 1, nlv_T
ZHT(JL) = ZHT(JL) - ZHT(nlv_T)
END DO
!**********************************************************************************************
!* ///// ---------------------------------------------------- /////
!* ///// DETERMINATION OF THE CLEAR/CLOUDY PROFILES (CLDFLAG) /////
!* ///// ---------------------------------------------------- /////
CLDFLAG = 0
!* -- REFERENCE FOR WINDOW CHANNEL
IWINDO = hir_get_chindx_fr_chn(CINST,IWINDOW)
IWINDO_ALT = hir_get_chindx_fr_chn(CINST,IWINDOW_ALT)
ICHREF = IWINDO
IF ( REJFLAG(IWINDO,9) == 1 ) THEN
ICHREF = IWINDO_ALT
IF ( REJFLAG(IWINDO_ALT,9) == 1 ) THEN
ICHREF = -1
CLDFLAG = -1
REJFLAG(:,9) = 1
write(*,*) 'WARNING'
write(*,*) 'WINDOW AND ALTERNATE WINDOW CHANNEL OBSERVATIONS'
write(*,*) 'HAVE BEEN REJECTED. '
write(*,*) 'ALL '//cinst//' OBSERVATIONS FROM THIS PROFILE REJECTED'
END IF
END IF
!* -- CLOUD TOP BASED ON MATCHING OBSERVED BRIGHTNESS TEMPERATURE
!* -- AT A REFERENCE SURFACE CHANNEL WITH BACKGROUND TEMPERATURE PROFILE (PTOP_EQ)
!* -- ON GUESS VERTICAL LEVELS.
LEV_START = 0
!iopt2=1 : calcul de la hauteur en hPa PTOP_MB et du NTOP_MB correspondant
CALL CLOUD_HEIGHT (PTOP_MB,NTOP_MB, btobs,cldflag,zt, &
zht,zps,zlevmod,nlv_T,nch_sel,ichref,lev_start,iopt2)
!iopt1=2 : calcul de la hauteur em metres PTOP_EQ et du NTOP_EQ correspondant
CALL CLOUD_HEIGHT (PTOP_EQ,NTOP_EQ, btobs,cldflag,zt, &
zht,zps,zlevmod,nlv_T,nch_sel,ichref,lev_start,iopt1)
if (liasi) then
! appel de RTTOV pour calculer les radiances des 3 canaux IR (3b, 4 et 5) de AVHRR 3
call get_avhrr_emiss(emi_sfc,coefs(id) %coef%ff_cwn,coefs(id) % coef%fmv_chn,avhrr_surfem1)
call tovs_rttov_AVHRR_for_IASI(indx,avhrr_surfem1,SATELLITE(id))
IOBS=INDX(1)
call convert_avhrr(profiles_qc(IOBS)%sunza, avhrr_bgck(IOBS) )
call stat_avhrr(avhrr_bgck(IOBS))
LEV_START_AVHRR(:) = 0
cldflag_avhrr(:)=0
DO JC=1,NCLASSAVHRR
btobs_avhrr(:,JC)= avhrr_bgck(IOBS) % TBMOY(JC,:)
robs_avhrr(1:NIR,JC)= avhrr_bgck(IOBS) % RADMOY(JC,NVIS+1:NIR+NVIS)
RCAL_CLR_AVHRR(:) = avhrr_bgck(IOBS) % RADCLEARCALC(:)
EMI_SFC_AVHRR(:) = avhrr_bgck(IOBS) % EMISS(:)
SFCTAU_AVHRR(:) = avhrr_bgck(IOBS) % TRANSMSURF(:)
DO JL=1,NLEVB
RCLD_AVHRR(:,JL) = avhrr_bgck(IOBS) % RADOVCALC(JL+iextr-1,:)
ENDDO
IF (btobs_avhrr(2,JC) >100.d0 ) THEN
ichref_avhrr(JC)=2
ELSE IF (btobs_avhrr(3,JC) >100.d0 ) THEN
ichref_avhrr(JC)=3
ELSE
ichref_avhrr(JC)=-1
cldflag_avhrr(JC)=-1
ENDIF
CALL CLOUD_HEIGHT (PTOP_EQ_AVHRR(JC),NTOP_EQ_AVHRR(JC), btobs_avhrr(:,JC),cldflag_avhrr(JC),zt, &
zht,zps,zvlev,nlv_T,NIR,ichref_avhrr(JC),lev_start_avhrr(JC),iopt1)
ENDDO
end if
!* -- CLEAR/CLOUDY PROFILE DETECTION USING THE GARAND & NADON ALGORITHM
CALL GARAND1998NADON (CLDFLAG, btobs,ztg,zt, &
zht,nlv_T,nch_sel,ptop_eq,ntop_eq,ichref)
if (liasi) then
DO JC=1,NCLASSAVHRR
CALL GARAND1998NADON (CLDFLAG_AVHRR(jC), btobs_avhrr(:,JC),ztg,zt, &
zht,nlv_T,NIR,ptop_eq_avhrr(JC),ntop_eq_avhrr(JC),ichref_avhrr(JC))
ENDDO
end if
!* -- FURTHER TESTS TO REMOVE POTENTIAL CLOUDY PROFILES
! *** TEST # A ***
! *** In daytime, set cloudy if cloud fraction over 5% ***
CFSUB=-1.d0
if (lairs) then
IF ( CLDFLAG == 0 .AND. CLFR > 5.d0 .AND. SUNZA < 90.d0 ) THEN
CLDFLAG = 1
CFSUB=0.01d0*CLFR !conversion % -> 0-1
ENDIF
endif
! *** TEST # B ***
! *** Set cloudy if temperature difference between guess (ZTG) ***
! *** and estimated true (ZTS) skin temperatures is over threshold ***
CALL ESTIM_TS(ZTS, ztg,emi_sfc,rcal_clr,robs, &
sfctau,cldflag,ichref,nch_sel,nchn,id,CINST)
IF ( CLDFLAG == 0 .AND. KSURF == 1 &
.AND. ABS(ZTS-ZTG) > DTW ) CLDFLAG = 1
IF ( CLDFLAG == 0 .AND. KSURF /= 1 &
.AND. ABS(ZTS-ZTG) > DTL ) CLDFLAG = 1
if (liasi) then
DO JC=1,NCLASSAVHRR
CALL ESTIM_TS_AVHRR(ZTS_AVHRR(JC), ztg,emi_sfc_avhrr,rcal_clr_avhrr,robs_avhrr(:,JC), &
sfctau_avhrr,CLDFLAG_AVHRR(jC),ichref_avhrr(JC),NIR)
ENDDO
DO JC=1,NCLASSAVHRR
IF ( CLDFLAG_AVHRR(JC) == 0 .AND. KSURF == 1 &
.AND. ABS(ZTS_AVHRR(JC)-ZTG) > DTW ) CLDFLAG_AVHRR(JC) = 1
IF ( CLDFLAG_AVHRR(JC) == 0 .AND. KSURF /= 1 &
.AND. ABS(ZTS_AVHRR(JC)-ZTG) > DTL ) CLDFLAG_AVHRR(JC) = 1
ENDDO
!criteres AVHRR utilisant les canaux visibles (de jour seulement)
IF (sunza<sunzenmax) THEN
ANISOT=1.d0
deltaphi=abs(SATAZIM - SUNAZIM )
IF (deltaphi>180.d0) deltaphi=360.d0 - deltaphi
IF (ALBEDO<0.17d0) THEN
CALL VISOCN(sunza,satzen,deltaphi,ANISOT,ZLAMB,ZCLOUD,IER)
SEUIL_ALBED=10.d0*max(1.d0,ANISOT)
ELSE
SEUIL_ALBED=100.d0*ALBEDO + 10.d0
ENDIF
IF (ANISOT<1.5d0) THEN !to avoid sun glint
SCOS=COS ( sunza * MPC_DEGREES_PER_RADIAN_R8 )
CALL cor_albedo ( DEL, SCOS )
SEUIL_ALBED=SEUIL_ALBED * DEL
DO JC=1,NCLASSAVHRR
IF (avhrr_bgck(IOBS)%ALBEDMOY(JC,1) > SEUIL_ALBED(1) ) THEN
CLDFLAG_AVHRR(JC) = 1
ENDIF
!static AVHRR thresholds v3
DO JL=1,NVIS
IF (avhrr_bgck(IOBS)%ALBEDMOY(JC,JL) > seuilalb_static(JL,KSURF) ) THEN
CLDFLAG_AVHRR(JC) = 1
ENDIF
ENDDO
ENDDO
ENDIF
ENDIF
!Calcul de la pseudo fraction nuageuse AVHRR
CFRAC_AVHRR=0.d0
DO JC=1,NCLASSAVHRR
IF (CLDFLAG_AVHRR(JC) == 1) CFRAC_AVHRR=CFRAC_AVHRR + avhrr_bgck(IOBS)%CFRAC(JC)
ENDDO
CFSUB=-1.0d0
IF ( CLDFLAG == 0 .AND. CFRAC_AVHRR > 5.d0 ) THEN
CLDFLAG = 1
CFSUB=0.01d0* MIN(CFRAC_AVHRR,100.d0) !conversion % -> 0-1 avec seuil car parfois CFRAC_AVHRR=101
ENDIF
!AVHRR Homogeneity criteria
IF (CLDFLAG == 0) THEN
IJOUR=1
IF (SUNZA<90.d0) IJOUR=2
! 1 NUIT
! 2 JOUR
IF (IJOUR==2) THEN
DO JC=1,NVIS
IF (avhrr_bgck(IOBS)%ALBSTD_PIXELIASI(JC)> seuilalb_homog(JC,KSURF) ) CLDFLAG=1
ENDDO
ENDIF
DO JC=NVIS+1,NVIS+NIR
IF (avhrr_bgck(IOBS)%TBSTD_PIXELIASI(JC)>seuilbt_homog(JC,KSURF,IJOUR)) CLDFLAG=1
ENDDO
ENDIF
endif
GNCLDFLAG=CLDFLAG
!* ///// ------------------------------------------------------- /////
!* ///// DETERMINATION OF THE ASSIMILABLE OBSERVATIONS (REJFLAG) /////
!* ///// ------------------------------------------------------- /////
!* -- FIRST TESTS TO REJECT OBSERVATIONS
! *** TEST # 1 ***
! *** Do not assimilate where cloudy ***
IF ( CLDFLAG == 1 ) then
REJFLAG(:,11) = 1
REJFLAG(:,23) = 1
endif
! *** TEST # 2 ***
! *** Gross check on valid BTs ***
! already done
!* -- CLOUD TOP BASED ON MATCHING
!* -- OBSERVED BRIGHTNESS TEMPERATURE WITH BACKGROUND TEMPERATURE PROFILES (PTOP_BT)
!* -- OR COMPUTED OBSERVED RADIANCES WITH BACKGROUND RADIANCE PROFILES (PTOP_RD)
!* -- ON RTTOV VERTICAL LEVELS
LEV_START = 0
DO JCH = 1, NCH_HE
ILIST_HE(JCH) = hir_get_chindx_fr_chn(CINST,ILIST1(JCH))
END DO
CALL CLOUD_TOP ( PTOP_BT,PTOP_RD,NTOP_BT,NTOP_RD, &
btobs,toext,zhoext,rcal_clr,zps,robs,rcld,zvlev,nlevb, &
nch_sel,cldflag,rejflag,lev_start,iopt2,ihgt,ichref,nch_he,ilist_he)
if (liasi) then
LEV_START_AVHRR(:) = 0
DO JC=1,NCLASSAVHRR
CALL CLOUD_TOP_AVHRR ( PTOP_BT_AVHRR(:,JC),PTOP_RD_AVHRR(:,JC),NTOP_BT_AVHRR(:,JC),NTOP_RD_AVHRR(:,JC), &
btobs_avhrr(:,JC),toext,zhoext,rcal_clr_avhrr,zps,robs_avhrr(:,JC),rcld_avhrr,zvlev,nlevb, &
NIR,cldflag_avhrr(jc),lev_start_avhrr(JC),iopt2,ihgt,nn,ilist_avhrr)
ENDDO
endif
!* -- REFERENCE CHANNEL FOR CO2-SLICING
DO JCH = 1, NCO2
ILIST_CO2(JCH) = hir_get_chindx_fr_chn(CINST,ILIST2(JCH))
ILIST_CO2_PAIR(JCH) = hir_get_chindx_fr_chn(CINST,ILIST2_PAIR(JCH))
END DO
cpt=0
DO JCH=1,NCO2
IF ( REJFLAG(ILIST_CO2(JCH),9)==1 .or. &
REJFLAG(ILIST_CO2_PAIR(JCH),9)==1 ) cpt=cpt+1
ENDDO
IF (cpt==nco2) THEN
CLDFLAG = -1
REJFLAG(:,9) = 1
write(*,*) 'WARNING'
write(*,*) 'CO2 REFERENCE AND ALTERNATE CHANNEL OBSERVATIONS'
write(*,*) 'HAVE BEEN REJECTED. '
write(*,*) 'ALL '//CINST//' OBSERVATIONS FROM THIS PROFILE REJECTED'
ENDIF
!* -- EQUIVALENT HEIGHT OF SELECTED WINDOW CHANNEL
HE = PTOP_RD( hir_get_chindx_fr_chn(CINST,ILIST1(2)))
IF (ICHREF==IWINDO_ALT) HE = PTOP_RD( hir_get_chindx_fr_chn(CINST,ILIST1(3)) )
!* -- CLOUD TOP BASED ON CO2 SLICING
LEV_START = MAX( MIN(LEV_START,CO2MAX(1)), CO2MIN(1) )
CALL CO2_SLICING ( PTOP_CO2,NTOP_CO2,FCLOUD_CO2, &
rcal_clr,rcld,robs,zps,zvlev,nlevb,nch_sel,cldflag,rejflag, &
lev_start,ichref,ilist_co2,ilist_co2_pair)
!* -- FIND CONSENSUS CLOUD TOP AND FRACTION
CALL SELTOP ( ETOP,VTOP,ECF,VCF,NGOOD, he,ptop_co2,fcloud_co2, &
CFSUB,PTOP_MB,zps,cldflag,gncldflag )
if (liasi) then
! Correction pour les nuages trop bas:
! en principe Pco2 < Heff.
! on cherche les cas pathologiques avec Pco2>Min(Heff(AVHRR))
minpavhrr(2:3)=12200
ILOC(2:3)=-1 ! pour eviter les catastrophes...
DO JC=1,NCLASSAVHRR
IF (avhrr_bgck(IOBS)%CFRAC(JC)>0.d0) THEN
IF (PTOP_RD_AVHRR(2,JC)<minpavhrr(2)) THEN
ILOC(2)=JC
minpavhrr(2)=PTOP_RD_AVHRR(2,JC)
ENDIF
IF (PTOP_RD_AVHRR(3,JC)<minpavhrr(3)) THEN
ILOC(3)=JC
minpavhrr(3)=PTOP_RD_AVHRR(3,JC)
ENDIF
ENDIF
ENDDO
IF ( ILOC(2)==-1 .or. ILOC(3)==-1) CYCLE ! pour eviter les catastrophes...
! on se limite aux cas "surs" ou les deux hauteurs effectives sont > a Pco2
! et ou un accord raisonnable existe entre les deux hauteurs effectives
IF ( ILOC(2)==ILOC(3) .and. &
minpavhrr(2) < ETOP .and. &
minpavhrr(3) < ETOP .and. &
ABS(minpavhrr(2)- minpavhrr(3))<25.d0 .and. &
CLDFLAG_AVHRR(ILOC(2))/=-1 .and. CLDFLAG_AVHRR(ILOC(3))/=-1) THEN
IF (ECF==0.d0 .and. CLDFLAG==1) THEN
! cas predetermine nuageux mais ramene a clair
ECF=0.01d0* min(100.d0,CFRAC_AVHRR)
! cette ligne peut generer des fractions nuageuses inferieures a 20 %.
ETOP=0.5d0*(minpavhrr(2) + minpavhrr(3))
ENDIF
IF (ECF>0.d0 .and. CLDFLAG==1) THEN
!cas predetermine nuageux pas ramene clair (==normal)
ETOP=0.5d0*(minpavhrr(2) + minpavhrr(3))
ENDIF
IF (CLDFLAG==0) THEN
!cas predetermine clair ... que faire
CLDFLAG=1
ETOP=0.5d0*(minpavhrr(2) + minpavhrr(3))
ECF=0.01d0* min(100.d0,CFRAC_AVHRR)
ENDIF
ENDIF
endif
!* -- FIND MINIMUM LEVEL OF SENSITIVITY FOR CHANNEL ASSIMILATION NOT SENSIBLE TO CLOUDS
CALL MIN_PRES_new (MAXWF, MINP,PMIN,DTAUDP1, zps,transm,zvlev,cldflag,nlevb,nch_sel,imodtop )
!* -- ASSIMILATION OF OBSERVATIONS WHEN CLOUDY PROFILES
! *** TEST # 3 ***
! *** Assimilation above clouds (refinement of test 1) ***
! *** Set security margin to 2x the std on height from CO2-slicing ***
TAMPON = MAX(50.D0, 2.d0*VTOP)
DO JC = 1, nch_sel
IF ( REJFLAG(JC,11) == 1 .AND. REJFLAG(JC,23) == 1 .and. ETOP - TAMPON > PMIN(JC) ) THEN
REJFLAG(JC,11) = 0
REJFLAG(JC,23) = 0
end IF
END DO
! LOOK AT THE FATE OF THE OBSERVATIONS
FATE(:) = SUM(REJFLAG(:,:),DIM=2)
! FURTHER REASONS TO REJECT OBSERVATIONS
ILIST_SUN= hir_get_chindx_fr_chn(CINST,ICHN_SUN)
DO JC = 1, nch_sel
IF ( FATE(JC) == 0 ) THEN
! *** TEST # 4 ***
! *** Background check, do not assimilate if O-P > 3sigma ***
IF ( ABS(BTOBS(JC)-BTCALC(JC)) > 3.d0*BTOBSERR(JC) ) THEN
REJFLAG(JC,9) = 1
REJFLAG(JC,16) = 1
END IF
! *** TEST # 5 ***
! *** Do not assimilate shortwave channels during the day ***
IF ( JC >= ILIST_SUN .AND. SUNZA < NIGHT_ANG ) then
REJFLAG(JC,11) = 1
REJFLAG(JC,7) = 1
END IF
! *** TEST # 6 ***
! *** Do not assimilate surface channels over land ***
IF ( MINP(JC) == NLEVB .or. ZPS-PMIN(JC) < 100.d0 ) THEN
IF ( KSURF == 0 ) THEN
REJFLAG(JC,11) = 1 !!! comment this line if assimilation under conditions
REJFLAG(JC,19) = 1 !!! comment this line if assimilation under conditions
IF ( PCNT_WAT > 0.01d0 .OR. PCNT_REG > 0.1d0 .OR. EMI_SFC(JC) < 0.97d0 ) THEN
REJFLAG(JC,11) = 1
REJFLAG(JC,19) = 1
END IF
! *** TEST # 7 ***
! *** Do not assimilate surface channels over water under conditions ***
ELSE IF ( KSURF == 1 ) THEN
IF ( PCNT_WAT < 0.99d0 .OR. PCNT_REG < 0.97d0 .OR. &
ICE > 0.001d0 .OR. ALBEDO >= 0.17d0 .OR. EMI_SFC(JC) < 0.9d0 ) THEN
REJFLAG(JC,11) = 1
REJFLAG(JC,19) = 1
END IF
! *** TEST # 8 ***
! *** Do not assimilate surface channels over sea ice ***
ELSE IF ( KSURF == 2 ) THEN
REJFLAG(JC,11) = 1
REJFLAG(JC,19) = 1
END IF
END IF
END IF
! *** TEST # 9 ***
! *** Do not assimilate if jacobian has a significant contribution over model top ***
! Condition valid if model top at 10mb or lower only
IF ( NINT(vco_trl%DPT_M) >= 1000 ) THEN
IF ( REJFLAG(JC,9) /= 1 .AND. DTAUDP1(JC) > 0.50d0 ) THEN
REJFLAG(JC,11) = 1
REJFLAG(JC,21) = 1
END IF
END IF
! Condition valid if model top at 10mb or lower only
IF ( NINT(vco_trl%DPT_M) >= 1000 ) THEN
IF ( REJFLAG(JC,9) /= 1 .AND. TRANSM(JC,1) < 0.99d0 ) THEN
REJFLAG(JC,11) = 1
REJFLAG(JC,21) = 1
END IF
END IF
! Condition valid if model top is higher than 10 mb
IF ( NINT(vco_trl%DPT_M) < 1000 ) THEN
IF ( REJFLAG(JC,9) /= 1 .AND. TRANSM(JC,1) < 0.95d0 ) THEN
REJFLAG(JC,11) = 1
REJFLAG(JC,21) = 1
END IF
END IF
! *** TEST # 10 ***
! *** Do not assimilate blacklisted channels ***
IF ( hir_get_assim_chan(CINST,JC) == 0 ) REJFLAG(JC,8) = 1
END DO
!* -- FOR EACH PROFILE, ARE ALL NON-BLACKLISTED CHANNELS ASSIMILATED
ASSIM_ALL = .true.
FATE(:) = SUM(REJFLAG(:,:),DIM=2)
chn: DO JC = 1, nch_sel
IF ( REJFLAG(JC,8) == 0 ) THEN
IF ( FATE(JC) /= 0 ) THEN
ASSIM_ALL = .false.
EXIT chn
END IF
END IF
END DO chn
if (.not.ASSIM_ALL) then
call obs_headSet_i(lobsSpaceData, OBS_ST1, index_header,ibset(obs_headElem_i(lobsSpaceData,OBS_ST1,INDEX_HEADER),6) )
endif
!* -- ADDITION OF BACKGROUND CHECK PARAMETERS TO BURP FILE
!* ------------------------------------------------
call obs_headSet_r(lobsSpaceData, OBS_ETOP, index_header, ETOP )
call obs_headSet_r(lobsSpaceData, OBS_VTOP, index_header, VTOP )
call obs_headSet_r(lobsSpaceData, OBS_ECF, index_header, 100._8*ECF )
call obs_headSet_r(lobsSpaceData, OBS_VCF, index_header, 100._8*VCF )
call obs_headSet_r(lobsSpaceData, OBS_HE, index_header, HE )
call obs_headSet_r(lobsSpaceData, OBS_ZTSR, index_header, ZTS )
call obs_headSet_i(lobsSpaceData, OBS_NCO2, index_header, NGOOD)
call obs_headSet_r(lobsSpaceData, OBS_ZTM, index_header, ZT(nlv_T) )
call obs_headSet_r(lobsSpaceData, OBS_ZTGM, index_header, ZTG )
call obs_headSet_r(lobsSpaceData, OBS_ZLQM, index_header, EXP(ZLQ(nlv_T)) )
call obs_headSet_r(lobsSpaceData, OBS_ZPS, index_header, 100._8*ZPS )
call obs_headSet_i(lobsSpaceData, OBS_STYP, index_header, KSURF )
DO INDEX_BODY= IDATA, IDATEND
IF ( obs_bodyElem_i(lobsSpaceData,OBS_ASS,INDEX_BODY).EQ.1 ) THEN
ICHN = NINT(obs_bodyElem_r(lobsSpaceData,OBS_PPP,INDEX_BODY))
ICHN = MAX(0,MIN(ICHN,JPCHMAX+1))
chan_indx=hir_get_chindx_fr_chn(CINST,ichn)
call obs_bodySet_r(lobsSpaceData,OBS_SEM,INDEX_BODY,EMI_SFC(chan_indx))
DO NFLG = 0, BITFLAG
IF ( REJFLAG(chan_indx,NFLG) == 1 ) &
call obs_bodySet_i(lobsSpaceData,OBS_FLG,INDEX_BODY,IBSET(obs_bodyElem_i(lobsSpaceData,OBS_FLG,INDEX_BODY),NFLG))
END DO
END IF
END DO
END IF
END DO HEADER_2
alloc_status(:) = 0
deallocate ( BTOBSERR, stat= alloc_status(1) )
deallocate ( BTOBS, stat= alloc_status(2) )
deallocate ( BTCALC, stat= alloc_status(3) )
deallocate ( RCAL_CLR, stat= alloc_status(4) )
deallocate ( SFCTAU, stat= alloc_status(5))
deallocate ( RCLD, stat= alloc_status(6))
deallocate ( TRANSM, stat= alloc_status(7))
deallocate ( EMI_SFC, stat= alloc_status(8))
deallocate ( TOEXT, stat= alloc_status(9))
deallocate ( ZHOEXT, stat= alloc_status(10))
deallocate ( ROBS, stat= alloc_status(11))
deallocate ( REJFLAG, stat= alloc_status(12))
deallocate ( NTOP_BT, stat= alloc_status(13))
deallocate ( NTOP_RD, stat= alloc_status(14))
deallocate ( PTOP_BT, stat= alloc_status(15))
deallocate ( PTOP_RD, stat= alloc_status(16))
deallocate ( MINP, stat= alloc_status(17))
deallocate ( PMIN, stat= alloc_status(18))
deallocate ( DTAUDP1, stat= alloc_status(19))
deallocate ( FATE, stat= alloc_status(20))
if (liasi) deallocate ( RCLD_AVHRR , stat= alloc_status(21))
deallocate ( maxwf, stat= alloc_status(22))
deallocate ( ZVLEV, stat= alloc_status(23))
deallocate ( ZLEVMOD, stat= alloc_status(24))
deallocate ( XPRES, stat= alloc_status(25))
deallocate ( ZT, stat= alloc_status(26))
deallocate ( ZHT, stat= alloc_status(27))
deallocate ( ZLQ, stat= alloc_status(28))
if( any(alloc_status /= 0) ) then
write(*,*) ' hirqc : memory deallocation error'
call abort3d('hirqc ')
end if
contains
subroutine convert_avhrr(sunzen,avhrr) 1,3
! conversion des radiance IR en temperatures de brillance
! et des radiances visibles en "albedo"
implicit none
real(8) ,intent(in) :: sunzen
type (avhrr_bgck_iasi) ,intent(inout) :: avhrr
integer :: ICL
REAL (8) :: tb(NIR),dtbsdrad(NIR)
REAL (8) :: FREQ(NIR),OFFSET(NIR),SLOPE(NIR)
freq=coefs_avhrr%coef%ff_cwn (:)
offset=coefs_avhrr%coef%ff_bco(:)
slope=coefs_avhrr%coef%ff_bcs(:)
DO ICL=1,NCLASSAVHRR
call calcbt(avhrr % radmoy(ICL,4:6), tb, dtbsdrad,freq,offset,slope)
avhrr % tbmoy(ICL,4:6)=tb(1:3)
avhrr % tbstd(ICL,4:6)=avhrr % radstd(ICL,4:6) * dtbsdrad(1:3)
call calcreflect(avhrr % radmoy(ICL,1:3) ,sunzen,avhrr % ALBEDMOY(ICL,1:3) )
call calcreflect(avhrr % radstd(ICL,1:3) ,sunzen,avhrr % ALBEDSTD(ICL,1:3) )
ENDDO
end subroutine convert_avhrr
subroutine calcreflect(rad,sunzen,reflect) 2,1
Use MathPhysConstants_mod ,only : MPC_PI_R8, MPC_RADIANS_PER_DEGREE_R8
implicit none
REAL (8) , INTENT(IN) ,dimension(nvis) :: rad
REAL (8) , INTENT(IN) :: sunzen
REAL (8) , INTENT(out),dimension(nvis) :: reflect ! reflectivite en %
!************
REAL (8) ,DIMENSION(NVIS) :: SOLAR_FILTERED_IRRADIANCE
DATA SOLAR_FILTERED_IRRADIANCE /139.873215D0,232.919556D0,14.016470D0/
!# equivalent widths, integrated solar irradiance, effective central wavelength
!0.084877,139.873215,0.632815
!0.229421,232.919556,0.841679
!0.056998,14.016470,1.606119
! pour la definition de l'albedo voir http://calval.cr.usgs.gov/PDF/Rao.CRN_IJRS.24.9.2003_Chander.pdf
REAL (8) :: RADB ! radiance en W/m2/str
!
integer :: i
!**************************************************************
Do i = 1, nvis
if (rad(i)>= 0.0D0 ) THEN
radb=rad(i) / 1000.0D0
reflect(i)=(MPC_PI_R8*radb)/SOLAR_FILTERED_IRRADIANCE(I)
IF (sunzen < 90.0D0 ) reflect(i)= reflect(i) / COS(sunzen*MPC_RADIANS_PER_DEGREE_R8)
else
reflect(i)=-1
end if
End Do
end subroutine calcreflect
subroutine calcbt(rad,tb,dtbsdrad,freq,offset,slope) 1
implicit none
INTEGER,parameter :: nchan=3
Real(8) ,parameter :: c1= 1.19106590D-05 ! first planck constant
Real(8) ,parameter :: c2= 1.438833D0 ! second planck constant
REAL (8) , INTENT(IN) ,dimension(nchan) :: rad,freq,offset,slope
REAL (8) , INTENT(out) ,dimension(nchan) :: tb,dtbsdrad
!************
integer :: i
REAL (8) :: radtotal,tstore,planck1,planck2
Do i = 1, nchan
if (rad(i)>1.d-20) THEN
planck2= c2 * freq(I)
planck1= c1 * ( freq(I) **3 )
tstore = planck2 / Log( 1+planck1/rad(i) )
tb(i) = ( tstore - offset(i) ) / slope(i)
radtotal = rad(i)
dtbsdrad(i) = planck1 * tstore**2 / ( planck2 * radtotal * ( radtotal + planck1 ) )
dtbsdrad(i) = dtbsdrad(i) / slope(i)
else
tb(i) =0.d0
dtbsdrad(i) = 0.d0
end if
End Do
end subroutine calcbt
real (8) function dplanck(nu,t,offset,slope)
! fonction de planck en double precision
! nu en cm-1 t en Kelvin planck en Watt / ( m2 strd cm-1 )
! c en m/s h en J.s k en J/K
implicit none
real (8),intent(in) :: nu,t,offset,slope
real (8) :: nu0,tt
real (8) ,parameter :: c=299792458.D0
real (8) ,parameter :: k=1.3806505D-23
real (8) ,parameter :: h=6.62606876D-34
real (8) ,parameter :: scale=100.d0
dplanck=-1.d0
if (t>0.d0) then
nu0=nu*scale
tt=t*slope+offset
dplanck=scale*2.d0*h*c**2*nu0**3/(dexp(h*c/k*nu0/tt)-1.d0)
endif
end function dplanck
subroutine stat_avhrr(avhrr) 1
! calcul de statistiques
! sur l'information sous-pixel AVHRR
implicit none
type (avhrr_bgck_iasi) ,intent(inout) :: avhrr
integer :: ICL,ICH
Real (8) :: SUMFRAC(NVIS+NIR),TBMIN(NVIS+1:NVIS+NIR),TBMAX(NVIS+1:NVIS+NIR),SUMTB(NVIS+1:NVIS+NIR),SUMTB2(NVIS+1:NVIS+NIR)
Real (8) :: SUMALB(1:NVIS),SUMALB2(1:NVIS)
!******************************************
SUMFRAC(:)=0.d0
SUMTB(:)=0.d0
SUMTB2(:)=0.d0
SUMALB(:)=0.d0
SUMALB2(:)=0.d0
DO ICL=1,NCLASSAVHRR
IF (avhrr%CFRAC(ICL) > 0.d0 ) THEN
DO ICH=1,NVIS
IF (avhrr%ALBEDMOY(ICL,ICH) >=0.d0 ) THEN
SUMFRAC(ICH)=SUMFRAC(ICH)+avhrr%CFRAC(ICL)
SUMALB(ICH) = SUMALB(ICH) + avhrr%CFRAC(ICL) * avhrr%ALBEDMOY(ICL,ICH)
SUMALB2(ICH) = SUMALB2(ICH) + avhrr%CFRAC(ICL) * ( avhrr%ALBEDMOY(ICL,ICH)**2 + avhrr%ALBEDSTD(ICL,ICH)**2)
ENDIF
ENDDO
DO ICH=1+NVIS,NVIS+NIR
IF (avhrr%TBMOY(ICL,ICH) > 0.d0 ) THEN
SUMFRAC(ICH) = SUMFRAC(ICH) + avhrr%CFRAC(ICL)
SUMTB(ICH) = SUMTB(ICH) + avhrr%CFRAC(ICL) * avhrr%TBMOY(ICL,ICH)
SUMTB2(ICH) = SUMTB2(ICH) + avhrr%CFRAC(ICL) * (avhrr%TBMOY(ICL,ICH)**2 + avhrr%TBSTD(ICL,ICH)**2 )
ENDIF
ENDDO
ENDIF
ENDDO
DO ICH=1,NVIS
IF (SUMFRAC(ICH) >0.d0 ) THEN
SUMALB(ICH) = SUMALB(ICH) / SUMFRAC(ICH)
SUMALB2(ICH) = SUMALB2(ICH)/SUMFRAC(ICH) - SUMALB(ICH)**2
IF (SUMALB2(ICH)>0.d0) THEN
SUMALB2(ICH)=SQRT( SUMALB2(ICH) )
ELSE
SUMALB2(ICH)=0.d0
ENDIF
ENDIF
ENDDO
DO ICH=NVIS+1,NVIS+NIR
IF (SUMFRAC(ICH) >0.d0 ) THEN
SUMTB(ICH) = SUMTB(ICH) / SUMFRAC(ICH)
SUMTB2(ICH) = SUMTB2(ICH)/SUMFRAC(ICH) - SUMTB(ICH)**2
IF (SUMTB2(ICH)>0.d0) THEN
SUMTB2(ICH)=SQRT ( SUMTB2(ICH) )
ELSE
SUMTB2(ICH)=0.d0
ENDIF
ENDIF
ENDDO
avhrr%TBSTD_PIXELIASI=SUMTB2
avhrr%ALBSTD_PIXELIASI=SUMALB2
end subroutine stat_avhrr
SUBROUTINE CO2_SLICING ( PTOP,NTOP,FCLOUD, & 1
rcal,rcld,robs,ps,plev,nlev,nchn,cldflag,rejflag, &
lev_start,ichref,ilist,ilist_pair)
!
!**ID CO2_SLICING -- CLOUD TOP HEIGHT COMPUTATION
!
! AUTHOR: L. GARAND July 2004
! A. BEAULNE (CMDA/SMC) March 2006 (ADAPT TO 3DVAR)
!
! REVISION: 001 O. Pancrati various improvements
!
! OBJECT: CLOUD TOP FROM CO2 SLICING AND CLOUD FRACTION ESTIMATE
!
! ARGUMENTS:
! INPUT:
! -RCAL(NCHN) : COMPUTED CLEAR RADIANCES (MW/M2/SR/CM-1)
! -RCLD(NCHN,NLEV) : COMPUTED CLOUD RADIANCES FROM EACH LEVEL (")
! -ROBS(NCHN) : COMPUTED OBSERVED RADIANCES (")
! -PS : SURFACE PRESSURE (HPA)
! -PLEV(NLEV) : PRESSURE LEVELS (HPA)
! -NLEV : NUMBER OF VERTICAL LEVELS
! -NCHN : NUMBER OF CHANNELS
! -CLDFLAG : (0) CLEAR, (1) CLOUDY, (-1) UNDEFINED PROFILE
! -REJFLAG(NCHN,0:BITFLAG) : FLAGS FOR REJECTED OBSERVATIONS
! -BITFLAG : HIGHEST FLAG IN POST FILES (VALUE OF N IN 2^N)
! -ICHREF : WINDOW CHANNEL TO PREDETERMINE CLEAR
! -NCO2 : NUMBER OF CHANNELS TO GET ESTIMATES IN
! COMBINATION WITH ICHREF_CO2 (NOT INCLUDED)
! -ILIST(NCO2) : LIST OF THE CHANNEL NUMBERS, ICHREF_CO2 NOT INCLUDED
! (SUBSET VALUES)
!
! INPUT/OUTPUT:
! -LEV_START : LEVEL TO START ITERATION (IDEALLY TROPOPAUSE)
!
! OUTPUT:
! -PTOP(NCO2) : CLOUD TOP (HPA)
! -FCLOUD(NCO2) : CLOUD FRACTION
! -NTOP(NCO2) : NEAREST PRESSURE LEVEL CORRESPONDING TO PTOP
! (PTOP <= PS)
!
IMPLICIT NONE
integer ,intent (in) :: NLEV,NCHN
REAL(8) ,intent (in) :: RCAL(NCHN),RCLD(NCHN,NLEV),ROBS(NCHN)
REAL(8) ,intent (in) :: PLEV(NLEV),PS
integer ,intent (in) :: ICHREF,CLDFLAG,REJFLAG(NCHN,0:BITFLAG)
integer ,intent (in) :: ILIST(NCO2),ILIST_PAIR(NCO2)
integer ,intent (inout) :: LEV_START
REAL(8) ,intent (out) :: PTOP(NCO2),FCLOUD(NCO2)
integer ,intent (out) :: NTOP(NCO2)
!*********************************************************************************
INTEGER :: J,JCH,JC,JPMAX,JMAX
INTEGER :: SUMREJ
REAL(8) :: EPS
REAL(8) :: FC(NCHN,NLEV),RAPG,RADP
REAL(8) :: DRAP(NCO2,NLEV),A_DRAP(NLEV)
REAL(8) :: VAL,VAL1,VAL2,VAL3,FCINT
REAL(8) :: EMI_RATIO
INTEGER :: JC_PAIR
INTEGER :: ITER,NITER
EPS = 1.D-12
PTOP(:) = -1.D0
NTOP(:) = -1
FCLOUD(:) = -1.D0
!** profile not assimilated if data from 2 windows channels bad
!** and/or if data from 2 reference co2 channels bad
IF ( CLDFLAG == -1 ) RETURN
!** define closest level jpmax to surface pressure ps
JPMAX = NLEV
DO J = LEV_START, NLEV
IF ( PLEV(J) > PS ) THEN
JPMAX = J
EXIT
END IF
END DO
!** define jmax as last level for co2-slicing calculations
JMAX = JPMAX - 1
!** predetermined clear window channel, all nco2 estimates clear
SUMREJ = SUM(REJFLAG(ICHREF,:))
IF ( SUMREJ == 0 ) THEN
PTOP(:) = PS
NTOP(:) = JPMAX
FCLOUD(:) = 0.D0
RETURN
END IF
channels: DO JCH = 1, NCO2
JC = ILIST(JCH)
JC_PAIR = ILIST_PAIR(JCH)
FC(JC_PAIR,:) = RCAL(JC_PAIR) - RCLD(JC_PAIR,:)
NITER=1
IF ( JCH > 13) NITER=2
iteration: DO ITER = 1, NITER
DRAP(JCH,:) = 9999.D0
NTOP(JCH) = -1
!-------------------------------------------------------------------------------
! calcul EMI_RATIO
IF (JCH > 13) THEN
If ( ITER == 1 ) THEN
EMI_RATIO = 1.0376d0
Else
EMI_RATIO = 1.09961d0 - 0.09082d0*FCLOUD(JCH)
Endif
ELSE
EMI_RATIO = 1.0d0
ENDIF
!-------------------------------------------------------------------------------
FC(JC,:) = RCAL(JC) - RCLD(JC,:)
!** gross check failure
IF ( REJFLAG(JC,9) == 1 ) CYCLE channels
IF ( REJFLAG(JC_PAIR,9) == 1 ) CYCLE channels
IF ( abs(RCAL(JC_PAIR)-ROBS(JC_PAIR)) > EPS ) THEN
RAPG = (RCAL(JC)-ROBS(JC)) / (RCAL(JC_PAIR)-ROBS(JC_PAIR))
ELSE
RAPG = 0.0d0
ENDIF
DO J = LEV_START, JPMAX
IF ( FC(JC,J) > 0.D0 .AND. FC(JC_PAIR,J) > 0.D0 ) &
DRAP(JCH,J) = RAPG - (FC(JC,J) / FC(JC_PAIR,J))*EMI_RATIO
END DO
A_DRAP(:) = ABS(DRAP(JCH,:))
levels: DO J = LEV_START+1, JMAX
!** do not allow fc negative (i.e. drap(jch,j) = 9999.)
IF ( DRAP(JCH,J) > 9000.D0 .AND. &
A_DRAP(J-1) < EPS .AND. &
A_DRAP(J+1) < EPS ) CYCLE channels
VAL = DRAP(JCH,J) / ( DRAP(JCH,J-1) )
!** find first, hopefully unique, zero crossing
IF ( VAL < 0.D0 ) THEN
!** conditions near zero crossing of isolated minimum need monotonically
!** decreasing drap from j-3 to j-1 as well increasing from j to j+1
VAL1 = DRAP(JCH,J-2) / ( DRAP(JCH,J-1) )
VAL2 = DRAP(JCH,J-3) / ( DRAP(JCH,J-1) )
VAL3 = DRAP(JCH,J) / ( DRAP(JCH,J+1) )
IF ( VAL1 > 0.D0 .AND. &
VAL2 > 0.D0 .AND. &
VAL3 > 0.D0 .AND. &
A_DRAP(J-2) > A_DRAP(J-1) .AND. &
A_DRAP(J-3) > A_DRAP(J-2) .AND. &
A_DRAP(J) < 9000.D0 .AND. &
A_DRAP(J+1) > A_DRAP(J) ) &
THEN
PTOP(JCH) = PLEV(J)
NTOP(JCH) = J
END IF
EXIT levels
END IF
END DO levels
J = NTOP(JCH)
!** special cases of no determination
IF ( J <= LEV_START .OR. DRAP(JCH,J) > 9000.D0 ) THEN
! IF ( ITER == 1) THEN
PTOP(JCH) = -1.D0
NTOP(JCH) = -1
FCLOUD(JCH) = -1.D0
! ENDIF
CYCLE channels
END IF
IF ( ABS(RCLD(JC,J)-RCAL(JC)) > 0.D0 ) &
FCLOUD(JCH) = (ROBS(JC)-RCAL(JC)) / &
(RCLD(JC,J)-RCAL(JC))
!** find passage to zero if it exists and interpolate to exact pressure
PTOP(JCH) = PLEV(J-1) - DRAP(JCH,J-1) / &
( DRAP(JCH,J) - DRAP(JCH,J-1) ) * ( PLEV(J) - PLEV(J-1) )
!** find cloud radiance at zero crossing to use to get cloud fraction
FCINT = FC(JC,J-1) + ( FC(JC,J) - FC(JC,J-1) ) / &
( PLEV(J) - PLEV(J-1) ) * ( PTOP(JCH) - PLEV(J-1) )
!** find cloud fraction based on exact cloud top
IF ( ABS(FCINT) > 0.D0 ) &
FCLOUD(JCH) = ( RCAL(JC) - ROBS(JC) ) / FCINT
FCLOUD(JCH) = MIN ( FCLOUD(JCH), 1.5D0 )
FCLOUD(JCH) = MAX ( FCLOUD(JCH), -0.5D0 )
IF (FCLOUD(JCH) < 0.0D0 .or. FCLOUD(JCH) > 1.0D0 ) CYCLE channels
END DO iteration
END DO channels
END SUBROUTINE CO2_SLICING
SUBROUTINE SELTOP ( ETOP,VTOP,ECF,VCF,NGOOD, he,ht,cf,cfsub,ptop_mb,ps,cldflag,gncldflag ) 1,1
!
!**ID SELTOP -- SELECT CLOUD TOP
!
! AUTHOR: L. GARAND July 2004
! A. BEAULNE (CMDA/SMC) March 2006 (ADAPT TO 3DVAR)
!
! REVISION:
!
! OBJECT: SELECT CLOUD TOP BY AVERAGING CO2-SLICING RESULTS
! JUDGED CORRECT. ALL MISSING VALUES ARE -1.
!
! ARGUMENTS:
! INPUT:
! -HE(NPRF) : EQUIVALENT CLOUD TOP HEIGHTS
! FROM A WINDOW CHANNEL (HPA)
! -HT(NCO2,NPRF) : CLOUD TOPS FROM CO2-SLICING (HPA)
! -CF(NCO2,NPRF) : EFFECTIVE CLOUD FRACTION FOR CO2-SLICING
! -CFSUB(NPRF) : visible ("subpixel") cloud fraction
! -PTOP_MB(NPRF) : height (mb) from cloud_height subroutine
! -PS(NPRF) : SURFACE PRESSURE IN (HPA)
! -CLDFLAG(NPRF) : (0) CLEAR, (1) CLOUDY, (-1) UNDEFINED PROFILE
! -NPRF : NUMBER OF PROFILES
!
! OUTPUT:
! -ETOP(NPRF) : CONSENSUS CLOUD TOP (HPA)
! -VTOP(NPRF) : CORRESPONDING VARIANCE ON ETOP (HPA)
! -ECF(NPRF) : CONSENSUS EFFECTIVE CLOUD FRACTION
! -VCF(NPRF) : CORRESPONDING VARIANCE ON ECF
! -NGOOD(NPRF) : NUMBER OF GOOD ESTIMATES
!
IMPLICIT NONE
REAL(8) ,intent (in) :: HE,HT(NCO2),CF(NCO2),PS,CFSUB
integer ,intent (in) :: CLDFLAG, GNCLDFLAG
REAL(8) ,intent (out):: ETOP,VTOP,ECF,VCF
integer ,intent (out):: NGOOD
!***********************************************************************************
INTEGER :: N,JCH
REAL(8) :: PTOP_MB
REAL(8) :: H(NCO2),F(NCO2)
ETOP = -1.D0
VTOP = -1.D0
ECF = -1.D0
VCF = -1.D0
NGOOD= 0
!** profile not assimilated if data from 2 windows channels bad
!** and/or if data from 2 reference co2 channels bad
IF ( CLDFLAG == -1 ) RETURN
N = 0
H(:) = 0.D0
F(:) = 0.D0
DO JCH = 1, NCO2
!* CHECK FOR ZERO CLOUD FRACTION
IF ( CF(JCH) > -0.9D0 .AND. CF(JCH) < 1.D-6 ) THEN
N = N + 1
H(N) = PS
F(N) = 0.D0
ELSE
!* CONSIDER ONLY VALID VALUES OF CLOUD FRACTION ABOVE SOME THRESHOLD
! IMPORTANT LOGIC: FOR VALUES ABOVE 1.0 OF CO2-SLICING CLOUD FRACTION,
! SET IT TO 1.0 AND FORCE THE TOP EQUAL TO THE EFFECTIVE HEIGHT HE.
! CO2-SLICING NOT ALLOWED TO GIVE ESTIMATES BELOW HE, WHICH HAPPENS
! FOR CLOUD FRACTION CF > 1.0.
IF ( HT(JCH) > 0.0D0 ) THEN
N=N+1
H(N) = HT(JCH)
F(N) = MIN(CF(JCH), 1.0D0)
F(N) = MAX(F(N), 0.D0)
IF ( CF(JCH) > 1.0D0 ) H(N) = HE
END IF
ENDIF
ENDDO
NGOOD = N
!* COMPUTE MEAN AND VARIANCE
IF ( N >= 1 ) THEN
! ETOP = SUM(H(1:N)) / N
! ECF = SUM(F(1:N)) / N
call calcul_median_fast(N,NCO2,H,F,ETOP,ECF)
VTOP = SQRT ( SUM((H(1:N)-ETOP)**2)/N )
VCF = SQRT ( SUM((F(1:N)- ECF)**2)/N )
IF ( N == 1 ) THEN
VTOP = 50.D0
VCF = 0.20D0
END IF
ELSE
!* IF NO SOLUTION FROM CO2-SLICING, AND NOT PREDETERMINED CLEAR,
!* ASSUME CLOUDY WITH TOP EQUAL TO EFFECTIVE HEIGHT HE;
!* HOWEVER IF HE IS VERY CLOSE TO SURFACE PRESSURE PS, ASSUME CLEAR.
ETOP = HE
ECF = 1.0D0
IF (CFSUB>=0.05D0) THEN
ECF=CFSUB
ETOP=MIN(MIN(HE,PTOP_MB),PS-50.0D0)
ENDIF
VTOP = 50.D0
VCF = 0.30D0
IF ( HE > (PS-10.D0) ) ECF = 0.D0
IF ( GNCLDFLAG == 0 ) THEN
ECF=0.0D0
ETOP=PS
ENDIF
END IF
IF ( ECF < 0.05D0 ) THEN
ECF=0.0D0
ETOP=PS
ENDIF
END SUBROUTINE SELTOP
subroutine calcul_median_fast(NN,Nmax,Hin,Fin,CTP,CFR) 1
!
implicit none
integer ,intent (in) :: NN
integer ,intent (in) :: Nmax
real (8) ,intent (in):: Hin(Nmax),Fin(Nmax)
real (8) ,intent (out):: CTP,CFR
!*********************************************
INTEGER :: index(NN)
real (4) :: H(NN)
!*******
integer :: i
IF (NN==1) THEN
CTP=Hin(NN)
CFR=Fin(NN)
ELSE
H(1:NN)=Hin(1:NN)
call IPSORT(index,H,NN)
if (mod(NN,2)==0) then ! N - pair
i=index(NN/2)
CTP=Hin(i)
CFR=Fin(i)
else ! N - impair
i=index(1+NN/2)
CTP=Hin(i)
CFR=Fin(i)
endif
ENDIF
end subroutine calcul_median_fast
SUBROUTINE MIN_PRES_new(MAXHEIGHT,MINP,PMIN,DT1, ps,tau,plev,cldflag,nlev,nchn,imodtop) 1
!
!**ID MIN_PRES -- FIND MINIMUM HEIGHT LEVEL OF SENSITIVITY
!
! AUTHOR: L. GARAND May 2004
! A. BEAULNE (CMDA/SMC) March 2006 (ADAPT TO 3DVAR)
!
! REVISION:
!
! OBJECT: FROM TOTAL TRANSMITTANCE ARRAY, FIND MINIMUM HEIGHT
! LEVEL OF SENSITIVITY FOR A NUMBER OF PROFILES AND CHANNELS.
! THIS MAY BE USED TO SELECT FOR ASSIMILATION ONLY THE
! OBSERVATIONS WITHOUT SENSITIVITY TO CLOUDS, THAT IS THE
! RESPONSE FUNCTION SIGNIFICANT ONLY ABOVE CLOUD LEVEL.
! THE CRITERION IS THAT dTAU/dPLEV > 0.01 FOR A 100 MB LAYER.
!
! ARGUMENTS:
! INPUT:
! -PS : SURFACE PRESSURE (HPA)
! -TAU(NCHN,NLEV) : LAYER TO SPACE TRANSMITTANCES (0.-1.)
! -PLEV(NLEV) : PRESSURE LEVELS (HPA)
! -CLDFLAG : (0) CLEAR, (1) CLOUDY, (-1) UNDEFINED PROFILE
! -NLEV : NUMBER OF VERTICAL LEVELS
! -NCHN : NUMBER OF CHANNELS
! -IMODTOP : RT MODEL LEVEL NEAREST TO MODEL TOP
!
! OUTPUT:
! -PMIN(NCHN) : MINIMUM HEIGHT OF SENSITIVITY (HPA)
! -MINP(NCHN) : VERTICAL LEVEL CORRESPONDING TO PMIN
! -DT1(NCHN) : VALUE OF 'DTAU/DLOGP' AT MODEL TOP
! -MAXHEIGHT(NCHN): Height (hPa) of the maximum of the weighting function
!
IMPLICIT NONE
INTEGER ,INTENT(IN) :: NCHN,NLEV,IMODTOP,CLDFLAG
REAL(8), intent(in) :: PLEV(NLEV),PS,TAU(NCHN,NLEV)
INTEGER, INTENT (out) :: MINP(NCHN)
REAL(8), intent(out) :: PMIN(NCHN), DT1(NCHN),MAXHEIGHT(NCHN)
!*******************************************************************************
REAL(8) :: MAXWF
INTEGER :: J,JC,ipos(1)
REAL(8) :: WFUNC(NLEV-1),RAP(NLEV-1)
MINP(:) = -1
PMIN(:) = -1.D0
DT1(:) = -1.D0
DO J = 1, NLEV-1
RAP(J) = LOG( PLEV(J+1) / PLEV(J) )
ENDDO
channels: DO JC = 1, NCHN
!** profile not assimilated if data from 2 windows channels bad
!** and/or if data from 2 reference co2 channels bad
IF ( CLDFLAG == -1 ) RETURN
DO J = 1, NLEV
IF ( TAU(JC,J) < 0.D0) CYCLE channels
END DO
MINP(JC) = NLEV
PMIN(JC) = MIN(PLEV(NLEV),PS)
!* COMPUTE ENTIRE ARRAY OF dTAU/dlog(P)
DO J = 1, NLEV-1
WFUNC(J) = (TAU(JC,J)-TAU(JC,J+1)) / ( RAP(J) )
END DO
DT1(JC) = WFUNC(IMODTOP)
!* IF CHANNEL SEES THE SURFACE, DON'T RECALCULATE MINP AND PMIN
IF ( TAU(JC,NLEV) > 0.01D0 ) CYCLE channels
! Recherche du maximum
IPOS=MAXLOC( WFUNC(:) )
! Calcul de la valeur du maximum
MAXWF = WFUNC(IPOS(1))
! maximum entre les 2 niveaux puisque WF calculee pour une couche finie ( discutable ?)
MAXHEIGHT(JC)= 0.5D0 * ( PLEV(IPOS(1)) + PLEV(IPOS(1)+1) )
!* IF CHANNEL DOESN'T SEE THE SURFACE, SEE WHERE dTAU/dlog(PLEV) BECOMES IMPORTANT
!* FOR RECOMPUTATION OF MINP AND PMIN.
DO J = NLEV-1, IPOS(1), -1
IF ( ( WFUNC(J)/ MAXWF ) > 0.01D0) THEN
MINP(JC) = J+1
PMIN(JC) = MIN(PLEV(J+1),PS)
EXIT
END IF
ENDDO
END DO channels
END SUBROUTINE MIN_PRES_NEW
SUBROUTINE CLOUD_HEIGHT (PTOP,NTOP, & 3,2
btobs,cldflag,tt,gz,ps,plev,nlev, &
nchn,ichref,lev_start,iopt)
!
!**ID CLOUD_HEIGHT -- CLOUD TOP HEIGHT COMPUTATION
!
! SCIENCE: L. GARAND
! AUTHOR: A. BEAULNE (CMDA/SMC) August 2004
! A. BEAULNE (CMDA/SMC) February 2006 (ADAPT TO 3DVAR)
!
! REVISION:
!
! OBJECT: COMPUTATION OF CLOUD TOP HEIGHT (ABOVE THE GROUND)
! BASED ON MATCHING OBSERVED BRIGHTNESS TEMPERATURE AT A
! REFERENCE SURFACE CHANNEL WITH BACKGROUND TEMPERATURE PROFILE.
! TO USE WITH ONE REFERENCE CHANNEL. USED HERE ON MODEL LEVELS.
!
! ARGUMENTS:
! INPUT:
! -BTOBS(NCHN) : OBSERVED BRIGHTNESS TEMPERATURE (DEG K)
! -CLDFLAG : CLEAR(0), CLOUDY(1), UNDEFINED(-1) PROFILES
! -TT(NLEV) : TEMPERATURE PROFILES (DEG K)
! -GZ(NLEV) : HEIGHT PROFILES ABOVE GROUND (M)
! -PS(NPRF) : SURFACE PRESSURE (HPA)
! -PLEV(NLEV) : PRESSURE LEVELS (HPA)
! -NLEV : NUMBER OF VERTICAL LEVELS
! -NCHN : NUMBER OF CHANNELS
! -ICHREF : CHOSEN REFERENCE SURFACE CHANNEL
! -IOPT : LEVELS USING PLEV (1) OR GZ (2)
!
!
! INPUT/OUTPUT:
! -LEV_START : LEVEL TO START ITERATION (IDEALLY TROPOPAUSE)
!
! OUTPUT:
! -PTOP : CHOSEN EQUIVALENT CLOUD TOPS
! (IN HPA|M WITH IOPT = 1|2)
! -NTOP : NUMBER OF POSSIBLE PTOP SOLUTIONS
!
!
IMPLICIT NONE
integer ,intent (in) :: NCHN,NLEV,IOPT,ICHREF,CLDFLAG
REAL(8) ,intent (in) :: BTOBS(NCHN),TT(NLEV),GZ(NLEV),PS,PLEV(NLEV)
integer ,intent (inout) :: LEV_START
REAL(8) ,intent (out) :: PTOP
integer ,intent (out) :: NTOP
!**********************************************************************************************
INTEGER :: JN
INTEGER :: ITOP
INTEGER :: NHT
REAL(8) :: HT(NLEV)
IF ( IOPT == 1 ) THEN
PTOP = PS
NTOP = 1
IF ( CLDFLAG == -1 ) RETURN
CALL GET_TOP ( HT,NHT, btobs(ichref),tt,plev,nlev,lev_start,iopt )
ITOP = 1
IF ( NHT >= 2 ) ITOP = 2
PTOP = MIN ( HT(ITOP), PS )
NTOP = NHT
ELSEIF ( IOPT == 2 ) THEN
PTOP = 0.D0
NTOP = 1
IF ( CLDFLAG == -1 ) RETURN
CALL GET_TOP ( HT,NHT, btobs(ichref),tt,gz,nlev,lev_start,iopt )
ITOP = 1
IF ( NHT >= 2 ) ITOP = 2
PTOP = MAX ( HT(ITOP), 0.D0 )
NTOP = NHT
END IF
END SUBROUTINE CLOUD_HEIGHT
SUBROUTINE GARAND1998NADON (CLDFLAG, btobs,tg,tt,gz,nlev, & 2,2
nchn,ptop_eq,ntop_eq,ichref)
!
!**ID GARAND1998NADON -- DETERMINE IF PROFILES ARE CLEAR OR CLOUDY
!
! SCIENCE: L. GARAND AND S. NADON
! AUTHOR: A. BEAULNE (CMDA/SMC) June 2004
! A. BEAULNE (CMDA/SMC) March 2006 (ADAPT TO 3DVAR)
!
! REVISION:
!
! OBJECT: DETERMINE IF THE PROFILES ARE CLEAR OR CLOUDY BASED ON
! THE ALGORITHM OF GARAND & NADON 98 J.CLIM V11 PP.1976-1996
! WITH CHANNEL IREF
!
! ARGUMENTS:
! INPUT:
! -BTOBS(NCHN) : OBSERVED BRIGHTNESS TEMPERATURES (DEG K)
! -TG : GUESS SKIN TEMPERATURES (DEG K)
! -TT(NLEV) : GUESS TEMPERATURE PROFILES (DEG K)
! -GZ(NLEV) : GUESS HEIGHT PROFILE ABOVE GROUND (M)
! -NLEV : NUMBER OF VERTICAL LEVELS
! -NCHN : NUMBER OF CHANNELS
! -PTOP_EQ : CHOSEN EQUIVALENT CLOUD TOPS (M)
! -NTOP_EQ : NUMBER OF POSSIBLE PTOP_EQ SOLUTIONS
! -ICHREF : CHOSEN REFERENCE SURFACE CHANNEL
!
! INPUT/OUTPUT:
! -CLDFLAG(NPRF) : CLEAR(0), CLOUDY(1), UNDEFINED(-1) PROFILES
!
IMPLICIT NONE
integer ,intent (in) :: NLEV,NCHN
REAL(8) ,intent (in) :: BTOBS(NCHN),TG,GZ(NLEV),TT(NLEV),PTOP_EQ
integer ,intent (in) :: NTOP_EQ,ICHREF
integer ,intent (inout) :: CLDFLAG
!*********************************************************************************************
INTEGER :: NINV
REAL(8) :: LEV(2)
LEV(1) = 222.D0
LEV(2) = 428.D0
IF ( CLDFLAG == -1 ) return
IF ( BTOBS(ICHREF) >= TG-3.D0 .AND. BTOBS(ICHREF) <= TG+3.D0 ) THEN
CLDFLAG = 0
return
END IF
IF ( BTOBS(ICHREF) >= TG-4.D0 .AND. BTOBS(ICHREF) <= TG-3.D0 ) THEN
IF ( PTOP_EQ > 1100.D0 ) THEN
CLDFLAG = 1
return
ELSE
CLDFLAG = 0
return
END IF
END IF
IF ( PTOP_EQ > 728.D0 ) THEN
CLDFLAG = 1
return
END IF
IF ( TG-BTOBS(ICHREF) > 8.D0 ) THEN
IF ( NTOP_EQ >= 3 ) THEN
IF ( PTOP_EQ > 73.D0 ) THEN
CLDFLAG=1
return
ELSE
CLDFLAG=0
return
END IF
ELSE
CALL MONOTONIC_INVERSION (NINV, tg,tt,gz,nlev,lev(1))
IF ( NINV == 1 ) THEN
IF ( PTOP_EQ > 222.D0 ) THEN
CLDFLAG = 1
return
ELSE
CLDFLAG = 0
return
END IF
ELSE
CLDFLAG = 0
return
END IF
END IF
END IF
IF ( TG-BTOBS(ICHREF) > 5.D0 ) THEN
IF ( NTOP_EQ >= 3 ) THEN
IF ( PTOP_EQ > 222.D0 ) THEN
CLDFLAG = 1
return
ELSE
CLDFLAG = 0
return
END IF
ELSE
CALL MONOTONIC_INVERSION (NINV, tg,tt,gz,nlev,lev(2))
IF ( NINV == 1) THEN
IF( PTOP_EQ > 428.D0 ) THEN
CLDFLAG = 1
return
ELSE
CLDFLAG = 0
return
END IF
ELSE
CLDFLAG = 0
END IF
END IF
ELSE
CLDFLAG=0
END IF
END SUBROUTINE GARAND1998NADON
SUBROUTINE MONOTONIC_INVERSION (NINVR, ptg,ptt,pgz,npr,lvl) 2
#if defined (DOC)
!***********************************************************************
!
!**ID MONOTONIC_INVERSION -- DETECT TEMPERATURE INVERSION
!
! SCIENCE: L. GARAND AND S. NADON
! AUTHOR: A. BEAULNE (CMDA/SMC) June 2004
! A. BEAULNE (CMDA/SMC) March 2006 (ADAPT TO 3DVAR)
!
! REVISION:
!
! OBJECT: DETERMINE IF THERE IS A PRESENCE (NINVR=1) OR NOT (NINVR=0)
! OF A TEMPERATURE INVERSION GOING FROM THE SURFACE UP TO THE
! HEIGHT LVL
!
! ARGUMENTS:
! INPUT:
! -PTG : SKIN TEMPERATURE (DEG K)
! -PTT(NPR) : TEMPERATURE PROFILE (DEG K)
! -PGZ(NPR) : HEIGHT PROFILE ABOVE GROUND (M)
! -NPR : NUMBER OF VERTICAL LVLELS
! -LVL : HEIGHT TO SEARCH FOR TEMPERATURE INVERSION (M)
!
! OUTPUT:
! -NINVR : PRESENCE (1) OR NOT (0) OF A TEMPERATURE INVERSION
! FROM THE SURFACE TO HEIGHT LVL
!
!
!***********************************************************************
#endif
IMPLICIT NONE
integer ,intent (in) :: npr
REAL(8),intent (in) :: PTT(NPR),PGZ(NPR),PTG,LVL
integer ,intent (out):: ninvr
!**************************************************
INTEGER :: NL
NINVR = 0
IF ( PTG - PTT(NPR) < 0.D0 ) THEN
NINVR = 1
DO NL = NPR-1, 1, -1
IF ( PGZ(NL) > LVL ) EXIT
IF ( PTT(NL+1) - PTT(NL) > 0.D0 ) THEN
NINVR = 0
EXIT
END IF
END DO
END IF
END SUBROUTINE MONOTONIC_INVERSION
SUBROUTINE ESTIM_TS(TS, tg,emi,rcal,radobs,sfctau,cldflag, & 1,6
ichref,nchn,nchnkept,satid,CINST)
!
!**ID ESTIM_TS -- GET AN ESTIMATED SKIN TEMPERATURE
!
! AUTHOR: L. GARAND May 2004
! A. BEAULNE (CMDA/SMC) March 2006 (ADAPT TO 3DVAR)
!
! REVISION:
!
! OBJECT: GET AN ESTIMATED SKIN TEMPERATURE BY INVERSION OF
! RADIATIVE TRANSFER EQUATION ASSUMING GUESS T AND Q PROFILES
! ARE PERFECT. DESIGNED FOR A SINGLE CHANNEL ICHREF AND NPRF
! PROFILES. ASSUMES A REAL TG (GUESS) OVER OCEANS AND A TG
! WITH HYPOTHESIS OF UNITY EMISSIVITY OVER LAND.
!
! USES: RCAL = B(TG)*EMI*SFCTAU + ATMOS_PART
! TS = B(TS)*EMI*SFCTAU + ATMOS_PART
! SOLVES FOR TS
!
! ARGUMENTS:
! INPUT:
! -TG : GUESS SKIN TEMPERATURE (DEG K)
! -EMI(NCHN) : SURFACE EMISSIVITIES FROM WINDOW CHANNEL (0.-1.)
! -RCAL(NCHN) : COMPUTED CLEAR RADIANCES (MW/M2/SR/CM-1)
! -RADOBS(NCHN) : OBSERVED RADIANCES (")
! -SFCTAU(NCHN) : SURFACE TO SPACE TRANSMITTANCES (0.-1.)
! -CLDFLAG : CLEAR(0), CLOUDY(1) OR UNDEFINED(-1) PROFILES
! -ICHREF : REFERENCE SURFACE CHANNEL (SUBSET VALUES)
! -NCHN : NUMBER OF CHANNELS
! -NCHNKEPT : NUMBER OF CHANNELS KEPT IN CMA
! -SATID : SATELLITE IDENTYFIER
! -CINST : INTRUMENT CrIS, IASI or AIRS
!
! OUTPUT:
! -TS : RETRIEVED SKIN TEMPERATURE (-1. FOR MISSING)
!
use tovs_nl_mod
use hir_chans
IMPLICIT NONE
integer ,intent(in) :: NCHN,NCHNKEPT,satid
integer ,intent(in) :: ICHREF,CLDFLAG
REAL(8) ,intent(in) :: TG,EMI(NCHN),RCAL(NCHN),RADOBS(NCHN)
REAL(8) ,intent(in) :: SFCTAU(NCHN)
CHARACTER (LEN=*) ,intent(in) :: CINST
REAL(8) ,intent(out):: TS
!************************************************************************************
INTEGER :: JC
INTEGER :: ICHN,INDX
REAL(8) :: RTG,RADTG(NCHN)
REAL(8) :: RADTS,TS1(NCHN),tstore,t_effective
integer :: ptc(NCHNKEPT)
TS1(:) = -1.D0
TS = -1.D0
RADTG(:) = -1.D0
if (NCHNKEPT/=hir_get_nchan_selected(CINST)) then
Write(*,*) "Invalid NCHNKEPT: ",NCHNKEPT,hir_get_nchan_selected(CINST),CINST
call abort3d("estim_ts")
endif
DO JC= 1, NCHNKEPT
ptc(JC)=hir_get_chindx_fr_chn(CINST,ichan(JC,SATID))
END DO
!* transform guess skin temperature to plank radiances
IF ( CLDFLAG /= -1 ) THEN
DO JC = 1, NCHNKEPT
t_effective = coefs(satid)%coef%ff_bco(jc) + coefs(satid)%coef%ff_bcs(jc) * TG
indx=ptc(jc)
RADTG(indx) = coefs(satid)%coef%planck1(jc) / &
( Exp( coefs(satid)%coef%planck2(jc)/t_effective ) - 1.0D0 )
END DO
ENDIF
IF ( CLDFLAG /= 0 ) RETURN
!* compute TOA planck radiances due to guess skin planck radiances
RTG = RADTG(ICHREF)*EMI(ICHREF)*SFCTAU(ICHREF)
!* compute true skin planck radiances due to TOA true planck radiances
RADTS = ( RADOBS(ICHREF) + RTG - RCAL(ICHREF) ) / &
( EMI(ICHREF) * SFCTAU(ICHREF) )
!* transform true skin planck radiances to true skin temperatures
DO JC = 1, NCHNKEPT
tstore = coefs(satid)%coef%planck2(jc) / Log( 1+coefs(satid)%coef%planck1(jc)/RADTS )
indx=ptc(jc)
TS1(indx) = ( tstore-coefs(satid)%coef%ff_bco(jc) ) / coefs(satid)%coef%ff_bcs(jc)
END DO
TS = TS1(ichref)
END SUBROUTINE ESTIM_TS
SUBROUTINE ESTIM_TS_AVHRR(TS, tg,emi,rcal,radobs,sfctau,cldflag, & 1
ichref,nchn)
!
!**ID ESTIM_TS -- GET AN ESTIMATED SKIN TEMPERATURE
!
! AUTHOR: L. GARAND May 2004
! A. BEAULNE (CMDA/SMC) March 2006 (ADAPT TO 3DVAR)
!
! REVISION:
!
! OBJECT: GET AN ESTIMATED SKIN TEMPERATURE BY INVERSION OF
! RADIATIVE TRANSFER EQUATION ASSUMING GUESS T AND Q PROFILES
! ARE PERFECT. DESIGNED FOR A SINGLE CHANNEL ICHREF AND NPRF
! PROFILES. ASSUMES A REAL TG (GUESS) OVER OCEANS AND A TG
! WITH HYPOTHESIS OF UNITY EMISSIVITY OVER LAND.
!
! USES: RCAL = B(TG)*EMI*SFCTAU + ATMOS_PART
! TS = B(TS)*EMI*SFCTAU + ATMOS_PART
! SOLVES FOR TS
!
! ARGUMENTS:
! INPUT:
! -TG : GUESS SKIN TEMPERATURE (DEG K)
! -EMI(NCHN) : SURFACE EMISSIVITIES FROM WINDOW CHANNEL (0.-1.)
! -RCAL(NCHN) : COMPUTED CLEAR RADIANCES (MW/M2/SR/CM-1)
! -RADOBS(NCHN) : OBSERVED RADIANCES (")
! -SFCTAU(NCHN) : SURFACE TO SPACE TRANSMITTANCES (0.-1.)
! -CLDFLAG : CLEAR(0), CLOUDY(1) OR UNDEFINED(-1) PROFILES
! -ICHREF : REFERENCE SURFACE CHANNEL (SUBSET VALUES)
! -NCHN : NUMBER OF CHANNELS
!
! OUTPUT:
! -TS : RETRIEVED SKIN TEMPERATURE (-1. FOR MISSING)
!
!
IMPLICIT NONE
integer ,intent(in) :: nchn
integer ,intent(in) :: ichref,CLDFLAG
REAL(8) ,intent(in) :: TG,EMI(NCHN),RCAL(NCHN),RADOBS(NCHN)
REAL(8) ,intent(in) :: SFCTAU(NCHN)
REAL(8) ,intent(out):: TS
!***************************************
INTEGER :: JC
INTEGER :: ICHN
REAL(8) :: RTG,RADTG(NCHN)
REAL(8) :: RADTS,TS1(NCHN),tstore,t_effective
TS1(:) = -1.D0
TS = -1.D0
RADTG(:) = -1.D0
!* transform guess skin temperature to plank radiances
IF ( CLDFLAG /= -1 ) THEN
DO JC = 1, NCHN
t_effective = coefs_avhrr%coef%ff_bco(jc) + coefs_avhrr%coef%ff_bcs(jc) * TG
RADTG(JC) = coefs_avhrr%coef%planck1(jc) / &
( Exp( coefs_avhrr%coef%planck2(jc)/t_effective ) - 1.0D0 )
END DO
ENDIF
IF ( CLDFLAG /= 0 ) RETURN
!* compute TOA planck radiances due to guess skin planck radiances
RTG = RADTG(ICHREF)*EMI(ICHREF)*SFCTAU(ICHREF)
!* compute true skin planck radiances due to TOA true planck radiances
RADTS = ( RADOBS(ICHREF) + RTG - RCAL(ICHREF) ) / &
( EMI(ICHREF) * SFCTAU(ICHREF) )
!* transform true skin planck radiances to true skin temperatures
DO JC = 1, NCHN
tstore = coefs_avhrr%coef%planck2(jc) / Log( 1+coefs_avhrr%coef%planck1(jc)/RADTS )
TS1(JC) = ( tstore-coefs_avhrr%coef%ff_bco(jc) ) / coefs_avhrr%coef%ff_bcs(jc)
END DO
TS = TS1(ichref)
END SUBROUTINE ESTIM_TS_AVHRR
SUBROUTINE CLOUD_TOP ( PTOP_BT,PTOP_RD,NTOP_BT,NTOP_RD, & 1,4
btobs,tt,gz,rcal,ps,robs,rcld,plev,nlev,nchn, &
cldflag,rejflag,lev_start,iopt,ihgt,ichref,nch,ilist)
!
!**ID CLOUD_TOP -- CLOUD TOP HEIGHT COMPUTATION
!
! AUTHOR: L. GARAND August 2004
! A. BEAULNE (CMDA/SMC) March 2006 (ADAPT TO 3DVAR)
!
! REVISION: 001 S. Heilliette: removal of hard-coded rttov level
!
! OBJECT: COMPUTATION OF CLOUD TOP HEIGHT (ABOVE THE GROUND)
! BASED ON MATCHING OBSERVED BRIGHTNESS TEMPERATURE WITH
! BACKGROUND TEMPERATURE PROFILES AND/OR COMPUTED OBSERVED
! RADIANCES WITH BACKGROUND RADIANCE PROFILES.
! TO USE WITH MORE THAN ONE CHANNEL. USED HERE ON RTTOV LEVELS.
!
! ARGUMENTS:
! INPUT:
! -BTOBS(NCHN) : OBSERVED BRIGHTNESS TEMPERAUTRES (DEG K)
! -TT(NLEV) : TEMPERATURE PROFILES (DEG K)
! -GZ(NLEV) : HEIGHT PROFILES ABOVE GROUND (M)
! -RCAL(NCHN) : COMPUTED CLEAR RADIANCES (MW/M2/SR/CM-1)
! -PS : SURFACE PRESSURE (HPA)
! -ROBS(NCHN) : COMPUTED OBSERVED RADIANCES (MW/M2/SR/CM-1)
! -RCLD(NCHN,NLEV) : COMPUTED CLOUD RADIANCES FROM EACH LEVEL (")
! -PLEV(NLEV) : PRESSURE LEVELS (HPA)
! -NLEV : NUMBER OF VERTICAL LEVELS
! -NCHN : NUMBER OF CHANNELS
! -CLDFLAG : CLEAR(0), CLOUDY(1), UNDEFINED(-1) PROFILES
! -REJFLAG(NCHN,0:BITFLAG) : FLAGS FOR REJECTED OBSERVATIONS
! -IOPT : LEVELS USING PLEV (1) OR GZ (2)
! -IHGT : GET *_BT* ONLY (0), *_RD* ONLY (1), BOTH (2)
! -ICHREF : REFERENCE SURFACE CHANNEL (SUBSET VALUE)
! -NCH : NUMBER OF CHANNELS WE WANT OUTPUTS
! -ILIST(NCH ) : LIST OF THE CHANNEL NUMBERS (SUBSET VALUES)
!
! INPUT/OUTPUT:
! -LEV_START : LEVEL TO START ITERATION (IDEALLY TROPOPAUSE)
!
! OUTPUT:
! -PTOP_BT(NCHN) : CHOSEN EQUIVALENT CLOUD TOPS BASED ON
! BRIGHTNESS TEMPERATURES (IN HPA|M WITH IOPT = 1|2)
! -PTOP_RD(NCHN) : CHOSEN EQUIVALENT CLOUD TOPS BASED ON
! RADIANCES (IN HPA|M WITH IOPT = 1|2)
! -NTOP_BT : NUMBER OF POSSIBLE PTOP_BT SOLUTIONS
! -NTOP_RD : NUMBER OF POSSIBLE PTOP_RD SOLUTIONS
!
IMPLICIT NONE
integer, intent (in) :: NCHN,NCH,NLEV,IOPT,IHGT
REAL(8), intent (in) :: BTOBS(NCHN),RCLD(NCHN,NLEV)
REAL(8), intent (in) :: ROBS(NCHN),RCAL(NCHN)
REAL(8), intent (in) :: TT(NLEV),GZ(NLEV),PLEV(NLEV),PS
integer, intent (in) :: REJFLAG(NCHN,0:BITFLAG),ILIST(NCH),CLDFLAG,ICHREF
integer, intent (inout) :: LEV_START
REAL(8), intent (out) :: PTOP_BT(NCHN),PTOP_RD(NCHN)
INTEGER, intent (out) :: NTOP_BT(NCHN),NTOP_RD(NCHN)
!******************************************************************
INTEGER :: JCH,JC,ITOP,NHT,i10,i
INTEGER :: SUMREJ
REAL(8) :: HT(NLEV)
i10=1
DO I=2,NLEV
IF (plev(i-1)<=100.d0 .AND. plev(i)>100.d0) THEN
I10=I
EXIT
ENDIF
ENDDO
PTOP_BT(:) = -10.D0
PTOP_RD(:) = -10.D0
NTOP_BT(:) = 0.D0
NTOP_RD(:) = 0.D0
!** profile not assimilated if data from 2 windows channels bad
IF ( CLDFLAG == -1 ) RETURN
!** predetermined clear
SUMREJ = SUM(REJFLAG(ICHREF,:))
IF ( SUMREJ == 0 ) THEN
IF ( IOPT == 1 ) THEN
PTOP_BT(:) = MIN ( PLEV(NLEV), PS )
PTOP_RD(:) = MIN ( PLEV(NLEV), PS )
ELSE IF ( IOPT == 2 ) THEN
PTOP_BT(:) = 0.D0
PTOP_RD(:) = 0.D0
END IF
NTOP_BT(:) = 1
NTOP_RD(:) = 1
LEV_START = MAX ( LEV_START , i10 )
RETURN
END IF
channels: DO JCH = 1, NCH
JC = ILIST(JCH)
!** gross check failure
IF ( REJFLAG(JC,9) == 1 ) CYCLE channels
!** no clouds if observed radiance warmer than clear estimate
IF ( ROBS(JC) > RCAL(JC) ) THEN
IF ( IOPT == 1 ) THEN
PTOP_BT(JC) = MIN ( PLEV(NLEV), PS )
PTOP_RD(JC) = MIN ( PLEV(NLEV), PS )
ELSE IF ( IOPT == 2 ) THEN
PTOP_BT(JC) = 0.D0
PTOP_RD(JC) = 0.D0
END IF
NTOP_BT(JC) = 1
NTOP_RD(JC) = 1
CYCLE channels
END IF
!** cloudy
IF ( REJFLAG(JC,11) == 1 .and. REJFLAG(JC,23) == 1 ) THEN
IF ( IOPT == 1 ) THEN
IF ( IHGT == 0 .OR. IHGT == 2 ) THEN
CALL GET_TOP ( HT,NHT, btobs(jc),tt,plev,nlev,lev_start,iopt)
ITOP = 1
IF ( NHT >= 2 ) ITOP = 2
PTOP_BT(JC) = MIN ( HT(ITOP), PS )
NTOP_BT(JC) = NHT
END IF
IF ( IHGT == 1 .OR. IHGT == 2 ) THEN
CALL GET_TOP ( HT,NHT, robs(jc),rcld(jc,:),plev,nlev,lev_start,iopt)
ITOP = 1
IF ( NHT >= 2 ) ITOP = 2
PTOP_RD(JC) = MIN ( HT(ITOP), PS )
NTOP_RD(JC) = NHT
END IF
ELSE IF ( IOPT == 2 ) THEN
IF ( IHGT == 0 .OR. IHGT == 2 ) THEN
CALL GET_TOP ( HT,NHT, btobs(jc),tt,gz,nlev,lev_start,iopt)
ITOP = 1
IF ( NHT >= 2 ) ITOP = 2
PTOP_BT(JC) = MAX ( HT(ITOP), 0.D0 )
NTOP_BT(JC) = NHT
END IF
IF ( IHGT == 1 .OR. IHGT == 2 ) THEN
CALL GET_TOP ( HT,NHT, robs(jc),rcld(jc,:),gz,nlev,lev_start,iopt)
ITOP = 1
IF ( NHT >= 2 ) ITOP = 2
PTOP_RD(JC) = MAX ( HT(ITOP), 0.D0 )
NTOP_RD(JC) = NHT
END IF
END IF
END IF
END DO channels
END SUBROUTINE CLOUD_TOP
SUBROUTINE CLOUD_TOP_AVHRR ( PTOP_BT,PTOP_RD,NTOP_BT,NTOP_RD, & 1,4
btobs,tt,gz,rcal,ps,robs,rcld,plev,nlev,nchn, &
cldflag,lev_start,iopt,ihgt,nch,ilist)
!
!**ID CLOUD_TOP -- CLOUD TOP HEIGHT COMPUTATION
!
! AUTHOR: L. GARAND August 2004
! A. BEAULNE (CMDA/SMC) March 2006 (ADAPT TO 3DVAR)
!
! REVISION: 001 S. Heilliette:
! -to remove hard-coded rttov pressure level numbers
!
! OBJECT: COMPUTATION OF CLOUD TOP HEIGHT (ABOVE THE GROUND)
! BASED ON MATCHING OBSERVED BRIGHTNESS TEMPERATURE WITH
! BACKGROUND TEMPERATURE PROFILES AND/OR COMPUTED OBSERVED
! RADIANCES WITH BACKGROUND RADIANCE PROFILES.
! TO USE WITH MORE THAN ONE CHANNEL. USED HERE ON RTTOV LEVELS.
!
! ARGUMENTS:
! INPUT:
! -BTOBS(NCHN) : OBSERVED BRIGHTNESS TEMPERAUTRES (DEG K)
! -TT(NLEV) : TEMPERATURE PROFILES (DEG K)
! -GZ(NLEV) : HEIGHT PROFILES ABOVE GROUND (M)
! -RCAL(NCHN) : COMPUTED CLEAR RADIANCES (MW/M2/SR/CM-1)
! -PS : SURFACE PRESSURE (HPA)
! -ROBS(NCHN) : COMPUTED OBSERVED RADIANCES (MW/M2/SR/CM-1)
! -RCLD(NCHN,NLEV) : COMPUTED CLOUD RADIANCES FROM EACH LEVEL (")
! -PLEV(NLEV) : PRESSURE LEVELS (HPA)
! -NLEV : NUMBER OF VERTICAL LEVELS
! -NCHN : NUMBER OF CHANNELS
! -CLDFLAG : CLEAR(0), CLOUDY(1), UNDEFINED(-1) PROFILES
! -IOPT : LEVELS USING PLEV (1) OR GZ (2)
! -IHGT : GET *_BT* ONLY (0), *_RD* ONLY (1), BOTH (2)
! -NCH : NUMBER OF CHANNELS WE WANT OUTPUTS
! -ILIST(NCH) : LIST OF THE CHANNEL NUMBERS (SUBSET VALUES)
!
! INPUT/OUTPUT:
! -LEV_START : LEVEL TO START ITERATION (IDEALLY TROPOPAUSE)
!
! OUTPUT:
! -PTOP_BT(NCHN) : CHOSEN EQUIVALENT CLOUD TOPS BASED ON
! BRIGHTNESS TEMPERATURES (IN HPA|M WITH IOPT = 1|2)
! -PTOP_RD(NCHN) : CHOSEN EQUIVALENT CLOUD TOPS BASED ON
! RADIANCES (IN HPA|M WITH IOPT = 1|2)
! -NTOP_BT(NCHN) : NUMBER OF POSSIBLE PTOP_BT SOLUTIONS
! -NTOP_RD(NCHN) : NUMBER OF POSSIBLE PTOP_RD SOLUTIONS
!
IMPLICIT NONE
INTEGER ,intent(in) :: NCH,IOPT,IHGT,NLEV,NCHN
INTEGER ,intent(in) :: ILIST(NCH),CLDFLAG
REAL(8) ,intent(in) :: PLEV(NLEV),PS
REAL(8) ,intent(in) :: ROBS(NCHN),RCAL(NCHN)
REAL(8) ,intent(in) :: BTOBS(NCHN),RCLD(NCHN,NLEV)
REAL(8) ,intent(in) :: TT(NLEV),GZ(NLEV)
INTEGER ,intent(inout) :: LEV_START
REAL(8) ,intent(out) :: PTOP_BT(NCHN),PTOP_RD(NCHN)
INTEGER ,intent(out) :: NTOP_BT(NCHN),NTOP_RD(NCHN)
!*********************************************************************
INTEGER :: JCH,JC,ITOP,NHT,i10,i
REAL(8) :: HT(NLEV)
i10=1
DO I=2,NLEV
IF (plev(i-1)<=100.d0 .AND. plev(i)>100.d0) THEN
I10=I
EXIT
ENDIF
ENDDO
PTOP_BT(:) = -10.D0
PTOP_RD(:) = -10.D0
NTOP_BT(:) = 0.D0
NTOP_RD(:) = 0.D0
!** profile not assimilated if data from 2 windows channels bad
IF ( CLDFLAG == -1 ) RETURN
!** predetermined clear
IF ( CLDFLAG ==0 ) THEN
IF ( IOPT == 1 ) THEN
PTOP_BT(:) = MIN ( PLEV(NLEV), PS )
PTOP_RD(:) = MIN ( PLEV(NLEV), PS )
ELSE IF ( IOPT == 2 ) THEN
PTOP_BT(:) = 0.D0
PTOP_RD(:) = 0.D0
END IF
NTOP_BT(:) = 1
NTOP_RD(:) = 1
LEV_START = MAX ( LEV_START , i10 )
RETURN
END IF
channels: DO JCH = 1, NCH
JC = ILIST(JCH)
!** gross check failure
IF ( BTOBS(JC)<150.d0 .or. BTOBS(JC)>350.d0) CYCLE channels
!** no clouds if observed radiance warmer than clear estimate
IF ( ROBS(JC) > RCAL(JC) ) THEN
IF ( IOPT == 1 ) THEN
PTOP_BT(JC) = MIN ( PLEV(NLEV), PS )
PTOP_RD(JC) = MIN ( PLEV(NLEV), PS )
ELSEIF ( IOPT == 2 ) THEN
PTOP_BT(JC) = 0.D0
PTOP_RD(JC) = 0.D0
END IF
NTOP_BT(JC) = 1
NTOP_RD(JC) = 1
CYCLE channels
END IF
!** cloudy
IF ( CLDFLAG ==1 ) THEN
IF ( IOPT == 1 ) THEN
IF ( IHGT == 0 .OR. IHGT == 2 ) THEN
CALL GET_TOP ( HT,NHT, btobs(jc),tt,plev,nlev,lev_start,iopt)
ITOP = 1
IF ( NHT >= 2 ) ITOP = 2
PTOP_BT(JC) = MIN ( HT(ITOP), PS )
NTOP_BT(JC) = NHT
END IF
IF ( IHGT == 1 .OR. IHGT == 2 ) THEN
CALL GET_TOP ( HT,NHT, robs(jc),rcld(jc,:),plev,nlev,lev_start,iopt)
ITOP = 1
IF ( NHT >= 2 ) ITOP = 2
PTOP_RD(JC) = MIN ( HT(ITOP), PS )
NTOP_RD(JC) = NHT
END IF
ELSE IF ( IOPT == 2 ) THEN
IF ( IHGT == 0 .OR. IHGT == 2 ) THEN
CALL GET_TOP ( HT,NHT, btobs(jc),tt,gz,nlev,lev_start,iopt)
ITOP = 1
IF ( NHT >= 2 ) ITOP = 2
PTOP_BT(JC) = MAX ( HT(ITOP), 0.D0 )
NTOP_BT(JC) = NHT
END IF
IF ( IHGT == 1 .OR. IHGT == 2 ) THEN
CALL GET_TOP ( HT,NHT, robs(jc),rcld(jc,:),gz,nlev,lev_start,iopt)
ITOP = 1
IF ( NHT >= 2 ) ITOP = 2
PTOP_RD(JC) = MAX ( HT(ITOP), 0.D0 )
NTOP_RD(JC) = NHT
END IF
END IF
END IF
END DO channels
END SUBROUTINE CLOUD_TOP_AVHRR
subroutine get_avhrr_emiss(iasi_surfem1,freqiasi,nchaniasi,avhrr_surfem1) 1
! choisi l'emissivité d'un canal IASI proche pour AVHRR
! a raffiner pour prendre en compte la largeur des canaux AVHRR ??
implicit none
integer ,intent(in) :: nchaniasi
real (8) ,intent (in) :: iasi_surfem1 ( nchaniasi )
real (8) ,intent (in) :: freqiasi( nchaniasi )
real (8) ,intent (out):: avhrr_surfem1( NIR )
!****************************
real (8),parameter :: freqavhrr(NIR)= (/0.2687000000D+04 , 0.9272000000D+03 , 0.8377000000D+03/)
INTEGER,save :: indxavhrr(NIR)
LOGICAL ,SAVE :: FIRST=.true.
integer :: i,pos(1)
!*************************************************************8
IF (FIRST) THEN
DO I=1,NIR
pos=minloc ( ABS (freqiasi(:)-freqavhrr(I)) )
indxavhrr(i)=pos(1)
ENDDO
FIRST=.false.
ENDIF
DO I=1,NIR
avhrr_surfem1(i)=iasi_surfem1(indxavhrr(i))
ENDDO
end subroutine get_avhrr_emiss
subroutine tovs_rttov_AVHRR_for_IASI (iptobs,surfem1_avhrr,idiasi) 1,12
#if defined (doc)
!
!**s/r tovs_rttov_AVHRR_for_IASI - Computation of forward radiance with rttov_direct
! (for AVHRR)
!
!
!author : S. Heilliette
!
!revision 001 : s. heilliette october 2010
! - adaptation to rttov 10.0
! -------------------
! purpose:
!
!arguments
!
! appel de RTTOV pour le calcul des radiances AVHRR
! (non assimilees mais necessaires au background check IASI)
#endif
Use tovs_nl_mod
implicit none
#include "rttov_setup.interface"
#include "rttov_direct2.interface"
#include "rttov_alloc_rad.interface"
integer ,intent(in) :: idiasi
integer ,intent (in) :: iptobs(1)
real (8) , intent (in) :: surfem1_avhrr(3)
!*********************************************************************
type (rttov_options ),save :: opts_avhrr
type (rttov_chanprof) :: chanprof(3)
real*8 :: emissivity_out (3)
real*8 :: cloudemissivity (3)
logical :: calcemis (3)
INTEGER :: list_sensor (3),setup_errorstatus
integer, save :: idiasi_old=-1
integer :: ich,i,j,jn,ichn
integer :: VERBOSITY_LEVEL,ERR_UNIT=0
integer :: ichan_avhrr (NIR)
integer :: joff,ioffset
type ( transmission_Type ) :: transmission
type ( radiance_type ) :: radiancedata_d
integer :: nchannels
integer :: asw,nlevels,errorstatus,io
!***********************************************
IF (IDIASI_OLD/=IDIASI) THEN
VERBOSITY_LEVEL = 3
LIST_SENSOR(1)=10
LIST_SENSOR(2)=idiasi
LIST_SENSOR(3)=5
DO ICH=1,NIR
ICHAN_AVHRR(ICH)=ICH
ENDDO
opts_avhrr%ipcreg=-1 ! index of the rquired PC predictors... to see later
opts_avhrr%addinterp=.false. !
opts_avhrr%addpc=.false. ! to carry out principal component calculations
opts_avhrr%addradrec=.false. ! to reconstruct radiances from principal components
opts_avhrr%addsolar=.false. ! to model solar component in the near IR (2000 cm-1 et plus)
opts_avhrr%addaerosl=.false. ! to account for scattering due to aerosols
opts_avhrr%addclouds=.false. ! to account for scattering due to clouds
opts_avhrr%switchrad=.true. ! to use brightness temperature (true) or radiance (false) units in AD routine
opts_avhrr%lgradp=.false. ! allow tl/ad of user pressure levels
opts_avhrr%use_q2m=.false. ! if true use of surface humidity
opts_avhrr%apply_reg_limits=.false. ! if true application of profiles limits
opts_avhrr%verbose_checkinput_warnings=.false. ! useful for debuging the code should be turned off later
opts_avhrr%ozone_data=.true. ! profil d'ozone disponible
opts_avhrr%clw_data=.false. ! profil d'eau liquide pas disponible
opts_avhrr%addrefrac=.false. ! to account for atmospheric refraction (useless)
opts_avhrr%do_checkinput=.true. ! to check if input profiles are within absolute and regression limits
setup_errorstatus=0
if (IDIASI_OLD>0) then
call rttov_dealloc_coefs(setup_errorstatus, coefs_avhrr )
if ( setup_errorstatus/=0) then
write(*,*) "Probleme dans rttov_dealloc_coefs !"
call abort3d("tovs_rttov_AVHRR_for_IASI")
endif
endif
call rttov_setup (&
setup_errorstatus,&! out
err_unit, &! in
verbosity_level, &! in
opts_avhrr, &! in
coefs_avhrr, &! out
list_sensor, &! in
ichan_avhrr ) ! in Optional
if ( setup_errorstatus/=0) then
write(*,*) "Probleme dans rttov_setup!"
call abort3d("tovs_rttov_AVHRR_for_IASI")
endif
opts_avhrr%co2_data = ( coefs_avhrr%coef%nco2 > 0 )
opts_avhrr%n2o_data = ( coefs_avhrr%coef%nn2o > 0 )
opts_avhrr%co_data = ( coefs_avhrr%coef%nco > 0 )
opts_avhrr%ch4_data = ( coefs_avhrr%coef%nch4 > 0 )
IDIASI_OLD=IDIASI
ENDIF
nlevels=coefs_avhrr % coef % nlevels
nchannels=NIR
calcemis(:)=.false.
! Build the list of channels/profiles indices
ichn = 0
DO ich = 1,NIR
ichn = ichn +1
chanprof(ichn)%prof=1
chanprof(ichn)%chan=ich
End Do
cloudemissivity(:) = 0.d0
! allocate transmittance structure
call tovs_allocate_transmission(transmission,nchannels,nlevels)
! allocate radiance structure
asw=1 ! 1 to allocate,0 to deallocate
call rttov_alloc_rad (errorstatus,nchannels,radiancedata_d,nlevels-1,asw)
if (errorstatus/=0) THEN
Write(*,*) "Error in radiance allocation",errorstatus
call abort3d("tovs_rttov_AVHRR_for_IASI")
ENDIF
Call rttov_direct2( &
errorstatus, & ! out
chanprof, & ! in
opts_avhrr, & ! in
profiles(iptobs(:)), & ! in
coefs_avhrr, & ! in
calcemis, & ! in
surfem1_avhrr, & ! inout
emissivity_out, & ! out
cloudemissivity, & ! inout
transmission, & ! inout
radiancedata_d ) ! inout
io=iptobs(1)
avhrr_bgck(io)% RADCLEARCALC(NVIS+1:NVIS+NIR) = radiancedata_d % clear(1:NIR)
avhrr_bgck(io)% TBCLEARCALC(NVIS+1:NVIS+NIR) = radiancedata_d % bt(1:NIR)
avhrr_bgck(io)% RADOVCALC(1:nlevels-1,NVIS+1:NVIS+NIR) = radiancedata_d % overcast(1:nlevels-1,1:NIR)
avhrr_bgck(io)% TRANSMCALC(1:nlevels,NVIS+1:NVIS+NIR) = transmission % tau_levels(1:nlevels,1:NIR)
avhrr_bgck(io)% EMISS(NVIS+1:NVIS+NIR) = emissivity_out(1:NIR)
avhrr_bgck(io)% TRANSMSURF(NVIS+1:NVIS+NIR) = transmission% tau_total(1:NIR)
call tovs_deallocate_transmission(transmission)
asw=0 ! 1 to allocate,0 to deallocate
call rttov_alloc_rad (errorstatus,nchannels,radiancedata_d,nlevels-1,asw)
if (errorstatus/=0) THEN
Write(*,*) "Erreur in radiance deallocation: ",errorstatus
call abort3d("tovs_rttov_AVHRR_for_IASI")
ENDIF
end subroutine tovs_rttov_AVHRR_for_IASI
SUBROUTINE COR_ALBEDO ( DEL, SCOS ) 1
!***subroutine COR_ALBEDO
!*
!*auteur Louis Garand - rpn - dorval
!*
!*revision 001 Jacques Halle - ddo - dorval - 421-4660
!* fev 1991
!* adapter au systeme operationel GOES.
!*
!*REVISION 002 JACQUES HALLE - DDO - DORVAL - 421-4660
!* Decembre 1995
!* Generaliser pour toutes les plateformes satellitaires.
!*
!*objet ce sous-programme calcule un facteur de correction
!* pour l'albedo a partir du cosinus de l'angle solaire.
!*
!*appel CALL COR_ALBEDO ( DEL, SCOS )
!*
!*arguments del - output - facteur de correction
!* scos - input - cosinus de l'angle solaire
!**
Use MathPhysConstants_mod ,only : MPC_RADIANS_PER_DEGREE_R8
implicit none
real(8),intent(in) :: scos
real(8),intent(out) :: del
!************************************
integer i1, i2
real(8) x1, x2, g1, g2, a, b
real(8) S(11)
DATA S / 00.00d0, 18.19d0, 31.79d0, 41.41d0, 49.46d0, 56.63d0, 63.26d0, 69.51d0, 75.52d0, 81.37d0, 87.13d0 /
I1 = 12 -( SCOS+0.05d0)*10.d0
I2 = I1+1
I1 = MIN0(I1,11)
I2 = MIN0(I2,11)
X1 = COS ( S(I1)*MPC_RADIANS_PER_DEGREE_R8 )
X2 = COS ( S(I2)*MPC_RADIANS_PER_DEGREE_R8 )
G1 = DRCLD(I1)
G2 = DRCLD(I2)
if (I1==I2) then
DEL =G1
else
CALL SOLU ( G1, X1, G2 ,X2, A, B )
DEL = A*SCOS + B
endif
RETURN
END SUBROUTINE COR_ALBEDO
SUBROUTINE SOLU ( YY1, XX1, YY2, XX2, AA, BB ) 1
!**subroutine SOLU
!
!auteur Louis Garand - rpn - dorval
!
!revision 001 Jacques Halle - ddo - dorval - 421-4660
! fev 1991
! adapter au systeme operationel GOES.
!
!REVISION 002 JACQUES HALLE - DDO - DORVAL - 421-4660
! Decembre 1995
! Generaliser pour toutes les plateformes satellitaires.
!
!langage fortran 5
!
!objet ce sous-programme calcule la pente et l'intercept
! a partir de deux couples de donnees.
!
!appel CALL SOLU ( Y1, X1, Y2, X2, A, B )
!
!arguments XY1 - input - coordonnee Y du point 1
! XX1 - input - coordonnee X du point 1
! YY2 - input - coordonnee Y du point 2
! YX2 - input - coordonnee X du point 2
! AA - output- pente
! BB - output- intercept
!*
implicit none
real(8),intent (in) :: YY1, XX1, YY2, XX2
real(8),intent (out) :: AA, BB
!
! DROITE PASSANT PAR DEUX POINTS PENTE A ET INTERCEPT B
!
AA = (YY1-YY2)/(XX1-XX2)
BB = YY1 - AA*XX1
RETURN
END SUBROUTINE SOLU
REAL(8) FUNCTION DRCLD ( IZ )
!**fonction DRCLD
!
!auteur Louis Garand - rpn - dorval
!
!revision 001 Jacques Halle - ddo - dorval - 421-4660
! fev 1991
! adapter au systeme operationel GOES.
!
!REVISION 002 JACQUES HALLE - DDO - DORVAL - 421-4660
! Decembre 1995
! Generaliser pour toutes les plateformes satellitaires.
!
!langage fortran 5
!
!objet ce sous-programme calcule la normalisation due
! a l'angle zenith solaire selon
! MINNIS-HARRISSON (COURBE FIG 7), P1038,JCAM 84.
!
!appel xnorm = DRCLD ( IZ )
!
!arguments xnorm - output - facteur de normalisation
! iz - input - cosinus de l'angle solaire
!*
implicit none
integer,intent (in) :: iz
real(8) DRF(11)
DATA DRF / 1.000d0, 1.002d0, 1.042d0, 1.092d0, 1.178d0, 1.286d0, &
1.420d0, 1.546d0, 1.710d0, 1.870d0, 2.050d0 /
DRCLD = DRF (IZ)
RETURN
END FUNCTION DRCLD
SUBROUTINE VISOCN(SZ,SATZ,RZ,ANISOT,ZLAMB,ZCLOUD,IER) 1,14
!***subroutine VISOCN
!*
!*auteur LOUIS GARAND 1985
!*
!*REVISION 001 JACQUES HALLE - DDO - DORVAL - 421-4660
!* Decembre 1995
!* Generaliser pour toutes les plateformes satellitaires.
!*
!*objet THIS ROUTINE PROVIDES THE CORRECTIVE FACTORS FOR THE ANISOTROPY
!* OF REFLECTANCE OVER CLEAR OCEAN.
!*
!*
!*appel CALL VISOCN(SZ,SATZ,RZ,ANISOT,ZLAMB,ZCLOUD,IER)
!*
!*arguments sz - input - SUN ZENITH ANGLE IN DEGREES (0 TO 90)
!* satz - input - SATELLITE ZENITH ANGLE (0 TO 90)
!* rz - input - RELATIVE ANGLE IN DEGREES (0 TO 180) WITH
!* 0 AS BACKSCATTERING AND
!* 180 AS FORWARD SCATTERING
!* anisot - output - ANISOTROPIC CORRECTIVE FACTOR
!* (KHI IN MINNIS-HARRISSON)
!* zlamb - output - CORRECTIVE FACTOR FOR LAMBERTIAN REFLECTANCE
!* (DELTA """") ZLAMB IS A FUNCTION OF SZ ONLY.
!* THIS IS FOR OCEAN SURFACE.
!* zcloud - output - SAME AS ZLAMB BUT FOR CLOUD SURFACE
!* ier - output - error code (0=ok; -1=problem with interpolation)
!*
!*notes OBTAINED FROM DR PAT MINNIS,LANGLEY , AND BASED ON THE WORK
!* OF MINNIS AND HARRISSON,JCAM 1984,P993.
!* THE ROUTINE IS A LOOK UP TABLE ALONG WITH INTERPOLATION ON THE
!* THREE ANGLES.
!**
Use MathPhysConstants_mod ,only: MPC_RADIANS_PER_DEGREE_R8
implicit none
real (8),intent(in) :: SZ,SATZ,rz
real (8),intent(out):: ANISOT,ZLAMB,ZCLOUD
integer ,intent(out) :: ier
!********************************************************
integer i1, i2, j1, j2, k1, k2, l, i, n, m, j, k
real(8) cc, d1, d2, slop, cept, x1, x2
real(8) g1, g2
real(8) VNORM(11,10,13),S(11),V(10),R(13),DA(2),DD(2)
DATA S/0.0d0,18.19d0,31.79d0,41.41d0,49.46d0,56.63d0,63.26d0,69.51d0,75.52d0,81.37d0,87.13d0/
DATA R/0.0d0,15.0d0,30.0d0,45.0d0,60.0d0,75.0d0,90.0d0,105.0d0,120.0d0,135.0d0,150.0d0,165.0d0,180.0d0/
DATA V/0.0d0,10.0d0,20.0d0,30.0d0,40.0d0,50.0d0,60.0d0,70.0d0,80.0d0,90.0d0/
DATA ((VNORM(1,J,K),J=1,10),K=1,13)/ &
2.668d0,2.210d0,1.105d0,0.979d0,0.810d0,0.735d0,0.785d0,0.979d0,1.092d0,1.174d0, &
2.668d0,2.210d0,1.105d0,0.979d0,0.810d0,0.735d0,0.785d0,0.979d0,1.092d0,1.174d0, &
2.668d0,2.210d0,1.105d0,0.979d0,0.810d0,0.735d0,0.785d0,0.979d0,1.092d0,1.174d0, &
2.668d0,2.210d0,1.105d0,0.979d0,0.810d0,0.735d0,0.785d0,0.979d0,1.092d0,1.174d0, &
2.668d0,2.210d0,1.105d0,0.979d0,0.810d0,0.735d0,0.785d0,0.979d0,1.092d0,1.174d0, &
2.668d0,2.210d0,1.105d0,0.979d0,0.810d0,0.735d0,0.785d0,0.979d0,1.092d0,1.174d0, &
2.668d0,2.210d0,1.105d0,0.979d0,0.810d0,0.735d0,0.785d0,0.979d0,1.092d0,1.174d0, &
2.668d0,2.210d0,1.105d0,0.979d0,0.810d0,0.735d0,0.785d0,0.979d0,1.092d0,1.174d0, &
2.668d0,2.210d0,1.105d0,0.979d0,0.810d0,0.735d0,0.785d0,0.979d0,1.092d0,1.174d0, &
2.668d0,2.210d0,1.105d0,0.979d0,0.810d0,0.735d0,0.785d0,0.979d0,1.092d0,1.174d0, &
2.668d0,2.210d0,1.105d0,0.979d0,0.810d0,0.735d0,0.785d0,0.979d0,1.092d0,1.174d0, &
2.668d0,2.210d0,1.105d0,0.979d0,0.810d0,0.735d0,0.785d0,0.979d0,1.092d0,1.174d0, &
2.668d0,2.210d0,1.105d0,0.979d0,0.810d0,0.735d0,0.785d0,0.979d0,1.092d0,1.174d0/
DATA ((VNORM(2,J,K),J=1,10),K=1,13)/ &
1.154d0, .960d0, .896d0, .818d0, .748d0, .825d0, .922d0,1.018d0,1.179d0,1.334d0, &
1.154d0, .954d0, .838d0, .799d0, .735d0, .786d0, .883d0, .960d0,1.128d0,1.250d0, &
1.514d0, .973d0, .825d0, .786d0, .722d0, .754d0,0.838d0,0.922d0,1.063d0,1.160d0, &
1.514d0,0.967d0,0.864d0,0.818d0,0.715d0,0.728d0,0.793d0,0.876d0,1.005d0,1.102d0, &
1.514d0,0.967d0,0.896d0,0.889d0,0.702d0,0.696d0,0.773d0,0.851d0,0.954d0,1.038d0, &
1.514d0,1.070d0,0.986d0,0.922d0,0.677d0,0.696d0,0.754d0,0.838d0,0.922d0,1.012d0, &
1.514d0,1.270d0,0.967d0,0.870d0,0.677d0,0.664d0,0.709d0,0.773d0,0.857d0,0.954d0, &
1.514d0,1.495d0,1.166d0,0.960d0,0.683d0,0.690d0,0.728d0,0.806d0,0.896d0,0.999d0, &
1.514d0,1.959d0,1.534d0,1.025d0,0.973d0,0.709d0,0.754d0,0.857d0,0.954d0,1.050d0, &
1.514d0,2.165d0,2.165d0,1.270d0,1.038d0,0.760d0,0.812d0,0.902d0,1.012d0,1.115d0, &
1.514d0,2.275d0,2.262d0,1.688d0,1.115d0,0.780d0,0.857d0,0.954d0,1.070d0,1.173d0, &
1.514d0,2.326d0,2.520d0,2.172d0,1.257d0,0.812d0,0.883d0,1.005d0,1.108d0,1.212d0, &
1.514d0,2.359d0,2.951d0,2.255d0,1.411d0,0.980d0,0.915d0,1.050d0,1.160d0,1.295d0/
DATA ((VNORM(3,J,K),J=1,10),K=1,13)/ &
0.897d0,0.792d0,0.765d0,0.765d0,0.778d0,0.897d0,0.996d0,1.095d0,1.306d0,1.431d0, &
0.897d0,0.712d0,0.739d0,0.745d0,0.765d0,0.891d0,0.970d0,1.069d0,1.214d0,1.359d0, &
0.897d0,0.666d0,0.699d0,0.745d0,0.759d0,0.811d0,0.917d0,1.042d0,1.148d0,1.306d0, &
0.897d0,0.646d0,0.693d0,0.739d0,0.693d0,0.752d0,0.858d0,0.989d0,1.102d0,1.234d0, &
0.897d0,0.686d0,0.679d0,0.726d0,0.679d0,0.693d0,0.792d0,0.924d0,1.049d0,1.154d0, &
0.897d0,0.660d0,0.673d0,0.693d0,0.646d0,0.660d0,0.759d0,0.858d0,1.003d0,1.102d0, &
0.897d0,0.673d0,0.765d0,0.792d0,0.712d0,0.600d0,0.699d0,0.811d0,0.963d0,1.055d0, &
0.897d0,0.706d0,0.772d0,0.917d0,0.904d0,0.613d0,0.726d0,0.858d0,1.055d0,1.121d0, &
0.897d0,0.825d0,0.924d0,0.996d0,0.989d0,0.686d0,0.778d0,0.937d0,1.115d0,1.181d0, &
0.897d0,1.036d0,1.253d0,1.286d0,1.260d0,0.778d0,0.858d0,0.996d0,1.181d0,1.260d0, &
0.897d0,1.201d0,1.788d0,1.986d0,1.827d0,0.884d0,0.851d0,1.062d0,1.227d0,1.333d0, &
0.897d0,1.530d0,2.249d0,2.546d0,2.381d0,1.352d0,0.891d0,1.108d0,1.286d0,1.405d0, &
0.897d0,1.854d0,2.401d0,3.325d0,2.559d0,1.590d0,0.937d0,1.168d0,1.214d0,1.425d0/
DATA ((VNORM(4,J,K),J=1,10),K=1,13)/ &
0.752d0,0.800d0,0.745d0,0.717d0,0.759d0,0.891d0,1.149d0,1.309d0,1.469d0,1.650d0, &
0.752d0,0.773d0,0.717d0,0.703d0,0.752d0,0.835d0,1.065d0,1.246d0,1.406d0,1.552d0, &
0.752d0,0.731d0,0.689d0,0.703d0,0.745d0,0.814d0,0.988d0,1.176d0,1.323d0,1.476d0, &
0.752d0,0.689d0,0.675d0,0.654d0,0.696d0,0.752d0,0.940d0,1.100d0,1.246d0,1.378d0, &
0.752d0,0.675d0,0.661d0,0.633d0,0.668d0,0.717d0,0.877d0,1.030d0,1.176d0,1.309d0, &
0.752d0,0.647d0,0.640d0,0.620d0,0.613d0,0.682d0,0.814d0,0.947d0,1.107d0,1.232d0, &
0.752d0,0.633d0,0.620d0,0.613d0,0.606d0,0.640d0,0.773d0,0.898d0,1.044d0,1.162d0, &
0.752d0,0.626d0,0.626d0,0.626d0,0.620d0,0.654d0,0.821d0,0.947d0,1.128d0,1.225d0, &
0.752d0,0.633d0,0.633d0,0.633d0,0.647d0,0.675d0,0.877d0,1.009d0,1.183d0,1.274d0, &
0.752d0,0.682d0,0.717d0,0.961d0,1.023d0,0.968d0,0.940d0,1.142d0,1.274d0,1.413d0, &
0.752d0,0.856d0,1.037d0,1.434d0,1.594d0,1.441d0,1.044d0,1.225d0,1.323d0,1.545d0, &
0.752d0,1.044d0,1.295d0,2.207d0,1.610d0,2.311d0,1.385d0,1.274d0,1.441d0,1.636d0, &
0.752d0,1.079d0,1.524d0,2.541d0,3.564d0,3.014d0,1.942d0,1.462d0,1.552d0,1.726d0/
DATA ((VNORM(5,J,K),J=1,10),K=1,13)/ &
0.552d0,0.588d0,0.617d0,0.638d0,0.724d0,0.860d0,1.133d0,1.362d0,1.556d0,1.678d0, &
0.552d0,0.581d0,0.602d0,0.617d0,0.652d0,0.803d0,1.075d0,1.326d0,1.484d0,1.592d0, &
0.552d0,0.559d0,0.588d0,0.595d0,0.617d0,0.731d0,1.018d0,1.283d0,1.412d0,1.527d0, &
0.552d0,0.531d0,0.538d0,0.574d0,0.595d0,0.710d0,0.946d0,1.240d0,1.341d0,1.463d0, &
0.552d0,0.516d0,0.523d0,0.552d0,0.559d0,0.695d0,0.911d0,1.226d0,1.291d0,1.412d0, &
0.552d0,0.516d0,0.523d0,0.538d0,0.538d0,0.652d0,0.882d0,1.154d0,1.240d0,1.348d0, &
0.552d0,0.516d0,0.523d0,0.538d0,0.523d0,0.595d0,0.774d0,1.075d0,1.169d0,1.269d0, &
0.552d0,0.531d0,0.545d0,0.552d0,0.566d0,0.609d0,0.817d0,1.140d0,1.248d0,1.369d0, &
0.552d0,0.538d0,0.545d0,0.566d0,0.581d0,0.645d0,0.911d0,1.240d0,1.319d0,1.441d0, &
0.552d0,0.566d0,0.552d0,0.574d0,0.710d0,0.839d0,0.982d0,1.298d0,1.391d0,2.323d0, &
0.552d0,0.566d0,0.559d0,0.710d0,1.147d0,1.176d0,1.040d0,1.348d0,1.671d0,2.674d0, &
0.552d0,0.588d0,1.133d0,1.355d0,2.194d0,2.803d0,2.201d0,2.459d0,2.904d0,3.126d0, &
0.552d0,0.710d0,1.341d0,1.757d0,3.026d0,3.900d0,4.445d0,4.503d0,4.445d0,4.503d0/
DATA ((VNORM(6,J,K),J=1,10),K=1,13)/ &
0.551d0,0.627d0,0.665d0,0.734d0,0.826d0,0.971d0,1.231d0,1.537d0,1.721d0,1.866d0, &
0.551d0,0.604d0,0.619d0,0.665d0,0.765d0,0.895d0,1.185d0,1.476d0,1.568d0,1.652d0, &
0.551d0,0.597d0,0.604d0,0.619d0,0.734d0,0.849d0,1.101d0,1.346d0,1.453d0,1.568d0, &
0.551d0,0.581d0,0.589d0,0.597d0,0.665d0,0.795d0,1.032d0,1.262d0,1.346d0,1.445d0, &
0.551d0,0.558d0,0.558d0,0.566d0,0.612d0,0.727d0,0.987d0,1.201d0,1.262d0,1.399d0, &
0.551d0,0.505d0,0.505d0,0.512d0,0.566d0,0.696d0,0.925d0,1.117d0,1.185d0,1.308d0, &
0.551d0,0.474d0,0.497d0,0.512d0,0.535d0,0.673d0,0.864d0,1.048d0,1.124d0,1.216d0, &
0.551d0,0.497d0,0.505d0,0.520d0,0.551d0,0.681d0,0.902d0,1.124d0,1.201d0,1.323d0, &
0.551d0,0.535d0,0.535d0,0.551d0,0.566d0,0.711d0,1.017d0,1.201d0,1.269d0,1.422d0, &
0.551d0,0.535d0,0.543d0,0.558d0,0.704d0,1.193d0,1.247d0,1.285d0,1.346d0,1.950d0, &
0.551d0,0.543d0,0.551d0,0.581d0,0.994d0,1.545d0,1.583d0,1.354d0,2.019d0,2.883d0, &
0.551d0,0.566d0,0.612d0,0.788d0,1.468d0,2.233d0,2.340d0,2.531d0,2.983d0,3.365d0, &
0.551d0,0.658d0,0.665d0,1.101d0,2.134d0,3.120d0,4.221d0,4.856d0,4.956d0,5.613d0/
DATA ((VNORM(7,J,K),J=1,10),K=1,13)/ &
0.545d0,0.606d0,0.683d0,0.744d0,0.798d0,0.990d0,1.228d0,1.704d0,1.850d0,2.049d0, &
0.545d0,0.576d0,0.583d0,0.714d0,0.783d0,0.952d0,1.144d0,1.573d0,1.758d0,1.888d0, &
0.545d0,0.560d0,0.568d0,0.629d0,0.744d0,0.875d0,1.105d0,1.504d0,1.642d0,1.788d0, &
0.545d0,0.553d0,0.560d0,0.599d0,0.629d0,0.791d0,1.028d0,1.420d0,1.527d0,1.696d0, &
0.545d0,0.545d0,0.553d0,0.599d0,0.606d0,0.714d0,0.990d0,1.335d0,1.451d0,1.581d0, &
0.545d0,0.530d0,0.537d0,0.568d0,0.583d0,0.683d0,0.890d0,1.243d0,1.351d0,1.489d0, &
0.545d0,0.491d0,0.499d0,0.507d0,0.576d0,0.622d0,0.791d0,1.182d0,1.282d0,1.389d0, &
0.545d0,0.507d0,0.514d0,0.507d0,0.576d0,0.675d0,0.890d0,1.197d0,1.328d0,1.451d0, &
0.545d0,0.522d0,0.537d0,0.522d0,0.591d0,0.760d0,0.944d0,1.259d0,1.389d0,1.527d0, &
0.545d0,0.537d0,0.545d0,0.553d0,0.614d0,0.906d0,1.028d0,1.389d0,1.504d0,2.533d0, &
0.545d0,0.553d0,0.553d0,0.576d0,0.637d0,1.036d0,1.550d0,1.658d0,1.934d0,3.277d0, &
0.545d0,0.560d0,0.568d0,0.606d0,1.174d0,1.781d0,2.563d0,3.170d0,3.791d0,4.966d0, &
0.545d0,0.591d0,0.614d0,1.259d0,2.065d0,2.824d0,3.761d0,4.498d0,5.902d0,6.148d0/
DATA ((VNORM(8,J,K),J=1,10),K=1,13)/ &
0.514d0,0.539d0,0.596d0,0.694d0,0.832d0,1.004d0,1.444d0,1.869d0,2.203d0,2.538d0, &
0.514d0,0.539d0,0.571d0,0.645d0,0.751d0,0.906d0,1.387d0,1.779d0,2.056d0,2.317d0, &
0.514d0,0.547d0,0.555d0,0.612d0,0.702d0,0.824d0,1.281d0,1.681d0,1.934d0,2.203d0, &
0.514d0,0.539d0,0.555d0,0.588d0,0.653d0,0.743d0,1.028d0,1.404d0,1.624d0,2.024d0, &
0.514d0,0.539d0,0.547d0,0.555d0,0.588d0,0.710d0,0.889d0,1.191d0,1.420d0,1.820d0, &
0.514d0,0.522d0,0.522d0,0.539d0,0.563d0,0.710d0,0.849d0,1.044d0,1.208d0,1.534d0, &
0.514d0,0.481d0,0.506d0,0.514d0,0.539d0,0.694d0,0.824d0,1.028d0,1.200d0,1.371d0, &
0.514d0,0.481d0,0.514d0,0.547d0,0.563d0,0.702d0,0.898d0,1.134d0,1.297d0,1.501d0, &
0.514d0,0.490d0,0.514d0,0.555d0,0.588d0,0.726d0,0.955d0,1.265d0,1.379d0,1.648d0, &
0.514d0,0.547d0,0.547d0,0.571d0,0.604d0,0.767d0,1.036d0,1.355d0,1.550d0,3.142d0, &
0.514d0,0.563d0,0.579d0,0.604d0,0.612d0,0.832d0,1.909d0,2.848d0,3.917d0,4.790d0, &
0.514d0,0.522d0,0.563d0,0.677d0,0.767d0,1.420d0,2.040d0,3.158d0,4.863d0,6.291d0, &
0.514d0,0.588d0,0.588d0,0.612d0,0.824d0,2.032d0,3.109d0,4.969d0,6.846d0,7.695d0/
DATA ((VNORM(9,J,K),J=1,10),K=1,13)/ &
0.572d0,0.608d0,0.679d0,0.751d0,0.831d0,1.001d0,1.377d0,1.913d0,2.512d0,2.879d0, &
0.572d0,0.572d0,0.608d0,0.679d0,0.760d0,0.930d0,1.243d0,1.707d0,2.369d0,2.700d0, &
0.572d0,0.563d0,0.590d0,0.644d0,0.706d0,0.831d0,1.171d0,1.618d0,2.190d0,2.378d0, &
0.572d0,0.554d0,0.563d0,0.599d0,0.662d0,0.760d0,1.010d0,1.502d0,2.011d0,2.235d0, &
0.572d0,0.545d0,0.563d0,0.590d0,0.626d0,0.715d0,0.885d0,1.323d0,1.815d0,2.119d0, &
0.572d0,0.527d0,0.554d0,0.572d0,0.608d0,0.670d0,0.724d0,1.144d0,1.618d0,1.868d0, &
0.572d0,0.545d0,0.572d0,0.572d0,0.599d0,0.662d0,0.724d0,1.117d0,1.484d0,1.761d0, &
0.572d0,0.554d0,0.590d0,0.599d0,0.608d0,0.679d0,0.760d0,1.216d0,1.582d0,1.922d0, &
0.572d0,0.572d0,0.599d0,0.608d0,0.635d0,0.715d0,0.822d0,1.377d0,1.707d0,2.056d0, &
0.572d0,0.590d0,0.608d0,0.635d0,0.662d0,0.742d0,0.912d0,1.529d0,3.075d0,4.693d0, &
0.572d0,0.590d0,0.626d0,0.644d0,0.670d0,0.760d0,1.109d0,1.564d0,3.111d0,4.702d0, &
0.572d0,0.599d0,0.644d0,0.662d0,0.688d0,0.822d0,1.788d0,2.816d0,5.346d0,7.295d0, &
0.572d0,0.608d0,0.662d0,0.670d0,0.715d0,1.851d0,3.227d0,4.810d0,6.669d0,9.557d0/
DATA ((VNORM(10,J,K),J=1,10),K=1,13)/ &
0.552d0,0.606d0,0.639d0,0.671d0,0.704d0,0.899d0,1.223d0,2.479d0,3.194d0,3.573d0, &
0.552d0,0.574d0,0.606d0,0.628d0,0.682d0,0.855d0,1.148d0,2.339d0,2.642d0,3.378d0, &
0.552d0,0.563d0,0.552d0,0.595d0,0.639d0,0.834d0,1.061d0,2.014d0,2.404d0,2.891d0, &
0.552d0,0.563d0,0.509d0,0.552d0,0.628d0,0.801d0,0.985d0,1.689d0,2.176d0,2.653d0, &
0.552d0,0.574d0,0.509d0,0.520d0,0.585d0,0.747d0,0.888d0,1.332d0,1.970d0,2.458d0, &
0.552d0,0.531d0,0.509d0,0.509d0,0.531d0,0.682d0,0.801d0,1.191d0,1.819d0,2.425d0, &
0.552d0,0.498d0,0.498d0,0.498d0,0.520d0,0.639d0,0.747d0,1.126d0,1.711d0,2.317d0, &
0.552d0,0.498d0,0.509d0,0.509d0,0.541d0,0.671d0,0.780d0,1.278d0,1.862d0,2.598d0, &
0.552d0,0.498d0,0.509d0,0.520d0,0.574d0,0.693d0,0.812d0,1.602d0,2.035d0,2.793d0, &
0.552d0,0.520d0,0.520d0,0.531d0,0.595d0,0.725d0,0.844d0,1.916d0,2.588d0,3.768d0, &
0.552d0,0.531d0,0.541d0,0.574d0,0.628d0,0.780d0,1.039d0,2.349d0,3.313d0,5.652d0, &
0.552d0,0.574d0,0.563d0,0.606d0,0.660d0,0.812d0,1.797d0,3.010d0,5.478d0,7.492d0, &
0.552d0,0.650d0,0.671d0,0.704d0,0.801d0,1.029d0,2.436d0,3.465d0,7.828d0,10.578d0/
DATA ((VNORM(11,J,K),J=1,10),K=1,13)/ &
0.518d0,0.576d0,0.605d0,0.633d0,0.662d0,0.864d0,1.238d0,2.620d0,3.455d0,3.887d0, &
0.518d0,0.547d0,0.576d0,0.576d0,0.633d0,0.835d0,1.123d0,2.447d0,2.821d0,3.656d0, &
0.518d0,0.518d0,0.518d0,0.547d0,0.605d0,0.806d0,1.036d0,2.102d0,2.533d0,3.080d0, &
0.518d0,0.518d0,0.461d0,0.518d0,0.576d0,0.777d0,0.950d0,1.727d0,2.274d0,2.821d0, &
0.518d0,0.547d0,0.461d0,0.489d0,0.547d0,0.720d0,0.864d0,1.353d0,2.044d0,2.591d0, &
0.518d0,0.489d0,0.461d0,0.461d0,0.489d0,0.662d0,0.777d0,1.180d0,1.871d0,2.562d0, &
0.518d0,0.461d0,0.461d0,0.461d0,0.489d0,0.605d0,0.720d0,1.123d0,1.756d0,2.418d0, &
0.518d0,0.461d0,0.461d0,0.461d0,0.518d0,0.633d0,0.749d0,1.296d0,1.929d0,2.764d0, &
0.518d0,0.461d0,0.461d0,0.489d0,0.547d0,0.662d0,0.777d0,1.641d0,2.130d0,2.994d0, &
0.518d0,0.489d0,0.489d0,0.489d0,0.547d0,0.691d0,0.806d0,1.986d0,2.735d0,4.117d0, &
0.518d0,0.489d0,0.489d0,0.547d0,0.576d0,0.749d0,1.008d0,2.476d0,3.599d0,6.334d0, &
0.518d0,0.547d0,0.518d0,0.576d0,0.633d0,0.777d0,1.842d0,3.224d0,6.132d0,8.550d0, &
0.518d0,0.605d0,0.633d0,0.662d0,0.777d0,1.008d0,2.562d0,3.771d0,8.953d0,12.293d0/
! COMPUTE SUN ZENITH BIN
CC = COS(SZ*MPC_RADIANS_PER_DEGREE_R8)
I1 = 12.d0-(CC+0.05d0)*10.d0
I2 = I1+1
IF(I1.GE.11)I1=11
IF(I1.EQ.11)I2=I1
! COMPUTE SAT ZENITH BIN
J1 = INT(SATZ/10.d0)+1
J2 = J1+1
IF(J1.EQ.10)J2=J1
! COMPUTE RELATIVE AZIMUTH BIN
K1 = RZ/15.d0+1.d0
K2 = K1+1
IF(K1.EQ.13)K2=K1
! INTERPOLATE
IER = 0
DO L=I1,I2
I = L-I1+1
! BETWEEN R'S FOR CONSTANT S
DO N=K1,K2
! BETWEEN V'S FOR CONSTANT R AND S
M = N-K1+1
D1 = VNORM(L,J1,N)
D2 = VNORM(L,J2,N)
IF(D1.EQ.D2)THEN
DA(M) = D1
ELSE
CALL LINEQ(V(J1),V(J2),D1,D2,SLOP,CEPT,IER)
DA(M) = SLOP*SATZ+CEPT
ENDIF
enddo
IF(K1.EQ.K2) THEN
DD(I) = DA(1)
ELSE
CALL LINEQ(R(K1),R(K2),DA(1),DA(2),SLOP,CEPT,IER)
DD(I) = SLOP*RZ+CEPT
ENDIF
enddo
!C BETWEEN S'S USING RESULT OF OTHER INTERPOLATIONS
IF(I1.EQ.I2)THEN
ZLAMB = DRM(I1)
ZCLOUD = DRCLD(I1)
ANISOT = DD(1)
ELSE
X1 = COS(S(I1)*MPC_RADIANS_PER_DEGREE_R8)
X2 = COS(S(I2)*MPC_RADIANS_PER_DEGREE_R8)
CALL LINEQ(X1,X2,DD(1),DD(2),SLOP,CEPT,IER)
ANISOT = SLOP*CC+CEPT
G1 = DRM(I1)
G2 = DRM(I2)
CALL LINEQ(X1,X2,G1,G2,SLOP,CEPT,IER)
ZLAMB = SLOP*CC+CEPT
G1 = DRCLD(I1)
G2 = DRCLD(I2)
CALL LINEQ(X1,X2,G1,G2,SLOP,CEPT,IER)
ZCLOUD = SLOP*CC+CEPT
ENDIF
IF(ANISOT.LT.0.) THEN
IER = -1
ANISOT = 1.d0
ZLAMB = DRM(I1)
ZCLOUD = DRCLD(I1)
ENDIF
END SUBROUTINE VISOCN
SUBROUTINE LINEQ(XX1,XX2,YY1,YY2,AA,BB,IERR) 5
!**subroutine LINEQ
!
!auteur Louis Garand - rpn - dorval
!
!REVISION 001 JACQUES HALLE - DDO - DORVAL - 421-4660
! Decembre 1995
! Generaliser pour toutes les plateformes satellitaires.
!
!langage fortran 5
!
!objet calculate slope and intercept of a line.
!
!appel CALL LINEQ(X1,X2,Y1,Y2,A,B,IER)
!
!arguments x1 - input - coordinate x of point 1
! x2 - input - coordinate x of point 2
! y1 - input - coordinate y of point 1
! y2 - input - coordinate y of point 2
! a - output - slope
! b - output - intercept
! ier - output - error code (0=ok)
!
real(8) ,intent(in) :: XX1,XX2,YY1,YY2
real(8) ,intent(out) :: AA,BB
integer ,intent(out) :: ierr
!****************************************
ierr = 0
IF((XX2-XX1).EQ.0.d0)THEN
IERR=-1
RETURN
ENDIF
AA=(YY2-YY1)/(XX2-XX1)
BB=YY1-AA*XX1
RETURN
END SUBROUTINE LINEQ
REAL(8) FUNCTION DRM(IZ) 4
!**function DRM
!
!auteur Louis Garand - rpn - dorval
!
!REVISION 001 JACQUES HALLE - DDO - DORVAL - 421-4660
! Decembre 1995
! Generaliser pour toutes les plateformes satellitaires.
!
!langage fortran 5
!
!objet NORMALIZATION FOR SUN ZENITH ANGLE (LAMBERTIAN)
! FOR OCEAN.
!
!appel val = DRM(IZ)
!
!arguments iz - input - index
! val - output - normalization factor
!*
integer,intent (in) :: iz
REAL(8) DRF(11)
DATA DRF /1.d0,1.0255d0,1.1197d0,1.2026d0,1.3472d0,1.4926d0,1.8180d0,2.1980d0, &
2.8180d0,3.8615d0,4.3555d0/
DRM=DRF(IZ)
END FUNCTION DRM
END SUBROUTINE HIRQC
End module MULTI_IR_BGCK_MOD