!--------------------------------------- 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 --------------------------------------
#include "maincompileswitch.inc"
#include "compileswitches.inc"
module burp_read 2
use burp_module
use ObsSpaceData_mod
use MathPhysConstants_mod
use earthconstants_mod
implicit none
save
private
! public variables (parameters)
public :: PPMIS
! public procedures
public :: READBURP,UPDATE_BURP
! MODULE CONSTANTS ...
!
! These variables are set during object initialization (variational_init) and
! are not changed thereafter.
! bits to verify in Quality Control Flag:
REAL*4, PARAMETER :: PPMIS=-999.
INTEGER*4 :: NELEMS,NELEMS_SFC,BLISTELEMENTS(20),BLISTELEMENTS_SFC(20)
INTEGER*4 :: BN_ITEMS
CHARACTER *3 :: BITEMLIST(20)
CHARACTER *7 :: TYPE_RESUME
INTEGER*4 :: BNBITSOFF,BNBITSON,BBITOFF(15),BBITON(15)
LOGICAL :: ENFORCE_CLASSIC_SONDES
CONTAINS
SUBROUTINE UPDATE_BURP(obsdat,familytype,brp_file,FILENUMB) 1,47
!********************************************************************************
!
!**ID UPDATE_BURP -- UPDATE VARIABLES RELATIVE TO ASSIMILATION IN BURP FILES
!
! AUTHOR: P. KOCLAS (CMDA/SMC) Feb 2013
!
! REVISION:
! S. MACPHERSON (ARMA) Oct 2013
! -- add 'GP' family (ground-based GPS) as type "SFC"
! P. KOCLAS (CMDA/SMC)) Aug 2014
! -- Fix for the Burp 24 bit header markers of the UA4D
! P. KOCLAS (CMDA/SMC)) Oct 2014
! -- CHANGE ADDSIZE FOR SW ( GROUPED SATWINDS)
!
! OBJECT: UPDATE CMC BURP FILE
!
! 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:
! -OBSDAT : instance of obsspace_data module object
! -FAMILYTYPE: TYPE of family ('UA' ,'SF','AI,''SW','TO')...
! -BRP_FILE : FILENAME OF BURP FILE
!
!
!****************************************************************************
IMPLICIT NONE
INTEGER, PARAMETER :: NBLOC_LIST=6
CHARACTER(LEN=128) :: BRP_FILE
CHARACTER *2 :: FAMILYTYPE
INTEGER :: FILENUMB,LNMX
type (struct_obs), intent(inout) :: obsdat
TYPE(BURP_FILE) :: FILE_IN
TYPE(BURP_RPT) :: RPT_IN,CP_RPT
TYPE(BURP_BLOCK) :: BLOCK_IN,BLOCK_OMA,BLOCK_OMP,BLOCK_OER,BLOCK_FGE,BLOCK_FLG
TYPE(BURP_BLOCK) :: BLOCK_OMA_SFC,BLOCK_OMP_SFC,BLOCK_OER_SFC,BLOCK_FGE_SFC,BLOCK_FLG_SFC
TYPE(BURP_BLOCK) :: Block_FLG_CP,BLOCK_OBS_MUL_CP,BLOCK_MAR_MUL_CP,BLOCK_OBS_SFC_CP,BLOCK_MAR_SFC_CP
CHARACTER(LEN=5) :: FAMILYTYPE2
CHARACTER(LEN=9) :: OPT_MISSING
INTEGER :: BTYP,BFAM,BTYP10,BTYP10_uni,BTYP10FLG_uni,BTYP10obs_uni
INTEGER :: BTYP10DES,BTYP10INF,BTYP10OBS,BTYP10FLG
INTEGER :: NB_RPTS,REF_RPT,REF_BLK,COUNT
INTEGER, ALLOCATABLE :: ADDRESS(:)
REAL :: VCOORD
INTEGER :: NBELE,NVALE,NTE
INTEGER :: I,J,JJ,K,KK,KI,IL,Jo,ERROR,OBSN,KOBSN,ITEM,IER
INTEGER :: info_elepos,IND_ELE,IND_VCOORD,IND_VCOORD2,IND_QCFLAG
INTEGER :: IND_ELE_MAR,IND_ELEU,IND_ELEF,IND_ELE_stat
INTEGER :: IND_LAT,IND_LON,IND_TIME
INTEGER :: vcord_type,vcord_type2,FLAG,SUM
REAL :: RELEV,ELEVFACT
REAL :: XLAT,XLON,XTIME
INTEGER :: status ,idtyp,lati,long,dx,dy,elev, &
drnd,date_h,hhmm_h,oars,runn,YMD_DATE,HM
INTEGER :: IND055200,IND5002, IND6002,IND4208,IND4197
INTEGER :: iele,NELE,NELE_SFC,NVAL,NT,NELE_INFO,LN
INTEGER :: bit_alt,btyp_offset,btyp_offset_uni
INTEGER :: BKNAT,BKTYP,BKSTP
character(len = 5) :: BURP_TYP
CHARACTER(LEN=9) :: STNID,STN_RESUME,STID
LOGICAL :: HIRES
INTEGER :: NDATA,NDATA_SF
INTEGER :: IFLAG,BITSflagoff
INTEGER :: OBS_START,SAVE_OBS,OBS_HIRES,ASSIM
INTEGER :: IL_INDEX,IRLN,INLV,LK,VNM
REAL :: PPP,OBS,OMA,OMP,OER,FGE,OBSVA,CONVFACT
INTEGER :: FLG,TIME,ILEMU,ILEMV,ILEMD,VCOORD_POS
INTEGER :: BLOCK_LIST(NBLOC_LIST),bl
INTEGER :: new_bktyp,post_bit,STATUS_HIRES,BIT_STATUS,FILEN
LOGICAL :: REGRUP,WINDS,OMA_SFC_EXIST,OMA_ALT_EXIST
INTEGER :: LISTE_INFO(16),LISTE_ELE(15),LISTE_ELE_SFC(15),is_in_list
INTEGER :: ADDSIZE,SIZE_DATA_BK
DATA LISTE_INFO &
/1007,002019,007024,007025 ,005021, 005022, 008012, 013039,020010,2048,2022,33060,33062,33039,10035,10036/
FAMILYTYPE2= 'SCRAP'
vcord_type2=-1
NELE_INFO=1
NELE_SFC=0
NELE=0
ILEMU=11003
ILEMV=11004
ILEMD=11001
ELEVFACT=0.
BNBITSOFF=0
BNBITSON=0
ENFORCE_CLASSIC_SONDES=.false.
ADDSIZE=100000
LNMX=100000
SELECT CASE(trim(FAMILYTYPE))
CASE('UA')
BURP_TYP='multi'
vcord_type=7004
LISTE_ELE_SFC = (/12004,11011,11012,10051,10004,12203,-1,-1,-1,-1,-1,-1,-1,-1,-1/)
NELE_SFC=6
CALL BRPACMA_NML('namburp_sfc')
NELE_SFC=NELEMS_SFC
FAMILYTYPE2= 'UA'
LISTE_ELE = (/12001,11001,11002,12192,10194,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1/)
NELE=5
ENFORCE_CLASSIC_SONDES=.false.
CALL BRPACMA_NML('namburp_conv')
NELE=NELEMS
WINDS=.TRUE.
ADDSIZE=10000
CASE('AI')
BURP_TYP='uni'
vcord_type=7004
LISTE_ELE = (/12001,12192,11001,11002,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1/)
NELE=4
CALL BRPACMA_NML('namburp_conv')
NELE=NELEMS
WINDS=.TRUE.
ADDSIZE=5000
CASE('SW')
BURP_TYP='uni'
vcord_type=7004
LISTE_ELE = (/11001,11002,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1/)
NELE=2
CALL BRPACMA_NML('namburp_conv')
NELE=NELEMS
WINDS=.TRUE.
vcord_type2=-1
! ADDSIZE=5000
! ' AMVS-> ADDSIZE 600000 oct 2014 pik'
ADDSIZE=600000
CASE('SF','GP')
BURP_TYP='uni'
vcord_type=0
NELE_SFC=7
LISTE_ELE_SFC = (/12004,11011,11012,10051,10004,12203,15031,-1,-1,-1,-1,-1,-1,-1,-1/)
CALL BRPACMA_NML('namburp_sfc')
NELE_SFC=NELEMS_SFC
FAMILYTYPE2= 'SFC'
WINDS=.TRUE.
IF (trim(FAMILYTYPE) == 'GP') WINDS=.FALSE.
ILEMU=11215
ILEMV=11216
ILEMD=11011
ADDSIZE=5000
CASE('SC')
BURP_TYP='uni'
LISTE_ELE_SFC = (/11012,11011,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1/)
NELE=2
CALL BRPACMA_NML('namburp_conv')
NELE=NELEMS
FAMILYTYPE2='SCAT'
WINDS=.TRUE.
ILEMU=11215
ILEMV=11216
ILEMD=11011
ADDSIZE=5000
CASE('PR')
BURP_TYP='multi'
vcord_type=7006
ELEVFACT=1.
LISTE_ELE = (/11001,11002,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1/)
NELE=2
CALL BRPACMA_NML('namburp_conv')
NELE=NELEMS
WINDS=.TRUE.
ADDSIZE=10000
CASE('RO')
BURP_TYP='multi'
vcord_type=7007
vcord_type2=7040
LISTE_ELE = (/15036,15037,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1/)
NELE=2
CALL BRPACMA_NML('namburp_conv')
NELE=NELEMS
WINDS=.FALSE.
!================GPS-RO CANNOT BE FILTERED=======
BNBITSOFF=0
BNBITSON=0
!================GPS-RO CANNOT BE FILTERED=======
NELE_INFO=16
CASE('GO','MI','TO')
BURP_TYP='multi'
vcord_type=5042
vcord_type2=2150
LISTE_ELE = (/12163,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1/)
NELE=1
CALL BRPACMA_NML('namburp_tovs')
NELE=NELEMS
NELE_INFO=16
WINDS=.FALSE.
ADDSIZE=600000
END SELECT
LISTE_ELE (1:NELE )=BLISTELEMENTS(1:NELE)
LISTE_ELE_SFC(1:NELE_SFC)=BLISTELEMENTS_SFC(1:NELE_SFC)
if(NELE .gt. 0)write(*,*) ' LISTE_ELE =',LISTE_ELE
if(NELE_SFC .gt. 0)write(*,*) ' LISTE_ELE_SFC =',LISTE_ELE_SFC
if(BNBITSOFF .gt. 0 .or. BNBITSON .gt.0)write(*,*) ' BNBITSON BNBITSOFF SIZE OF CP_RPT =',BNBITSON,BNBITSOFF,LNMX*8
TYPE_RESUME='POSTALT'
BN_ITEMS=1
BITEMLIST(1)='OMA'
CALL BRPACMA_NML('namburp_update')
WRITE(*,*) ' BN_ITEMS =',BN_ITEMS
WRITE(*,'(a12,x)') ' ITEMS TO ADD IN BURP FILE REPORTS =', BITEMLIST(1:BN_ITEMS)
WRITE(*,'(x,a9)' ) ' BTYP OF UPDATED BURP FILE=', TYPE_RESUME
SELECT CASE( trim(TYPE_RESUME))
CASE("BGCKALT", "POSTALT")
BIT_STATUS = 12
CASE("DERIALT")
BIT_STATUS = 11
END SELECT
if (trim(BURP_TYP) .eq. 'uni') then
btyp_offset=256
else
btyp_offset=0
endif
if ( TRIM(FAMILYTYPE2) .eq. 'SCAT') then
btyp_offset= 0
btyp_offset_uni= 256 +0
elseif ( TRIM(FAMILYTYPE2) .eq. 'SFC') then
btyp_offset= 0
btyp_offset_uni= 256 +32
elseif ( TRIM(FAMILYTYPE2) .eq. 'UA') then
btyp_offset_uni= 256 +32
else
btyp_offset_uni= -999 !set to -999 when not used
endif
WRITE(*,*) '----------------------------------------------------'
WRITE(*,*) '----------- BEGIN UPDATE_BURP ------------'
WRITE(*,*) 'FAMILYTYPE =',FAMILYTYPE
WRITE(*,*) 'BURP_TYP btyp_offset =',BURP_TYP, btyp_offset
WRITE(*,*) 'BURP_TYP btyp_offset_uni=',BURP_TYP, btyp_offset_uni
WRITE(*,*) '----------------------------------------------------'
! initialisation
SUM=0
opt_missing = 'MISSING'
Call BURP_Set_Options( &
& REAL_OPTNAME = opt_missing, &
& REAL_OPTNAME_VALUE = PPMIS, &
& CHAR_OPTNAME = 'MSGLVL', &
& CHAR_OPTNAME_VALUE = 'FATAL', &
& IOSTAT = error )
Call BURP_Init(File_in ,IOSTAT=error)
!Call BURP_Init(Rpt_in,IOSTAT=error)
Call BURP_Init(Rpt_in,CP_RPT,IOSTAT=error)
Call BURP_Init(Block_in ,IOSTAT=error)
Call BURP_Init(BLOCK_OMA ,IOSTAT=error)
Call BURP_Init(BLOCK_OMP ,IOSTAT=error)
Call BURP_Init(BLOCK_OER ,IOSTAT=error)
Call BURP_Init(BLOCK_FGE ,IOSTAT=error)
Call BURP_Init(BLOCK_OMA_SFC,IOSTAT=error)
Call BURP_Init(BLOCK_OMP_SFC,IOSTAT=error)
Call BURP_Init(BLOCK_OER_SFC,IOSTAT=error)
Call BURP_Init(BLOCK_FGE_SFC,IOSTAT=error)
Call BURP_Init(BLOCK_FLG_SFC,IOSTAT=error)
Call BURP_Init(BLOCK_FLG ,IOSTAT=error)
Call BURP_Init(Block_FLG_CP ,IOSTAT=error)
Call BURP_Init(BLOCK_OBS_MUL_CP ,IOSTAT=error)
Call BURP_Init(BLOCK_MAR_MUL_CP ,IOSTAT=error)
Call BURP_Init(BLOCK_OBS_SFC_CP ,IOSTAT=error)
Call BURP_Init(BLOCK_MAR_SFC_CP ,IOSTAT=error)
! opening file
! ------------
write(*,*) 'OPENING BURP FILE FOR UPDATE = ', trim(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)
Call BURP_Init(Rpt_in,IOSTAT=error)
WRITE(*,*) '-----------------------------------------'
WRITE(*,*) 'IOSTAT =',error
WRITE(*,*) 'NUMBER OF REPORTS IN FILE = ',nb_rpts
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)
Call burp_get_property(Rpt_in, STNID = stnid )
IF ( stnid(1:2) == ">>" ) then
STN_RESUME=stnid
SELECT CASE(stnid)
CASE(">>BGCKALT", ">>POSTALT")
bit_alt=1
CASE(">>DERIALT")
bit_alt=2
END SELECT
ENDIF
if (ref_rpt < 0) Exit
if (count .eq. nb_rpts) then
write(*,*) 'UPDATE_BURP: ERROR: count = nb_rpts:',count,nb_rpts
exit
endif
count = count + 1
address(count) = ref_rpt
end do
write(*,'(a9,1x,a16,1x,i2)' )STN_RESUME,' bit_alt==== > ',bit_alt
BTYP10obs = 291 -btyp_offset
BTYP10obs_uni = 291 -btyp_offset_uni
if (bit_alt .eq. 2) btyp10obs = BTYP10obs - 2
if (bit_alt .eq. 2) btyp10obs_uni = BTYP10obs_uni - 2
BTYP10flg = 483 -btyp_offset
BTYP10flg_uni = 483 -btyp_offset_uni
if (bit_alt .eq. 2) BTYP10flg = BTYP10flg - 2
if (bit_alt .eq. 2) BTYP10flg_uni = BTYP10flg_uni - 2
BTYP10des = 160
BTYP10inf = 96
write(*, *) ' NUMBER OF VALID REPORTS IN FILE = ',count
write(*, *) ' BTYP10obs BTYP10obs_uni = ',BTYP10obs,BTYP10obs_uni
BITSflagoff=0
DO J = 1, Bnbitsoff
BITSflagoff = IBSET ( BITSflagoff, 13-BBITOFF(J) )
END DO
if ( count > 0 ) then
OBS_START=1
SAVE_OBS=1
DO Jo=1,obs_numHeader(obsdat)
filen= obs_headElem_i(obsdat,OBS_OTP,Jo)
if ( filen .eq. filenumb) then
OBS_START=Jo
SAVE_OBS=Jo
exit
endif
END DO
write(*, *) ' FILE = ',trim(brp_file),' OBS_START= ',OBS_START
! create a new report
Call BURP_New(Cp_rpt, ALLOC_SPACE=10*LNMX, IOSTAT=error)
! LOOP ON REPORTS
REPORTS: do kk = 1, count
Call BURP_Get_Report(File_in, &
& REPORT = Rpt_in, &
& REF = address(kk), &
& IOSTAT = error)
Call burp_get_property(Rpt_in, &
STNID = stnid ,TEMPS =hhmm_h,FLGS = status ,IDTYP =idtyp,LATI = lati &
,LONG = long ,DX = dx ,DY = dy,ELEV=elev,DRND =drnd,DATE =date_h &
,OARS =oars,RUNN=runn ,IOSTAT=error)
IF ( stnid(1:2) == ">>" ) THEN
Call BURP_Set_Property(Rpt_in ,STNID =">>"//TYPE_RESUME)
Call BURP_Write_Report(File_in,Rpt_in,UPDATE =.TRUE.,IOSTAT= error)
write(*,*) ' RESUME RECORD POSITION IN BURP FILE =',stnid,kk
Call BURP_Copy_Header(TO=Cp_rpt,FROM=Rpt_in)
Call BURP_Init_Report_Write(File_in,Cp_Rpt, IOSTAT=error)
Call BURP_Delete_Report(File_in,Rpt_in, IOSTAT=error)
Call BURP_Write_Report(File_in,Cp_rpt, IOSTAT=error)
cycle REPORTS
ELSE
!write(*,*) ' UPDATING STN IN BURP FILE =', TRIM(FAMILYTYPE),KK,stnid,lati,LONG,dx,DY,elev,idtyp
ENDIF
Call BURP_Copy_Header(TO=Cp_rpt,FROM=Rpt_in)
Call BURP_Init_Report_Write(File_in,Cp_Rpt, IOSTAT=error)
! FIRST LOOP ON BLOCKS
ref_blk = 0
HIRES=.FALSE.
REGRUP=.false.
NDATA_SF=-1
!WRITE(*,*)' record number =',kk,' obs_start =',obs_start
BLOCK_LIST(1:6)=-1
BLOCKS0: do
ref_blk = BURP_Find_Block(Rpt_in, &
& BLOCK = Block_in, &
& SEARCH_FROM = ref_blk, &
& IOSTAT = error)
if (ref_blk < 0) EXIT BLOCKS0
Call BURP_Get_Property(Block_in, &
& NELE = nbele, &
& NVAL = nvale, &
& NT = nte, &
& BFAM = bfam, &
& BTYP = btyp, &
& BKTYP = bktyp, &
& BKNAT = BKNAT, &
& BKSTP = BKSTP, &
& IOSTAT = error)
btyp10 = ishft(btyp,-5)
if ( btyp10 - BTYP10des == 0 ) then
Block_FLG_CP=BLOCK_IN
BLOCK_LIST(1)=BTYP
REGRUP=.TRUE.
elseif ( btyp10 - btyp10obs_uni == 0 .and. bkstp <= 4 ) then
BLOCK_OBS_SFC_CP=BLOCK_IN
BLOCK_LIST(2)=BTYP
NDATA_SF=0
elseif ( btyp10 - btyp10flg_uni == 0 .and. bkstp <= 4) then
BLOCK_MAR_SFC_CP=BLOCK_IN
BLOCK_LIST(3)=BTYP
elseif ( btyp10 - btyp10obs == 0 .and. bfam == 0 ) then
BLOCK_LIST(4)=BTYP
BLOCK_OBS_MUL_CP=BLOCK_IN
elseif ( btyp10 - btyp10flg == 0 ) then
BLOCK_LIST(5)=BTYP
BLOCK_MAR_MUL_CP=BLOCK_IN
elseif ( (btyp10 - btyp10inf == 0) .or. (btyp10 - btyp10inf == 1) ) then
BLOCK_LIST(6)=BTYP
else
!WRITE(*, *)' POUR STATION bloc NON CONNU: ',STNID,ref_blk,bfam,familytype
endif
end do BLOCKS0
if ( TYPE_RESUME == 'POSTALT' .or. TYPE_RESUME == 'BGCKALT') THEN
post_bit=2
else
post_bit=0
endif
BLOCKS1: do bl=1,NBLOC_LIST
if( BLOCK_LIST(bl) .lt. 0 )cycle
ref_blk = BURP_Find_Block(Rpt_in, &
& BLOCK = Block_in, &
& BTYP = BLOCK_LIST(bl), &
& IOSTAT = error)
if (ref_blk < 0) cycle BLOCKS1
Call BURP_Get_Property(Block_in, &
& NELE = nbele, &
& NVAL = nvale, &
& NT = nte, &
& BFAM = bfam, &
& BTYP = btyp, &
& BKTYP = bktyp, &
& BKNAT = BKNAT, &
& IOSTAT = error)
! observation block (btyp = 0100 100011X XXXX)
!======================================================
btyp10 = ishft(btyp,-5)
!======================================================
OBS_START=SAVE_OBS
!if ( btyp10 - btyp10obs_uni == 0 .and. bfam == 0 ) then
if ( bl .eq. 2 ) then
NDATA_SF=0
new_bktyp=bktyp
if ( post_bit .gt. 0 ) then
new_bktyp=IBSET(bktyp,post_bit)
Call BURP_Set_Property(BLOCK_OBS_SFC_CP ,BKTYP =new_bktyp)
Call BURP_Set_Property(BLOCK_MAR_SFC_CP ,BKTYP =new_bktyp)
endif
il_index=1
KOBSN=0
IND_eleu = BURP_Find_Element(Block_in, ELEMENT=11215, IOSTAT=error)
IND_elef = BURP_Find_Element(Block_in, ELEMENT=11011, IOSTAT=error)
!Call BURP_Delete_BLOCK(Rpt_in,BLOCK=Block_in)
Call BURP_New(BLOCK_OMA_SFC,NELE =NBELE+2,NVAL=nvale,NT=NTE,bfam=12,BKNAT=BKNAT,BKTYP=new_bktyp,BKSTP=10 &
,IOSTAT = error)
Call BURP_New(BLOCK_OMP_SFC,NELE =NBELE+2,NVAL =nvale,NT=NTE,bfam=14,BKNAT=BKNAT,BKTYP=new_bktyp,BKSTP=10 &
,IOSTAT = error)
Call BURP_New(BLOCK_OER_SFC, NELE =NBELE+2, NVAL =nvale,NT=NTE,bfam=10,BKNAT=BKNAT,BKTYP=new_bktyp,BKSTP=14 &
,IOSTAT = error)
Call BURP_New(BLOCK_FGE_SFC, NELE =NBELE+2, NVAL =nvale,NT=NTE,bfam=10,BKNAT=BKNAT,BKTYP=new_bktyp,BKSTP=15 &
,IOSTAT = error)
OMA_SFC_EXIST=.true.
ILEMU=11215
ILEMV=11216
call BURP_Set_Element( BLOCK_OMA_SFC,NELE_IND = 1,ElEMENT=ILEMU,IOSTAT=error)
call BURP_Set_Element( BLOCK_OMA_SFC,NELE_IND = 2,ElEMENT=ILEMV,IOSTAT=error)
call BURP_Set_Element( BLOCK_OMP_SFC,NELE_IND = 1,ElEMENT=ILEMU,IOSTAT=error)
call BURP_Set_Element( BLOCK_OMP_SFC,NELE_IND = 2,ElEMENT=ILEMV,IOSTAT=error)
call BURP_Set_Element( BLOCK_OER_SFC,NELE_IND = 1,ElEMENT=ILEMU,IOSTAT=error)
call BURP_Set_Element( BLOCK_OER_SFC,NELE_IND = 2,ElEMENT=ILEMV,IOSTAT=error)
call BURP_Set_Element( BLOCK_FGE_SFC,NELE_IND = 1,ElEMENT=ILEMU,IOSTAT=error)
call BURP_Set_Element( BLOCK_FGE_SFC,NELE_IND = 2,ElEMENT=ILEMV,IOSTAT=error)
do k =1,nte
Call BURP_Set_Rval(Block_OMA_SFC,NELE_IND =1,NVAL_IND =1,NT_IND = k,RVAL = PPMIS )
Call BURP_Set_Rval(Block_OMA_SFC,NELE_IND =2,NVAL_IND =1,NT_IND = k,RVAL = PPMIS )
Call BURP_Set_Rval(Block_OMP_SFC,NELE_IND =1,NVAL_IND =1,NT_IND = k,RVAL = PPMIS )
Call BURP_Set_Rval(Block_OMP_SFC,NELE_IND =2,NVAL_IND =1,NT_IND = k,RVAL = PPMIS )
Call BURP_Set_Rval(Block_OER_SFC,NELE_IND =1,NVAL_IND =1,NT_IND = k,RVAL = PPMIS )
Call BURP_Set_Rval(Block_OER_SFC,NELE_IND =2,NVAL_IND =1,NT_IND = k,RVAL = PPMIS )
Call BURP_Set_Rval(Block_FGE_SFC,NELE_IND =1,NVAL_IND =1,NT_IND = k,RVAL = PPMIS )
Call BURP_Set_Rval(Block_FGE_SFC,NELE_IND =2,NVAL_IND =1,NT_IND = k,RVAL = PPMIS )
end do
il_index=2
IF (WINDS .and. IND_eleu .lt. 0 .and. IND_elef .gt. 0) THEN
Call BURP_RESIZE_BLOCK(BLOCK_OBS_SFC_CP,ADD_NELE = 2 ,IOSTAT=error)
call BURP_Set_Element( BLOCK_OBS_SFC_CP,NELE_IND = nbele+1,ElEMENT=ILEMU,IOSTAT=error)
call BURP_Set_Element( BLOCK_OBS_SFC_CP,NELE_IND = nbele+2,ElEMENT=ILEMV,IOSTAT=error)
do k =1,nte
Call BURP_Set_Rval(Block_OBS_SFC_CP,NELE_IND =nbele+1,NVAL_IND =1,NT_IND = k,RVAL = PPMIS )
Call BURP_Set_Rval(Block_OBS_SFC_CP,NELE_IND =nbele+2,NVAL_IND =1,NT_IND = k,RVAL = PPMIS )
end do
Call BURP_RESIZE_BLOCK(BLOCK_MAR_SFC_CP,ADD_NELE = 2 ,IOSTAT=error)
call BURP_Set_Element( BLOCK_MAR_SFC_CP,NELE_IND = nbele+1,ElEMENT=ILEMU+200000,IOSTAT=error)
call BURP_Set_Element( BLOCK_MAR_SFC_CP,NELE_IND = nbele+2,ElEMENT=ILEMV+200000,IOSTAT=error)
do k =1,nte
Call BURP_Set_tblval(Block_MAR_SFC_CP,NELE_IND =nbele+1,NVAL_IND =1,NT_IND = k,tblval = 0 )
Call BURP_Set_tblval(Block_MAR_SFC_CP,NELE_IND =nbele+2,NVAL_IND =1,NT_IND = k,tblval = 0 )
end do
il_index=2
nbele=nbele +2
endif
elems_sfc: do IL = 1, NBELE
iele=-1
iele=BURP_Get_Element(BLOCK_OBS_SFC_CP,INDEX =il,IOSTAT= error)
IND_ELE_MAR= BURP_Find_Element(Block_MAR_SFC_CP, ELEMENT=iele+200000, IOSTAT=error)
if (IND_ele_mar .le. 0 ) cycle
IND_ele = BURP_Find_Element(BLOCK_OBS_SFC_CP, ELEMENT=iele, IOSTAT=error)
if( OMA_SFC_EXIST .eqv. .true. ) then
if (iele .ne. ILEMU .and. iele .ne. ILEMV) then
il_index=il_index +1
call BURP_Set_Element (BLOCK_OMA_SFC,NELE_IND= il_index,ElEMENT=iele,IOSTAT=error)
Call BURP_Set_Element (BLOCK_OMP_SFC,NELE_IND= il_index,ElEMENT=iele,IOSTAT=error)
Call BURP_Set_Element (BLOCK_OER_SFC,NELE_IND= il_index,ElEMENT=iele,IOSTAT=error)
Call BURP_Set_Element (BLOCK_FGE_SFC,NELE_IND= il_index,ElEMENT=iele,IOSTAT=error)
endif
endif
k=1
is_in_list=-1
is_in_list=FIND_INDEX(LISTE_ELE_SFC,iele)
if (is_in_list .lt. 0 .and. iele .ne. ILEMU .and. iele .ne. ILEMV) cycle ELEMS_SFC
!pikk do k=1,nte
IND_ele_stat = BURP_Find_Element(BLOCK_OMA_SFC, ELEMENT=iele, IOSTAT=error)
Call BURP_Set_Rval(Block_OMA_SFC, NELE_IND =IND_ELE_stat ,NVAL_IND =1 , NT_IND = k , RVAL = PPMIS)
Call BURP_Set_Rval(Block_OMP_SFC, NELE_IND =IND_ELE_stat ,NVAL_IND =1 , NT_IND = k , RVAL = PPMIS)
Call BURP_Set_Rval(Block_OER_SFC, NELE_IND =IND_ELE_stat ,NVAL_IND =1 , NT_IND = k , RVAL = PPMIS)
Call BURP_Set_Rval(Block_FGE_SFC, NELE_IND =IND_ELE_stat ,NVAL_IND =1 , NT_IND = k , RVAL = PPMIS)
IFLAG = BURP_Get_Tblval(Block_MAR_SFC_CP,NELE_IND = IND_ele_mar,NVAL_IND = 1, NT_IND = k)
OBSVA = BURP_Get_Rval (Block_OBS_SFC_CP,NELE_IND = IND_ele ,NVAL_IND = 1, NT_IND = k)
if (OBSVA .eq. PPMIS .and. iele .ne. ILEMU .and. iele .ne. ILEMV ) cycle
if(iand(iflag,BITSflagoff) .ne.0) cycle
if (OBS_START .gt. obs_numHeader(obsdat) ) write(*,*) ' debordement surface OBS_START=',OBS_START
if (OBS_START .gt. obs_numHeader(obsdat)) cycle
IRLN=obs_headElem_i(obsdat,OBS_RLN,OBS_START )
INLV=obs_headElem_i(obsdat,OBS_NLV,OBS_START )
IND_ELE_stat = BURP_Find_Element(BLOCK_OMA_SFC, ELEMENT=iele, IOSTAT=error)
STID=obs_elem_c(obsdat,'STID',obs_start)
if ( STID .ne. stnid ) cycle
OBSDATA: do LK=IRLN,IRLN+INLV-1
VNM=obs_bodyElem_i(obsdat,OBS_VNM ,LK)
ASSIM=obs_bodyElem_i(obsdat,OBS_ASS,LK)
if( VNM .eq. iele ) then
OBS=obs_bodyElem_r(obsdat,OBS_VAR,LK)
OMA=obs_bodyElem_r(obsdat,OBS_OMA ,LK)
OMP=obs_bodyElem_r(obsdat,OBS_OMP ,LK)
OER=obs_bodyElem_r(obsdat,OBS_OER ,LK)
FGE=obs_bodyElem_r(obsdat,OBS_HPHT,LK)
FLG=obs_bodyElem_i(obsdat,OBS_FLG ,LK)
KOBSN= KOBSN + 1
SUM=SUM +1
Call BURP_Set_Rval( Block_OER_SFC, NELE_IND =IND_ele_stat ,NVAL_IND =1,NT_IND = k , RVAL = OER )
Call BURP_Set_Rval( Block_FGE_SFC, NELE_IND =IND_ele_stat ,NVAL_IND =1,NT_IND = k , RVAL = FGE )
IND_ELE_stat = BURP_Find_Element(BLOCK_OMA_SFC, ELEMENT=iele, IOSTAT=error)
Call BURP_Set_Rval( Block_OMA_SFC, NELE_IND =IND_ele_stat ,NVAL_IND =1,NT_IND = k , RVAL = OMA)
IND_ELE_stat = BURP_Find_Element(BLOCK_OMP_SFC, ELEMENT=iele, IOSTAT=error)
Call BURP_Set_Rval( Block_OMP_SFC, NELE_IND =IND_ele_stat ,NVAL_IND =1,NT_IND = k , RVAL = OMP)
Call BURP_Set_tblval(Block_MAR_SFC_CP,NELE_IND =IND_ele_mar,NVAL_IND =1,NT_IND = k ,TBLVAL= FLG)
OBS=obs_bodyElem_r(obsdat,OBS_VAR,LK)
IND_ele = BURP_Find_Element(BLOCK_OBS_SFC_CP, ELEMENT=iele, IOSTAT=error)
Call BURP_Set_Rval(Block_OBS_SFC_CP,NELE_IND =IND_ele,NVAL_IND =1,NT_IND = k,RVAL = OBS )
exit
endif
end do OBSDATA
!pikk end do
end do elems_sfc
do item=1,BN_ITEMS
if ( BITEMLIST(item) .eq. 'OMA') then
Call BURP_Reduce_Block(BLOCK_OMA_SFC, NEW_NELE =il_index )
Call BURP_Write_Block( CP_RPT, BLOCK_OMA_SFC,&
ENCODE_BLOCK = .TRUE., CONVERT_BLOCK = .TRUE., IOSTAT= error)
cycle
endif
if ( BITEMLIST(item) .eq. 'OMP') then
Call BURP_Reduce_Block(BLOCK_OMP_SFC, NEW_NELE =il_index )
Call BURP_Write_Block( CP_RPT, BLOCK_OMP_SFC,&
ENCODE_BLOCK = .TRUE., CONVERT_BLOCK = .TRUE., IOSTAT= error)
cycle
endif
if ( BITEMLIST(item) .eq. 'OER') then
Call BURP_Reduce_Block(BLOCK_OER_SFC, NEW_NELE =il_index )
Call BURP_Write_Block( CP_RPT, BLOCK_OER_SFC,&
ENCODE_BLOCK = .TRUE., CONVERT_BLOCK = .TRUE., IOSTAT= error)
cycle
endif
if ( BITEMLIST(item) .eq. 'FGE') then
Call BURP_Reduce_Block(BLOCK_FGE_SFC, NEW_NELE =il_index )
Call BURP_Write_Block( CP_RPT, BLOCK_FGE_SFC,&
ENCODE_BLOCK = .TRUE., CONVERT_BLOCK = .TRUE., IOSTAT= error)
cycle
endif
end do
Call BURP_Set_Property(BLOCK_OBS_SFC_CP ,BFAM =0)
Call BURP_Set_Property(BLOCK_MAR_SFC_CP ,BFAM =0)
Call BURP_Write_Block( CP_RPT, BLOCK_OBS_SFC_CP,&
ENCODE_BLOCK = .TRUE., CONVERT_BLOCK = .TRUE., IOSTAT= error)
Call BURP_Write_Block( CP_RPT, BLOCK_MAR_SFC_CP,&
ENCODE_BLOCK = .TRUE., CONVERT_BLOCK = .FALSE., IOSTAT= error)
IF ( KOBSN .gt. 0 ) THEN
STATUS=obs_headElem_i(obsdat,OBS_ST1,OBS_START)
STATUS=IBSET(STATUS,BIT_STATUS)
Call BURP_Set_Property(CP_RPT ,FLGS =STATUS)
ENDIF
SAVE_OBS=OBS_START
NDATA_SF=KOBSN
if (BLOCK_LIST(4) .eq. -1 .and. KOBSN .gt. 0 ) THEN
SAVE_OBS=SAVE_OBS+1
OBS_START=OBS_START+1
endif
endif ! bl.eq.2
!if ( btyp10 - btyp10obs == 0 .and. bfam == 0 ) then
if ( bl .eq. 4 ) then
ILEMU=11003
ILEMV=11004
new_bktyp=bktyp
if ( post_bit .gt.0 ) then
new_bktyp=IBSET(bktyp,post_bit)
Call BURP_Set_Property(BLOCK_OBS_MUL_CP ,BKTYP =new_bktyp)
Call BURP_Set_Property(BLOCK_MAR_MUL_CP ,BKTYP =new_bktyp)
endif
OBSN=OBS_START
!if( idtyp .eq. 168) print *, ' bobossmi donnees OBS_START save obs=',OBS_START,SAVE_OBS
NVAL=NVALE ; NT=NTE
il_index=1
Call BURP_New(BLOCK_OMA, NELE =1, NVAL =nvale,NT=NTE,bfam=12,BKNAT=BKNAT,BKTYP=new_bktyp,BKSTP=10 &
,IOSTAT = error)
Call BURP_New(BLOCK_OMP, NELE =1, NVAL =nvale,NT=NTE,bfam=14,BKNAT=BKNAT,BKTYP=new_bktyp,BKSTP=10 &
,IOSTAT = error)
Call BURP_New(BLOCK_OER, NELE =1, NVAL =nvale,NT=NTE,bfam=10,BKNAT=BKNAT,BKTYP=new_bktyp,BKSTP=14 &
,IOSTAT = error)
Call BURP_New(BLOCK_FGE, NELE =1, NVAL =nvale,NT=NTE,bfam=10,BKNAT=BKNAT,BKTYP=new_bktyp,BKSTP=15 &
,IOSTAT = error)
VCOORD_POS=0
IND_VCOORD = BURP_Find_Element(BLOCK_OBS_MUL_CP, ELEMENT=vcord_type, IOSTAT=error)
IF ( IND_VCOORD .gt. 0 ) then
call BURP_Set_Element(BLOCK_OMA,NELE_IND= 1,ElEMENT=vcord_type,IOSTAT=error)
call BURP_Set_Element(BLOCK_OMP,NELE_IND= 1,ElEMENT=vcord_type,IOSTAT=error)
call BURP_Set_Element(BLOCK_OER,NELE_IND= 1,ElEMENT=vcord_type,IOSTAT=error)
call BURP_Set_Element(BLOCK_FGE,NELE_IND= 1,ElEMENT=vcord_type,IOSTAT=error)
VCOORD_POS=1
ENDIF
IND_VCOORD2 = BURP_Find_Element(BLOCK_OBS_MUL_CP, ELEMENT=vcord_type2, IOSTAT=error)
IF ( IND_VCOORD2 .gt. 0 ) then
call BURP_Set_Element(BLOCK_OMA,NELE_IND= 1,ElEMENT=vcord_type2,IOSTAT=error)
call BURP_Set_Element(BLOCK_OMP,NELE_IND= 1,ElEMENT=vcord_type2,IOSTAT=error)
call BURP_Set_Element(BLOCK_OER,NELE_IND= 1,ElEMENT=vcord_type2,IOSTAT=error)
call BURP_Set_Element(BLOCK_FGE,NELE_IND= 1,ElEMENT=vcord_type2,IOSTAT=error)
VCOORD_POS=1
IND_VCOORD=IND_VCOORD2
ENDIF
if (IND_VCOORD == -1 .and. IND_VCOORD2 == -1) then
!WRITE(*,*) ' PAS DE COORDONNEE VERTICALE famille ',trim(FAMILYTYPE)
il_index=0
endif
VCOORD = -999.
IND_eleu = BURP_Find_Element(BLOCK_OBS_MUL_CP, ELEMENT=ILEMU, IOSTAT=error)
IND_elef = BURP_Find_Element(BLOCK_OBS_MUL_CP, ELEMENT=ILEMD, IOSTAT=error)
OMA_ALT_EXIST=.false.
if(WINDS .and. IND_eleu .lt. 0 .and. IND_elef .gt. 0) then
Call BURP_RESIZE_BLOCK(BLOCK_OMA,ADD_NELE = 2 ,IOSTAT=error)
call BURP_Set_Element( BLOCK_OMA,NELE_IND = VCOORD_POS+1,ElEMENT=ILEMU,IOSTAT=error)
call BURP_Set_Element( BLOCK_OMA,NELE_IND = VCOORD_POS+2,ElEMENT=ILEMV,IOSTAT=error)
OMA_ALT_EXIST=.true.
Call BURP_RESIZE_BLOCK(BLOCK_OMP,ADD_NELE = 2 ,IOSTAT=error)
call BURP_Set_Element( BLOCK_OMP,NELE_IND = VCOORD_POS+1,ElEMENT=ILEMU,IOSTAT=error)
call BURP_Set_Element( BLOCK_OMP,NELE_IND = VCOORD_POS+2,ElEMENT=ILEMV,IOSTAT=error)
Call BURP_RESIZE_BLOCK(BLOCK_OER,ADD_NELE = 2 ,IOSTAT=error)
call BURP_Set_Element( BLOCK_OER,NELE_IND = VCOORD_POS+1,ElEMENT=ILEMU,IOSTAT=error)
call BURP_Set_Element( BLOCK_OER,NELE_IND = VCOORD_POS+2,ElEMENT=ILEMV,IOSTAT=error)
Call BURP_RESIZE_BLOCK(BLOCK_FGE,ADD_NELE = 2 ,IOSTAT=error)
call BURP_Set_Element( BLOCK_FGE,NELE_IND = VCOORD_POS+1,ElEMENT=ILEMU,IOSTAT=error)
call BURP_Set_Element( BLOCK_FGE,NELE_IND = VCOORD_POS+2,ElEMENT=ILEMV,IOSTAT=error)
Call BURP_RESIZE_BLOCK(BLOCK_OBS_MUL_CP,ADD_NELE = 2 ,IOSTAT=error)
call BURP_Set_Element( BLOCK_OBS_MUL_CP,NELE_IND = nbele+1,ElEMENT=ILEMU,IOSTAT=error)
call BURP_Set_Element( BLOCK_OBS_MUL_CP,NELE_IND = nbele+2,ElEMENT=ILEMV,IOSTAT=error)
Call BURP_RESIZE_BLOCK(BLOCK_MAR_MUL_CP,ADD_NELE = 2 ,IOSTAT=error)
call BURP_Set_Element( BLOCK_MAR_MUL_CP,NELE_IND = nbele+1,ElEMENT=ILEMU+200000,IOSTAT=error)
call BURP_Set_Element( BLOCK_MAR_MUL_CP,NELE_IND = nbele+2,ElEMENT=ILEMV+200000,IOSTAT=error)
do k=1,nte
do jj=1,nvale
Call BURP_Set_Rval( Block_OMA, NELE_IND =VCOORD_POS+1 ,NVAL_IND =jj , NT_IND = k , RVAL = PPMIS )
Call BURP_Set_Rval( Block_OMA, NELE_IND =VCOORD_POS+2 ,NVAL_IND =jj , NT_IND = k , RVAL = PPMIS )
Call BURP_Set_Rval( Block_OMP, NELE_IND =VCOORD_POS+1 ,NVAL_IND =jj , NT_IND = k , RVAL = PPMIS )
Call BURP_Set_Rval( Block_OMP, NELE_IND =VCOORD_POS+2 ,NVAL_IND =jj , NT_IND = k , RVAL = PPMIS )
Call BURP_Set_Rval( Block_OER, NELE_IND =VCOORD_POS+1 ,NVAL_IND =jj , NT_IND = k , RVAL = PPMIS )
Call BURP_Set_Rval( Block_OER, NELE_IND =VCOORD_POS+2 ,NVAL_IND =jj , NT_IND = k , RVAL = PPMIS )
Call BURP_Set_Rval( Block_FGE, NELE_IND =VCOORD_POS+1 ,NVAL_IND =jj , NT_IND = k , RVAL = PPMIS )
Call BURP_Set_Rval( Block_FGE, NELE_IND =VCOORD_POS+2 ,NVAL_IND =jj , NT_IND = k , RVAL = PPMIS )
Call BURP_Set_Rval( BLOCK_OBS_MUL_CP, NELE_IND =nbele+1 ,NVAL_IND =jj , NT_IND = k , RVAL = PPMIS)
Call BURP_Set_Rval( BLOCK_OBS_MUL_CP, NELE_IND =nbele+2 ,NVAL_IND =jj , NT_IND = k , RVAL = PPMIS)
Call BURP_Set_tblval(BLOCK_MAR_MUL_CP, NELE_IND =nbele+1 ,NVAL_IND =jj , NT_IND = k , TBLVAL = 0 )
Call BURP_Set_tblval(BLOCK_MAR_MUL_CP, NELE_IND =nbele+2 ,NVAL_IND =jj , NT_IND = k , TBLVAL = 0 )
end do
end do
nbele=nbele+2
il_index=il_index+2
endif
!Call BURP_Delete_BLOCK(Rpt_in,BLOCK=Block_in)
! LAT LON TIME IN DATA BLOCK
IND_LAT = BURP_Find_Element(BLOCK_OBS_MUL_CP, ELEMENT=5001, IOSTAT=error)
IND_LON = BURP_Find_Element(BLOCK_OBS_MUL_CP, ELEMENT=6001, IOSTAT=error)
IND_TIME = BURP_Find_Element(BLOCK_OBS_MUL_CP, ELEMENT=4015, IOSTAT=error)
if (IND_LAT .gt. 0 .and. IND_LON .gt. 0 .and. IND_TIME .gt. 0 ) HIRES=.true.
if(ENFORCE_CLASSIC_SONDES .eqv. .true.) hires=.false.
!print * , ' hires =true ? ndata_sf ',stnid,hires,NDATA_SF
if ( HIRES .AND. NDATA_SF .gt.0 ) OBS_START =OBS_START +1
OBSN=OBS_START
STATUS_HIRES=obs_headElem_i(obsdat,OBS_ST1,OBS_START )
regrup_LOOP: do k=1,nte
KOBSN=0
levels: do j=1,nvale
!pikpik
if(HIRES)KOBSN=0
!pikpik
elems: do IL = 1, NBELE
iele=-1
iele=BURP_Get_Element(BLOCK_OBS_MUL_CP,INDEX =il,IOSTAT= error)
IND_ELE_MAR= BURP_Find_Element(Block_MAR_MUL_CP, ELEMENT=iele+200000, IOSTAT=error)
if (IND_ele_mar .lt. 0 ) cycle
IND_ele = BURP_Find_Element(BLOCK_OBS_MUL_CP, ELEMENT=iele, IOSTAT=error)
if (IND_ele .eq. IND_LAT .and. hires ) cycle
if (IND_ele .eq. IND_LON .and. hires ) cycle
if (IND_ele .eq. IND_TIME .and. hires ) cycle
IND_ELE_STAT=-1
IND_ele_STAT = BURP_Find_Element(BLOCK_OMA, ELEMENT=iele, IOSTAT=error)
if(j .eq. 1 .and. il .ne. ind_vcoord .and. IND_ELE_STAT .lt. 1 ) then
il_index=il_index +1
Call BURP_RESIZE_BLOCK(BLOCK_OMA,ADD_NELE = 1 ,IOSTAT=error)
call BURP_Set_Element (BLOCK_OMA,NELE_IND = il_index,ElEMENT=iele,IOSTAT=error)
Call BURP_RESIZE_BLOCK(BLOCK_OMP,ADD_NELE = 1 ,IOSTAT=error)
call BURP_Set_Element (BLOCK_OMP,NELE_IND = il_index,ElEMENT=iele,IOSTAT=error)
Call BURP_RESIZE_BLOCK(BLOCK_OER,ADD_NELE = 1 ,IOSTAT=error)
call BURP_Set_Element (BLOCK_OER,NELE_IND = il_index,ElEMENT=iele,IOSTAT=error)
Call BURP_RESIZE_BLOCK(BLOCK_FGE,ADD_NELE = 1 ,IOSTAT=error)
call BURP_Set_Element (BLOCK_FGE,NELE_IND = il_index,ElEMENT=iele,IOSTAT=error)
do ki=1,nte
do jj=1,nvale
Call BURP_Set_Rval( Block_OMA, NELE_IND =il_index ,NVAL_IND =jj , NT_IND = ki, RVAL = PPMIS )
Call BURP_Set_Rval( Block_OMP, NELE_IND =il_index ,NVAL_IND =jj , NT_IND = ki, RVAL = PPMIS )
Call BURP_Set_Rval( Block_OER, NELE_IND =il_index ,NVAL_IND =jj , NT_IND = ki, RVAL = PPMIS )
Call BURP_Set_Rval( Block_FGE, NELE_IND =il_index ,NVAL_IND =jj , NT_IND = ki, RVAL = PPMIS )
end do
end do
endif
VCOORD = BURP_Get_Rval(BLOCK_OBS_MUL_CP, &
& NELE_IND = IND_VCOORD, &
& NVAL_IND = j, &
& NT_IND = k)
IF (il .eq. IND_VCOORD) THEN
Call BURP_Set_Rval( Block_OMA, NELE_IND =1 ,NVAL_IND =j , NT_IND = k , RVAL = VCOORD )
Call BURP_Set_Rval( Block_OMP, NELE_IND =1 ,NVAL_IND =j , NT_IND = k , RVAL = VCOORD )
Call BURP_Set_Rval( Block_OER, NELE_IND =1 ,NVAL_IND =j , NT_IND = k , RVAL = VCOORD )
Call BURP_Set_Rval( Block_FGE, NELE_IND =1 ,NVAL_IND =j , NT_IND = k , RVAL = VCOORD )
ENDIF
IND_ele = BURP_Find_Element(BLOCK_OBS_MUL_CP, ELEMENT=iele, IOSTAT=error)
!if ( kk .lt. obs_headElem_i(obsdat,OBS_IDO,OBSN) ) print *, ' kk OBS_IDO cycle =',kk, obs_headElem_i(obsdat,OBS_IDO,OBSN)
!if ( kk .lt. obs_headElem_i(obsdat,OBS_IDO,OBSN) ) cycle elems
is_in_list=-1
is_in_list=FIND_INDEX(LISTE_ELE,iele)
if (is_in_list .lt. 0 .and. iele .ne. ILEMU .and. iele .ne. ILEMV)cycle
IFLAG = BURP_Get_Tblval(Block_MAR_MUL_CP,NELE_IND = IND_ELE_MAR,NVAL_IND = J, NT_IND = k)
OBSVA = BURP_Get_Rval (Block_OBS_MUL_CP,NELE_IND = IND_ele ,NVAL_IND = J, NT_IND = k)
!if( idtyp .eq. 168) print * ,' bobossmi avant obsva iflag iele stnid =', IND_ele,j,k,iele,stnid,obsva,iflag,BITSflagoff,iand(iflag,BITSflagoff)
if(iand(iflag,BITSflagoff) .ne.0) CYCLE ELEMS
OBSVA = BURP_Get_Rval (Block_OBS_MUL_CP,NELE_IND = IND_ele ,NVAL_IND = J, NT_IND = k)
!if( idtyp .eq. 168) print * , ' bobossmi avant vcoord obsva stnid =', VCOORD,OBSVA,stnid
if (VCOORD .eq. PPMIS ) CYCLE ELEMS
if (OBSVA .eq. PPMIS .and. iele .ne. ILEMU .and. iele .ne. ILEMV ) CYCLE ELEMS
if (OBSN .gt. obs_numHeader(obsdat)) write(*,*) ' debordement altitude OBSN=',OBSN
if (OBSN .gt. obs_numHeader(obsdat)) cycle
IRLN=obs_headElem_i(obsdat,OBS_RLN,OBSN)
INLV=obs_headElem_i(obsdat,OBS_NLV,OBSN)
TIME=obs_headElem_i(obsdat,OBS_ETM,OBSN)
STID=obs_elem_c(obsdat,'STID',OBSN)
if ( STID .ne. stnid ) cycle
IND_ELE_stat = BURP_Find_Element(BLOCK_OMA, ELEMENT=iele, IOSTAT=error)
IND_ELE = BURP_Find_Element(BLOCK_OBS_MUL_CP, ELEMENT=iele, IOSTAT=error)
IND_eleu = BURP_Find_Element(BLOCK_OBS_MUL_CP, ELEMENT=ILEMU, IOSTAT=error)
convfact=1.
if (iele .eq. 10194) convfact=1./RG
do LK=IRLN,IRLN+INLV-1
ASSIM=obs_bodyElem_i(obsdat,OBS_ASS,LK)
VNM =obs_bodyElem_i(obsdat,OBS_VNM,LK)
PPP =obs_bodyElem_r(obsdat,OBS_PPP,LK) - (ELEV-400.)*ELEVFACT
if( abs( VCOORD - PPP) .lt. .01 .and. VNM .eq. iele ) then
OBS=obs_bodyElem_r(obsdat,OBS_VAR,LK)*convfact
OMA=obs_bodyElem_r(obsdat,OBS_OMA,LK)
OMP=obs_bodyElem_r(obsdat,OBS_OMP,LK)
OER=obs_bodyElem_r(obsdat,OBS_OER,LK)
FGE=obs_bodyElem_r(obsdat,OBS_HPHT,LK)
FLG=obs_bodyElem_i(obsdat,OBS_FLG,LK)
KOBSN= KOBSN + 1
IND_ELE_stat = BURP_Find_Element(BLOCK_OMA, ELEMENT=iele, IOSTAT=error)
if ( OMA .ne. PPMIS ) then
OMA=OMA*convfact
endif
Call BURP_Set_Rval(Block_OMA, NELE_IND =IND_ele_stat ,NVAL_IND =j , NT_IND = k , RVAL = OMA )
!if(trim(familytype) .eq. 'TO' )print *,' bingo stnid kk vnm ppp flg omp ',stnid,kk,vnm,ppp,flg,omp,oma
SUM=SUM +1
IND_ELE_stat = BURP_Find_Element(BLOCK_OMP, ELEMENT=iele, IOSTAT=error)
if ( OMP .ne. PPMIS ) then
OMP=OMP*convfact
endif
Call BURP_Set_Rval( Block_OMP, NELE_IND =IND_ele_stat ,NVAL_IND =j , NT_IND = k , RVAL = OMP)
Call BURP_Set_Rval( Block_OER, NELE_IND =IND_ele_stat ,NVAL_IND =j , NT_IND = k , RVAL = OER )
Call BURP_Set_Rval( Block_FGE, NELE_IND =IND_ele_stat ,NVAL_IND =j , NT_IND = k , RVAL = FGE )
IND_ele_mar = BURP_Find_Element(Block_MAR_MUL_CP, ELEMENT=iele+200000, IOSTAT=error)
Call BURP_Set_tblval(Block_MAR_MUL_CP,NELE_IND =IND_ELE_MAR ,NVAL_IND =j , NT_IND = k,TBLVAL = FLG )
IND_ele = BURP_Find_Element(Block_OBS_MUL_CP, ELEMENT=iele, IOSTAT=error)
Call BURP_Set_Rval(Block_OBS_MUL_CP,NELE_IND =IND_ele,NVAL_IND =j,NT_IND = k,RVAL = OBS)
EXIT
endif
end do
IF (HIRES .and. KOBSN .gt. 0 ) THEN
STATUS=obs_headElem_i(obsdat,OBS_ST1,OBSN )
STATUS_HIRES=ior(STATUS_HIRES,STATUS)
ENDIF
end do ELEMS
IF (HIRES .and. KOBSN .gt. 0 ) OBSN=OBSN +1
end do LEVELS
if ( REGRUP .and. KOBSN .gt. 0 ) then
STATUS=obs_headElem_i(obsdat,OBS_ST1,OBS_START )
STATUS=IBSET(STATUS,BIT_STATUS)
ind055200 = BURP_Find_Element(Block_FLG_CP, ELEMENT=055200, IOSTAT=error)
Call BURP_Set_tblval( Block_FLG_CP, NELE_IND =ind055200,NVAL_IND =1,NT_IND = k ,TBLVAL = STATUS )
OBSN=OBSN +1
OBS_START=OBS_START +1
endif
end do regrup_LOOP
IF (HIRES .and. KOBSN .gt. 0 .and. .not. regrup ) THEN
STATUS=obs_headElem_i(obsdat,OBS_ST1,OBS_START)
!pik 8-2014 STATUS=IBSET(STATUS,BIT_STATUS)
STATUS_HIRES=IBSET(STATUS_HIRES,BIT_STATUS)
Call BURP_Set_Property(CP_RPT ,FLGS =STATUS_HIRES)
ENDIF
IF (HIRES )OBS_START=OBSN
IF (HIRES )SAVE_OBS=OBS_START
IF (REGRUP)OBS_START=OBSN
IF ( .not. HIRES .and. .not. regrup .and. KOBSN .gt. 0 ) THEN
STATUS=obs_headElem_i(obsdat,OBS_ST1,OBS_START)
STATUS=IBSET(STATUS,BIT_STATUS)
OBS_START=OBSN +1
OBSN=OBSN +1
Call BURP_Set_Property(CP_RPT ,FLGS =STATUS)
ENDIF
IF ( .not. HIRES .and. .not. regrup .and. KOBSN .eq. 0 ) THEN
write(*,*) ' KOBSN=0 stnid',stnid
ENDIF
IF ( .not. HIRES .and. regrup .and. KOBSN .eq. 0 ) THEN
write(*,*)' KOBSN=0 regrup stnid',kk,stnid,obsn,obs_numHeader(obsdat)
ENDIF
IF (REGRUP) SAVE_OBS=OBS_START
Call BURP_Reduce_Block(BLOCK_OMA, NEW_NELE =il_index )
Call BURP_Reduce_Block(BLOCK_OMP, NEW_NELE =il_index )
Call BURP_Reduce_Block(BLOCK_OER, NEW_NELE =il_index )
Call BURP_Reduce_Block(BLOCK_FGE, NEW_NELE =il_index )
Call BURP_Set_Property(BLOCK_OBS_MUL_CP ,BFAM =0)
Call BURP_Set_Property(BLOCK_MAR_MUL_CP ,BFAM =0)
Call BURP_Write_Block( CP_RPT, BLOCK_OBS_MUL_CP,&
ENCODE_BLOCK = .TRUE., CONVERT_BLOCK = .TRUE., IOSTAT= error)
Call BURP_Write_Block( CP_RPT, BLOCK_MAR_MUL_CP,&
ENCODE_BLOCK = .TRUE., CONVERT_BLOCK = .FALSE., IOSTAT= error)
do item=1,BN_ITEMS
if ( BITEMLIST(item) .eq. 'OMA') then
Call BURP_Write_Block( CP_RPT, BLOCK_OMA,&
ENCODE_BLOCK = .TRUE., CONVERT_BLOCK = .TRUE., IOSTAT= error)
endif
if ( BITEMLIST(item) .eq. 'OMP') then
Call BURP_Write_Block( CP_RPT, BLOCK_OMP,&
ENCODE_BLOCK = .TRUE., CONVERT_BLOCK = .TRUE., IOSTAT= error)
endif
if ( BITEMLIST(item) .eq. 'OER') then
Call BURP_Write_Block( CP_RPT, BLOCK_OER,&
ENCODE_BLOCK = .TRUE., CONVERT_BLOCK = .TRUE., IOSTAT= error)
endif
if ( BITEMLIST(item) .eq. 'FGE') then
Call BURP_Write_Block( CP_RPT, BLOCK_FGE,&
ENCODE_BLOCK = .TRUE., CONVERT_BLOCK = .TRUE., IOSTAT= error)
endif
end do
if (regrup ) OBS_START=OBSN
if( .not. hires)SAVE_OBS=OBS_START
end if ! bl.eq.4
if ( bl .eq. 6 ) then
Call BURP_Write_Block( CP_RPT, BLOCK_in, ENCODE_BLOCK = .FALSE., CONVERT_BLOCK = .FALSE., IOSTAT= error)
endif
! descriptor block (btyp = 0010 100000X XXXX)
BTYP10des = 160
!if ( BTYP10 - BTYP10des == 0 ) then
if ( bl .eq. 1 ) then
OBS_START=SAVE_OBS
end if
!==================== IASI SPECIAL BLOCK==================
if ( (BTYP .eq. 9217 .or. BTYP .eq. 15361) .and. IDTYP .eq. 186 ) then
Call BURP_Write_Block( CP_RPT, BLOCK_in, ENCODE_BLOCK = .FALSE., CONVERT_BLOCK = .FALSE., IOSTAT= error)
endif
!==================== IASI SPECIAL BLOCK==================
end do BLOCKS1
if ( REGRUP ) then
Call BURP_Write_Block( CP_RPT, Block_FLG_CP, ENCODE_BLOCK = .TRUE., CONVERT_BLOCK = .FALSE.)
endif
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)
Call BURP_Free(Rpt_in,CP_RPT,IOSTAT=error)
Call BURP_Free(Block_in, IOSTAT=error)
Call BURP_Free(Block_OMA, IOSTAT=error)
Call BURP_Free(Block_OMP, IOSTAT=error)
Call BURP_Free(Block_OER, IOSTAT=error)
Call BURP_Free(Block_FGE, IOSTAT=error)
Call BURP_Free(Block_OMA_SFC,IOSTAT=error)
Call BURP_Free(Block_OMP_SFC,IOSTAT=error)
Call BURP_Free(Block_OER_SFC,IOSTAT=error)
Call BURP_Free(Block_FGE_SFC,IOSTAT=error)
Call BURP_Free(Block_FLG_SFC,IOSTAT=error)
Call BURP_Free(Block_FLG ,IOSTAT=error)
Call BURP_Free(Block_FLG_CP ,IOSTAT=error)
Call BURP_Free(Block_MAR_MUL_CP ,IOSTAT=error)
Call BURP_Free(Block_MAR_SFC_CP ,IOSTAT=error)
Call BURP_Free(Block_OBS_MUL_CP ,IOSTAT=error)
Call BURP_Free(Block_OBS_SFC_CP ,IOSTAT=error)
Call BURP_Free(File_in, IOSTAT=error)
write(*,*) ' BURPFILE UPDATED SUM = ',trim(brp_file),SUM
END SUBROUTINE UPDATE_BURP
SUBROUTINE BRPACMA_NML(NML_SECTION) 19
INTEGER*4 :: NULNAM,IER,FNOM,FCLOS
CHARACTER *256 :: NAMFILE
CHARACTER(len = *) :: NML_SECTION
NAMELIST /NAMBURP_FILTER_CONV/NELEMS, BLISTELEMENTS, BNBITSOFF,BBITOFF,BNBITSON,BBITON,ENFORCE_CLASSIC_SONDES
NAMELIST /NAMBURP_FILTER_SFC/ NELEMS_SFC,BLISTELEMENTS_SFC,BNBITSOFF,BBITOFF,BNBITSON,BBITON
NAMELIST /NAMBURP_FILTER_TOVS/NELEMS,BLISTELEMENTS,BNBITSOFF,BBITOFF,BNBITSON,BBITON
NAMELIST /NAMBURP_UPDATE/BN_ITEMS, BITEMLIST,TYPE_RESUME
NAMFILE=trim("flnml")
nulnam=0
IER=FNOM(NULNAM,NAMFILE,'R/O',0)
WRITE(*,*) ' READ NML_SECTION =',trim(NML_SECTION)
SELECT CASE(trim(NML_SECTION))
CASE( 'namburp_sfc')
READ(NULNAM,NML=NAMBURP_FILTER_SFC)
CASE( 'namburp_conv')
READ(NULNAM,NML=NAMBURP_FILTER_CONV)
CASE( 'namburp_tovs')
READ(NULNAM,NML=NAMBURP_FILTER_TOVS)
CASE( 'namburp_update')
READ(NULNAM,NML=NAMBURP_UPDATE)
END SELECT
ier=FCLOS(NULNAM)
END SUBROUTINE BRPACMA_NML
SUBROUTINE READBURP(obsdat,familytype,brp_file,FILENUMB) 1,57
!***********************************************************************
!
!**ID READBURP -- SELECT VARIABLES RELATIVE TO AIRS IN BURP FILE
!
! AUTHOR: P. KOCLAS (CMDA/SMC) May 2011
!
! REVISION:
! S. MACPHERSON (ARMA) Oct 2013
! -- add 'GP' family (ground-based GPS)
! P. KOCLAS (CMDA) Oct 2014
! -- Changed VCOORD Dimensions
! -- add VCORD array to allow grouped SW or AI
!
! OBJECT: READ CMC BURP FILE
!
! 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
!
!
!***********************************************************************
IMPLICIT NONE
CHARACTER(LEN=128) :: BRP_FILE
INTEGER :: FILENUMB
CHARACTER *2 :: FAMILYTYPE
type (struct_obs), intent(inout) :: obsdat
TYPE(BURP_FILE) :: FILE_IN
TYPE(BURP_RPT) :: RPT_IN
TYPE(BURP_BLOCK) :: BLOCK_IN
CHARACTER(LEN=5) :: FAMILYTYPE2
CHARACTER(LEN=9) :: OPT_MISSING
INTEGER :: BTYP,BFAM,BKSTP,BTYP10,BTYP10_uni,BTYP10FLG_uni,BTYP10obs_uni
INTEGER :: BTYP10DES,BTYP10INF,BTYP10OBS,BTYP10FLG
INTEGER :: NB_RPTS,REF_RPT,REF_BLK,COUNT
INTEGER, ALLOCATABLE :: ADDRESS(:)
REAL , ALLOCATABLE :: OBSVALUE(:,:,:),OBSVALUE_SFC(:,:,:)
REAL , ALLOCATABLE :: OBSERV (:,:), OBSERV_SFC(:,:)
INTEGER, ALLOCATABLE :: QCFLAG (:,:,:), QCFLAG_SFC(:,:,:)
INTEGER, ALLOCATABLE :: QCFLAGS (:,:), QCFLAGS_SFC(:,:)
REAL , ALLOCATABLE :: VCOORD (:,:), VCOORD_SFC(:)
REAL , ALLOCATABLE :: VCORD (:)
INTEGER, ALLOCATABLE :: LAT(:),LON(:),HHMM(:),DATE(:),GLBFLAG(:)
REAL , ALLOCATABLE :: HLAT(:,:), HLON(:,:), HTIME(:,:)
REAL , ALLOCATABLE :: HLAT_SFC(:),HLON_SFC(:),HTIME_SFC(:)
REAL , ALLOCATABLE :: RINFO(:,:)
REAL , ALLOCATABLE :: TRINFO(:)
REAL , ALLOCATABLE :: EMIS(:,:),SURF_EMIS(:)
INTEGER, ALLOCATABLE :: CFRAC(:,:)
REAL(OBS_REAL), ALLOCATABLE :: RADMOY(:,:,:)
REAL(OBS_REAL), ALLOCATABLE :: radstd(:,:,:)
INTEGER :: LISTE_INFO(16),LISTE_ELE(15),LISTE_ELE_SFC(15)
INTEGER :: NBELE,NVALE,NTE
INTEGER :: I,J,JJ,K,KK,KL,IL,ERROR,OBSN
INTEGER :: info_elepos,IND_ELE,IND_VCOORD,IND_QCFLAG
INTEGER :: IND055200,IND4208,ind4197,IND5002,IND6002
INTEGER :: IND_LAT,IND_LON,IND_TIME,IND_EMIS
INTEGER :: FLAG_PASSAGE1,FLAG_PASSAGE2,FLAG_PASSAGE3,FLAG_PASSAGE4
INTEGER :: vcord_type,vcord_type2,FLAG,SUM
REAL(OBS_REAL) :: RELEV,XLAT,XLON
REAL :: XTIME,SECONDS
INTEGER :: status ,idtyp,lati,long,dx,dy,elev, &
drnd,date_h,hhmm_h,oars,runn,YMD_DATE,HM,kstamp,kstamp2,HM_SFC,YMD_DATE_SFC
INTEGER :: iele,NELE,NELE_SFC,NVAL,NT,NELE_INFO,LN
INTEGER :: bit_alt,btyp_offset,btyp_offset_uni
character(len = 5) :: BURP_TYP
CHARACTER(LEN=9) :: STNID,STN_RESUME
LOGICAL :: HIRES,HIRES_SFC
INTEGER :: NDATA,NDATA_SF
INTEGER :: IER,date2,DATE3,time2,time_sonde,NEWDATE
REAL :: RAD_MOY,RAD_STD
INTEGER :: iclass,NCHANAVHRR,NCLASSAVHRR,ichan,iobs,inorm
INTEGER :: infot
DATA LISTE_INFO &
/1007,002019,007024,007025 ,005021, 005022, 008012, &
013039,020010,2048,2022,33060,33062,33039,10035,10036/
FAMILYTYPE2= 'SCRAP'
vcord_type2=-1
NELE_INFO=1
NELE_SFC=0
NELE=0
BNBITSOFF=0
BNBITSON=0
ENFORCE_CLASSIC_SONDES=.false.
SELECT CASE(trim(FAMILYTYPE))
CASE('UA')
BURP_TYP='multi'
vcord_type=7004
LISTE_ELE_SFC = (/12004,11011,11012,10051,10004,12203,-1,-1,-1,-1,-1,-1,-1,-1,-1/)
NELE_SFC=6
CALL BRPACMA_NML('namburp_sfc')
NELE_SFC=NELEMS_SFC
FAMILYTYPE2= 'UA'
LISTE_ELE = (/12001,11001,11002,12192,10194,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1/)
NELE=5
ENFORCE_CLASSIC_SONDES=.false.
CALL BRPACMA_NML('namburp_conv')
NELE=NELEMS
CASE('AI')
BURP_TYP='uni'
vcord_type=7004
LISTE_ELE = (/12001,12192,11001,11002,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1/)
NELE=4
CALL BRPACMA_NML('namburp_conv')
NELE=NELEMS
CASE('SW')
BURP_TYP='uni'
vcord_type=7004
LISTE_ELE = (/11001,11002,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1/)
NELE=2
CALL BRPACMA_NML('namburp_conv')
NELE=NELEMS
CASE('SF','GP')
BURP_TYP='uni'
vcord_type=0
NELE_SFC=7
LISTE_ELE_SFC = (/12004,11011,11012,10051,10004,12203,15031,-1,-1,-1,-1,-1,-1,-1,-1/)
CALL BRPACMA_NML('namburp_sfc')
NELE_SFC=NELEMS_SFC
FAMILYTYPE2= 'SFC'
CASE('SC')
vcord_type=0
BURP_TYP='uni'
LISTE_ELE_SFC = (/11012,11011,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1/)
NELE=2
CALL BRPACMA_NML('namburp_conv')
NELE=NELEMS
FAMILYTYPE2= 'UASFC2'
CASE('PR')
BURP_TYP='multi'
vcord_type=7006
LISTE_ELE = (/11001,11002,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1/)
NELE=2
CALL BRPACMA_NML('namburp_conv')
NELE=NELEMS
CASE('RO')
BURP_TYP='multi'
vcord_type=7007
vcord_type2=7040
LISTE_ELE = (/15036,15037,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1/)
NELE=2
CALL BRPACMA_NML('namburp_conv')
NELE=NELEMS
!================GPS-RO CANNOT BE FILTERED=======
BNBITSOFF=0
BNBITSON=0
!================GPS-RO CANNOT BE FILTERED=======
NELE_INFO=16
CASE('GO','MI','TO')
BURP_TYP='multi'
vcord_type=5042
vcord_type2=2150
LISTE_ELE = (/12163,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1/)
NELE=1
CALL BRPACMA_NML('namburp_tovs')
NELE=NELEMS
NELE_INFO=16
END SELECT
LISTE_ELE (1:NELE )=BLISTELEMENTS(1:NELE)
LISTE_ELE_SFC(1:NELE_SFC)=BLISTELEMENTS_SFC(1:NELE_SFC)
write(*,*) ' NELE NELEMS LISTE_ELE =',NELE,NELEMS,LISTE_ELE
write(*,*) ' NELE_SFC LISTE_ELE_SFC =',NELE_SFC,LISTE_ELE_SFC(1:NELE_SFC)
write(*,*) ' BNBITSON BNBITSOFF =',BNBITSON,BNBITSOFF
btyp_offset_uni=-999
btyp_offset=-999
if (trim(BURP_TYP) .eq. 'uni') then
btyp_offset=256
else
btyp_offset=0
endif
if (TRIM(FAMILYTYPE2) .eq. 'SFC') then
btyp_offset= btyp_offset+32
btyp_offset_uni= 256 +32
elseif ( TRIM(FAMILYTYPE2) .eq. 'UA') then
btyp_offset_uni= 256 +32
else
btyp_offset_uni= -999 ! set to -999 when not used
endif
WRITE(*,*) '-----------------------------------------------'
WRITE(*,*) '----------- BEGIN READBURP ------------'
WRITE(*,*) 'FAMILYTYPE vcord_type =',FAMILYTYPE,vcord_type
WRITE(*,*) 'BURP_TYP btyp_offset =',BURP_TYP, btyp_offset
WRITE(*,*) '-----------------------------------------------'
! initialisation
! --------------
SUM=0
flag_passage1 = 0
flag_passage2 = 0
flag_passage3 = 0
flag_passage4 = 0
opt_missing = 'MISSING'
Call BURP_Set_Options( &
& REAL_OPTNAME = opt_missing, &
& REAL_OPTNAME_VALUE = PPMIS, &
& CHAR_OPTNAME = 'MSGLVL', &
& CHAR_OPTNAME_VALUE = 'FATAL', &
& IOSTAT = error )
Call BURP_Init(File_in ,IOSTAT=error)
Call BURP_Init(Rpt_in ,IOSTAT=error)
Call BURP_Init(Block_in ,IOSTAT=error)
! opening file
write(*,*) 'OPENING BURP FILE FOR READING = ', trim(brp_file)
Call BURP_New(File_in, FILENAME = brp_file, &
& MODE = FILE_ACC_READ, &
& IOSTAT = error )
! obtain input burp file number of reports
Call BURP_Get_Property(File_in, NRPTS=nb_rpts)
WRITE(*,*) '-----------------------------------------'
WRITE(*,*) 'IOSTAT =',error
WRITE(*,*) 'NUMBER OF REPORTS IN FILE = ',nb_rpts
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)
Call burp_get_property(Rpt_in, STNID = stnid )
IF ( stnid(1:2) == ">>" ) then
STN_RESUME=stnid
TYPE_RESUME=STN_RESUME(3:9)
SELECT CASE(stnid)
CASE(">>BGCKALT", ">>POSTALT")
bit_alt=1
CASE(">>DERIALT")
bit_alt=2
END SELECT
ENDIF
if (ref_rpt < 0) Exit
if (count .eq. nb_rpts) then
write(*,*) 'READBURP: ERROR: count = nb_rpts:',count,nb_rpts
exit
endif
count = count + 1
address(count) = ref_rpt
end do
!pik write(*,'(a9,1x,a16,1x,i2)' )STN_RESUME,' bit_alt==== > ',bit_alt
write(*, *)STN_RESUME,' bit_alt==== > ',bit_alt
BTYP10obs = 291 -btyp_offset
BTYP10obs_uni = 291 -btyp_offset_uni
if (bit_alt .eq. 2) btyp10obs = BTYP10obs - 2
if (bit_alt .eq. 2) btyp10obs_uni = BTYP10obs_uni - 2
BTYP10flg = 483 -btyp_offset
BTYP10flg_uni = 483 -btyp_offset_uni
if (bit_alt .eq. 2) BTYP10flg = BTYP10flg - 2
if (bit_alt .eq. 2) BTYP10flg_uni = BTYP10flg_uni - 2
write(*, *) ' NUMBER OF VALID REPORTS IN FILE = ',count
write(*, *) ' BTYP10obs BTYP10obs_uni = ',BTYP10obs,BTYP10obs_uni
if ( count > 0 ) then
! LOOP ON REPORTS
REPORTS: do kk = 1, count
Call BURP_Get_Report(File_in, &
& REPORT = Rpt_in, &
& REF = address(kk), &
& IOSTAT = error)
Call burp_get_property(Rpt_in, &
STNID = stnid ,TEMPS =hhmm_h,FLGS = status ,IDTYP =idtyp,LATI = lati &
,LONG = long ,DX = dx ,DY = dy,ELEV=elev,DRND =drnd,DATE =date_h &
,OARS =oars,RUNN=runn ,IOSTAT=error)
IF ( stnid(1:2) == ">>" ) cycle
! LOOP ON BLOCKS
ref_blk = 0
HIRES=.FALSE.
HIRES_SFC=.FALSE.
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, &
& BKSTP = BKSTP, &
& IOSTAT = error)
! observation block (btyp = 0100 100011X XXXX)
btyp10 = ishft(btyp,-5)
if ( btyp10 - btyp10obs_uni == 0 .and. bkstp <= 4 ) then
ALLOCATE(obsvalue_sfc(NELE_SFC,1,nte))
ALLOCATE( OBSERV_SFC(NELE_SFC,1) )
ALLOCATE( vcoord_sfc(1))
vcoord_SFC(:) = 0
obsvalue_sfc(:,:,:) = PPMIS
IND_LAT = BURP_Find_Element(Block_in, ELEMENT=5001, IOSTAT=error)
IND_LON = BURP_Find_Element(Block_in, ELEMENT=6001, IOSTAT=error)
IND_TIME = BURP_Find_Element(Block_in, ELEMENT=4015, IOSTAT=error)
if (IND_LAT .gt. 0 .and. IND_LON .gt. 0 .and. IND_TIME .gt. 0 ) HIRES_SFC=.true.
if(HIRES_SFC) ALLOCATE(HLAT_SFC(nte),HLON_SFC(nte),HTIME_SFC(nte) )
IF (HIRES_SFC) THEN
do k=1,nte
HLAT_SFC(k) =BURP_Get_Rval(Block_in, &
& NELE_IND = IND_LAT, &
& NVAL_IND = 1, &
& NT_IND = k)
HLON_SFC(k) =BURP_Get_Rval(Block_in, &
& NELE_IND = IND_LON, &
& NVAL_IND = 1, &
& NT_IND = k)
HTIME_SFC(k)=BURP_Get_Rval(Block_in, &
& NELE_IND = IND_TIME, &
& NVAL_IND = 1, &
& NT_IND = k)
end do
ENDIF
do IL = 1, NELE_SFC
iele=LISTE_ELE_SFC(IL)
IND_ele = BURP_Find_Element(Block_in, ELEMENT=iele, IOSTAT=error)
if (IND_ele .lt. 0 ) cycle
do k=1,nte
obsvalue_sfc(IL,1,k) = BURP_Get_Rval(Block_in, &
& NELE_IND = IND_ele, &
& NVAL_IND = 1, &
& NT_IND = k)
end do
end do
endif
if ( btyp10 - btyp10flg_uni == 0 .and. bkstp <= 4 ) then
ALLOCATE( qcflag_sfc (NELE_SFC,1,nte))
ALLOCATE( qcflags_SFC(NELE_SFC,1) )
QCFLAGS_SFC(:,:)=0
do IL = 1, NELE_SFC
iele=LISTE_ELE_SFC(IL) + 200000
IND_QCFLAG = BURP_Find_Element(Block_in, ELEMENT=iele, IOSTAT=error)
if (IND_QCFLAG .lt. 0 ) cycle
DO k=1,nte
QCFLAG_sfc(IL,1,k) = BURP_Get_Tblval(Block_in, &
& NELE_IND = IND_QCFLAG, &
& NVAL_IND = 1, &
& NT_IND = k)
SUM = SUM +1
END DO
end do
endif
if ( btyp10 - btyp10obs == 0 .and. bfam == 0 ) then
flag_passage3 = 1
NVAL=NVALE ; NT=NTE
ALLOCATE(obsvalue(NELE,nvale,nte),VCOORD(nvale,nte))
ALLOCATE( OBSERV(NELE,nvale) )
ALLOCATE( VCORD(nvale) )
obsvalue(:,:,:) = PPMIS
OBSERV (:,:) = PPMIS
VCOORD (:,:) = 0.
VCORD (:) = 0.
IND_VCOORD = BURP_Find_Element(Block_in, ELEMENT=vcord_type, IOSTAT=error)
if (IND_VCOORD <= 0)IND_VCOORD = BURP_Find_Element(Block_in, ELEMENT=vcord_type2, IOSTAT=error)
!if (IND_VCOORD == -1)write(*,*) 'PAS DE COORDONNEE VERTICALE STNID=',STNID,trim(FAMILYTYPE)
! LAT LON TIME IN DATA BLOCK
IND_LAT = BURP_Find_Element(Block_in, ELEMENT=5001, IOSTAT=error)
IND_LON = BURP_Find_Element(Block_in, ELEMENT=6001, IOSTAT=error)
IND_TIME = BURP_Find_Element(Block_in, ELEMENT=4015, IOSTAT=error)
IND_EMIS = BURP_Find_Element(Block_in, ELEMENT=55043,IOSTAT=error)
if (IND_LAT .gt. 0 .and. IND_LON .gt. 0 .and. IND_TIME .gt. 0 ) HIRES=.true.
if(HIRES) ALLOCATE(HLAT(nvale,nte),HLON(nvale,nte),HTIME(nvale,nte) )
ALLOCATE(EMIS(nvale,nte))
ALLOCATE(SURF_EMIS(nvale))
EMIS(:,:) = PPMIS
OBSVALUE(:,:,:) = PPMIS
do IL = 1, NELE
iele=LISTE_ELE(IL)
IND_ele = BURP_Find_Element(Block_in, ELEMENT=iele, IOSTAT=error)
if (IND_ele .lt. 0 ) cycle
do k=1,nte
do j=1,nvale
obsvalue(IL,j,k) = BURP_Get_Rval(Block_in, &
& NELE_IND = IND_ele, &
& NVAL_IND = j, &
& NT_IND = k)
IF (HIRES) THEN
HLAT(j,k) =BURP_Get_Rval(Block_in, &
& NELE_IND = IND_LAT, &
& NVAL_IND = j, &
& NT_IND = k)
HLON(j,k) =BURP_Get_Rval(Block_in, &
& NELE_IND = IND_LON, &
& NVAL_IND = j, &
& NT_IND = k)
HTIME(j,k)=BURP_Get_Rval(Block_in, &
& NELE_IND = IND_TIME, &
& NVAL_IND = j, &
& NT_IND = k)
ENDIF
IF (IND_EMIS > 0) THEN
EMIS(j,k) =BURP_Get_Rval(Block_in, &
& NELE_IND = IND_EMIS, &
& NVAL_IND = j, &
& NT_IND = k)
ENDIF
if (IND_VCOORD <= 0) cycle
VCOORD(j,k) = BURP_Get_Rval(Block_in, &
& NELE_IND = IND_VCOORD, &
& NVAL_IND = j, &
& NT_IND = k)
end do
end do
end do
end if
! flag block (btyp = 0111 100011X XXXX)
if ( btyp10 - btyp10flg == 0 ) then
flag_passage4 = 1
ALLOCATE(qcflag( NELE,nvale,nte))
ALLOCATE(qcflags(NELE,nvale) )
QCFLAG (:,:,:) = 0
QCFLAGS(:,:) = 0
do IL = 1, NELE
iele=LISTE_ELE(IL)
IND_QCFLAG = BURP_Find_Element(Block_in, ELEMENT=200000+iele, IOSTAT=error)
if (IND_QCFLAG .le. 0 ) cycle
do k = 1, nte
do j = 1, nvale
QCFLAG(IL,j,k)= BURP_Get_Tblval(Block_in, &
& NELE_IND = IND_QCFLAG, &
& NVAL_IND = j, &
& NT_IND = k, &
& IOSTAT = error)
SUM = SUM +1
end do
end do
end do
end if
! info block (btyp = 0001 100000X XXXX)
BTYP10inf = 96
if ( (btyp10 - btyp10inf == 0) .or. (btyp10 - btyp10inf == 1) ) then
ALLOCATE( RINFO(NELE_INFO,nte))
ALLOCATE(TRINFO(NELE_INFO))
flag_passage2 = 1
do kl=1,NELE_INFO
info_elepos = BURP_Find_Element(Block_in, &
& ELEMENT = LISTE_INFO(kl), &
& IOSTAT = error)
if ( info_elepos .ge. 0 )then
do k =1 , nte
RINFO(kl,k)= BURP_Get_rval(Block_in, &
& NELE_IND = info_elepos, &
& NVAL_IND = 1, &
& NT_IND = k, &
& IOSTAT = error)
if (RINFO(kl,k) .eq. PPMIS) THEN
infot= BURP_Get_tblval(Block_in, &
& NELE_IND = info_elepos, &
& NVAL_IND = 1, &
& NT_IND = k, &
& IOSTAT = error)
if (infot .ne. -1) RINFO(kl,k) =real(infot)
ENDIF
end do
else
RINFO(kl,1:nte)=PPMIS
endif
end do
endif
! descriptor block (btyp = 0010 100000X XXXX)
BTYP10des = 160
if ( BTYP10 - BTYP10des == 0 ) then
flag_passage1 = 1
ALLOCATE(GLBFLAG(nte))
ALLOCATE( lat(nte))
ALLOCATE( lon(nte))
ALLOCATE( date(nte))
ALLOCATE( hhmm(nte))
! DATE 004208 HHMM 004197 STATUS 055200 LAT 005002 LON 006002 DELAY 004195
ind055200 = BURP_Find_Element(Block_in, ELEMENT=055200, IOSTAT=error)
ind5002 = BURP_Find_Element(Block_in, ELEMENT=5002 , IOSTAT=error)
ind6002 = BURP_Find_Element(Block_in, ELEMENT=6002 , IOSTAT=error)
ind4208 = BURP_Find_Element(Block_in, ELEMENT=4208 , IOSTAT=error)
ind4197 = BURP_Find_Element(Block_in, ELEMENT=4197 , IOSTAT=error)
do k = 1, nte
LAT(k) = BURP_Get_Tblval(Block_in, &
& NELE_IND = ind5002, &
& NVAL_IND = 1, &
& NT_IND = k)
LON(k) = BURP_Get_Tblval(Block_in, &
& NELE_IND = ind6002, &
& NVAL_IND = 1, &
& NT_IND = k)
HHMM(k) = BURP_Get_Tblval(Block_in, &
& NELE_IND = ind4197, &
& NVAL_IND = 1, &
& NT_IND = k)
DATE(k) = BURP_Get_Tblval(Block_in, &
& NELE_IND = ind4208, &
& NVAL_IND = 1, &
& NT_IND = k)
GLBFLAG(k) = BURP_Get_Tblval(Block_in, &
& NELE_IND = ind055200, &
& NVAL_IND = 1, &
& NT_IND = k)
end do
end if
!==================== IASI SPECIAL BLOCK==================
if ( BTYP .eq. 9217 .and. IDTYP .eq. 186 ) then
NCLASSAVHRR=obs_getNclassAvhrr()
NCHANAVHRR=obs_getNchanAvhrr()
if (.not. allocated(CFRAC) ) allocate( CFRAC(NCLASSAVHRR,nte) )
if (.not. allocated(RADMOY)) allocate(RADMOY(NCLASSAVHRR,NCHANAVHRR,nte))
if (.not. allocated(radstd)) allocate(radstd(NCLASSAVHRR,NCHANAVHRR,nte))
RADMOY(:,:,:)=PPMIS
RADSTD(:,:,:)=PPMIS
CFRAC(:,:)=-999
IASIQUAL: DO k = 1, nte
iclass=1
NVALS :do j=1,nvale
DO il=1,nbele
iele=BURP_Get_Element(Block_in,INDEX =il,IOSTAT= error)
SELECT CASE(iele)
CASE(25085)
CFRAC(iclass,k)= BURP_Get_RVAL(Block_in,NELE_IND = il, NVAL_IND = j, NT_IND = k, IOSTAT = error)
CASE(5042)
!ICHAN= BURP_Get_TBLVAL(Block_in,NELE_IND = il, NVAL_IND = j, NT_IND = k, IOSTAT = error)
ICHAN= BURP_Get_RVAL(Block_in,NELE_IND = il, NVAL_IND = j, NT_IND = k, IOSTAT = error)
CASE(25142)
!INORM= BURP_Get_TBLVAL(Block_in,NELE_IND = il, NVAL_IND = j, NT_IND = k, IOSTAT = error)
INORM= BURP_Get_RVAL(Block_in,NELE_IND = il, NVAL_IND = j, NT_IND = k, IOSTAT = error)
CASE(14047)
RAD_MOY=BURP_Get_RVAL(Block_in,NELE_IND = il, NVAL_IND = j, NT_IND = k, IOSTAT = error)
RADMOY(iclass,ICHAN,k)=RAD_MOY * 10.d0**(-1.d0 * INORM ) * 100000.d0
CASE(14048)
RAD_STD=BURP_Get_RVAL(Block_in,NELE_IND = il, NVAL_IND = j, NT_IND = k, IOSTAT = error)
RADSTD(iclass,ICHAN,k)= RAD_STD * 10.d0**(-1.d0 * INORM ) * 100000.d0
IF (ICHAN==NCHANAVHRR) iclass=iclass+1
IF ( iclass==(NCLASSAVHRR+1) ) EXIT NVALS
END SELECT
ENDDO
enddo NVALS
ENDDO IASIQUAL
endif
end do BLOCKS1
do k = 1, nte
IF ( allocated(lat) ) then
XLON = (lon(k)*1.-18000.)*.01
XLAT = (lat(k)*1.- 9000.)*.01
IF ( xlon .LT. 0. ) xlon = 360. + xlon
XLON = XLON*MPC_RADIANS_PER_DEGREE_R8
XLAT = XLAT*MPC_RADIANS_PER_DEGREE_R8
YMD_DATE=date(k)
HM =hhmm(k)
STATUS =GLBFLAG(K)
RELEV =REAL(ELEV) - 400.
ELSE
XLON =.01*LONG
XLAT =LATI*.01 -90.
XLON = XLON*MPC_RADIANS_PER_DEGREE_R8
XLAT = XLAT*MPC_RADIANS_PER_DEGREE_R8
YMD_DATE=date_h
HM =hhmm_h
RELEV =REAL(ELEV,OBS_REAL) - 400.
ENDIF
if (allocated(RINFO)) TRINFO(1:NELE_INFO) =RINFO (1:NELE_INFO,k)
if(ENFORCE_CLASSIC_SONDES .eqv. .true.) hires=.false.
IF (HIRES ) THEN
if (allocated(EMIS)) SURF_EMIS(1:NVAL) =EMIS (1:NVAL,k)
IF ( allocated(obsvalue_sfc) ) THEN
OBSERV_SFC(1:NELE_SFC,1:1)=obsvalue_sfc(1:NELE_SFC,1:1,k)
QCFLAGS_sfc(1:NELE_SFC,1:1)=qcflag_sfc (1:NELE_SFC,1:1,k)
IF ( HIRES_SFC) THEN
XLAT=HLAT_SFC(k);XLON=HLON_SFC(k);XTIME=HTIME_SFC(k)
IF ( XLON .LT. 0. ) XLON = 360. + XLON
ier= NEWDATE(kstamp2,YMD_DATE,HM*10000,3)
XLAT=XLAT*MPC_RADIANS_PER_DEGREE_R8
XLON=XLON*MPC_RADIANS_PER_DEGREE_R8
CALL INCDATR(kstamp, kstamp2, XTIME/60.d0 )
IER=newdate(kstamp,date2,time_sonde,-3)
time2=time_sonde/10000
YMD_DATE_SFC=date2
HM_SFC=time2
ENDIF
NDATA_SF= WRITE_BODY(obsdat,'SF',RELEV,vcoord_sfc ,OBSERV_sfc,qcflags_sfc,NELE_SFC,1,LISTE_ELE_SFC)
IF ( NDATA_SF .GT. 0) THEN
call WRITE_HEADER(obsdat,STNID,XLAT,XLON,YMD_DATE_SFC,HM_SFC,idtyp,STATUS,RELEV,FILENUMB)
OBSN=obs_numHeader(obsdat)
call obs_setFamily(obsdat,trim(FAMILYTYPE), OBSN )
call obs_headSet_i(obsdat,OBS_NLV,OBSN,NDATA_SF)
IF (OBSN .GT. 1 ) THEN
LN= obs_headElem_i(obsdat,OBS_RLN,OBSN-1) + obs_headElem_i(obsdat,OBS_NLV,OBSN-1)
call obs_headSet_i(obsdat,OBS_RLN,OBSN,LN)
ELSE
call obs_headSet_i(obsdat,OBS_RLN,OBSN,1)
ENDIF
ENDIF
ENDIF
IF ( allocated(obsvalue) ) THEN
ier= NEWDATE(kstamp2,YMD_DATE,HM*10000,3)
do JJ =1,nval
OBSERV(1:NELE,1:1) =obsvalue (1:NELE,jj:jj,k)
if (allocated(qcflag)) QCFLAGS(1:NELE,1:1) =qcflag (1:NELE,jj:jj,k)
XLAT=HLAT(jj,k);XLON=HLON(jj,k);XTIME=HTIME(jj,k)
IF ( XLON .LT. 0. ) XLON = 360. + XLON
XLAT=XLAT*MPC_RADIANS_PER_DEGREE_R8
XLON=XLON*MPC_RADIANS_PER_DEGREE_R8
CALL INCDATR(kstamp, kstamp2, XTIME/60.d0 )
IER=newdate(kstamp,date2,time_sonde,-3)
time2=time_sonde/10000
VCORD(1)=VCOORD(jj,k)
NDATA= WRITE_BODY(obsdat,familytype,RELEV,VCORD, OBSERV,qcflags,NELE,1,LISTE_ELE,SURF_EMIS)
IF (NDATA .gt. 0) THEN
call WRITE_HEADER(obsdat,STNID,XLAT,XLON,date2,time2,idtyp,STATUS,RELEV,FILENUMB)
OBSN=obs_numHeader(obsdat)
call obs_setFamily(obsdat,trim(FAMILYTYPE), OBSN )
call obs_headSet_i(obsdat,OBS_NLV,OBSN,NDATA)
IF (OBSN .GT. 1 ) THEN
LN= obs_headElem_i(obsdat,OBS_RLN,OBSN-1) + obs_headElem_i(obsdat,OBS_NLV,OBSN-1)
call obs_headSet_i(obsdat,OBS_RLN,OBSN,LN)
!call obs_headSet_i(obsdat,OBS_IDO,OBSN,kk)
ELSE
call obs_headSet_i(obsdat,OBS_RLN,OBSN,1)
!call obs_headSet_i(obsdat,OBS_IDO,OBSN,kk)
ENDIF
ENDIF
end do
ENDIF
ELSE
if (allocated(EMIS)) SURF_EMIS(1:NVAL) =EMIS (1:NVAL,k)
NDATA =0
NDATA_SF=0
IF ( allocated(obsvalue_sfc) ) THEN
IF ( HIRES_SFC) THEN
XLAT=HLAT_SFC(k);XLON=HLON_SFC(k);XTIME=HTIME_SFC(k)
IF ( XLON .LT. 0. ) XLON = 360. + XLON
ier= NEWDATE(kstamp2,YMD_DATE,HM*10000,3)
XLAT=XLAT*MPC_RADIANS_PER_DEGREE_R8
XLON=XLON*MPC_RADIANS_PER_DEGREE_R8
CALL INCDATR(kstamp, kstamp2, XTIME/60.d0 )
IER=newdate(kstamp,date2,time_sonde,-3)
time2=time_sonde/10000
YMD_DATE=date2
HM=time2
ENDIF
OBSERV_SFC (1:NELE_SFC,1:1)=obsvalue_sfc(1:NELE_SFC,1:1,k)
QCFLAGS_sfc(1:NELE_SFC,1:1)=qcflag_sfc (1:NELE_SFC,1:1,k)
NDATA_SF= WRITE_BODY(obsdat,'SF',RELEV,vcoord_sfc ,OBSERV_sfc,qcflags_sfc,NELE_SFC,1,LISTE_ELE_SFC)
IF ( NDATA_SF .GT. 0) THEN
call WRITE_HEADER(obsdat,STNID,XLAT,XLON,YMD_DATE,HM,idtyp,STATUS,RELEV,FILENUMB)
OBSN=obs_numHeader(obsdat)
call obs_setFamily(obsdat,trim(FAMILYTYPE), OBSN )
call obs_headSet_i(obsdat,OBS_NLV ,OBSN,NDATA_SF)
IF (OBSN .GT. 1 ) THEN
LN= obs_headElem_i(obsdat,OBS_RLN,OBSN-1) + obs_headElem_i(obsdat,OBS_NLV,OBSN-1)
call obs_headSet_i(obsdat,OBS_RLN,OBSN,LN)
!call obs_headSet_i(obsdat,OBS_IDO,OBSN,kk)
ELSE
call obs_headSet_i(obsdat,OBS_RLN,OBSN,1)
!call obs_headSet_i(obsdat,OBS_IDO,OBSN,kk)
ENDIF
ENDIF
ENDIF
IF ( allocated(obsvalue) ) THEN
OBSERV(1:NELE,1:NVAL) =obsvalue(1:NELE,1:NVAL,k)
QCFLAGS(1:NELE,1:NVAL) =qcflag (1:NELE,1:NVAL,k)
VCORD(1:NVAL) =VCOORD (1:NVAL,k)
NDATA= WRITE_BODY(obsdat,familytype,RELEV,VCORD,OBSERV,qcflags,NELE,NVAL,LISTE_ELE,SURF_EMIS)
IF (NDATA .gt. 0) THEN
IF (NDATA_SF .eq. 0) THEN
call WRITE_HEADER(obsdat,STNID,XLAT,XLON,YMD_DATE,HM,idtyp,STATUS,RELEV,FILENUMB)
OBSN=obs_numHeader(obsdat)
call obs_setFamily(obsdat,trim(FAMILYTYPE), OBSN )
ENDIF
OBSN=obs_numHeader(obsdat)
call obs_headSet_i(obsdat,OBS_NLV,OBSN,NDATA+NDATA_SF)
IF (OBSN .GT. 1 ) THEN
LN= obs_headElem_i(obsdat,OBS_RLN,OBSN-1) + obs_headElem_i(obsdat,OBS_NLV,OBSN-1)
call obs_headSet_i(obsdat,OBS_RLN,OBSN,LN)
!call obs_headSet_i(obsdat,OBS_IDO,OBSN,kk)
ELSE
call obs_headSet_i(obsdat,OBS_RLN,OBSN,1)
!call obs_headSet_i(obsdat,OBS_IDO,OBSN,kk)
ENDIF
ENDIF
ENDIF
!============ IASI =====================================
if ( allocated(RADMOY) .and. NDATA .gt. 0 ) then
OBSN=obs_numHeader(obsdat)
iclass=1
do iobs=OBS_CF1,OBS_CF7
if(obs_columnActive_IH(obsdat,iobs)) then
call obs_headSet_i(obsdat,iobs,OBSN,CFRAC(iclass,k))
iclass=iclass+1
endif
enddo
iclass=1
ichan=1
do iobs=OBS_M1C1,OBS_M7C6
if(obs_columnActive_RH(obsdat,iobs)) then
call obs_headSet_r(obsdat,iobs,OBSN,RADMOY(iclass,ichan,k))
ichan=ichan+1
if (ichan>obs_getNchanAvhrr()) then
ichan=1
iclass=iclass+1
endif
endif
enddo
iclass=1
ichan=1
do iobs=OBS_S1C1,OBS_S7C6
if(obs_columnActive_RH(obsdat,iobs)) then
call obs_headSet_r(obsdat,iobs,OBSN,radstd(iclass,ichan,k))
ichan=ichan+1
if (ichan>obs_getNchanAvhrr()) then
ichan=1
iclass=iclass+1
endif
endif
enddo
endif
!============ IASI =====================================
ENDIF
if (allocated(TRINFO)) then
IF ( NDATA .gt. 0 ) then
call WRITE_INFO(obsdat,familytype, TRINFO,LISTE_INFO,NELE_INFO )
ENDIF
endif
end do
!---------UPPER AIR---------------------------
if ( allocated(obsvalue) ) then
DEALLOCATE ( obsvalue,VCOORD,VCORD,observ)
end if
if ( allocated(qcflag) ) then
DEALLOCATE (qcflag,qcflags)
end if
if ( allocated(EMIS) ) then
DEALLOCATE (EMIS,SURF_EMIS)
end if
!---------SURFACE-----------------------------
if ( allocated(obsvalue_sfc) ) then
DEALLOCATE(obsvalue_sfc,vcoord_sfc,OBSERV_SFC)
endif
if ( allocated(qcflag_sfc) ) then
DEALLOCATE( qcflag_sfc, qcflags_SFC)
endif
!--------SURFACE------------------------------
if ( allocated(lat) ) then
DEALLOCATE (lat,lon,date,hhmm,glbflag)
endif
if ( allocated(hlat) ) then
DEALLOCATE (hlat,hlon,htime)
endif
if ( allocated(hlat_sfc) ) then
DEALLOCATE (hlat_sfc,hlon_sfc,htime_sfc)
endif
if ( allocated(rinfo) ) then
DEALLOCATE (rinfo,trinfo)
endif
if ( allocated(RADMOY) ) then
DEALLOCATE (RADMOY,CFRAC,radstd)
endif
end do REPORTS
end if
Deallocate(address)
if ( flag_passage1 == 1 ) then
write(*,*)
write(*,*) ' descriptor block for grouped data present '
end if
if ( flag_passage2 == 1 ) then
write(*,*)
write(*,*) '- info block Present '
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
Call BURP_Free(File_in, IOSTAT=error)
Call BURP_Free(Rpt_in, IOSTAT=error)
Call BURP_Free(Block_in, IOSTAT=error)
write(*,*)' file Nobs SUM = ',trim(brp_file),obs_numHeader(obsdat),SUM
END SUBROUTINE READBURP
integer function cvt_burp_instrum2(sensor) 1
!
! func CVT_BURP_INSTRUM : Map burp satellite sensor indicator (element #2048) to
! the corresponding burp satellite instrument (element
! #2019).
!
! Author : J. Halle CMDA/SMC May 2002
! Revision:
! J.W. Blezius ARMA Feb 2011 - converted from subroutine to a function
!
! Purpose: Map burp satellite sensor indicator (element #2048) to
! burp satellite instrument (element #2019). This is a more
! complete common element, allowing for future expansion.
!
! Table of BURP satellite sensor indicator element #002048
! --------------------------------------------------------
! Satellite sensor BURP satellite sensor indicator
! ---------------- -------------------------------
! HIRS 0
! MSU 1
! SSU 2
! AMSUA 3
! AMSUB 4
! AVHRR 5
! SSMI 6
! NSCAT 7
! SEAWINDS 8
! Reserved 9-14
! Missing value 15
!
implicit none
integer :: sensor ! BURP satellite sensor indicator (element #2048)
integer :: instrument ! BURP satellite instrument (element #2019)
select case (sensor)
case (000); instrument=606 ! HIRS
case (001); instrument=623 ! MSU
case (002); instrument=627 ! SSU
case (003); instrument=570 ! AMSUA
case (004); instrument=574 ! AMSUB
case (005); instrument=591 ! AVHRR
case (006); instrument=905 ! SSMI
case (007); instrument=312 ! NSCAT
case (008); instrument=313 ! SEAWINDS
case (015); instrument=2047 ! Missing value
case default; instrument=2047 ! Unrecognized value
end select
cvt_burp_instrum2 = instrument
return
end function cvt_burp_instrum2
FUNCTION WRITE_BODY(obsdat,FAMTYP, ELEV,VERTCOORD & 4,30
,obsvalue,qcflag,NELE,NVAL,LISTE_ELE,SURF_EMIS)
type (struct_obs), intent(inout) :: obsdat
INTEGER :: WRITE_BODY
REAL , allocatable :: OBSVALUE(:,:)
REAL , allocatable,optional :: SURF_EMIS(:)
INTEGER, allocatable :: QCFLAG(:,:)
REAL , allocatable :: VERTCOORD(:)
CHARACTER*2 :: FAMTYP
REAL :: ELEVFACT,VCOORD,ZFACT,INFOV
INTEGER :: NELE,NVAL
integer :: LISTE_ELE(:)
INTEGER :: ID_OBS,ID_DATA
INTEGER :: NOBS
INTEGER :: VARNO,IL,J,COUNT,NLV
INTEGER :: IFLAG,LN,BITSflagoff,BITSflagon
REAL(OBS_REAL) :: MISG,OBSV,ELEV,ELEV_R,REMIS
INTEGER :: VCO
INTEGER :: NONELEV
REAL :: ZEMFACT
LOGICAL :: L_EMISS
if(present(SURF_EMIS)) then
L_EMISS=.true.
else
L_EMISS=.false.
endif
NONELEV =-1
MISG=PPMIS
ZEMFACT=0.01
BITSflagoff=0
DO J = 1, Bnbitsoff
BITSflagoff = IBSET ( BITSflagoff, 13-BBITOFF(J) )
END DO
BITSflagon=0
DO J = 1, Bnbitson
BITSflagon = IBSET ( BITSflagon, 13-BBITON(J) )
END DO
!write(*,*) ' write body BITSFLAGON= ',BITSFLAGON, ' BITSFLAGOFF= ',BITSFLAGOFF
NOBS =obs_numHeader(obsdat) +1
COUNT=obs_numBody (obsdat)
NLV=0
id_obs=NOBS
if ( trim(FAMTYP) .eq. trim('PR') .OR. trim(FAMTYP) .eq. trim('SF') ) then
ELEVFACT=1.
else
ELEVFACT=0.
endif
if ( trim(FAMTYP) .eq. trim('TO') ) then
!ELEV=0.
ENDIF
SELECT CASE(FAMTYP)
CASE ( 'UA' , 'SW' , 'AI')
VCO=2 ! PRESSURE COORD
CASE ( 'SF' , 'SC', 'PR', 'RO', 'GP' )
VCO=1 ! HEIGHT COORD
CASE ( 'TO' )
VCO=3 ! CHANNEL NUMBER
END SELECT
!-------------------SPECIAL CASES--------------
DO il = 1, NELE
varno=LISTE_ELE(il)
DO j = 1, NVAL
VCOORD=VERTCOORD(j)
OBSV = obsvalue(il,j)
if( L_EMISS .eqv. .true.) then
if( SURF_EMIS(j) .ne. MISG) then
REMIS = SURF_EMIS(j)*ZEMFACT
else
REMIS = MISG
endif
endif
IFLAG = INT(qCflag(il,j))
if(iand(iflag,BITSflagoff) .ne.0) cycle
!burpmodule IFLAG = IBCLR(IFLAG,12)
!if (VARNO .eq. .10194)OBSV=OBSV*RG
if ( obsv .ne. PPMIS .and. VCOORD .ne. PPMIS ) then
count = count + 1
NLV= NLV +1
ID_DATA=count
IFLAG = IBCLR(IFLAG,12)
call obs_bodySet_r(obsdat,OBS_VAR,count,OBSV)
call obs_bodySet_i(obsdat,OBS_VNM,count,VARNO)
call obs_bodySet_i(obsdat,OBS_VCO,count,VCO)
ELEV_R=VCOORD + ELEV*ELEVFACT
call obs_bodySet_r(obsdat,OBS_PPP,count, ELEV_R)
call obs_bodySet_i(obsdat,OBS_VNM,count,VARNO)
call obs_bodySet_i(obsdat,OBS_FLG,count,IFLAG)
if ( REMIS .ne. PPMIS .and. FAMTYP .eq. 'TO') THEN
call obs_bodySet_r(obsdat,OBS_SEM,count,REMIS)
else
call obs_bodySet_r(obsdat,OBS_SEM,count,MISG)
endif
!call obs_set_i(obsdat,'OBS',count,NOBS)
call obs_bodySet_i(obsdat,OBS_VCO,count,VCO)
!call obs_bodySet_i(obsdat,OBS_IDD,count,ID_DATA)
!call obs_bodySet_i(obsdat,OBS_IDD,count,0)
if ( varno .eq. 11001 .or. varno .eq. 11011) then
call obs_bodySet_r(obsdat,OBS_VAR,count,OBSV)
if ( varno .eq. 11001) then
call obs_bodySet_i(obsdat,OBS_VNM,count+1,11003)
call obs_bodySet_i(obsdat,OBS_FLG,count+1,0)
!call obs_bodySet_i(obsdat,OBS_IDD,count+1,-1)
ELEV_R=VCOORD + ELEV*ELEVFACT
call obs_bodySet_r(obsdat,OBS_PPP,count+1,ELEV_R)
call obs_bodySet_i(obsdat,OBS_VCO,count+1,VCO)
call obs_bodySet_i(obsdat,OBS_VNM,count+2,11004)
!call obs_set_i(obsdat,'OBS',count+2,NOBS)
call obs_bodySet_i(obsdat,OBS_FLG,count+2,0)
!call obs_bodySet_i(obsdat,OBS_IDD,count+2,-1)
call obs_bodySet_r(obsdat,OBS_PPP,count+2,ELEV_R)
call obs_bodySet_i(obsdat,OBS_VCO,count+2,VCO)
else
call obs_bodySet_i(obsdat,OBS_VNM,count+1,11215)
call obs_bodySet_i(obsdat,OBS_FLG,count+1,0)
!call obs_bodySet_i(obsdat,OBS_IDD,count+1,-1)
ELEV_R=VCOORD + ELEV*ELEVFACT
call obs_bodySet_r(obsdat,OBS_PPP,count+1,ELEV_R)
call obs_bodySet_i(obsdat,OBS_VCO,count+1,VCO)
call obs_bodySet_i(obsdat,OBS_VNM,count+2,11216)
call obs_bodySet_i(obsdat,OBS_FLG,count+2,0)
!call obs_bodySet_i(obsdat,OBS_IDD,count+2,-1)
call obs_bodySet_r(obsdat,OBS_PPP,count+2,ELEV_R)
call obs_bodySet_i(obsdat,OBS_VCO,count+2,VCO)
endif
call obs_bodySet_r(obsdat,OBS_VAR,count+1,MISG)
call obs_bodySet_r(obsdat,OBS_VAR,count+2,MISG)
count = count + 2
NLV = NLV + 2
endif
endif
END DO
END DO
WRITE_BODY=NLV
END FUNCTION WRITE_BODY
subroutine GET_HEADER(obsdat, LAT,LON,DATE,TIME,CODTYP,STATUS,ELEV,NOBS,FILENUMB),9
type (struct_obs), intent(inout) :: obsdat
INTEGER :: DATE,TIME,CODTYP,STATUS,FILENUMB
REAL(OBS_REAL) :: ELEV,LAT,LON
INTEGER :: LN,NOBS
NOBS=obs_numHeader(obsdat)
LAT = obs_headElem_r(obsdat,OBS_LAT,nobs)
LON = obs_headElem_r(obsdat,OBS_LON,nobs)
DATE = obs_headElem_i(obsdat,OBS_DAT,nobs)
TIME = obs_headElem_i(obsdat,OBS_ETM,nobs)
CODTYP = obs_headElem_i(obsdat,OBS_ITY,nobs)
STATUS = obs_headElem_i(obsdat,OBS_ST1,nobs)
!NOBS = obs_headElem_i(obsdat,OBS_IDO,nobs)
FILENUMB= obs_headElem_i(obsdat,OBS_OTP,nobs)
ELEV = obs_headElem_r(obsdat,OBS_ALT,nobs)
RETURN
END SUBROUTINE GET_HEADER
SUBROUTINE WRITE_HEADER(obsdat, STNID,LAT,LON,DATE,TIME,CODTYP,STATUS,ELEV,FILENUMB) 4,11
type (struct_obs), intent(inout) :: obsdat
CHARACTER(LEN=9) :: STNID
INTEGER :: DATE,TIME,CODTYP,STATUS
INTEGER :: FILENUMB
REAL(OBS_REAL) :: ELEV,LAT,LON
INTEGER :: LN,NOBS
NOBS=obs_numHeader(obsdat) +1
call obs_headSet_i(obsdat,OBS_ONM,nobs,nobs)
call obs_headSet_r(obsdat,OBS_LAT,nobs,LAT)
call obs_headSet_r(obsdat,OBS_LON,nobs,LON)
call obs_headSet_i(obsdat,OBS_DAT,nobs,DATE)
call obs_headSet_i(obsdat,OBS_ETM,nobs,TIME)
call obs_headSet_i(obsdat,OBS_ITY,nobs,CODTYP)
call obs_headSet_i(obsdat,OBS_ST1,nobs,STATUS)
!call obs_headSet_i(obsdat,OBS_IDO,nobs,NOBS)
call obs_headSet_r(obsdat,OBS_ALT,nobs,ELEV)
!call obs_headSet_i(obsdat,OBS_IDF,nobs,FILENUMB)
call obs_headSet_i(obsdat,OBS_OTP,nobs,FILENUMB)
call obs_set_c(obsdat,'STID',nobs,STNID )
END SUBROUTINE WRITE_HEADER
subroutine WRITE_INFO(obsdat,FAMTYP, RINFO,LISTE_INFO,NELE_INFO ) 1,16
type (struct_obs), intent(inout) :: obsdat
!REAL , allocatable :: RINFO(:)
REAL :: RINFO(NELE_INFO)
CHARACTER*2 :: FAMTYP
REAL*4 :: INFOV
INTEGER :: NELE_INFO
integer :: LISTE_INFO(NELE_INFO)
INTEGER :: CODTYP
INTEGER :: IL,J,NOBS
INTEGER :: SENSOR,ID_SAT,INSTRUMENT,LAND_SEA
INTEGER :: TERRAIN_TYPE,ZENITH,SOLAR_ZENITH,AZIMUTH,CLOUD_COVER,SOLAR_AZIMUTH
INTEGER :: IGQISFLAGQUAL,IGQISQUALINDEXLOC,ITANGENT_RADIUS,IGEOID,IRO_QCFLAG
REAL :: RSOLAR_ZENITH,RCLOUD_COVER,RZENITH,RAZIMUTH,RSOLAR_AZIMUTH
REAL :: RIGQISFLAGQUAL,RIGQISQUALINDEXLOC
REAL :: RTERRAIN_TYPE,RLAND_SEA,RID_SAT,RSENSOR,RINSTRUMENT,RRO_QCFLAG
REAL(OBS_REAL) :: RTANGENT_RADIUS,RGEOID
NOBS=obs_numHeader(obsdat)
CODTYP=obs_headElem_i(obsdat,OBS_ITY,NOBS)
!write(*,*)' DEBUT WRITE_INFO NOBS CODTYP ----> ',NOBS,CODTYP,size(liste_info),size(RINFO),liste_info
LAND_SEA =0
INSTRUMENT=0
ID_SAT =0
ZENITH =0
SENSOR =0
AZIMUTH =0
SOLAR_AZIMUTH = 0
SOLAR_ZENITH = 0
RTANGENT_RADIUS=PPMIS
RGEOID=PPMIS
!CLOUD_COVER = 0
!if ( allocated(rinfo) ) then
do il=1,NELE_INFO
INFOV=rinfo(il)
SELECT CASE( liste_info(il) )
CASE( 1007)
RID_SAT=INFOV
IF (RID_SAT .eq. PPMIS ) THEN
ID_SAT=0
ELSE
ID_SAT=NINT(RID_SAT)
ENDIF
CASE( 2048)
RSENSOR=INFOV
if (RSENSOR .eq. PPMIS ) THEN
SENSOR=-99
ELSE
SENSOR=NINT(RSENSOR)
ENDIF
CASE( 2019)
RINSTRUMENT=INFOV
if (RINSTRUMENT .eq. PPMIS ) THEN
INSTRUMENT=0
ELSE
INSTRUMENT=NINT(RINSTRUMENT)
ENDIF
CASE( 7024)
RZENITH=INFOV
if (RZENITH .eq. PPMIS ) THEN
ZENITH=9000
ELSE
ZENITH=NINT ( (90.0 + RZENITH)*100 )
ENDIF
CASE( 7025)
RSOLAR_ZENITH =INFOV
if (RSOLAR_ZENITH .eq. PPMIS ) THEN
SOLAR_ZENITH=0
SOLAR_ZENITH=-99
ELSE
SOLAR_ZENITH=NINT ( (90.0 + RSOLAR_ZENITH)*100 )
ENDIF
CASE( 5021)
RAZIMUTH=INFOV
if (RAZIMUTH .eq. PPMIS ) THEN
AZIMUTH=0
ELSE
AZIMUTH=NINT ( (RAZIMUTH)*100 )
ENDIF
CASE( 33060)
RIGQISFLAGQUAL=INFOV
if (RIGQISFLAGQUAL .eq. PPMIS ) then
IGQISFLAGQUAL=0
ELSE
IGQISFLAGQUAL=NINT ( RIGQISFLAGQUAL )
ENDIF
CASE( 33062)
RIGQISQUALINDEXLOC=INFOV
if (RIGQISQUALINDEXLOC .eq. PPMIS ) then
IGQISQUALINDEXLOC=0
ELSE
IGQISQUALINDEXLOC=NINT ( RIGQISQUALINDEXLOC )
ENDIF
CASE( 5022)
RSOLAR_AZIMUTH=INFOV
if (RSOLAR_AZIMUTH .eq. PPMIS ) then
SOLAR_AZIMUTH=0
SOLAR_AZIMUTH=-99
ELSE
SOLAR_AZIMUTH=NINT ( (RSOLAR_AZIMUTH)*100 )
ENDIF
CASE( 8012)
RLAND_SEA=INFOV
if (RLAND_SEA .eq. PPMIS ) THEN
LAND_SEA=99
ELSE
LAND_SEA=NINT ( RLAND_SEA )
ENDIF
CASE( 13039)
RTERRAIN_TYPE=INFOV
if (RTERRAIN_TYPE .eq. PPMIS ) THEN
TERRAIN_TYPE=99
ELSE
TERRAIN_TYPE=NINT ( RTERRAIN_TYPE )
ENDIF
CASE( 20010)
RCLOUD_COVER=INFOV
if (RCLOUD_COVER .eq. PPMIS ) THEN
CLOUD_COVER=0
ELSE
CLOUD_COVER=NINT ( RCLOUD_COVER )
ENDIF
CASE( 10035)
RTANGENT_RADIUS=INFOV
CASE( 10036)
RGEOID=INFOV
CASE( 33039)
RRO_QCFLAG=INFOV
if (RRO_QCFLAG .eq. PPMIS ) THEN
IRO_QCFLAG=-99
ELSE
IRO_QCFLAG=NINT ( RRO_QCFLAG )
ENDIF
END SELECT
end do
!-------------------SPECIAL CASES--------------
! INSTRUMENT
IF ( SENSOR .EQ. -99)then
IF ( INSTRUMENT .EQ. -99)then
INSTRUMENT=0
ENDIF
ELSE
INSTRUMENT = cvt_burp_instrum2(sensor)
ENDIF
! AIRS
IF ( INSTRUMENT == 420 ) ID_SAT = 784
if ( trim(FAMTYP) .eq. trim('GO') ) then
LAND_SEA=0
ZENITH=0
ENDIF
!-------------------SPECIAL CASES--------------
! Is terrain type sea ice (iterrain=0)?, If so, set imask=2.
IF ( TERRAIN_TYPE .EQ. 0 ) THEN
LAND_SEA = 2
ENDIF
call obs_headSet_i(obsdat,OBS_OFL,nobs,LAND_SEA)
call obs_headSet_i(obsdat,OBS_INS,nobs,INSTRUMENT )
call obs_headSet_i(obsdat,OBS_SZA,nobs,ZENITH )
call obs_headSet_i(obsdat,OBS_CLF,nobs,CLOUD_COVER )
call obs_headSet_i(obsdat,OBS_AZA,nobs,AZIMUTH )
call obs_headSet_i(obsdat,OBS_SUN,nobs,SOLAR_ZENITH )
call obs_headSet_i(obsdat,OBS_SAZ,nobs,SOLAR_AZIMUTH )
call obs_headSet_i(obsdat,OBS_SAT,nobs,ID_SAT)
call obs_headSet_i(obsdat,OBS_GQF,nobs,IGQISFLAGQUAL)
call obs_headSet_i(obsdat,OBS_GQL,nobs,IGQISQUALINDEXLOC)
!if( trim(FAMTYP) .eq. trim('RO'))print *, 'geoid QCFLAG TANGENT_RADIUS GEOID=',IRO_QCFLAG,RTANGENT_RADIUS,RGEOID
call obs_headSet_i(obsdat,OBS_ROQF,nobs,IRO_QCFLAG)
call obs_headSet_r(obsdat,OBS_TRAD,nobs,RTANGENT_RADIUS)
call obs_headSet_r(obsdat,OBS_GEOI,nobs,RGEOID)
END SUBROUTINE WRITE_INFO
INTEGER FUNCTION FIND_INDEX(LIST,ELEMENT) 2
INTEGER LIST(:)
INTEGER I,ELEMENT
FIND_INDEX=-1
do I=1,size (LIST)
if (list(i) .eq. element) THEN
FIND_INDEX=i
exit
endif
end do
RETURN
END FUNCTION FIND_INDEX
end module burp_read