misc.F90

Go to the documentation of this file.

 
 
subroutine bfrini
 
  use modv_vars, only: maxtba, maxtbb, maxtbd, mxmsgl, nfiles, adsn, idnr
 
  use moda_stbfr
  use moda_idrdm
  use moda_msglim
  use moda_bitbuf
  use moda_bufrmg
  use moda_bufrsr
  use moda_tababd
  use moda_usrint
  use moda_dscach
 
  implicit none
 
  integer ndndx(10), nldxa(10), nldxb(10), nldxd(10), nld30(10), ibct, ipd1, ipd2, ipd3, ipd4, nrpl, nmrg, namb, ntot, &
    maxdx, idxv, nxstr, ldxa, ldxb, ldxd, ld30, i, j, i1, ifxy
 
  character*240 cmtdir
  character*56 dxstr
  character*6 dndx(25,10)
 
  common /padesc/ ibct, ipd1, ipd2, ipd3, ipd4
  common /dxtab/ maxdx, idxv, nxstr(10), ldxa(10), ldxb(10), ldxd(10), ld30(10), dxstr(10)
  common /mrgcom/ nrpl,nmrg,namb,ntot
 
  data (dndx(i,1),i=1,25)/ &
    '102000','031001','000001','000002', &
    '110000','031001','000010','000011','000012','000013','000015','000016','000017','000018','000019','000020', &
    '107000','031001','000010','000011','000012','000013','101000','031001','000030'/
 
  data (dndx(i,2),i=1,15)/ &
    '103000','031001','000001','000002','000003', &
    '101000','031001','300004', &
    '105000','031001','300003','205064','101000','031001','000030'/
 
  data ndndx /  25 ,  15 , 8*0 /
  data nldxa /  35 ,  67 , 8*0 /
  data nldxb /  80 , 112 , 8*0 /
  data nldxd /  38 ,  70 , 8*0 /
  data nld30 /   5 ,   6 , 8*0 /
 
  ! Initialize module moda_bitbuf
 
  maxbyt = min(10000,mxmsgl)
 
  ! Initialize common /padesc/
 
  ibct = ifxy('063000')
  ipd1 = ifxy('102000')
  ipd2 = ifxy('031001')
  ipd3 = ifxy('206001')
  ipd4 = ifxy('063255')
 
  ! Initialize module moda_stbfr
 
  do i=1,nfiles
    iolun(i) = 0
    iomsg(i) = 0
  enddo
 
  ! Initialize module moda_idrdm
 
  do i=1,nfiles
    idrdm(i) = 0
  enddo
 
  ! Initialize module moda_msglim
 
  do i=1,nfiles
    msglim(i) = 3
  enddo
 
  ! Initialize module moda_usrint
 
  do i=1,nfiles
    nval(i) = 0
  enddo
 
  ! Initialize idnr array
 
  do i=1,10
    idnr(i) = ifxy(adsn(i))
  enddo
 
  ! Initialize module moda_tababd
 
  ! ntba(0) is the maximum number of entries within internal BUFR table A
  ntba(0) = maxtba
  ! ntbb(0) is the maximum number of entries within internal BUFR Table B
  ntbb(0) = maxtbb
  ! ntbd(0) is the maximum number of entries within internal BUFR Table D
  ntbd(0) = maxtbd
 
  ! Initialize common /dxtab/
 
  maxdx = maxbyt
  ! idxv is the version number of the local tables
  idxv = 1
 
  do j=1,10
    ldxa(j) = nldxa(j)
    ldxb(j) = nldxb(j)
    ldxd(j) = nldxd(j)
    ld30(j) = nld30(j)
    dxstr(j) = '      '
    nxstr(j) = ndndx(j)*2
    do i=1,ndndx(j)
      i1 = i*2-1
      call ipkm(dxstr(j)(i1:i1),2,ifxy(dndx(i,j)))
    enddo
  enddo
 
  ! Initialize module moda_bufrmg
 
  do i=1,nfiles
    msglen(i) = 0
  enddo
 
  ! Initialize common /mrgcom/
 
  nrpl = 0
  nmrg = 0
  namb = 0
  ntot = 0
 
  ! Initialize module moda_bufrsr
 
  do i=1,nfiles
    jsr(i) = 0
  enddo
 
  ! Initialize module moda_dscach
 
  ncnem = 0
 
  ! Initialize common /mstinf/
 
  cmtdir = &
    '/home/runner/work/NCEPLIBS-bufr/NCEPLIBS-bufr/bufr/build-doc' // &
