!-------------------------------------- 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 AIRSABRP(brp_file) 1,1
#if defined (DOC)
!***********************************************************************
!
!**ID AIRSABRP -- PUT VARIABLES RELATIVE TO AIRS IN BURP FILE
!
! AUTHOR: A. BEAULNE (CMDA/SMC) March 2006
!
! REVISION:
!
! OBJECT: OPEN CMC BURP FILE GENERATED BY S/R CMAABRP AND ADD
! AIRS 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 mod_tovs
IMPLICIT NONE
!implicits
#include "comlun.cdk"
TYPE(BURP_FILE) :: FILE_IN
TYPE(BURP_RPT) :: RPT_IN,CP_RPT
TYPE(BURP_BLOCK) :: BLOCK_IN
CHARACTER(LEN=128) :: BRP_FILE
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(:,:)
INTEGER :: NBELE,NVALE,NTE
INTEGER, ALLOCATABLE :: QFLAG(:,:),GLBFLAG(:)
INTEGER :: I,J,K,KK,BTYP,BFAM,ERROR
INTEGER :: IND008012,IND012163,IND033032,IND055200
INTEGER :: IDATA1,IDATA2,IDATA3
INTEGER :: FLAG_PASSAGE1,FLAG_PASSAGE2,FLAG_PASSAGE3
INTEGER :: FLAG_PASSAGE4,FLAG_PASSAGE5
REAL :: VAL_OPTION
WRITE(NULOUT,*) '--------------------------------------'
WRITE(NULOUT,*) '------- BEGIN AIRSABRP -------'
WRITE(NULOUT,*) '--------------------------------------'
! initialisation
! --------------
flag_passage1 = 0
flag_passage2 = 0
flag_passage3 = 0
flag_passage4 = 0
flag_passage5 = 0
idata1 = 1
idata2 = 1
idata3 = 1
opt_missing = 'MISSING'
val_option = -77.77
Call BURP_Set_Options( &
& REAL_OPTNAME = opt_missing, &
& REAL_OPTNAME_VALUE = val_option, &
& 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(nulout,*) '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(NULOUT,*)
WRITE(NULOUT,*) 'NUMBER OF REPORTS WITH OBSERVATIONS = ',nb_rpts-1
WRITE(NULOUT,*)
! 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
! ------------------
Call BURP_New(Cp_rpt, ALLOC_SPACE=1000000, IOSTAT=error)
! LOOP ON REPORTS
! ---------------
REPORTS: do kk = 1, count
Call BURP_Get_Report(File_in, &
& REPORT = Rpt_in, &
& REF = address(kk), &
& IOSTAT = error)
if ( id(1:2) == ">>" ) then
if( id .ne. ">>BGCKALT" ) then
write(nulout,*) 'ERREUR - le type de fichier devrait etre >>BGCKALT'
stop
end if
end if
! 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)
btyp10 = ishft(btyp,-5)
btyp10obs = 291
if ( btyp10 - btyp10obs == 0 .and. bfam == 0 ) then
ALLOCATE(goodprof(nte),btobs(nvale,nte),qflag(nvale,nte))
goodprof(:) = 0
btobs(:,:) = 0.
qflag(:,:) = 0
ind012163 = BURP_Find_Element(Block_in, ELEMENT=012163, IOSTAT=error)
ind033032 = BURP_Find_Element(Block_in, ELEMENT=033032, 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)
qflag(j,k) = BURP_Get_Tblval(Block_in, &
& NELE_IND = ind033032, &
& NVAL_IND = j, &
& NT_IND = k)
! if ( btobs(j,k) > 0. .and. qflag(j,k) == 0 ) goodprof(k) = 1
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(nulout,*)
write(nulout,*) '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)
! 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 ) then
if ( .not. airspro(idata1)%assim_all ) glbflag(k) = ibset(glbflag(k),6)
idata1 = idata1 + 1
else
glbflag(k) = ibset(glbflag(k),6)
end if
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)
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
if ( airspro(idata2)%etop >= 0. ) then
Call BURP_Set_Rval(Block_in, &
& NELE_IND = nbele+1, &
& NVAL_IND = 1, &
& NT_IND = k, &
& RVAL = airspro(idata2)%etop, &
& IOSTAT = error)
else
Call BURP_Set_Rval(Block_in, &
& NELE_IND = nbele+1, &
& NVAL_IND = 1, &
& NT_IND = k, &
& RVAL = val_option, &
& IOSTAT = error)
end if
if ( airspro(idata2)%vtop >= 0. ) then
Call BURP_Set_Rval(Block_in, &
& NELE_IND = nbele+2, &
& NVAL_IND = 1, &
& NT_IND = k, &
& RVAL = airspro(idata2)%vtop, &
& IOSTAT = error)
else
Call BURP_Set_Rval(Block_in, &
& NELE_IND = nbele+2, &
& NVAL_IND = 1, &
& NT_IND = k, &
& RVAL = val_option, &
& IOSTAT = error)
end if
if ( airspro(idata2)%ecf >= 0. ) then
Call BURP_Set_Rval(Block_in, &
& NELE_IND = nbele+3, &
& NVAL_IND = 1, &
& NT_IND = k, &
& RVAL = airspro(idata2)%ecf, &
& IOSTAT = error)
else
Call BURP_Set_Rval(Block_in, &
& NELE_IND = nbele+3, &
& NVAL_IND = 1, &
& NT_IND = k, &
& RVAL = val_option, &
& IOSTAT = error)
end if
if ( airspro(idata2)%vcf >= 0. ) then
Call BURP_Set_Rval(Block_in, &
& NELE_IND = nbele+4, &
& NVAL_IND = 1, &
& NT_IND = k, &
& RVAL = airspro(idata2)%vcf, &
& IOSTAT = error)
else
Call BURP_Set_Rval(Block_in, &
& NELE_IND = nbele+4, &
& NVAL_IND = 1, &
& NT_IND = k, &
& RVAL = val_option, &
& IOSTAT = error)
end if
if ( airspro(idata2)%he >= 0. ) then
Call BURP_Set_Rval(Block_in, &
& NELE_IND = nbele+5, &
& NVAL_IND = 1, &
& NT_IND = k, &
& RVAL = airspro(idata2)%he, &
& IOSTAT = error)
else
Call BURP_Set_Rval(Block_in, &
& NELE_IND = nbele+5, &
& NVAL_IND = 1, &
& NT_IND = k, &
& RVAL = val_option, &
& IOSTAT = error)
end if
if ( airspro(idata2)%zts > 0. ) then
Call BURP_Set_Rval(Block_in, &
& NELE_IND = nbele+6, &
& NVAL_IND = 1, &
& NT_IND = k, &
& RVAL = airspro(idata2)%zts, &
& IOSTAT = error)
else
Call BURP_Set_Rval(Block_in, &
& NELE_IND = nbele+6, &
& NVAL_IND = 1, &
& NT_IND = k, &
& RVAL = val_option, &
& IOSTAT = error)
end if
Call BURP_Set_Rval(Block_in, &
& NELE_IND = nbele+7, &
& NVAL_IND = 1, &
& NT_IND = k, &
& RVAL = real(airspro(idata2)%ngood), &
& IOSTAT = error)
Call BURP_Set_Rval(Block_in, &
& NELE_IND = nbele+8, &
& NVAL_IND = 1, &
& NT_IND = k, &
& RVAL = airspro(idata2)%zt, &
& IOSTAT = error)
Call BURP_Set_Rval(Block_in, &
& NELE_IND = nbele+9, &
& NVAL_IND = 1, &
& NT_IND = k, &
& RVAL = airspro(idata2)%ztg, &
& IOSTAT=error)
Call BURP_Set_Rval(Block_in, &
& NELE_IND = nbele+10, &
& NVAL_IND = 1, &
& NT_IND = k, &
& RVAL = airspro(idata2)%zlqexp, &
& IOSTAT = error)
Call BURP_Set_Rval(Block_in, &
& NELE_IND = nbele+11, &
& NVAL_IND = 1, &
& NT_IND = k, &
& RVAL = airspro(idata2)%zps, &
& IOSTAT = error)
Call BURP_Set_Rval(Block_in, &
& NELE_IND = ind008012, &
& NVAL_IND = 1, &
& NT_IND = k, &
& RVAL = real(airspro(idata2)%sfctyp), &
& IOSTAT = error)
idata2 = idata2 + 1
else
do i = 1, 11
Call BURP_Set_Rval(Block_in, &
& NELE_IND = nbele+i, &
& NVAL_IND = 1, &
& NT_IND = k, &
& RVAL = val_option, &
& IOSTAT=error)
end do
Call BURP_Set_Rval(Block_in, &
& NELE_IND = ind008012, &
& NVAL_IND = 1, &
& NT_IND = k, &
& RVAL = val_option, &
& IOSTAT = error)
end if
end do
end if
! observation block (btyp = 0100 100011X XXXX)
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)
do k = 1, nte
if ( goodprof(k) == 1 ) then
do j = 1, nvale
if ( airspro(idata3)%emisfc(j) > 0. ) then
Call BURP_Set_Rval(Block_in, &
& NELE_IND = nbele+1, &
& NVAL_IND = j, &
& NT_IND = k, &
& RVAL = 100.*airspro(idata3)%emisfc(j), &
& IOSTAT = error)
else
Call BURP_Set_Rval(Block_in, &
& NELE_IND = nbele+1, &
& NVAL_IND = j, &
& NT_IND = k, &
& RVAL = val_option, &
& IOSTAT = error)
end if
end do
idata3 = idata3 + 1
else
do j = 1, nvale
Call BURP_Set_Rval(Block_in, &
& NELE_IND = nbele+1, &
& NVAL_IND = j, &
& NT_IND = k, &
& RVAL = val_option, &
& IOSTAT = error)
end do
end if
end do
end if
! flag block (btyp = 0111 100011X XXXX)
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)
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 BURP_Set_Rval(Block_in, &
& NELE_IND = nbele+1, &
& NVAL_IND = j, &
& NT_IND = k, &
& RVAL = val_option, &
& IOSTAT = error)
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,qflag)
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(nulout,*)
write(nulout,*) 'ERROR - descriptor block not seen ? Verify btyp'
end if
if ( flag_passage2 == 0 ) then
write(nulout,*)
write(nulout,*) 'ERROR - info block not seen ? Verify btyp'
end if
if ( flag_passage3 == 0 ) then
write(nulout,*)
write(nulout,*) 'ERROR - observation block not seen ? Verify btyp'
end if
if ( flag_passage4 == 0 ) then
write(nulout,*)
write(nulout,*) 'ERROR - flag block not seen ? Verify btyp'
end if
if ( flag_passage5 == 0 ) then
write(nulout,*)
write(nulout,*) '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)
Deallocate (AIRSPRO)
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
END SUBROUTINE AIRSABRP