!-------------------------------------- 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 hir_cldprm_to_brp(lobsspacedata,brp_file) 3,35
#if defined (DOC)
!***********************************************************************
!
!**ID hir_cldprm_to_brp -- PUT VARIABLES RELATIVE TO AIRS/IASI/CrIS quality control IN BURP FILE
!
! AUTHOR: S. Heilliette 2008 inspired from A. BEAULNE (CMDA/SMC)
!
! REVISION:
!
! OBJECT: OPEN CMC BURP FILE GENERATED BY S/R CMAABRP AND ADD
! AIRS/IASI/CrIS DATA IN BLOCKS. ADDED ELEMENTS: 013214, 014213 - 014221,
! 055043, 059182. MODIFIED ELEMENTS: 008012, 055200
!
! WHEN SEARCHING FOR A SPECIFIC BLOCK BY ITS BTYP, VALUES OF
! BIT 0 TO 3 ARE IRRELEVANT WHILE BIT 4 IS 0 FOR GLOBAL AND 1
! FOR REGIONAL MODEL. HERE, WE SEARCH BLOCK BY THEIR FIRST
! 10 BITS (BIT 5 TO 14).
!
! ARGUMENTS:
! INPUT:
! -BRP_FILE : NAME OF BURP FILE
!
!
!***********************************************************************
#endif
use burp_module
use tovs_nl_mod
use obsSpaceData_mod
IMPLICIT NONE
!implicits
CHARACTER(LEN=128),intent(in) :: BRP_FILE
type(struct_obs),intent(inout) :: lobsSpaceData
TYPE(BURP_FILE) :: FILE_IN
TYPE(BURP_RPT) :: RPT_IN,CP_RPT
TYPE(BURP_BLOCK) :: BLOCK_IN
CHARACTER(LEN=9) :: ID,OPT_MISSING
INTEGER :: NEW_BTYP
INTEGER :: BTYP10
INTEGER :: BTYP10DES,BTYP10INF,BTYP10OBS,BTYP10FLG,BTYP10OMP
INTEGER :: NB_RPTS,REF_RPT,REF_BLK,COUNT
INTEGER, ALLOCATABLE :: ADDRESS(:), GOODPROF(:)
REAL(8), ALLOCATABLE :: BTOBS(:,:)
REAL(8) :: ETOP,VTOP,ECF,VCF,HE,ZTS,emisfc
INTEGER :: NBELE,NVALE,NTE
INTEGER, ALLOCATABLE :: GLBFLAG(:)
INTEGER :: I,J,K,KK,L,BTYP,BFAM,ERROR
INTEGER :: IND008012,IND012163,IND055200,INDCHAN,ICHN,ICHNB
INTEGER :: IDATA2,IDATA3,IDATA,IDATEND
INTEGER :: FLAG_PASSAGE1,FLAG_PASSAGE2,FLAG_PASSAGE3
INTEGER :: FLAG_PASSAGE4,FLAG_PASSAGE5
REAL :: VAL_OPTION_R4
WRITE(*,*) '---------------------------------------'
WRITE(*,*) '------- BEGIN hir_cldprm_to_brp -------'
WRITE(*,*) '---------------------------------------'
! initialisation
! --------------
flag_passage1 = 0
flag_passage2 = 0
flag_passage3 = 0
flag_passage4 = 0
flag_passage5 = 0
idata2 = 1
idata3 = 1
opt_missing = 'MISSING'
val_option_r4 = -7777.77
Call BURP_Set_Options( &
REAL_OPTNAME = opt_missing, &
REAL_OPTNAME_VALUE = val_option_r4, &
IOSTAT = error )
Call BURP_Init(File_in,IOSTAT=error)
Call BURP_Init(Rpt_in,Cp_rpt,IOSTAT=error)
Call BURP_Init(Block_in,IOSTAT=error)
! opening file
! ------------
write(*,*) 'OPENED FILE = ', brp_file
Call BURP_New(File_in, &
FILENAME = brp_file, &
MODE = FILE_ACC_APPEND, &
IOSTAT = error )
! obtain input burp file number of reports
! ----------------------------------------
Call BURP_Get_Property(File_in, NRPTS=nb_rpts)
WRITE(*,*)
WRITE(*,*) 'NUMBER OF REPORTS WITH OBSERVATIONS = ',nb_rpts-1
WRITE(*,*)
! scan input burp file to get all reports address
! -----------------------------------------------
Allocate(address(nb_rpts))
address(:) = 0
count = 0
ref_rpt = 0
do
ref_rpt = BURP_Find_Report(File_in, &
REPORT = Rpt_in, &
SEARCH_FROM = ref_rpt, &
IOSTAT = error)
if (ref_rpt < 0) Exit
count = count + 1
address(count) = ref_rpt
end do
if ( count > 0 ) then
! crate a new report
! ------------------
!cpik Call BURP_New(Cp_rpt, ALLOC_SPACE=10000000, IOSTAT=error)
Call BURP_New(Cp_rpt, ALLOC_SPACE=20000000, IOSTAT=error)
! LOOP ON REPORTS
! ---------------
REPORTS: do kk = 1, count
Call BURP_Get_Report(File_in, &
REPORT = Rpt_in, &
REF = address(kk), &
IOSTAT = error)
! FIRST LOOP ON BLOCKS
! --------------------
! find bad profiles not in CMA. This occurs if :
! - all observations are -1 and/or have a quality flag not zero
ref_blk = 0
BLOCKS1: do
ref_blk = BURP_Find_Block(Rpt_in, &
BLOCK = Block_in, &
SEARCH_FROM = ref_blk, &
IOSTAT = error)
if (ref_blk < 0) EXIT BLOCKS1
Call BURP_Get_Property(Block_in, &
NELE = nbele, &
NVAL = nvale, &
NT = nte, &
BFAM = bfam, &
BTYP = btyp, &
IOSTAT = error)
! observation block (btyp = 0100 100011X XXXX)
! 0100 1000110 0000 = 9312
btyp10 = ishft(btyp,-5)
btyp10obs = 291
if ( btyp10 - btyp10obs == 0 .and. bfam == 0 ) then
ALLOCATE(goodprof(nte),btobs(nvale,nte))
goodprof(:) = 0
btobs(:,:) = 0.
ind012163 = BURP_Find_Element(Block_in, ELEMENT=012163, IOSTAT=error)
do k=1,nte
do j=1,nvale
btobs(j,k) = BURP_Get_Rval(Block_in, &
NELE_IND = ind012163, &
NVAL_IND = j, &
NT_IND = k )
if ( btobs(j,k) > 0. ) goodprof(k) = 1
end do
end do
end if
end do BLOCKS1
Call BURP_Copy_Header(TO=Cp_rpt,FROM=Rpt_in)
Call BURP_Init_Report_Write(File_in,Cp_Rpt, IOSTAT=error)
! SECOND LOOP ON BLOCKS
! ---------------------
! add new informations
ref_blk = 0
BLOCKS2: do
if ( .not. allocated(goodprof) ) then
write(*,*)
write(*,*) 'Resume report is position # ',kk
EXIT BLOCKS2
end if
ref_blk = BURP_Find_Block(Rpt_in, &
BLOCK = Block_in, &
SEARCH_FROM = ref_blk, &
IOSTAT = error)
if (ref_blk < 0) EXIT BLOCKS2
Call BURP_Get_Property(Block_in, &
NELE = nbele, &
NVAL = nvale, &
NT = nte, &
BFAM = bfam, &
BTYP = btyp, &
IOSTAT = error)
! descriptor block (btyp = 0010 100000X XXXX)
! 0010 1000000 0000==5120 )
! if profile contains rejected observations (apart from blacklisted channels),
! set bit 6 in global flags.
btyp10 = ishft(btyp,-5)
btyp10des = 160
if ( btyp10 - btyp10des == 0 ) then
flag_passage1 = 1
ALLOCATE(glbflag(nte))
ind055200 = BURP_Find_Element(Block_in, ELEMENT=055200, IOSTAT=error)
do k = 1, nte
glbflag(k) = BURP_Get_Tblval(Block_in, &
NELE_IND = ind055200, &
NVAL_IND = 1, &
NT_IND = k )
end do
do k = 1, nte
if (goodprof(k)/=1) glbflag(k) = ibset(glbflag(k),6)
end do
do k = 1, nte
Call BURP_Set_Tblval(Block_in, &
NELE_IND = ind055200, &
NVAL_IND = 1, &
NT_IND = k, &
TBLVAL = glbflag(k), &
IOSTAT = error)
end do
DEALLOCATE(glbflag)
end if
! info block (btyp = 0001 100000X XXXX)
! 0001 100000X XXXX = 3072
btyp10 = ishft(btyp,-5)
btyp10inf = 96
if ( btyp10 - btyp10inf == 0 ) then
flag_passage2 = 1
Call BURP_Resize_Block(Block_in, ADD_NELE=11, IOSTAT=error)
Call BURP_Set_Element(Block_in, NELE_IND=nbele+ 1, ELEMENT=014213, IOSTAT=error)
Call BURP_Set_Element(Block_in, NELE_IND=nbele+ 2, ELEMENT=014214, IOSTAT=error)
Call BURP_Set_Element(Block_in, NELE_IND=nbele+ 3, ELEMENT=014215, IOSTAT=error)
Call BURP_Set_Element(Block_in, NELE_IND=nbele+ 4, ELEMENT=014216, IOSTAT=error)
Call BURP_Set_Element(Block_in, NELE_IND=nbele+ 5, ELEMENT=014217, IOSTAT=error)
Call BURP_Set_Element(Block_in, NELE_IND=nbele+ 6, ELEMENT=014218, IOSTAT=error)
Call BURP_Set_Element(Block_in, NELE_IND=nbele+ 7, ELEMENT=014219, IOSTAT=error)
Call BURP_Set_Element(Block_in, NELE_IND=nbele+ 8, ELEMENT=014220, IOSTAT=error)
Call BURP_Set_Element(Block_in, NELE_IND=nbele+ 9, ELEMENT=014221, IOSTAT=error)
Call BURP_Set_Element(Block_in, NELE_IND=nbele+10, ELEMENT=013214, IOSTAT=error)
Call BURP_Set_Element(Block_in, NELE_IND=nbele+11, ELEMENT=059182, IOSTAT=error)
ind008012 = BURP_Find_Element(Block_in, &
ELEMENT = 008012, &
IOSTAT = error)
do k = 1, nte
if ( goodprof(k) == 1 ) then
call Insert_into_burp_r8(obs_headElem_r(lobsSpaceData,OBS_ETOP,idata2),nbele+1,1,k)
call Insert_into_burp_r8(obs_headElem_r(lobsSpaceData,OBS_VTOP,idata2),nbele+2,1,k)
call Insert_into_burp_r8(obs_headElem_r(lobsSpaceData,OBS_ECF,idata2),nbele+3,1,k)
call Insert_into_burp_r8(obs_headElem_r(lobsSpaceData,OBS_VCF,idata2),nbele+4,1,k)
call Insert_into_burp_r8(obs_headElem_r(lobsSpaceData,OBS_HE,idata2),nbele+5,1,k)
call Insert_into_burp_r8(obs_headElem_r(lobsSpaceData,OBS_ZTSR,idata2),nbele+6,1,k)
call Insert_into_burp_i(obs_headElem_i(lobsSpaceData,OBS_NCO2,idata2),nbele+7,1,k)
call Insert_into_burp_r8(obs_headElem_r(lobsSpaceData,OBS_ZTM,idata2),nbele+8,1,k)
call Insert_into_burp_r8(obs_headElem_r(lobsSpaceData,OBS_ZTGM,idata2),nbele+9,1,k)
call Insert_into_burp_r8(obs_headElem_r(lobsSpaceData,OBS_ZLQM,idata2),nbele+10,1,k)
call Insert_into_burp_r8(obs_headElem_r(lobsSpaceData,OBS_ZPS,idata2),nbele+11,1,k)
call Insert_into_burp_i(obs_headElem_i(lobsSpaceData,OBS_STYP,idata2),ind008012,1,k)
idata2 = idata2 + 1
else
do i = 1, 11
call Insert_into_burp_r8(-1.d0,nbele+i,1,k)
end do
call Insert_into_burp_i(-1,ind008012,1,k)
end if
end do
end if
! observation block (btyp = 0100 100011X XXXX)
! 0100 1000110 0000 = 9312
btyp10 = ishft(btyp,-5)
btyp10obs = 291
if ( btyp10 - btyp10obs == 0 .and. bfam == 0 ) then
flag_passage3 = 1
Call BURP_Resize_Block(Block_in, ADD_NELE=1, IOSTAT=error)
Call BURP_Set_Element(Block_in, NELE_IND=nbele+1, ELEMENT=055043, IOSTAT=error)
indchan = BURP_Find_Element(Block_in, ELEMENT=005042, IOSTAT=error)
do k = 1, nte
do j = 1, nvale
call Insert_into_burp_i(-1,nbele+1,j,k)
end do
if ( goodprof(k) == 1 ) then
IDATA = obs_headElem_i(lobsSpaceData,OBS_RLN,idata3)
IDATEND = obs_headElem_i(lobsSpaceData,OBS_NLV,idata3) + IDATA - 1
do j = IDATA,IDATEND
emisfc=100.d0*obs_bodyElem_r(lobsspacedata,OBS_SEM,j)
ICHN = NINT(obs_bodyElem_r(lobsSpaceData,OBS_PPP,j))
ICHN = MAX(0,MIN(ICHN,JPCHMAX+1))
bl: do l=1,nvale
ichnb=BURP_Get_Tblval(Block_in, &
NELE_IND = indchan, &
NVAL_IND = l, &
NT_IND = k)
if (ichn==ichnb) then
call Insert_into_burp_r8(emisfc,nbele+1,l,k)
exit bl
endif
enddo bl
end do
idata3 = idata3 + 1
end if
end do
end if
! flag block (btyp = 0111 100011X XXXX)
! 0111 1000110 0000 = 15456
btyp10 = ishft(btyp,-5)
btyp10flg = 483
if ( btyp10 - btyp10flg == 0 ) then
flag_passage4 = 1
Call BURP_Resize_Block(Block_in, ADD_NELE=1, IOSTAT=error)
Call BURP_Set_Element(Block_in, NELE_IND=nbele+1, ELEMENT=255043, IOSTAT=error)
do k = 1, nte
do j = 1, nvale
Call BURP_Set_Tblval(Block_in, &
NELE_IND = nbele+1, &
NVAL_IND = j, &
NT_IND = k, &
TBLVAL = 0, &
IOSTAT = error)
end do
end do
end if
! O-P block (btyp = 0100 100011X XXXX)
! 0100 1000110 0000 = 9312
btyp10 = ishft(btyp,-5)
btyp10omp = 291
if ( btyp10 - btyp10omp == 0 .and. bfam == 14 ) then
flag_passage5 = 1
Call BURP_Resize_Block(Block_in, ADD_NELE=1, IOSTAT=error)
Call BURP_Set_Element(Block_in, NELE_IND=nbele+1, ELEMENT=055043, IOSTAT=error)
do k = 1, nte
do j = 1, nvale
call Insert_into_burp_i(-1,nbele+1,j,k)
end do
end do
end if
! add block into new report
! -------------------------
if ( btyp == 5120 ) then
Call BURP_Write_Block(Cp_rpt, Block_in, &
ENCODE_BLOCK = .true., &
IOSTAT = error)
else
Call BURP_Write_Block(Cp_rpt, Block_in, &
ENCODE_BLOCK = .true., &
CONVERT_BLOCK = .true., &
IOSTAT = error)
end if
end do BLOCKS2
if ( allocated(goodprof) ) then
DEALLOCATE (goodprof,btobs)
end if
! write new report into file
! --------------------------
Call BURP_Delete_Report(File_in,Rpt_in, IOSTAT=error)
Call BURP_Write_Report(File_in,Cp_rpt, IOSTAT=error)
end do REPORTS
end if
Deallocate(address)
if ( flag_passage1 == 0 ) then
write(*,*)
write(*,*) 'ERROR - descriptor block not seen ? Verify btyp'
end if
if ( flag_passage2 == 0 ) then
write(*,*)
write(*,*) 'ERROR - info block not seen ? Verify btyp'
end if
if ( flag_passage3 == 0 ) then
write(*,*)
write(*,*) 'ERROR - observation block not seen ? Verify btyp'
end if
if ( flag_passage4 == 0 ) then
write(*,*)
write(*,*) 'ERROR - flag block not seen ? Verify btyp'
end if
if ( flag_passage5 == 0 ) then
write(*,*)
write(*,*) 'ERROR - O-P block not seen ? Verify btyp'
end if
Call BURP_Free(File_in,IOSTAT=error)
Call BURP_Free(Rpt_in,Cp_rpt,IOSTAT=error)
Call BURP_Free(Block_in,IOSTAT=error)
CONTAINS
!------------------------------------- HANDLE_ERROR -----
subroutine handle_error()
implicit none
write(*,*) BURP_STR_ERROR()
write(*,*) "history"
Call BURP_STR_ERROR_HISTORY()
Deallocate(address)
Call BURP_Free(File_in)
Call BURP_Free(Rpt_in,Cp_rpt)
Call BURP_Free(Block_in)
stop
end subroutine handle_error
subroutine Insert_into_burp_r8(r8val,pele,pval,pt) 12
implicit none
real (8), intent(in):: r8val
integer, intent(in) :: pele,pval,pt
if ( r8val >= 0.d0 ) then
Call BURP_Set_Rval(Block_in, &
NELE_IND = pele, &
NVAL_IND = pval, &
NT_IND = pt, &
RVAL = sngl(r8val), &
IOSTAT = error)
else
Call BURP_Set_Rval(Block_in, &
NELE_IND = pele, &
NVAL_IND = pval, &
NT_IND = pt, &
RVAL = val_option_r4, &
IOSTAT = error)
end if
end subroutine Insert_into_burp_r8
subroutine Insert_into_burp_i(ival,pele,pval,pt) 5
implicit none
integer, intent(in) :: ival
integer, intent(in) :: pele,pval,pt
if ( ival >= 0 ) then
Call BURP_Set_Rval(Block_in, &
NELE_IND = pele, &
NVAL_IND = pval, &
NT_IND = pt, &
RVAL = real(ival), &
IOSTAT = error)
else
Call BURP_Set_Rval(Block_in, &
NELE_IND = pele, &
NVAL_IND = pval, &
NT_IND = pt, &
RVAL = val_option_r4, &
IOSTAT = error)
end if
end subroutine Insert_into_burp_i
END SUBROUTINE HIR_CLDPRM_TO_BRP