's/install/tables'
  call mtinfo(cmtdir,98,99)
 
  return
end subroutine bfrini
 
recursive subroutine strnum( str, num, iret )
  use modv_vars, only: im8b
 
  implicit none
 
  character*(*), intent(in) :: str
 
  integer, intent(out) :: num, iret
 
  character str2*40
 
  integer lens, ios
 
  ! Check for I8 integers.
  if (im8b) then
    im8b = .false.
    call strnum ( str, num, iret )
    call x48 ( num, num, 1 )
    call x48 ( iret, iret, 1 )
    im8b = .true.
    return
  end if
 
  ! Decode the integer from the string.
  iret = 0
  num = 0
  call strsuc ( str, str2, lens )
  if ( lens == 0 ) return
  read ( str2(1:lens), '(I40)', iostat = ios ) num
  if ( ios /= 0 ) iret = -1
 
  return
end subroutine strnum
 
subroutine strsuc(str1,str2,lens)
  implicit none
 
  character*(*), intent(in) :: str1
  character*(*), intent(out) :: str2
 
  integer, intent(out) :: lens
 
  str2 = adjustl(str1)
  lens = len_trim(str2)
 
  return
end subroutine strsuc
 
integer function irev(n) result(iret)
 
  use modv_vars, only: nbytw, iordle
 
  implicit none
 
  integer, intent(in) :: n
 
  integer int, jnt, i
 
  character*8 cint,dint
 
  equivalence(cint,int)
  equivalence(dint,jnt)
 
#ifdef BIG_ENDIAN
  iret = n
#else
  int = n
  do i=1,nbytw
    dint(i:i) = cint(iordle(i):iordle(i))
  enddo
  iret = jnt
#endif
 
  return
end function irev
 
subroutine jstnum(str,sign,iret)
 
  implicit none
 
  integer, intent(out) :: iret
  integer iprt, lstr, num, ier
 
  character*(*), intent(inout) :: str
  character, intent(out) :: sign
  character*128 errstr
 
  common /quiet/ iprt
 
  iret = 0
 
  if(str==' ') call bort('BUFRLIB: JSTNUM - INPUT BLANK CHARACTER STRING NOT ALLOWED')
 
  str = adjustl(str)
  lstr = len(str)
  if(str(1:1)=='+') then
    str = str(2:lstr)
    sign = '+'
  elseif(str(1:1)=='-') then
    str = str(2:lstr)
    sign = '-'
  else
    sign = '+'
  endif
 
  call strnum(str,num,ier)
  if(ier<0) then
    if(iprt>=0) then
      call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
      errstr = 'BUFRLIB: JSTNUM: ENCODED VALUE WITHIN RESULTANT CHARACTER STRING (' // str // ') IS NOT AN INTEGER - '// &
        'RETURN WITH IRET = -1'
      call errwrt(errstr)
      call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
      call errwrt(' ')
    endif
    iret = -1
  endif
 
  return
end subroutine jstnum
 
subroutine capit(str)
 
  implicit none
 
  integer i, j
 
  character*(*), intent(inout) :: str
  character*26 upcs, lwcs
 
  data upcs /'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
  data lwcs /'abcdefghijklmnopqrstuvwxyz'/
 
  do i=1,len(str)
    do j=1,26
      if(str(i:i)==lwcs(j:j)) then
        str(i:i) = upcs(j:j)
        exit
      endif
    enddo
  enddo
 
  return
end subroutine capit
 
