standard.F90

Go to the documentation of this file.

 
 
recursive subroutine stdmsg(cf)
 
  use bufrlib
 
  use moda_msgstd
 
  implicit none
 
  integer bort_target_set
 
  character, intent(in) :: cf
  character*128 bort_str
  character my_cf
 
  ! If we're catching bort errors, set a target return location if one doesn't already exist.
 
  if (bort_target_set() == 1) then
    call catch_bort_stdmsg_c(cf)
    call bort_target_unset
    return
  endif
 
  my_cf = cf
  call capit(my_cf)
  if(my_cf /= 'Y' .and. my_cf /= 'N') then
    write(bort_str,'("BUFRLIB: STDMSG - INPUT ARGUMENT IS ",A1,", IT MUST BE EITHER Y, y, N OR n")') cf
    call bort(bort_str)
  endif
  csmf = my_cf
 
  return
end subroutine stdmsg
 
recursive subroutine stndrd(lunit,msgin,lmsgot,msgot)
 
  use bufrlib
 
  use modv_vars, only: im8b, nbytw, nby5, bmcstr
 
  use moda_s3list
 
  implicit none
 
  integer, intent(in) :: msgin(*), lunit, lmsgot
  integer, intent(out) :: msgot(*)
  integer my_lunit, my_lmsgot, lun, il, im, len0, len1, len2, len3, len4, len5
  integer iad3, iad4, lenn, lenm, iupbs01, iupbs3, iupb, mxbyto, lbyto, ii, isub, itab, mtyp, msbt, inod
  integer istdesc, ncd, iben, ibit, jbit, kbit, mbit, nad4, lsub, nsub, islen, kval, nval, i, k, l, n, bort_target_set
 
  character*128 bort_str
  character*8 subset
  character*4 s5str
  character*1 tab
  character*(*), parameter :: bort_arrayoverflow = &
    'BUFRLIB: STNDRD - OVERFLOW OF OUTPUT (STANDARD) MESSAGE ARRAY; TRY A LARGER DIMENSION FOR THIS ARRAY'
 
  logical found
 
  ! Check for I8 integers.
 
  if(im8b) then
    im8b=.false.
    call x84(lunit,my_lunit,1)
    call x84(lmsgot,my_lmsgot,1)
    call stndrd(my_lunit,msgin,my_lmsgot*2,msgot)
    im8b=.true.
    return
  endif
 
  ! If we're catching bort errors, set a target return location if one doesn't already exist.
 
  if (bort_target_set() == 1) then
    call catch_bort_stndrd_c(lunit,msgin,lmsgot,msgot)
    call bort_target_unset
    return
  endif
 
  ! lunit must point to an open BUFR file.
 
  call status(lunit,lun,il,im)
  if(il==0) call bort('BUFRLIB: STNDRD - BUFR FILE IS CLOSED, IT MUST BE OPEN')
 
  ! Identify the section lengths and addresses in msgin.
 
  call getlens(msgin,5,len0,len1,len2,len3,len4,len5)
 
  iad3 = len0+len1+len2
  iad4 = iad3+len3
 
  lenn = len0+len1+len2+len3+len4+len5
 
  lenm = iupbs01(msgin,'LENM')
 
  if(lenn/=lenm) then
    write(bort_str,'("BUFRLIB: STNDRD - INPUT MESSAGE LENGTH FROM SECTION 0",I6," DOES NOT EQUAL SUM OF ALL INDIVIDUAL '// &
      'SECTION LENGTHS (",I6,")")') lenm,lenn
    call bort(bort_str)
  endif
 
  mbit = (lenn-4)*8
  call upc(s5str,nby5,msgin,mbit,.true.)
  if(s5str/=bmcstr) then
    write(bort_str,'("BUFRLIB: STNDRD - INPUT MESSAGE DOES NOT END WITH ""7777"" (ENDS WITH ",A)') s5str
    call bort(bort_str)
  endif
 
  ! Copy Sections 0 through part of Section 3 into msgot.
 
  mxbyto = (lmsgot*nbytw) - 8
 
  lbyto = iad3+7
  if(lbyto>mxbyto) call bort(bort_arrayoverflow)
  call mvb(msgin,1,msgot,1,lbyto)
 
  ! Rewrite new Section 3 in a standard form.  First, locate the top-level Table A descriptor.
 
  found = .false.
  ii = 10
  do while ((.not.found).and.(ii>=8))
    isub = iupb(msgin,iad3+ii,16)
    call numtab(lun,isub,subset,tab,itab)
    if((itab/=0).and.(tab=='D')) then
      call nemtbax(lun,subset,mtyp,msbt,inod)
      if(inod/=0) found = .true.
    endif
    ii = ii - 2
  enddo
  if(.not.found) call bort('BUFRLIB: STNDRD - TABLE A SUBSET DESCRIPTOR NOT FOUND')
 
  if (istdesc(isub)==0) then
    ! isub is a non-standard Table A descriptor and needs to be expanded into an equivalent standard sequence
    call restd_c(lun,isub,ncd,ids3)
  else
    ! isub is already a standard descriptor, so just copy it "as is" into the new Section 3 (i.e. no expansion is necessary)
    ncd = 1
    ids3(ncd) = isub
  endif
 
  ! Use the edition number to determine the length of the new Section 3.
 
  len3 = 7+(ncd*2)
  iben = iupbs01(msgin,'BEN')
  if(iben<4) then
    len3 = len3+1
  endif
  lbyto = lbyto + len3 - 7
  if(lbyto>mxbyto) call bort(bort_arrayoverflow)
 
  ! Store the descriptors into the new Section 3.
 
  ibit = (iad3+7)*8
  do n=1,ncd
    call pkb(ids3(n),16,msgot,ibit)
  enddo
 
  ! Depending on the edition number, pad out the new Section 3 with an additional zeroed-out byte to ensure an even byte count.
 
  if(iben<4) then
    call pkb(0,8,msgot,ibit)
  endif
 
  ! Store the length of the new Section 3.
 
  ibit = iad3*8
  call pkb(len3,24,msgot,ibit)
 
  ! Now the tricky part - new Section 4.
 
  if(iupbs3(msgin,'ICMP')==1) then
 
    ! The data in Section 4 is compressed and is therefore already standardized, so copy it "as is" into the new Section 4.
 
    if((lbyto+len4+4)>mxbyto) call bort(bort_arrayoverflow)
 
    call mvb(msgin,iad4+1,msgot,lbyto+1,len4)
    jbit = (lbyto+len4)*8
 
  else
 
    nad4 = iad3+len3
 
    ibit = (iad4+4)*8
    jbit = (nad4+4)*8
 
    lbyto = lbyto + 4
 
    ! Copy the subsets, minus the byte counters and bit pads, into the new Section 4.
 
    nsub = iupbs3(msgin,'NSUB')
 
    subset_copy: do i=1,nsub
      call upb(lsub,16,msgin,ibit)
      if(nsub>1) then
        ! Use the byte counter to copy this subset.
        islen = lsub-2
      else
        ! This is the only subset in the message, and it could possibly be an overlarge (> 65530 bytes) subset, in
        ! which case we can't rely on the value stored in the byte counter.  Either way, we don't really need it.
        islen = iad4+len4-(ibit/8)
      endif
      do l=1,islen
        call upb(nval,8,msgin,ibit)
        lbyto = lbyto + 1
        if(lbyto>mxbyto) call bort(bort_arrayoverflow)
        call pkb(nval,8,msgot,jbit)
      enddo
      do k=1,8
        kbit = ibit-k-8
        call upb(kval,8,msgin,kbit)
        if(kval==k) then
          jbit = jbit-k-8
          cycle subset_copy
        endif
      enddo
      call bort('BUFRLIB: STNDRD - BIT MISMATCH COPYING SECTION 4 FROM INPUT TO OUTPUT (STANDARD) MESSAGE')
    enddo subset_copy
 
    ! From this point on, we will need (at most) 6 more bytes of space within msgot in order to be able to store the entire
    ! standardized message (i.e. we will need (at most) 2 more zeroed-out bytes in Section 4, plus the 4 bytes '7777' in
    ! Section 5), so do a final msgot overflow check now.
 
    if(lbyto+6>mxbyto) call bort(bort_arrayoverflow)
 
    ! Pad the new Section 4 with zeroes up to the next whole byte boundary.
 
    do while(.not.(mod(jbit,8)==0))
     call pkb(0,1,msgot,jbit)
    enddo
 
    ! Depending on the edition number, we may need to further pad the new Section 4 with an additional zeroed-out byte in
    ! order to ensure that the padding is up to an even byte boundary.
 
    if( (iben<4) .and. (mod(jbit/8,2)/=0) ) then
      call pkb(0,8,msgot,jbit)
    endif
 
    ibit = nad4*8
    len4 = jbit/8 - nad4
    call pkb(len4,24,msgot,ibit)
    call pkb(0,8,msgot,ibit)
  endif
 
  ! Finish the new message with an updated section 0 byte count.
 
  ibit = 32
  lenn = len0+len1+len2+len3+len4+len5
  call pkb(lenn,24,msgot,ibit)
 
  call pkc(bmcstr,nby5,msgot,jbit)
 
  return
end subroutine stndrd
 
integer function istdesc( idn ) result( iret )
 
  implicit none
 
  integer, intent(in) :: idn
  integer if, ix, iy, iokoper
 
  character*6 adsc, adn30
 
  adsc = adn30( idn, 6 )
 
  read(adsc,'(I1,I2,I3)') if,ix,iy
  if ( if == 1 ) then
    ! adsc is a replication descriptor and therefore standard by default
    iret = 1
  else if ( if == 2 ) then
    ! adsc is an operator descriptor
    iret = iokoper( adsc )
  else if ( ( ix < 48 ) .and. ( iy < 192 ) ) then
    iret = 1
  else
    iret = 0
  end if
 
  return
end function istdesc