!-------------------------------------- LICENCE BEGIN ------------------------------------
!Environment Canada - Atmospheric Science and Technology License/Disclaimer,
! version 3; Last Modified: May 7, 2008.
!This is free but copyrighted software; you can use/redistribute/modify it under the terms
!of the Environment Canada - Atmospheric Science and Technology License/Disclaimer
!version 3 or (at your option) any later version that should be found at:
!http://collaboration.cmc.ec.gc.ca/science/rpn.comm/license.html
!
!This software is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY;
!without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
!See the above mentioned License/Disclaimer for more details.
!You should have received a copy of the License/Disclaimer along with this software;
!if not, you can write to: EC-RPN COMM Group, 2121 TransCanada, suite 500, Dorval (Quebec),
!CANADA, H9P 1J3; or send e-mail to service.rpn@ec.gc.ca
!-------------------------------------- LICENCE END --------------------------------------
!
SUBROUTINE IASIQC ( iasi_end, iasi_bunch,iasi_loop_done) 1,23
#if defined (DOC)
!***********************************************************************
!
!**ID IASIQC -- QUALITY CONTROL OF IASI 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)
!
! REVISION:
!
! OBJECT: ASSIGN ASSIMILATION FLAGS TO OBSERVATIONS
!
! ARGUMENTS:
! INPUT:
! -IASI_BUNCH : MAXIMUM NUMBER OF PROFILES FOR ONE CALL
! -IASI_LOOP_DONE : NUMBER OF PREVIOUS CALLS TO IASIQC
!
! OUTPUT:
! -IASI_END : AT THE END OF THIS CALL TO IASIQC, DO ALL IASI
! PROFILES BEEN TREATED (true) OR NOT (false)
!
!***********************************************************************
#endif
use mod_tovs
use iasich
use iasibgcheck
use common_iasi
use avhrr_var_mod
IMPLICIT NONE
!implicits
#include "pardim.cdk"
#include "comdimo.cdk"
#include "comlun.cdk"
#include "comcst.cdk"
#include "comoabdy.cdk"
#include "comoahdr.cdk"
#include "comoba.cdk"
#include "commvohr.cdk"
#include "partov.cdk"
#include "comtov.cdk"
#include "cvcord.cdk"
#include "comdim.cdk"
#include "comgem.cdk"
INTEGER :: JC,NCHN,JCH,JF,JL,NLEV,JN,NPRF,JO,NFLG,ICHN
INTEGER :: IWINDO,IWINDO_ALT,KRTID,IPRO,NOBIASI
INTEGER :: JDATA,IDATA,IDATEND,IDIASI
INTEGER :: IBEGIN,ILAST,IBEGINOB,ILASTOB,IDATYP
INTEGER :: DIFFTOP_MIN
INTEGER ,SAVE :: IMODTOP
INTEGER :: iasi_loop_done,count_iasi,iasi_bunch
REAL(8) :: T_EFFECTIVE
LOGICAL :: iasi_end
integer :: alloc_status(85)
real(8), allocatable :: ZTG(:),ZPS(:),ZTS(:),ZT(:,:),ZHT(:,:),ZLQ(:,:),ZPRES(:,:)
real(8), allocatable :: BTOBSERR(:),BTOBS(:,:),BTCALC(:,:),RCAL_CLR(:,:),SFCTAU(:,:)
real(8), allocatable :: ROBS(:,:),RCLD(:,:,:),TRANSM(:,:,:),EMI_SFC(:,:)
real(8), allocatable :: TOEXT(:,:),ZHOEXT(:,:),SUNZA(:),SATAZIM(:),SATZEN(:)
real, allocatable :: ALBEDO(:),ICE(:),PCNT_WAT(:),PCNT_REG(:)
integer, allocatable :: KSURF(:),LTYPE(:)
integer, allocatable :: CLDFLAG(:),REJFLAG(:,:,:),LEV_START(:),ILIST(:),ILIST_PAIR(:)
integer, allocatable :: GNCLDFLAG(:)
integer, allocatable :: ICHREF(:)
integer, allocatable :: NTOP_EQ(:),NTOP_BT(:,:),NTOP_RD(:,:),NTOP_MB(:)
integer, allocatable :: NTOP_CO2(:,:),NGOOD(:)
real(8), allocatable :: PTOP_EQ(:),PTOP_BT(:,:),PTOP_RD(:,:),PTOP_MB(:)
real(8), allocatable :: PTOP_CO2(:,:),FCLOUD_CO2(:,:),HE(:)
real(8), allocatable :: ETOP(:),VTOP(:),ECF(:),VCF(:)
integer, allocatable :: MINP(:,:),FATE(:,:)
real(8), allocatable :: PMIN(:,:),DTAUDP1(:,:),TAMPON(:),MAXWF(:,:),CFSUB(:)
real(8), allocatable :: ZLAT(:),ZLON(:)
logical, allocatable :: ASSIM_ALL(:)
real(8), allocatable :: ZTS_AVHRR(:,:),SFCTAU_AVHRR(:,:),EMI_SFC_AVHRR(:,:),RCAL_CLR_AVHRR(:,:)
real(8), allocatable :: RCLD_AVHRR(:,:,:),PTOP_BT_AVHRR(:,:,:),PTOP_RD_AVHRR(:,:,:)
real(8), allocatable :: BTOBS_AVHRR(:,:,:),ROBS_AVHRR(:,:,:),PTOP_EQ_AVHRR(:,:)
real(8), allocatable :: CFRAC_AVHRR(:)
integer, allocatable :: CLDFLAG_AVHRR(:,:),LEV_START_AVHRR(:,:),ICHREF_AVHRR(:,:),NTOP_RD_AVHRR(:,:,:)
integer, allocatable :: NTOP_BT_AVHRR(:,:,:),NTOP_EQ_AVHRR(:,:)
type(avhrr_var), allocatable :: out_avhrr_param(:)
integer :: ICL
integer ,parameter :: nn=2
integer ,parameter :: ilist_avhrr(nn)=(/ 2 ,3 /)
integer :: cpt
real (8) :: ztorad
logical :: bad
!seuils detection nuageuse AVHRR
Real(8),parameter :: sunzenmax=87.12d0
Real(8) :: seuilalb_static(NIR,0:2)
Real(8) :: seuil_albed(NIR)
Real(8) :: seuilalb_homog(NIR,0:2)
Real(8) :: seuilbt_homog(NVIS+1:NVIS+NIR,0:2,1:2)
Real(8) :: minpavhrr(2:3)
Real(4) :: anisot,zlamb,zcloud,scos,del,deltaphi
Integer :: ier,ijour,iloc(2:3)
!**************
ZTORAD=RPI/180.
! ** find sensor number corresponding to IASI
DO KRTID = 1, NSENSORS
IF ( PLATFORM(KRTID) .EQ. 10 .AND. &
& SATELLITE(KRTID) .EQ. 2 .AND. &
& INSTRUMENT(KRTID) .EQ. 16 ) THEN
IDIASI = KRTID
EXIT
END IF
END DO
! ** find number of IASI profiles (for memory allocation)
NPRF = 0
count_iasi = 0
DO JF = 1, NFILES
IF ( CFAMTYP(JF) .EQ. 'TO' .AND. NBEGINTYP(JF) .GT. 0 ) THEN
IBEGIN = NBEGINTYP(JF)
ILAST = NENDTYP(JF)
IBEGINOB = MOBDATA(NCMOBS,IBEGIN)
ILASTOB = MOBDATA(NCMOBS,ILAST)
DO JO = IBEGINOB, ILASTOB
IDATYP = MOD(MOBHDR(NCMITY,JO),1000)
IF ( IDATYP .EQ. 186) THEN
count_iasi = count_iasi + 1
IF ( count_iasi > iasi_loop_done * iasi_bunch .AND. &
& count_iasi <= (iasi_loop_done+1) * iasi_bunch ) NPRF = NPRF + 1
END IF
END DO
END IF
END DO
! ** find number of IASI channels and RTTOV levels
NCHN = coef(idiasi)%fmv_chn
NLEV = coef(idiasi)%nlevels
write(nulout,*) ' IASIQC - nchn ', nchn
! information to extract (transvidage)
! ------------------------------------
!
! ZTG(NPRF) -- guess skin temperatures (deg K)
! ZPS(NPRF) -- surface pressure (hPa)
! ZT(NLEVTRL,NPRF) -- temperature profiles on NWP model levels (deg K)
! ZHT(NLEVTRL,NPRF) -- height profiles on NWP model levels (m)
! ZPRES(NLEVTRL,NPRF) -- NWP pressure model levels
! ZLQ(NLEVTRL,NPRF) -- surface specific humidity in ln q (kg/kg)
! BTOBSERR(IASISNCH) -- observation error standard deviation
! BTOBS(IASISNCH,NPRF) -- observed brightness temperatures (deg K)
! BTCALC(IASISNCH,NPRF) -- computed brightness temperatures (deg K)
! RCAL_CLR(IASISNCH,NPRF) -- computed clear radiances (mw/m2/sr/cm-1)
! SFCTAU(IASISNCH,NPRF) -- surface to space transmittances (0-1)
! RCLD(IASISNCH,NPRF,NLEV) -- overcast cloudy radiances (mw/m2/sr/cm-1)
! TRANSM(IASISNCH,NPRF,NLEV) -- layer to space transmittances (0-1)
! EMI_SFC(IASISNCH,NPRF) -- surface emissivities (0-1)
! KSURF(NPRF) -- surface type in obs file (0, 1)
! CLFR(NPRF) -- cloud fraction (%)
! TOEXT(NLEV,NPRF) -- temperature profiles on RT model levels (deg K)
! ZHOEXT(NLEV,NPRF) -- height profiles on RT model levels (m)
! SUNZA(NPRF) -- sun zenith angle (deg)
! SATAZIM(NPRF) -- satellite azimuth angle (deg)
! SATZEN(NPRF) -- satellite zenith angle (deg)
! ALBEDO(NPRF) -- surface albedo (0-1)
! ICE(NPRF) -- ice fraction (0-1)
! LTYPE(NPRF) -- surface type (1,...,20)
! PCNT_WAT(NPRF) -- water fraction (0-1)
! PCNT_REG(NPRF) -- water fraction in the area (0-1)
! ROBS(IASISNCH,NPRF) -- observed radiances (mW/m2/sr/cm-1)
alloc_status(:) = 0
allocate ( ZTG(NPRF), stat= alloc_status(1) )
allocate ( ZPS(NPRF), stat= alloc_status(2) )
allocate ( ZT(NLEVTRL,NPRF), stat= alloc_status(3) )
allocate ( ZHT(NLEVTRL,NPRF), stat= alloc_status(4) )
allocate ( ZLQ(NLEVTRL,NPRF), stat= alloc_status(5) )
allocate ( BTOBSERR(IASISNCH), stat= alloc_status(6) )
allocate ( BTOBS(IASISNCH,NPRF), stat= alloc_status(7) )
allocate ( BTCALC(IASISNCH,NPRF), stat= alloc_status(8) )
allocate ( RCAL_CLR(IASISNCH,NPRF), stat= alloc_status(9) )
allocate ( SFCTAU(IASISNCH,NPRF), stat= alloc_status(10))
allocate ( RCLD(IASISNCH,NPRF,NLEV), stat= alloc_status(11))
allocate ( TRANSM(IASISNCH,NPRF,NLEV), stat= alloc_status(12))
allocate ( EMI_SFC(IASISNCH,NPRF), stat= alloc_status(13))
allocate ( KSURF(NPRF), stat= alloc_status(14))
! allocate ( CLFR(NPRF), stat= alloc_status(15))
allocate ( TOEXT(NLEV,NPRF), stat= alloc_status(16))
allocate ( ZHOEXT(NLEV,NPRF), stat= alloc_status(17))
allocate ( SUNZA(NPRF), stat= alloc_status(18))
allocate ( ALBEDO(NPRF), stat= alloc_status(19))
allocate ( ICE(NPRF), stat= alloc_status(20))
allocate ( LTYPE(NPRF), stat= alloc_status(21))
allocate ( PCNT_WAT(NPRF), stat= alloc_status(22))
allocate ( PCNT_REG(NPRF), stat= alloc_status(23))
allocate ( ROBS(IASISNCH,NPRF), stat= alloc_status(24))
allocate ( ZTS(NPRF), stat= alloc_status(26))
allocate ( CLDFLAG(NPRF), stat= alloc_status(27))
allocate ( REJFLAG(IASISNCH,NPRF,0:BITFLAG),stat= alloc_status(28))
allocate ( LEV_START(NPRF), stat= alloc_status(29))
allocate ( ILIST(IASISNCH), stat= alloc_status(30))
allocate ( NTOP_EQ(NPRF), stat= alloc_status(31))
allocate ( NTOP_BT(IASISNCH,NPRF), stat= alloc_status(32))
allocate ( NTOP_RD(IASISNCH,NPRF), stat= alloc_status(33))
allocate ( NTOP_CO2(NCO2,NPRF), stat= alloc_status(34))
allocate ( PTOP_EQ(NPRF), stat= alloc_status(35))
allocate ( PTOP_BT(IASISNCH,NPRF), stat= alloc_status(36))
allocate ( PTOP_RD(IASISNCH,NPRF), stat= alloc_status(37))
allocate ( PTOP_CO2(NCO2,NPRF), stat= alloc_status(38))
allocate ( FCLOUD_CO2(NCO2,NPRF), stat= alloc_status(39))
allocate ( HE(NPRF), stat= alloc_status(40))
allocate ( ETOP(NPRF), stat= alloc_status(41))
allocate ( VTOP(NPRF), stat= alloc_status(42))
allocate ( ECF(NPRF), stat= alloc_status(43))
allocate ( VCF(NPRF), stat= alloc_status(44))
allocate ( NGOOD(NPRF), stat= alloc_status(45))
allocate ( MINP(IASISNCH,NPRF), stat= alloc_status(46))
allocate ( PMIN(IASISNCH,NPRF), stat= alloc_status(47))
allocate ( DTAUDP1(IASISNCH,NPRF), stat= alloc_status(48))
allocate ( TAMPON(NPRF), stat= alloc_status(49))
allocate ( FATE(IASISNCH,NPRF), stat= alloc_status(50))
allocate ( ICHREF(NPRF), stat= alloc_status(51))
allocate ( ASSIM_ALL(NPRF), stat= alloc_status(53))
allocate ( out_avhrr_param(NPRF), stat= alloc_status(54))
allocate ( LEV_START_AVHRR(NPRF,NCLASSAVHRR),stat= alloc_status(55))
allocate ( PTOP_EQ_AVHRR(NPRF,NCLASSAVHRR), stat= alloc_status(56))
allocate ( NTOP_EQ_AVHRR(NPRF,NCLASSAVHRR), stat= alloc_status(57))
allocate ( BTOBS_AVHRR(1:NIR,NPRF,NCLASSAVHRR),stat= alloc_status(58))
allocate ( ICHREF_AVHRR(NPRF,NCLASSAVHRR) ,stat= alloc_status(59))
allocate ( CLDFLAG_AVHRR(NPRF,NCLASSAVHRR) ,stat= alloc_status(60))
allocate ( ROBS_AVHRR(1:NIR,NPRF,NCLASSAVHRR),stat= alloc_status(61))
allocate ( RCAL_CLR_AVHRR(1:NIR,NPRF),stat= alloc_status(62))
allocate ( EMI_SFC_AVHRR(1:NIR,NPRF),stat= alloc_status(63))
allocate ( ZTS_AVHRR(NPRF,NCLASSAVHRR),stat= alloc_status(64))
allocate ( SFCTAU_AVHRR(NIR,NPRF), stat= alloc_status(65))
allocate ( PTOP_BT_AVHRR(NIR,NPRF,NCLASSAVHRR), stat= alloc_status(66))
allocate ( PTOP_RD_AVHRR(NIR,NPRF,NCLASSAVHRR), stat= alloc_status(67))
allocate ( NTOP_BT_AVHRR(NIR,NPRF,NCLASSAVHRR), stat= alloc_status(68))
allocate ( NTOP_RD_AVHRR(NIR,NPRF,NCLASSAVHRR), stat= alloc_status(69))
allocate ( RCLD_AVHRR(NIR,NPRF,NLEV), stat= alloc_status(70))
allocate ( ZLAT(NPRF), stat= alloc_status(71))
allocate ( ZLON(NPRF), stat= alloc_status(72))
allocate ( maxwf(IASISNCH,NPRF), stat= alloc_status(73))
allocate ( CFRAC_AVHRR(NPRF), stat= alloc_status(74))
allocate ( SATAZIM(NPRF), stat= alloc_status(75))
allocate ( SATZEN(NPRF), stat= alloc_status(76))
allocate ( ZPRES(NLEVTRL,NPRF), stat= alloc_status(77))
allocate ( PTOP_MB(NPRF), stat= alloc_status(78))
allocate ( NTOP_MB(NPRF), stat= alloc_status(79))
allocate ( CFSUB(NPRF), stat= alloc_status(80))
allocate ( GNCLDFLAG(NPRF), stat= alloc_status(81))
allocate ( ILIST_PAIR(IASISNCH), stat= alloc_status(82))
if( any(alloc_status /= 0) ) then
write(nulout,*) ' iasiqc : memory allocation error'
call abort3d(nulout,'iasiqc ')
end if
seuilalb_static(1,0)=70.0
seuilalb_static(1,1)=40.0
seuilalb_static(1,2)=70.0
seuilalb_static(2,0)=67.0
seuilalb_static(2,1)=37.0
seuilalb_static(2,2)=57.0
seuilalb_static(3,0)=50.0
seuilalb_static(3,1)=37.0
seuilalb_static(3,2)=40.0
seuilalb_homog(1,0)=15.d0
seuilalb_homog(1,1)=9.d0
seuilalb_homog(1,2)=18.d0
seuilalb_homog(2,0)=18.d0
seuilalb_homog(2,1)=10.d0
seuilalb_homog(2,2)=16.d0
seuilalb_homog(3,0)=13.d0
seuilalb_homog(3,1)=10.d0
seuilalb_homog(3,2)=10.d0
seuilbt_homog(NVIS+1,0,1)=5.d0
seuilbt_homog(NVIS+1,1,1)=4.d0
seuilbt_homog(NVIS+1,2,1)=5.d0
seuilbt_homog(NVIS+1,0,2)=5.d0
seuilbt_homog(NVIS+1,1,2)=4.d0
seuilbt_homog(NVIS+1,2,2)=5.d0
seuilbt_homog(NVIS+2,0,1)=4.d0
seuilbt_homog(NVIS+2,1,1)=3.d0
seuilbt_homog(NVIS+2,2,1)=4.d0
seuilbt_homog(NVIS+2,0,2)=5.d0
seuilbt_homog(NVIS+2,1,2)=3.d0
seuilbt_homog(NVIS+2,2,2)=5.d0
seuilbt_homog(NVIS+3,0,1)=4.d0
seuilbt_homog(NVIS+3,1,1)=3.d0
seuilbt_homog(NVIS+3,2,1)=4.d0
seuilbt_homog(NVIS+3,0,2)=5.d0
seuilbt_homog(NVIS+3,1,2)=3.d0
seuilbt_homog(NVIS+3,2,2)=5.d0
BTOBS(:,:) = -1.
BTCALC(:,:) = -1.
RCAL_CLR(:,:) = -1.
SFCTAU(:,:) = -1.
RCLD(:,:,:) = -1.
TRANSM(:,:,:) = -1.
EMI_SFC(:,:) = -1.
REJFLAG(:,:,:) = 0
NOBIASI = 0
NOBTOV = 0
count_iasi = 0
DO JF = 1, NFILES
IF ( CFAMTYP(JF) .EQ. 'TO' .AND. NBEGINTYP(JF) .GT. 0 ) THEN
IBEGIN = NBEGINTYP(JF)
ILAST = NENDTYP(JF)
IBEGINOB = MOBDATA(NCMOBS,IBEGIN)
ILASTOB = MOBDATA(NCMOBS,ILAST)
DO JO = IBEGINOB, ILASTOB
IDATYP = MOD(MOBHDR(NCMITY,JO),1000)
IF ( IDATYP .EQ. 164 .OR. &
& IDATYP .EQ. 168 .OR. &
& IDATYP .EQ. 180 .OR. &
& IDATYP .EQ. 181 .OR. &
& IDATYP .EQ. 182 .OR. &
& IDATYP .EQ. 183 .OR. &
& IDATYP .EQ. 186 ) NOBTOV = NOBTOV + 1
IF ( IDATYP .EQ. 186) THEN
count_iasi = count_iasi + 1
IF ( count_iasi > iasi_loop_done * iasi_bunch .AND. &
& count_iasi <= (iasi_loop_done+1) * iasi_bunch ) THEN
NOBIASI = NOBIASI + 1
call read_avhrrparam(JO,out_avhrr_param(NOBIASI),access_mode=1)
call convert_avhrr(out_avhrr_param(NOBIASI),profiles_qc(JO)%sunza)
call stat_avhrr(out_avhrr_param(NOBIASI))
ZTG(NOBIASI) = GOMTGRHR(1,JO)
ZPS(NOBIASI) = GOMPSHR(1,JO)*RPATMB
ZLAT(NOBIASI) = ROBHDR(NCMLAT,JO)/ZTORAD
ZLON(NOBIASI) = ROBHDR(NCMLON,JO)/ZTORAD
DO JL = 1, NLEVTRL
ZT(JL,NOBIASI) = GOMTHR(JL,JO)
ZHT(JL,NOBIASI) = GOMGZHR(JL,JO) / RG
ZLQ(JL,NOBIASI) = GOMQHR(JL,JO)
ZPRES(JL,NOBIASI)= RPPOBSHR(JL,JO) * RPATMB
END DO
IDATA = MOBHDR(NCMRLN,JO)
IDATEND = MOBHDR(NCMNLV,JO) + IDATA - 1
BAD=.false.
if (out_avhrr_param(NOBIASI)%GQISFLAGQUAL/=0 .or. &
& out_avhrr_param(NOBIASI)%GQISQUALINDEXLOC >1) &
& BAD=.true.
DO JDATA= IDATA, IDATEND
IF ( MOBDATA(NCMASS,JDATA).EQ.1 ) THEN
ICHN = NINT(ROBDATA8(NCMPPP,JDATA))
ICHN = MAX(0,MIN(ICHN,JPCH+1))
BTOBSERR(IASISCH(ICHN)) = ROBDATA8(NCMOER,JDATA)
BTOBS(IASISCH(ICHN),NOBIASI) = ROBDATA8(NCMVAR,JDATA)
! *** Flag check on observed BTs ***
IF (BAD) THEN
REJFLAG(IASISCH(ICHN),NOBIASI,9) = 1
ENDIF
! *** Gross check on observed BTs ***
IF (BTOBS(IASISCH(ICHN),NOBIASI)<150.) THEN
REJFLAG(IASISCH(ICHN),NOBIASI,9) = 1
ENDIF
IF (BTOBS(IASISCH(ICHN),NOBIASI)>350.) THEN
REJFLAG(IASISCH(ICHN),NOBIASI,9) = 1
ENDIF
END IF
END DO
DO JC = 1, NCHN
ICHN = ichan(JC,IDIASI)
BTCALC(IASISCH(ICHN),NOBIASI) = radiance_d(nobtov)%out(jc)
RCAL_CLR(IASISCH(ICHN),NOBIASI) = radiance_d(nobtov)%clear_out(jc)
SFCTAU(IASISCH(ICHN),NOBIASI) = transmission_d(nobtov)%tau_surf(jc)
DO JL = 1, NLEV
RCLD(IASISCH(ICHN),NOBIASI,JL) = radiance_d(nobtov)%overcast(jl,jc)
TRANSM(IASISCH(ICHN),NOBIASI,JL) = transmission_d(nobtov)%tau_layer(jl,jc)
END DO
EMI_SFC(IASISCH(ICHN),NOBIASI) = emissivity(JC,NOBTOV)
! *** Gross check on computed BTs ***
IF (BTCALC(IASISCH(ICHN),NOBIASI)<150.) THEN
REJFLAG(IASISCH(ICHN),NOBIASI,9) = 1
ENDIF
IF (BTCALC(IASISCH(ICHN),NOBIASI)>350.) THEN
REJFLAG(IASISCH(ICHN),NOBIASI,9) = 1
ENDIF
END DO
KSURF(NOBIASI) = profiles(nobtov)%skin%surftype
DO JL = 1, NLEV
TOEXT(JL,NOBIASI) = profiles(nobtov)%t(jl)
ZHOEXT(JL,NOBIASI) = profiles_qc(nobtov)%z(jl)
END DO
SUNZA(NOBIASI) = profiles_qc(nobtov)%sunza
SATAZIM(NOBIASI) = profiles(nobtov)%azangle
SATZEN(NOBIASI) = profiles(nobtov)%zenangle
ALBEDO(NOBIASI) = profiles_qc(nobtov)%albedo
ICE(NOBIASI) = profiles_qc(nobtov)%ice
LTYPE(NOBIASI) = profiles_qc(nobtov)%ltype
IF(LTYPE(NOBIASI).EQ.20) KSURF(NOBIASI)=2
PCNT_WAT(NOBIASI) = profiles_qc(nobtov)%pcnt_wat
PCNT_REG(NOBIASI) = profiles_qc(nobtov)%pcnt_reg
END IF
END IF
END DO
END IF
END DO
IF ( NOBIASI < iasi_bunch ) iasi_end = .true.
! ** find TOA radiances converted from observed BT's
ROBS(:,:) = -1.
profils: DO JN = 1, NPRF
channels: DO JC = 1, NCHN
ICHN = ichan(JC,IDIASI)
IF ( REJFLAG(IASISCH(ICHN),JN,9) == 1 ) CYCLE channels
t_effective = coef(idiasi)%ff_bco(jc) &
& + coef(idiasi)%ff_bcs(jc) * BTOBS(iasisch(ichn),jn)
ROBS(iasisch(ichn),jn) = coef(idiasi)%planck1(jc) / &
& ( Exp( coef(idiasi)%planck2(jc)/t_effective ) - 1.0 )
END DO channels
END DO profils
! ** set height fields to 'height above ground' fields
DO JN = 1, NPRF
DO JL = 1, NLEV
ZHOEXT(JL,JN) = ZHOEXT(JL,JN) - ZHT(NLEVTRL,JN)
END DO
DO JL = 1, NLEVTRL
ZHT(JL,JN) = ZHT(JL,JN) - ZHT(NLEVTRL,JN)
END DO
END DO
!**********************************************************************************************
!* ///// ---------------------------------------------------- /////
!* ///// DETERMINATION OF THE CLEAR/CLOUDY PROFILES (CLDFLAG) /////
!* ///// ---------------------------------------------------- /////
CLDFLAG(:) = 0
!* -- REFERENCE FOR WINDOW CHANNEL
IWINDO = IASISCH(IWINDOW)
IWINDO_ALT = IASISCH(IWINDOW_ALT)
ICHREF(:) = IWINDO
DO JN = 1, NPRF
IF ( REJFLAG(IWINDO,JN,9) == 1 ) THEN
ICHREF(JN) = IWINDO_ALT
IF ( REJFLAG(IWINDO_ALT,JN,9) == 1 ) THEN
ICHREF(JN) = -1
CLDFLAG(JN) = -1
REJFLAG(:,JN,9) = 1
write(nulout,*) 'WARNING'
write(nulout,*) 'WINDOW AND ALTERNATE WINDOW CHANNEL OBSERVATIONS'
write(nulout,*) 'HAVE BEEN REJECTED. '
write(nulout,*) 'ALL IASI OBSERVATIONS FROM THIS PROFILE REJECTED'
END IF
END IF
END DO
!* -- 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,zpres,nlevtrl,iasisnch,nprf,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,zpres,nlevtrl,iasisnch,nprf,ichref,lev_start,iopt1)
LEV_START_AVHRR(:,:) = 0
cldflag_avhrr(:,:)=0
DO JC=1,NCLASSAVHRR
DO JN=1,NPRF
btobs_avhrr(:,JN,JC)= out_avhrr_param(JN) % TBMOY(JC,:)
robs_avhrr(1:NIR,JN,JC)= out_avhrr_param(JN) % RADMOY(JC,NVIS+1:NIR+NVIS)
RCAL_CLR_AVHRR(:,JN) = out_avhrr_param(JN) % RADCLEARCALC(:)
EMI_SFC_AVHRR(:,JN) = out_avhrr_param(JN) % EMISS(:)
SFCTAU_AVHRR(:,JN) = out_avhrr_param(JN) % TRANSMSURF(:)
DO JL=1,NLEV
RCLD_AVHRR(:,JN,JL) = out_avhrr_param(JN) % RADOVCALC(JL,:)
ENDDO
IF (btobs_avhrr(2,JN,JC) >100.d0 ) THEN
ichref_avhrr(JN,JC)=2
ELSE IF (btobs_avhrr(3,JN,JC) >100.d0 ) THEN
ichref_avhrr(JN,JC)=3
ELSE
ichref_avhrr(JN,JC)=-1
cldflag_avhrr(JN,JC)=-1
ENDIF
ENDDO
CALL CLOUD_HEIGHT (PTOP_EQ_AVHRR(:,JC),NTOP_EQ_AVHRR(:,JC), btobs_avhrr(:,:,JC),cldflag_avhrr(:,JC),zt, &
& zht,zps,zpres,nlevtrl,NIR,nprf,ichref_avhrr(:,JC),lev_start_avhrr(:,JC),iopt1)
ENDDO
!* -- CLEAR/CLOUDY PROFILE DETECTION USING THE GARAND & NADON ALGORITHM
CALL GARAND1998NADON (CLDFLAG, btobs,ztg,zt, &
& zht,nlevtrl,iasisnch,nprf,ptop_eq,ntop_eq,ichref)
DO JC=1,NCLASSAVHRR
CALL GARAND1998NADON (CLDFLAG_AVHRR(:,jC), btobs_avhrr(:,:,JC),ztg,zt, &
& zht,nlevtrl,NIR,nprf,ptop_eq_avhrr(:,JC),ntop_eq_avhrr(:,JC),ichref_avhrr(:,JC))
ENDDO
!* -- FURTHER TESTS TO REMOVE POTENTIAL CLOUDY PROFILES
! *** TEST # A ***
! *** In daytime, set cloudy if cloud fraction over 5% ***
! A changer avec AVHRR
! WHERE ( CLDFLAG(:) == 0 .AND. CLFR(:) > 5. .AND. SUNZA(:) < 90. ) CLDFLAG(:) = 1
! *** 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,btobs,robs, &
& sfctau,cldflag,ichref,iasisnch,nchn,nprf,idiasi,"IASI")
DO JC=1,NCLASSAVHRR
CALL ESTIM_TS_AVHRR(ZTS_AVHRR(:,JC), ztg,emi_sfc_avhrr,rcal_clr_avhrr,btobs_avhrr(:,:,JC),robs_avhrr(:,:,JC), &
& sfctau_avhrr,CLDFLAG_AVHRR(:,jC),ichref_avhrr(:,JC),NIR,nprf)
ENDDO
WHERE ( CLDFLAG(:) == 0 .AND. KSURF(:) == 1 &
& .AND. ABS(ZTS(:)-ZTG(:)) > DTW ) CLDFLAG(:) = 1
WHERE ( CLDFLAG(:) == 0 .AND. KSURF(:) /= 1 &
& .AND. ABS(ZTS(:)-ZTG(:)) > DTL ) CLDFLAG(:) = 1
DO JC=1,NCLASSAVHRR
WHERE ( CLDFLAG_AVHRR(:,JC) == 0 .AND. KSURF(:) == 1 &
& .AND. ABS(ZTS_AVHRR(:,JC)-ZTG(:)) > DTW ) CLDFLAG_AVHRR(:,JC) = 1
WHERE ( 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)
DO JN=1,NPRF
IF (sunza(jn)<sunzenmax) THEN
ANISOT=1.0
deltaphi=abs(SATAZIM(JN) - out_avhrr_param(JN) %sunazim )
IF (deltaphi>180.) deltaphi=360. - deltaphi
IF (ALBEDO(JN)<0.101) THEN
CALL VISOCN(sngl(sunza(jn)),sngl(satzen(jn)),deltaphi,ANISOT,ZLAMB,ZCLOUD,IER)
SEUIL_ALBED(1)=10.0*max(1.0,ANISOT)
! SEUIL_ALBED(1)=20.0*max(1.0,ANISOT)
ELSE
SEUIL_ALBED(1)=100.0*ALBEDO(JN) + 10.
ENDIF
IF (ANISOT<1.5) THEN !to avoid sun glint
SCOS=COS ( sngl( sunza(jn) * ZTORAD) )
CALL DELT ( DEL, SCOS )
SEUIL_ALBED(1)=SEUIL_ALBED(1) * DEL
DO JC=1,NCLASSAVHRR
IF (out_avhrr_param(JN)%ALBEDMOY(JC,1) > SEUIL_ALBED(1) ) THEN
CLDFLAG_AVHRR(JN,JC) = 1
ENDIF
!static AVHRR thresholds v3
DO JL=1,NVIS
IF (out_avhrr_param(JN)%ALBEDMOY(JC,JL) > seuilalb_static(JL,KSURF(JN)) ) THEN
CLDFLAG_AVHRR(JN,JC) = 1
ENDIF
ENDDO
ENDDO
ENDIF
ENDIF
ENDDO
!Calcul de la pseudo fraction nuageuse AVHRR
! OPEN(Unit=124,file="cfracavhrr_-1",position="append")
! OPEN(Unit=125,file="cfracavhrr_0",position="append")
! OPEN(Unit=126,file="cfracavhrr_1",position="append")
DO JN=1,NPRF
CFRAC_AVHRR(JN)=0.
DO JC=1,NCLASSAVHRR
IF (CLDFLAG_AVHRR(JN,JC) == 1) CFRAC_AVHRR(JN)=CFRAC_AVHRR(JN) + out_avhrr_param(JN)%CFRAC(JC)
ENDDO
! Write(125+ CLDFLAG(JN),'(e14.6)') CFRAC_AVHRR(JN)
ENDDO
! close(124)
! close(125)
! close(126)
CFSUB(:)=-1.0
DO JN =1, NPRF
IF ( CLDFLAG(JN) == 0 .AND. CFRAC_AVHRR(JN) > 5. ) THEN
CLDFLAG(JN) = 1
CFSUB(JN)=0.01* MIN(CFRAC_AVHRR(JN),100.d0) !conversion % -> 0-1 avec seuil car parfois CFRAC_AVHRR(JN)=101
ENDIF
ENDDO
!seuil differents de jour et de nuit => v4
! DO JN=1,NPRF
! IF (SUNZA(JN)>=90.0 .AND. CFRAC_AVHRR(JN)>30.d0) CLDFLAG(JN) = 1
! IF (SUNZA(JN)<90.0 .AND. CFRAC_AVHRR(JN)>20.d0) CLDFLAG(JN) = 1
! ENDDO
!AVHRR Homogeneity criteria
DO JN=1,NPRF
IF (CLDFLAG(JN) == 0) THEN
IJOUR=1
IF (SUNZA(JN)<90.d0) IJOUR=2
! 1 NUIT
! 2 JOUR
IF (IJOUR==2) THEN
DO JC=1,NVIS
IF (out_avhrr_param(JN)%ALBSTD_PIXELIASI(JC)> seuilalb_homog(JC,KSURF(JN)) ) CLDFLAG(JN)=1
ENDDO
ENDIF
DO JC=NVIS+1,NVIS+NIR
IF (out_avhrr_param(JN)%TBSTD_PIXELIASI(JC)>seuilbt_homog(JC,KSURF(JN),IJOUR)) CLDFLAG(JN)=1
ENDDO
ENDIF
ENDDO
GNCLDFLAG(:)=CLDFLAG(:)
!* ///// ------------------------------------------------------- /////
!* ///// DETERMINATION OF THE ASSIMILABLE OBSERVATIONS (REJFLAG) /////
!* ///// ------------------------------------------------------- /////
! CLDFLAG(:) = 1
!* -- FIRST TESTS TO REJECT OBSERVATIONS
! *** TEST # 1 ***
! *** Do not assimilate where cloudy ***
DO JN = 1, NPRF
IF ( CLDFLAG(JN) == 1 ) REJFLAG(:,JN,11) = 1
END DO
! *** 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 43 RTTOV VERTICAL LEVELS
LEV_START(:) = 0
DO JCH = 1, NCH
ILIST(JCH) = IASISCH(ILIST1(JCH))
END DO
CALL CLOUD_TOP ( PTOP_BT,PTOP_RD,NTOP_BT,NTOP_RD, &
& btobs,toext,zhoext,rcal_clr,zps,robs,rcld,xpres,nlev, &
& iasisnch,nprf,cldflag,rejflag,bitflag,lev_start,iopt2,ihgt,ichref,nch,ilist)
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,xpres,nlev, &
& NIR,nprf,cldflag_avhrr(:,jc),lev_start_avhrr(:,JC),iopt2,ihgt,nn,ilist_avhrr)
ENDDO
!* -- REFERENCE CHANNEL FOR CO2-SLICING
DO JN = 1, NPRF
cpt=0
DO JCH=1,NCO2
IF ( REJFLAG(ILIST2_PAIR(JCH),JN,9)==1 ) cpt=cpt+1
ENDDO
IF (cpt==nco2) THEN
CLDFLAG(JN) = -1
REJFLAG(:,JN,9) = 1
write(nulout,*) 'WARNING'
write(nulout,*) 'CO2 REFERENCE AND ALTERNATE CHANNEL OBSERVATIONS'
write(nulout,*) 'HAVE BEEN REJECTED. '
write(nulout,*) 'ALL IASI OBSERVATIONS FROM THIS PROFILE REJECTED'
ENDIF
END DO
!* -- EQUIVALENT HEIGHT OF SELECTED WINDOW CHANNEL
HE(:) = PTOP_RD(IASISCH(ILIST1(2)),:)
DO JN = 1, NPRF
IF (ICHREF(JN)==IWINDO_ALT) HE(JN) = PTOP_RD(IASISCH(ILIST1(3)),JN)
END DO
!* -- CLOUD TOP BASED ON CO2 SLICING
LEV_START(:) = MAX( MIN(LEV_START(:),CO2MAX), CO2MIN )
DO JCH = 1, NCO2
ILIST(JCH) = IASISCH(ILIST2(JCH))
ILIST_PAIR(JCH) = IASISCH(ILIST2_PAIR(JCH))
END DO
CALL CO2_SLICING ( PTOP_CO2,NTOP_CO2,FCLOUD_CO2, &
& rcal_clr,rcld,robs,zps,xpres,nlev,iasisnch,nprf,cldflag,rejflag,bitflag, &
& lev_start,ichref,nco2,ilist,ilist_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,nprf,nco2 )
! DO JN=1,NPRF
! IF (ECF(JN)==0.0 .AND. ETOP(JN)==ZPS(JN) ) THEN
! WHERE (REJFLAG(:,JN,11) == 1) REJFLAG(:,JN,11) = 0
! ENDIF
! ENDDO
! Correction pour les nuages trop bas:
! en principe Pco2 < Heff.
! on cherche les cas pathologiques avec Pco2>Min(Heff(AVHRR))
DO JN=1,NPRF
minpavhrr(2:3)=12200
ILOC(2:3)=-1 ! pour eviter les catastrophes...
DO JC=1,NCLASSAVHRR
IF (out_avhrr_param(JN)%CFRAC(JC)>0.) THEN
IF (PTOP_RD_AVHRR(2,JN,JC)<minpavhrr(2)) THEN
ILOC(2)=JC
minpavhrr(2)=PTOP_RD_AVHRR(2,JN,JC)
ENDIF
IF (PTOP_RD_AVHRR(3,JN,JC)<minpavhrr(3)) THEN
ILOC(3)=JC
minpavhrr(3)=PTOP_RD_AVHRR(3,JN,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. &
PTOP_RD_AVHRR(2,JN,ILOC(2)) < ETOP(JN) .and. &
PTOP_RD_AVHRR(3,JN,ILOC(3)) < ETOP(JN) .and. &
ABS(minpavhrr(2)- minpavhrr(3))<25. .and. &
CLDFLAG_AVHRR(JN,ILOC(2))/=-1 .and. CLDFLAG_AVHRR(JN,ILOC(3))/=-1) THEN
IF (ECF(JN)==0.0 .and. CLDFLAG(JN)==1) THEN
!cas predetermine nuageux mais ramene a clair
ECF(JN)=0.01* min(100.d0,CFRAC_AVHRR(JN))
! cette ligne peut generer des fractions nuageuses inferieures a 20 %. Probleme ?
ETOP(JN)=0.5*(minpavhrr(2) + minpavhrr(3))
ENDIF
IF (ECF(JN)>0.0 .and. CLDFLAG(JN)==1) THEN
!cas predetermine nuageux pas ramene clair (==normal)
ETOP(JN)=0.5*(minpavhrr(2) + minpavhrr(3))
ENDIF
IF (CLDFLAG(JN)==0) THEN
!cas predetermine clair ... que faire
CLDFLAG(JN)=1
ETOP(JN)=0.5*(minpavhrr(2) + minpavhrr(3))
ECF(JN)=0.01* min(100.d0,CFRAC_AVHRR(JN))
ENDIF
ENDIF
ENDDO
!* -- FIND RADIATIVE TRANSFER MODEL LEVEL NEAREST TO TRIAL TOP (only compute one time)
IF ( iasi_loop_done == 0 ) THEN
DIFFTOP_MIN = 100000.
IMODTOP = 1
DO JL = 1, NLEV
IF ( ABS(RPTOPINC-100.*XPRES(JL)) < DIFFTOP_MIN ) THEN
DIFFTOP_MIN = ABS(RPTOPINC-100.*XPRES(JL))
IMODTOP = JL
END IF
END DO
write(nulout,*) 'TOIT DU MODELE (MB)'
write(nulout,*) 0.01*RPTOPINC
write(nulout,*) 'NIVEAU DU MODELE DE TRANSFERT RADIATIF LE PLUS PRES DU TOIT DU MODELE'
write(nulout,*) IMODTOP
END IF
!* -- FIND MINIMUM LEVEL OF SENSITIVITY FOR CHANNEL ASSIMILATION NOT SENSIBLE TO CLOUDS
! CALL MIN_PRES ( MINP,PMIN,DTAUDP1, zps,transm,xpres,cldflag,nlev,iasisnch,nprf,imodtop )
CALL MIN_PRES_new (MAXWF, MINP,PMIN,DTAUDP1, zps,transm,xpres,cldflag,nlev,iasisnch,nprf,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.*VTOP(:))
DO JC = 1, IASISNCH
WHERE ( REJFLAG(JC,:,11) == 1 .AND. ETOP(:) - TAMPON(:) > PMIN(JC,:) ) &
& REJFLAG(JC,:,11) = 0
END DO
! LOOK AT THE FATE OF THE OBSERVATIONS
FATE(:,:) = SUM(REJFLAG(:,:,:),DIM=3)
! FURTHER REASONS TO REJECT OBSERVATIONS
DO JC = 1, IASISNCH
DO JN = 1, NPRF
IF ( FATE(JC,JN) == 0 ) THEN
! *** TEST # 4 ***
! *** Background check, do not assimilate if O-P > 3sigma ***
IF ( ABS(BTOBS(JC,JN)-BTCALC(JC,JN)) > 3.0*BTOBSERR(JC) ) THEN
REJFLAG(JC,JN,9) = 1
REJFLAG(JC,JN,16) = 1
END IF
! *** TEST # 5 ***
! *** Do not assimilate shortwave channels during the day ***
IF ( JC >= IASISCH(ICHN_SUN) .AND. SUNZA(JN) < NIGHT_ANG ) REJFLAG(JC,JN,11) = 1
! *** TEST # 6 ***
! *** Do not assimilate surface channels over land ***
IF ( MINP(JC,JN) == NLEV .or. ZPS(JN)-PMIN(JC,JN) < 100. ) THEN
IF ( KSURF(JN) == 0 ) THEN
REJFLAG(JC,JN,11) = 1 !!! comment this line if assimilation under conditions
REJFLAG(JC,JN,19) = 1 !!! comment this line if assimilation under conditions
IF ( PCNT_WAT(JN) > 0.01 .OR. PCNT_REG(JN) > 0.1 .OR. EMI_SFC(JC,JN) < 0.97 ) THEN
REJFLAG(JC,JN,11) = 1
REJFLAG(JC,JN,19) = 1
END IF
! *** TEST # 7 ***
! *** Do not assimilate surface channels over water under conditions ***
ELSE IF ( KSURF(JN) == 1 ) THEN
IF ( PCNT_WAT(JN) < 0.99 .OR. PCNT_REG(JN) < 0.97 .OR. &
& ICE(JN) > 0.001 .OR. ALBEDO(JN) >= 0.1 .OR. EMI_SFC(JC,JN) < 0.9 ) THEN
REJFLAG(JC,JN,11) = 1
REJFLAG(JC,JN,19) = 1
END IF
! *** TEST # 8 ***
! *** Do not assimilate surface channels over sea ice ***
ELSE IF ( KSURF(JN) == 2 ) THEN
REJFLAG(JC,JN,11) = 1
REJFLAG(JC,JN,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(RPTOPINC) >= 1000 ) THEN
IF ( REJFLAG(JC,JN,9) /= 1 .AND. DTAUDP1(JC,JN) > 0.50 ) THEN
REJFLAG(JC,JN,11) = 1
REJFLAG(JC,JN,21) = 1
END IF
END IF
! Condition valid if model top at 10mb or lower only
IF ( NINT(RPTOPINC) >= 1000 ) THEN
IF ( REJFLAG(JC,JN,9) /= 1 .AND. TRANSM(JC,JN,1) < 0.99 ) THEN
REJFLAG(JC,JN,11) = 1
REJFLAG(JC,JN,21) = 1
END IF
END IF
! Condition valid if model top is higher than 10 mb
IF ( NINT(RPTOPINC) < 1000 ) THEN
IF ( REJFLAG(JC,JN,9) /= 1 .AND. TRANSM(JC,JN,1) < 0.95 ) THEN
REJFLAG(JC,JN,11) = 1
REJFLAG(JC,JN,21) = 1
END IF
END IF
! *** TEST # 10 ***
! *** Do not assimilate blacklisted channels ***
IF ( IASI_ASSIM(JC) == 0 ) REJFLAG(JC,JN,8) = 1
END DO
END DO
!* -- FOR EACH PROFILE, ARE ALL NON-BLACKLISTED CHANNELS ASSIMILATED
ASSIM_ALL(:) = .true.
FATE(:,:) = SUM(REJFLAG(:,:,:),DIM=3)
prf: DO JN = 1, NPRF
chn: DO JC = 1, IASISNCH
IF ( REJFLAG(JC,JN,8) == 0 ) THEN
IF ( FATE(JC,JN) /= 0 ) THEN
ASSIM_ALL(JN) = .false.
EXIT chn
END IF
END IF
END DO chn
END DO prf
!******************************************************************************************
!* -- PUT REJECT FLAGS INTO CMA VARIABLE --
!* ----------------------------------------
NOBIASI = 0
count_iasi = 0
DO JF = 1, NFILES
IF ( CFAMTYP(JF) .EQ. 'TO' .AND. NBEGINTYP(JF) .GT. 0 ) THEN
IBEGIN = NBEGINTYP(JF)
ILAST = NENDTYP(JF)
IBEGINOB = MOBDATA(NCMOBS,IBEGIN)
ILASTOB = MOBDATA(NCMOBS,ILAST)
DO JO = IBEGINOB, ILASTOB
IDATYP = MOD(MOBHDR(NCMITY,JO),1000)
IF ( IDATYP .EQ. 186) THEN
count_iasi = count_iasi + 1
IF ( count_iasi > iasi_loop_done * iasi_bunch .AND. &
& count_iasi <= (iasi_loop_done+1) * iasi_bunch ) THEN
NOBIASI = NOBIASI + 1
IDATA = MOBHDR(NCMRLN,JO)
IDATEND = MOBHDR(NCMNLV,JO) + IDATA - 1
DO JDATA= IDATA, IDATEND
IF ( MOBDATA(NCMASS,JDATA).EQ.1 ) THEN
ICHN = NINT(ROBDATA8(NCMPPP,JDATA))
ICHN = MAX(0,MIN(ICHN,JPCH+1))
DO NFLG = 0, BITFLAG
IF ( REJFLAG(IASISCH(ICHN),NOBIASI,NFLG) == 1 ) &
& MOBDATA(NCMFLG,JDATA) = IBSET ( MOBDATA(NCMFLG,JDATA), NFLG )
END DO
END IF
END DO
END IF
END IF
END DO
END IF
END DO
!* -- ADDITION OF NEW IASI INFORMATION IN BURP FILE
!* ------------------------------------------------
IPRO = iasi_loop_done * iasi_bunch + 1
DO JN = 1, NPRF
IASIPRO(IPRO)%ETOP = ETOP(JN)
IASIPRO(IPRO)%VTOP = VTOP(JN)
IASIPRO(IPRO)%ECF = 100.*ECF(JN)
IASIPRO(IPRO)%VCF = 100.*VCF(JN)
IASIPRO(IPRO)%HE = HE(JN)
IASIPRO(IPRO)%ZTS = ZTS(JN)
IASIPRO(IPRO)%NGOOD = NGOOD(JN)
IASIPRO(IPRO)%ZT = ZT(NLEVTRL,JN)
IASIPRO(IPRO)%ZTG = ZTG(JN)
IASIPRO(IPRO)%ZLQEXP = EXP(ZLQ(NLEVTRL,JN))
IASIPRO(IPRO)%ZPS = 100.*ZPS(JN)
IASIPRO(IPRO)%EMISFC(:) = EMI_SFC(:,JN)
IASIPRO(IPRO)%SFCTYP = KSURF(JN)
IASIPRO(IPRO)%ASSIM_ALL = ASSIM_ALL(JN)
IPRO = IPRO + 1
END DO
deallocate (ZTG,ZPS,ZTS,ZT,ZHT,ZLQ)
deallocate (BTOBSERR,BTOBS,BTCALC,RCAL_CLR,SFCTAU)
deallocate (ROBS,RCLD,TRANSM,EMI_SFC)
deallocate (TOEXT,ZHOEXT,SUNZA)
deallocate (ALBEDO,ICE,PCNT_WAT,PCNT_REG)
deallocate (KSURF,LTYPE)
deallocate (CLDFLAG,REJFLAG,LEV_START,ILIST)
deallocate (NTOP_EQ,NTOP_BT,NTOP_RD)
deallocate (NTOP_CO2,NGOOD)
deallocate (PTOP_EQ,PTOP_BT,PTOP_RD)
deallocate (PTOP_CO2,FCLOUD_CO2,HE)
deallocate (ETOP,VTOP,ECF,VCF)
deallocate (MINP,FATE)
deallocate (PMIN,DTAUDP1,TAMPON)
deallocate (ICHREF)
deallocate (ASSIM_ALL,ZPRES,PTOP_MB,NTOP_MB,CFSUB)
deallocate (out_avhrr_param)
deallocate ( LEV_START_AVHRR,PTOP_EQ_AVHRR,NTOP_EQ_AVHRR,BTOBS_AVHRR)
deallocate ( ICHREF_AVHRR )
deallocate ( CLDFLAG_AVHRR )
deallocate ( ROBS_AVHRR)
deallocate ( RCAL_CLR_AVHRR )
deallocate ( EMI_SFC_AVHRR)
deallocate ( ZTS_AVHRR)
deallocate ( SFCTAU_AVHRR)
deallocate ( PTOP_BT_AVHRR)
deallocate ( PTOP_RD_AVHRR)
deallocate ( NTOP_BT_AVHRR)
deallocate ( NTOP_RD_AVHRR)
deallocate ( RCLD_AVHRR)
deallocate ( ZLAT,ZLON)
deallocate ( MAXWF,CFRAC_AVHRR )
deallocate(satazim,satzen)
deallocate (GNCLDFLAG,ILIST_PAIR)
END SUBROUTINE IASIQC