subroutine bvers (cverstr)
 
  implicit none
 
  character*(*), intent(out) :: cverstr
 
  if (len(cverstr)<8) call bort('BUFRLIB: BVERS - INPUT STRING MUST CONTAIN SPACE FOR AT LEAST 8 CHARACTERS')
 
  cverstr = '12.1.0'
 
  return
end subroutine bvers
 
integer function isize (num) result (iret)
 
  implicit none
 
  integer, intent(in) :: num
 
  character*128 bort_str
 
  if ( num >= 0 ) then
    do iret = 1, 5
      if ( num < 10**iret ) return
    enddo
  endif
  write(bort_str,'("BUFRLIB: ISIZE - INPUT NUMBER (",I7,") IS OUT OF RANGE")') num
  call bort(bort_str)
 
  return
end function isize
 
recursive integer function igetsc(lunit) result(iret)
 
  use modv_vars, only: im8b
 
  use moda_stcode
 
  implicit none
 
  integer, intent(in) :: lunit
  integer my_lunit, lun, il, im
 
  ! Check for I8 integers.
  if (im8b) then
    im8b = .false.
    call x84(lunit,my_lunit,1)
    iret = igetsc(my_lunit)
    im8b = .true.
    return
  end if
 
  iret = 0
 
  ! Make sure the specified logical unit is connected to the library.
  call status(lunit,lun,il,im)
  if(il==0) call bort('BUFRLIB: IGETSC - BUFR FILE IS CLOSED, IT MUST BE OPEN')
 
  iret = iscodes(lun)
 
  return
end function igetsc
 
integer function iokoper(nemo) result(iret)
 
  implicit none
 
  integer imrkopr
 
  character*(*), intent(in) :: nemo
 
  if ( len(nemo)<6 ) then
    iret = 0
  else if ( lge(nemo(1:3),'201') .and. lle(nemo(1:3),'208') ) then
    iret = 1
  else if ( nemo(1:3)=='221' ) then
    iret = 1
  else if ( ( ( nemo(4:6)=='000' ) .or. ( nemo(4:6)=='255' ) ) .and. &
    ( ( nemo(1:3)=='237' ) .or. ( lge(nemo(1:3),'241') .and. lle(nemo(1:3),'243') ) ) ) then
    iret = 1
  else if ( ( nemo(4:6)=='000' ) .and. ( ( lge(nemo(1:3),'222') .and. lle(nemo(1:3),'225') ) .or. &
    ( nemo(1:3)=='232' ) .or. ( nemo(1:3)=='235' ) .or. ( nemo(1:3)=='236' ) ) ) then
    iret = 1
  else
    iret = imrkopr(nemo)
  endif
 
  return
end function iokoper
 
subroutine mrginv
 
  implicit none
 
  integer nrpl, nmrg, namb, ntot, iprt
 
  character*128 errstr
 
  common /mrgcom/ nrpl, nmrg, namb, ntot
  common /quiet/ iprt
 
  if(iprt>=0) then
    call errwrt('+++++++++++++++++++++BUFRLIB+++++++++++++++++++++++')
    call errwrt('---------------------------------------------------')
    call errwrt('INVENTORY FROM MERGE PROCESS IN SUBROUTINE INVMRG:')
    call errwrt('---------------------------------------------------')
    write ( unit=errstr, fmt='(A,I8)' ) 'NUMBER OF DRB EXPANSIONS  = ', nrpl
    call errwrt(errstr)
    write ( unit=errstr, fmt='(A,I8)' ) 'NUMBER OF MERGES          = ', nmrg
    call errwrt(errstr)
    write ( unit=errstr, fmt='(A,I8)' ) 'NUMBER THAT ARE AMBIGUOUS = ', namb
    call errwrt(errstr)
    call errwrt('---------------------------------------------------')
    write ( unit=errstr, fmt='(A,I9)' ) 'TOTAL NUMBER OF VISITS    = ', ntot
    call errwrt(errstr)
    call errwrt('---------------------------------------------------')
    call errwrt('+++++++++++++++++++++BUFRLIB+++++++++++++++++++++++')
    call errwrt(' ')
  endif
 
  return
end subroutine mrginv