! $Id: bufr2ropp_ec.f90 2738 2011-03-22 15:34:18Z frdo $ PROGRAM bufr2ropp_eccodes !****x* Programs/bufr2ropp_eccodes * ! ! NAME ! bufr2ropp (bufr2ropp_eccodes.f90) ! ! SYNOPSIS ! Decode RO BUFR message(s) to ROPP file(s) [ECMWF ecCodes library] ! ! > export BUFR_TABLES=bufr_directory_path ! > bufr2ropp bufr_file [bufr_file...] [-o ropp_file] [-m] [-a] ! [-f first] [-n number] [-d] [-h] [-v] ! ! ARGUMENTS ! bufr_file - one or more files containing BUFR messages ! ! OPTIONS ! Option switches can be in any order and are case-insensitive; ! any space(s) between a switch and its (madatory) argument is ! optional. ! -o specify the ROPP output file name. Not recommended if more ! than one RO BUFR message could be decoded. ! -f specify the first RO BUFR message to decode ! (ie skip first-1 messages) ! -n specify the maximum number of RO messages to decode ! -d to output additional diagnostics ! -h help ! -v version information ! Defaults: ! Input file name : ropp.bufr ! Output file name : .nc (netCDF) ! first : 1 ! number : 999999 (all) ! ! INPUTS ! bufr_file is the input file containing BUFR message(s). ! The input file can contain any number of aribitrary ! BUFR messages, but any which do not contain RO data ! (or have coding errors) will be ignored. (See Ref.1) ! ! OUTPUTS ! ropp_file is the output file, which will be created in ROPP netCDF. ! The output file name is optional, and if not specified, ! is generated from the occulation ID. ! One output file will be written for each input RO ! BUFR message. NB: as any existing output file will be ! overwritten, using the -o option could lose data if ! there is more than one RO BUFR message in the input ! file. If this is a possibility, let the program ! generate default (and unique) file names. (See Ref.2) ! ! CALLS ! IARGC ! GetOptions ! ReplicationCount ! ConvertBUFRtoROPP ! ropp_io_init ! ropp_io_write ! ropp_io_nrec ! ropp_io_free ! ropp_io_version ! PBOPEN ! PBCLOSE ! PBBUFR ! BUFREX ! BUSEL ! Date_and_Time_UTC ! File_Delete ! message ! message_set_routine ! ! MODULES ! bufr2ropp - fixed parameter definitions & common routines ! ropp_io - ROPP I/O file support ! ropp_io_types - ROPP derived type definitions ! BUFRutils - BUFR utility routines ! DateTimeProgs - Date & Time conversion routines ! DateTimeTypes - Date & Time conversion definitions ! ! DEPENDENCIES ! ECMWF BUFR package - BUFR kernel routines ! ROPP I/O library - ROPP file I/O support ! ROPP Utils library - ROPP utility routines ! netCDF library - netCDF file support ! roppbufrcodes.nl - NAMELIST file (in BUFR_TABLES) ! ! ENVIRONMENT VARIABLES ! BUFR_TABLES - path for run-time files ! ! ERRORS ! Program (shell) return codes: ! 0 = OK ! 1 = At least one Warning occurred ! 2 = At least one Error occurred ! 3 = A Fatal error occurred ! ! DESCRIPTION ! A BUFR decoder for Radio Occultation data. ! By default, outputs one ROPP file per RO BUFR message in the ! input file. ! Options are available to skip a first block of messages, ! to limit the number of decoded messages and to append decoded ! messages to a single output file. ! BUFR tables are found via the environment variable 'BUFR_TABLES'. ! ! REFERENCES ! 1) WMO FM94 (BUFR) Specification for ROM SAF Processed Radio ! Occultation Data. ! SAF/ROM/METO/FMT/BUFR/001 ! 2) ROPP Input/Output Module User Guide ! SAF/ROM/METO/UG/ROPP/002 ! SEE ALSO ! bufr2ropp(1), ropp2bufr(1) ! ! AUTHOR ! Met Office, Exeter, UK. ! Any comments on this software should be given via the ROM SAF ! Helpdesk at http://www.romsaf.org ! ! COPYRIGHT ! (c) EUMETSAT. All rights reserved. ! For further details please refer to the file COPYRIGHT ! which you should have received as part of this distribution. ! !**** ! Modules USE eccodes USE bufr2ropp USE messages USE ropp_utils, ONLY: File_Delete USE ropp_io_types, ONLY: ROprof USE ropp_io, ONLY: ropp_io_init, & ropp_io_write, & ropp_io_nrec, & ropp_io_free, & ropp_io_version USE BUFRutils, ONLY: ReplicationCount USE DateTimeProgs, ONLY: Date_and_Time_UTC, & MonthOfYear USE DateTimeTypes, ONLY: IdxYear, IdxMonth, IdxDay, & IdxHour, IdxMinute IMPLICIT NONE ! Fixed values CHARACTER (LEN=*), PARAMETER :: Fmt1 = & "(1X,I4,' Non-RO BUFR Message(s) ',A)" CHARACTER (LEN=*), PARAMETER :: Fmt2 = & "(1X,I4,' RO BUFR Message(s) ',A)" CHARACTER (LEN=*), PARAMETER :: DTfmt1 = & ! hh:mm dd-mm-yyyy "(I2.2,':',I2.2,'UT ',I2.2,'-',A3,'-',I4.4)" CHARACTER (LEN=*), PARAMETER :: FmtNum = "(I10)" INTEGER, PARAMETER :: MaxLen = nb/4 ! enough for 500,000 octets ! Local variables CHARACTER (LEN=256), & DIMENSION(:), & ALLOCATABLE :: BUFRdsn ! Name(s) of input file(s) CHARACTER (LEN=256) :: ROPPdsn ! Name of output file INTEGER :: BUFRunit ! BUFR I/O unit (C FILE pointer) INTEGER :: nfiles ! No. of BUFR input files INTEGER :: ierr = 0 ! Error code INTEGER :: nElem ! Expected no. of BUFR elements INTEGER :: ifile ! File loop counter INTEGER :: fMsgToDecode ! First RO BUFR message to decode INTEGER :: nMsgToDecode ! No. of RO BUFR messages to decode INTEGER :: nMsgRead = 0 ! No. of RO BUFR messages read INTEGER :: nMsgDecoded = 0 ! No. of RO BUFR messages decoded INTEGER :: nMsgSkipped = 0 ! No. of RO BUFR messages skipped INTEGER :: nMsgIgnored = 0 ! No. of non-RO BUFR Messages ignored INTEGER :: nMsgWritten = 0 ! Total no. of messages written INTEGER :: nProf = 0 ! No of profiles in an existing file INTEGER :: i=0,j ! Index LOGICAL :: multi ! Multifile output if .T. else single files LOGICAL :: newfile ! Append output if .F. else start a new file LOGICAL :: exists ! file exists flag LOGICAL :: first = .TRUE. ! first output profile flag LOGICAL :: skip ! skip message flag INTEGER :: iBUF(maxLen) ! BUFR message INTEGER :: LenBUF ! Length of BUFR as read (bytes) CHARACTER (LEN=80) :: cValues(nv) ! Decoded character values ! Start ecCodes REAL(KIND=8), DIMENSION(:), ALLOCATABLE :: Values ! *NEW* INTEGER :: iret,iret1,iret2 INTEGER :: ibufr INTEGER , DIMENSION(:), ALLOCATABLE :: ExpDescr INTEGER :: kiter INTEGER :: count=0 CHARACTER(LEN=256) :: key CHARACTER(LEN=256),DIMENSION(20000) :: key_array CHARACTER(LEN=256),DIMENSION(20000) :: main_key_array LOGICAL ,DIMENSION(20000) :: mask_array INTEGER :: tmpDescr ! End ecCodes CHARACTER (LEN=64) :: Names(nd) ! Element names CHARACTER (LEN=24) :: Units(nd) ! Element units INTEGER :: nDescr ! No. of descriptors in Section 3 INTEGER :: nExpDescr ! No. of expanded descriptors INTEGER :: Descr(nd) ! Descriptor(s) in Section 3 (fxxyyy form) INTEGER :: Supp(9) ! Array for Supplimentary info INTEGER :: Sec0(3) ! Array for Section 0 info INTEGER :: Sec1(40) ! Array for Section 1 info INTEGER :: Sec2(4096) ! Array for Section 2 info INTEGER :: Sec3(4) ! Array for Section 3 info INTEGER :: Sec4(2) ! Array for Section 4 info CHARACTER (LEN=80) :: outmsg ! Output text string CHARACTER (LEN=10) :: number ! Numeric value as string CHARACTER (LEN=10) :: MonthName ! Month name TYPE (ROprof) ROdata INTEGER :: nLev1a, nLev1b ! No. of Level 1 samples in BUFR INTEGER :: nLev2a, nLev2b, nLev2c, nLev2d ! No. of Level 2 samples in BUFR INTEGER :: nFreq ! No. of frequency sets in BUFR ! Functions ! Some compilers may need the following declaration to be commented out INTEGER :: IARGC !-------------------------------------------------------------- ! 1. Initalise !-------------------------------------------------------------- CALL message_set_routine ( "bufr2ropp_ecodes" ) CALL message(msg_noin, '') CALL message(msg_noin, & '---------------------------------------------------------------------') CALL message(msg_noin, & ' BUFR (ecCodes) to ROPP Decoder' ) CALL message(msg_noin, & '---------------------------------------------------------------------') CALL message(msg_noin, '') !-------------------------------------------------------------- ! 2. Parse command line !-------------------------------------------------------------- nfiles = MAX ( IARGC(), 1 ) ALLOCATE ( BUFRdsn(nfiles) ) CALL GetOptions ( BUFRdsn, & nfiles, & ROPPdsn, & multi, & newfile, & fMsgToDecode, & nMsgToDecode ) !-------------------------------------------------------------- ! 3. Loop over input BUFR files !-------------------------------------------------------------- DO ifile = 1, nfiles nMsgDecoded = 0 !-------------------------------------------------------------- ! 3.1 Check that input BUFR file exists & try to open it !-------------------------------------------------------------- INQUIRE ( FILE=BUFRdsn(ifile), EXIST=exists ) IF ( .NOT. exists ) THEN CALL message ( msg_error, "Input BUFR file '"// & TRIM(BUFRdsn(ifile))//"' not found" ) CYCLE END IF CALL message ( msg_info, "Reading "//TRIM(BUFRdsn(ifile)) ) CALL codes_open_file(BUFRunit, BUFRdsn(ifile), 'r',ierr) IF ( ierr /= 0 ) THEN CALL message ( msg_error, "Failed to open BUFR input file" ) CYCLE END IF CALL codes_bufr_new_from_file(BUFRunit,ibufr,iret) !-------------------------------------------------------------- ! 3.2 Loop over required messages in input file, skipping ! any unwanted messages, stop on EOF or read error !-------------------------------------------------------------- DO WHILE (iret/=CODES_END_OF_FILE) ! We need to instruct ecCodes to expand all the descriptors ! i.e. unpack the data values CALL codes_set(ibufr,"unpack",1) !-------------------------------------------------------------- ! 3.3 Extract unexpanded & expanded descriptor lists ! Ignore if this isn't an RO message (first unexpanded ! descriptor must be same as ROdescr [310026]) !-------------------------------------------------------------- CALL codes_get(ibufr,'unexpandedDescriptors',Descr(1)) IF ( Descr(1) /= ROdescr ) THEN nMsgIgnored = nMsgIgnored + 1 CALL message ( msg_diag, "Message does not contain RO data - ignored") CYCLE ENDIF !-------------------------------------------------------------- ! 3.4 Extract replication counts !-------------------------------------------------------------- ! Get number of levels CALL codes_get(ibufr,'#1#extendedDelayedDescriptorReplicationFactor',nLev1b) CALL codes_get(ibufr,'#2#extendedDelayedDescriptorReplicationFactor',nLev2a) CALL codes_get(ibufr,'#3#extendedDelayedDescriptorReplicationFactor',nLev2b) ! Get number of frequencies (1 or 3) CALL codes_get(ibufr,'#1#delayedDescriptorReplicationFactor',nFreq) ! Get the expanded data values CALL codes_get(ibufr,'numericValues',Values,iret1) ! Get the expanded descriptors CALL codes_get(ibufr,'bufrdcExpandedDescriptors',ExpDescr,iret2) IF (iret1 == 0 .AND. iret2 == 0) nMsgDecoded = nMsgDecoded + 1 ! Release the bufr message CALL codes_release(ibufr) ! Load the next bufr message CALL codes_bufr_new_from_file(BUFRunit,ibufr,iret) !-------------------------------------------------------------- ! 3.5 Initialise RO data structures. ! - Reserve a single Level 2c (surface geophysical data) sample ! if any Level 2b (geophysical profile) samples ! - No Level 2d data in BUFR !-------------------------------------------------------------- nLev1a = 0 IF ( nLev2b == 0 ) THEN nLev2c = 0 ELSE nLev2c = 1 END IF nLev2d = 0 CALL ropp_io_init ( ROdata, & nLev1a, nLev1b, & nLev2a, nLev2b, nLev2c, nLev2d ) !-------------------------------------------------------------- ! 3.6 No. of BUFR elements expected !-------------------------------------------------------------- nElem = 37 & ! Header + 1 + ROdata%Lev1b%Npoints * ( 5 + nFreq * 6 ) & ! Level 1b + 1 + ROdata%Lev2a%Npoints * 6 & ! Level 2a + 1 + ROdata%Lev2b%Npoints * 10 & ! Level 2b + 7 ! Level 2c CALL message ( msg_diag, "Decoded the following data: " ) WRITE(number, FMT="(I6)") LenBUF CALL message ( msg_diag, " Length of BUFR message : "//TRIM(number)// & " octets" ) WRITE(number, FMT="(I6)") nExpDescr CALL message ( msg_diag, " No. of expanded BUFR descr. : "//TRIM(number) ) WRITE(number, FMT="(I6)") nElem CALL message ( msg_diag, " Total no. of BUFR elements : "//TRIM(number) ) WRITE(number, FMT="(I6)") ROdata%Lev1b%Npoints CALL message ( msg_diag, " No. of bending angle samples : "//TRIM(number) ) IF ( ROdata%Lev1b%Npoints > 0 ) THEN IF ( nFreq == 1 ) THEN CALL message ( msg_diag, " Bending angles present : "// & " Corrected only" ) ELSE CALL message ( msg_diag, " Bending angles present : "// & " L1+L2+Corrected" ) END IF END IF WRITE(number, FMT="(I6)") ROdata%Lev2a%Npoints CALL message ( msg_diag, " No. of refractivity samples : "//TRIM(number) ) WRITE(number, FMT="(I6)") ROdata%Lev2b%Npoints CALL message ( msg_diag, " No. of geophysical samples : "//TRIM(number) ) WRITE(number, FMT="(I6)") ROdata%Lev2c%Npoints CALL message ( msg_diag, " No. of surface geo. samples : "//TRIM(number) ) WRITE(number, FMT="(I6)") ROdata%Lev2d%Npoints CALL message ( msg_diag, " No. of model coeff. levels : "//TRIM(number) ) IF ( nLev1b == 0 .AND. & nLev2a == 0 .AND. & nLev2b == 0 .AND. & nFreq == 0 ) THEN CALL message ( msg_warn, "No recognisable replications - skipping" ) END IF !------------------------------------------------------------- ! 3.7 Convert BUFR array to ROPP derived type parameters !------------------------------------------------------------- CALL ConvertBUFRtoROPP ( Values, & nFreq, & ROdata, & ierr ) WRITE( number, FMT="(I4)") nMsgDecoded CALL message ( msg_info, "Decoded profile "//TRIM(number)// & " : "//TRIM(ROdata%Occ_ID) ) CALL MonthOfYear ( ROdata%DTocc%Month, MonthName, 1 ) WRITE ( outmsg, FMT=DTfmt1 ) ROdata%DTocc%Hour, & ROdata%DTocc%Minute, & ROdata%DTocc%Day, & MonthName(1:3), & ROdata%DTocc%Year WRITE ( number, FMT="(F8.1)" ) ROdata%georef%lat outmsg = TRIM(outmsg)//" ("//ADJUSTL(number) WRITE ( number, FMT="(F8.1)" ) ROdata%georef%lon outmsg = TRIM(outmsg)//","//TRIM(ADJUSTL(number))//")" CALL message ( msg_diag, "Occ. time & (lat,lon) "//": "//TRIM(outmsg) ) !------------------------------------------------------------- ! 3.8 Check/create output file name; explcitly delete any ! existing potential multifile (unless appending) !------------------------------------------------------------- IF ( ROPPdsn == " " ) THEN ROPPdsn = TRIM(ROdata%occ_id) // '.nc' CALL To_Lower ( ROPPdsn ) first = .TRUE. END IF IF ( first ) THEN INQUIRE ( FILE=ROPPdsn, EXIST=exists ) IF ( exists ) THEN IF ( newfile .AND. multi ) THEN CALL File_Delete ( ROPPdsn, ierr ) ELSE nProf = ropp_io_nrec ( ROPPdsn ) IF ( nProf < 0 ) nProf = 1 END IF ELSE newfile = .TRUE. END IF first = .FALSE. END IF !------------------------------------------------------------- ! 3.9 Write to output file !------------------------------------------------------------- CALL message ( msg_info, "Writing "//TRIM(ROPPdsn) ) CALL ropp_io_write ( ROdata, file=ROPPdsn, append=multi ) nMsgWritten = nMsgWritten + 1 ! increment total no. of saved profiles !-------------------------------------------------------------- ! 3.10 Free memory ready for next profile !-------------------------------------------------------------- CALL ropp_io_free ( ROdata ) END DO ! WHILE (iret/=CODES_END_OF_FILE) !-------------------------------------------------------------- ! 3.11 Summary for this file !-------------------------------------------------------------- WRITE ( outmsg, FMT=Fmt2 ) nMsgRead, "read successfully" CALL message ( msg_diag, TRIM(outmsg) ) WRITE ( outmsg, FMT=Fmt1 ) nMsgIgnored, "read but ignored" CALL message ( msg_diag, TRIM(outmsg) ) WRITE ( outmsg, FMT=Fmt2 ) nMsgSkipped, "read but skipped" CALL message ( msg_diag, TRIM(outmsg) ) WRITE ( outmsg, FMT=Fmt2 ) nMsgDecoded, "decoded successfully" CALL message ( msg_diag, TRIM(outmsg) ) WRITE ( outmsg, FMT=Fmt2 ) nMsgWritten, "saved" CALL message ( msg_diag, TRIM(outmsg) ) END DO ! end files loop !-------------------------------------------------------------- ! 4. Show summary over all files !-------------------------------------------------------------- WRITE(number, FMT="(I7)") nMsgWritten IF ( nMsgWritten == 0 ) THEN CALL message ( msg_warn, "No new profiles saved" ) ELSE IF ( nMsgWritten == 1 ) THEN CALL message ( msg_info, " 1 new profile saved" ) ELSE CALL message ( msg_info, TRIM(number)//" new profiles saved in total" ) END IF IF ( nMsgWritten > 0 .AND. .NOT. newfile ) THEN WRITE ( number, FMT="(I7)" ) nProf + nMsgWritten CALL message ( msg_info, TRIM(number)//" profiles now in "//TRIM(ROPPdsn) ) END IF !-------------------------------------------------------------- ! 5. Signal final exit error code !-------------------------------------------------------------- CALL message ( msg_noin, " " ) CALL EXIT(msg_exit_status) END PROGRAM bufr2ropp_eccodes !------------------------------------------------------------------------------- ! 6. Version information !------------------------------------------------------------------------------- SUBROUTINE version_info() USE ropp_io, ONLY : ropp_io_version CHARACTER (LEN=40) :: version version = ropp_io_version() PRINT *, 'bufr2ropp - BUFR to ROPP netCDF decoder [ECMWF ecCodes library]' PRINT *, '' PRINT *, 'This program is part of ROPP (IO) Release ' // TRIM(version) PRINT *, '' END SUBROUTINE version_info