! reads Env Canada "bufr_decoder -dump" and writes CSV
! by TOYODA Eizi, 2014. Licensed LGPLv3 (same as libecbufr).
PROGRAM READDUMP
  IMPLICIT NONE
  ! number of maximum columns i.e. data elements in BUFR subset
  INTEGER, PARAMETER:: NCOL = 256
  ! number of maximum rows i.e. data subsets in BUFR
  INTEGER, PARAMETER:: NROW = 8192
  ! undefined value
  DOUBLE PRECISION, PARAMETER:: UNDEF = -HUGE(0.0D0)
  ! the data array
  DOUBLE PRECISION:: DBUF(NCOL, NROW) = UNDEF
  ! BUFR element descriptors to describe columns
  INTEGER:: ELEM(NCOL) = 0
  ! If true the column is string type
  LOGICAL:: STRP(NCOL) = .FALSE.
  ! separator string
  CHARACTER(*), PARAMETER:: SSEP = 'VALUE='
  ! output format for header
  CHARACTER(80):: FMTH
  ! output format for data
  CHARACTER(80):: FMTD
  ! input file unit
  INTEGER:: INFILE
  ! count of actual row / column
  INTEGER:: CCOL = 0, CROW = 0
  ! index for row / column
  INTEGER:: IROW, ICOL
  ! temporary line buffer
  CHARACTER(80):: LINE, WORD
  ! temporary data value in floating point
  DOUBLE PRECISION:: DVAL
  ! temporary data value in integer
  INTEGER:: IVAL
  ! IOSTAT to detect I/O error
  INTEGER:: IOS
  ! position of colon
  INTEGER:: CPOS
  ! element number (element descriptor in BUFR)
  INTEGER:: ELNO
CONTINUE
  !
  ! === open dump file ===
  !
  INFILE = OPENTEXT()
  IF (INFILE < 0) CALL STOP('OPEN ERROR')
  !
  ! === read dump file ===
  !
  IROW = 1
  ICOL = 1

  ! infinite loop until read error happens
LINES: DO
    READ(INFILE, '(A)', IOSTAT=IOS) LINE
    IF (IOS /= 0) EXIT LINES 

    ! header for the subset
    IF (STARTS_WITH(LINE, 'DATASUBSET')) THEN
      CPOS = INDEX(LINE, ':')
      WORD = LINE(12:CPOS-1) 
      READ(WORD, '(I16)') IROW
      IF (IROW > NROW) CALL STOP('TOO MANY SUBSETS - RECOMPILE ME')
      CROW = MAX(CROW, IROW)
      ICOL = 0
      CYCLE LINES
    ENDIF

    ! skip file header and
    !  descriptors without data (starts with '1', '2', or '3')
    IF (LINE(1:1) /= '0') THEN
      CYCLE LINES
    ENDIF

    ! now it is certain the line is descriptor-data pair.
    ICOL = ICOL + 1
    IF (ICOL > NCOL) CALL STOP('TOO MANY ELEMENTS - RECOMPILE ME')

    ! decodes descriptor number
    READ(LINE(1:6), '(I6)', IOSTAT=IOS) ELNO
    IF (IOS /= 0) CALL STOP('FMTERR(E,' // TRIM(LINE) // ')')
    IF (ELEM(ICOL) == 0) THEN
      ELEM(ICOL) = ELNO
      ! string type if the value contains double quote
      STRP(ICOL) = CONTAINS(LINE, '"')
      CCOL = MAX(ICOL, CCOL)
    ELSE
      IF (ICOL > CCOL) CALL STOP('MORE ELEMENTS THAN IN 1ST ROW')
      IF (ELNO /= ELEM(ICOL)) CALL STOP('VARYING TEMPLATE UNSUPPORTED')
    ENDIF

    ! decodes value, depending on type
    WORD = LINE(8:)
    ! skip repetition number
    IF (WORD(1:1) == '{') THEN
      CPOS = INDEX(WORD, '}')
      IF (CPOS > 0) WORD = WORD(CPOS+2:)
    ENDIF
    IF (STRP(ICOL)) THEN
      ! string type [fake] - only first 8 chars stored
      CPOS = INDEX(WORD, '"')
      IF (CPOS > 0) WORD = WORD(CPOS+1:)
      CPOS = INDEX(WORD, '"')
      IF (CPOS > 0) WORD = WORD(1:CPOS-1)
      DVAL = TRANSFER(WORD, DVAL)
    ELSEIF (CONTAINS(WORD, 'MSNG')) THEN
      ! missing value
      DVAL = UNDEF
    ELSEIF (CONTAINS(WORD, '.')) THEN
      ! double precision if there is full stop
      READ(WORD, '(G20.10)', IOSTAT=IOS) DVAL
    ELSE
      ! integer or code/flag reference if full stop is missing
      READ(WORD, '(I16)', IOSTAT=IOS) IVAL
      DVAL = IVAL
    ENDIF
    IF (IOS /= 0) CALL STOP('FMTERR(V,' // TRIM(LINE) // ')')
    DBUF(ICOL, IROW) = DVAL 
  END DO LINES
  !
  ! === report the result ===
  !
  WRITE(FMTH, '("(I5,",I3,A,")")') CCOL, '(",",I15.6)'
  WRITE(FMTD, '("(I5,",I3,A,")")') CCOL, '(",",G15.10)'
  WRITE(*, FMTH) CROW, (ELEM(ICOL), ICOL = 1, CCOL)
  DO, IROW = 1, CROW
    WRITE(*, FMTD) IROW, (DTOA(DBUF(ICOL, IROW), STRP(ICOL)), ICOL = 1, CCOL)
  ENDDO
CONTAINS

  ! assuming unit number zero is standard error
  SUBROUTINE INFO(MSG)
    CHARACTER(*), INTENT(IN):: MSG
    WRITE(0, '(A)') MSG
  END SUBROUTINE INFO

  SUBROUTINE STOP(MSG)
    CHARACTER(*), INTENT(IN):: MSG
    WRITE(0, '(A)') '#ERR# ' // MSG
    STOP 16
  END SUBROUTINE STOP

  LOGICAL FUNCTION STARTS_WITH(SA, SB)
    CHARACTER(*), INTENT(IN):: SA
    CHARACTER(*), INTENT(IN):: SB
    STARTS_WITH = (SA(1:LEN(SB)) == SB)
  END FUNCTION STARTS_WITH

  LOGICAL FUNCTION CONTAINS(SA, SB)
    CHARACTER(*), INTENT(IN):: SA
    CHARACTER(*), INTENT(IN):: SB
    CONTAINS = (INDEX(SA, SB) >= 1)
  END FUNCTION CONTAINS

  CHARACTER(15) FUNCTION DTOA(X, STRINGP)
    DOUBLE PRECISION, INTENT(IN):: X
    LOGICAL, INTENT(IN):: STRINGP
    CHARACTER(15):: OBUF
    INTEGER:: PPOS
    IF (STRINGP) THEN
      OBUF = '"' // TRANSFER(X, OBUF(1:8)) // '"'
    ELSE
      WRITE(OBUF, '(G15.10)') X
      PPOS = INDEX(OBUF, '.')
      ! if fractional part is all digit zero, omit it
      IF (PPOS > 0) THEN
        IF (VERIFY(OBUF(PPOS+1:), '0 ') == 0) THEN
          OBUF = OBUF(1:PPOS-1)
        ENDIF
      ENDIF
    ENDIF
    DTOA = ADJUSTR(OBUF)
  END FUNCTION DTOA

  INTEGER FUNCTION OPENTEXT()
    CHARACTER(256):: FILENAME
    INTEGER:: I, R
    LOGICAL:: OP, EX
    ! searches for unit number unused
    DO, R = 10, 100
      INQUIRE(UNIT=R, EXIST=EX, OPENED=OP)
      IF (EX .AND. .NOT. OP) EXIT
    ENDDO
    IF (OP .OR. .NOT. EX) CALL STOP('RUNNING OUT OF UNIT NUMBER')
    ! reads the filename from standard input and opens the file
    READ(*, '(A)', IOSTAT=I) FILENAME
    IF (I /= 0) CALL STOP('READING FILENAME')
    OPEN(UNIT=R, FILE=FILENAME, ACCESS='SEQUENTIAL', FORM='FORMATTED', IOSTAT=I)
    IF (I /= 0) CALL STOP('OPEN(' // TRIM(FILENAME) // ')')
    CALL INFO('OPEN(' // TRIM(FILENAME) // ')')
    OPENTEXT = R
  END FUNCTION OPENTEXT

END PROGRAM