Merge pull request #439 from NOAA-EMC/jba_writlc

more testing of oddball cases

test/intest7.F90

@@ -91,59 +91,75 @@ program intest7
   call ufbrep ( 11, r8val, 0, 1, nr8v, 'TIDER' )
   idx = index( errstr(1:errstr_len), 'UFBREP - 3rd ARG. (INPUT) IS .LE. 0' )
   if ( ( nr8v .ne. 0 ) .or. ( idx .eq. 0 ) ) stop 8
+  errstr_len = 0
+  call ufbrep ( 11, r8val, 1, 0, nr8v, 'TIDER' )
+  idx = index( errstr(1:errstr_len), 'UFBREP - 4th ARG. (INPUT) IS .LE. 0' )
+  if ( ( nr8v .ne. 0 ) .or. ( idx .eq. 0 ) ) stop 9
 
   ! Jump ahead to the 5th subset of the 23rd message and read some data values.
   call ufbpos ( 11, 23, 5, cmgtag, jdate )
   call ufbint ( 11, r8arr, mxr8pm, mxr8lv, nr8v, 'CLATH CLONH TMDB SWRAD' )
   if ( ( nr8v .ne. 1 ) .or.  &
       ( nint ( r8arr(1,1)*100000 ) .ne. 2001191 ) .or. ( nint ( r8arr(2,1)*100000 ) .ne. -3785017 ) .or. &
-      ( nint ( r8arr(3,1)*100 ) .ne. 30035 ) .or. ( nint ( r8arr(4,1) ) .ne. 2187000 ) ) stop 9
+      ( nint ( r8arr(3,1)*100 ) .ne. 30035 ) .or. ( nint ( r8arr(4,1) ) .ne. 2187000 ) ) stop 10
   errstr_len = 0
   call ufbint ( 11, r8val, 1, 1, nr8v, 'DUMMY' )
   idx = index( errstr(1:errstr_len), 'UFBINT - NO SPECIFIED VALUES READ IN' )
-  if ( ( nr8v .ne. 0 ) .or. ( idx .eq. 0 ) ) stop 10
+  if ( ( nr8v .ne. 0 ) .or. ( idx .eq. 0 ) ) stop 11
+  errstr_len = 0
+  call ufbint ( 11, r8val, 0, 1, nr8v, 'TMDB' )
+  idx = index( errstr(1:errstr_len), 'UFBINT - 3rd ARG. (INPUT) IS .LE. 0' )
+  if ( ( nr8v .ne. 0 ) .or. ( idx .eq. 0 ) ) stop 12
   errstr_len = 0
   call ufbint ( 11, r8val, 1, 0, nr8v, 'TMDB' )
   idx = index( errstr(1:errstr_len), 'UFBINT - 4th ARG. (INPUT) IS .LE. 0' )
-  if ( ( nr8v .ne. 0 ) .or. ( idx .eq. 0 ) ) stop 11
+  if ( ( nr8v .ne. 0 ) .or. ( idx .eq. 0 ) ) stop 13
 
   ! Jump ahead to the 2nd subset of the 30th message and read some data values.
   call ufbpos ( 11, 30, 2, cmgtag, jdate )
   call ufbstp ( 11, r8arr, mxr8pm, mxr8lv, nr8v, 'CLAT CLON HSMSL' )
   if ( ( nr8v .ne. 1 ) .or. &
       ( nint ( r8arr(1,1)*100 ) .ne. 3163 ) .or. ( nint ( r8arr(2,1)*100 ) .ne. -11017 ) .or. &
-      ( nint ( r8arr(3,1) ) .ne. 1205 ) ) stop 12
+      ( nint ( r8arr(3,1) ) .ne. 1205 ) ) stop 14
   errstr_len = 0
   call ufbstp ( 11, r8val, 1, 1, nr8v, 'DUMMY' )
   idx = index( errstr(1:errstr_len), 'UFBSTP - NO SPECIFIED VALUES READ IN' )
-  if ( ( nr8v .ne. 0 ) .or. ( idx .eq. 0 ) ) stop 13
+  if ( ( nr8v .ne. 0 ) .or. ( idx .eq. 0 ) ) stop 15
+  errstr_len = 0
+  call ufbstp ( 11, r8val, 0, 1, nr8v, 'CLON' )
+  idx = index( errstr(1:errstr_len), 'UFBSTP - 3rd ARG. (INPUT) IS .LE. 0' )
+  if ( ( nr8v .ne. 0 ) .or. ( idx .eq. 0 ) ) stop 16
   errstr_len = 0
   call ufbstp ( 11, r8val, 1, 0, nr8v, 'CLON' )
   idx = index( errstr(1:errstr_len), 'UFBSTP - 4th ARG. (INPUT) IS .LE. 0' )
-  if ( ( nr8v .ne. 0 ) .or. ( idx .eq. 0 ) ) stop 14
+  if ( ( nr8v .ne. 0 ) .or. ( idx .eq. 0 ) ) stop 17
 
   ! Jump backwards to the 88th subset of the 29th message and read some data values.
   call ufbpos ( 11, 29, 88, cmgtag, jdate )
   call ufbseq ( 11, r8arr, mxr8pm, mxr8lv, nr8v, 'NC008023' )
   if ( ( nr8v .ne. 1 ) .or. &
       ( nint ( r8arr(6,1)*100000 ) .ne. 2967000 ) .or. ( nint ( r8arr(7,1)*100000 ) .ne. -9512833 ) .or. &
-      ( nint ( r8arr(5,1) ) .ne. 482011039 ) ) stop 15
+      ( nint ( r8arr(5,1) ) .ne. 482011039 ) ) stop 18
   errstr_len = 0
   call ufbseq ( 11, r8val, 1, 1, nr8v, 'DUMMY' )
   idx = index( errstr(1:errstr_len), 'UFBSEQ - NO SPECIFIED VALUES READ IN' )
-  if ( ( nr8v .ne. 0 ) .or. ( idx .eq. 0 ) ) stop 16
+  if ( ( nr8v .ne. 0 ) .or. ( idx .eq. 0 ) ) stop 19
   errstr_len = 0
   call ufbseq ( 11, r8val, 0, 1, nr8v, 'CLON' )
   idx = index( errstr(1:errstr_len), 'UFBSEQ - 3rd ARG. (INPUT) IS .LE. 0' )
-  if ( ( nr8v .ne. 0 ) .or. ( idx .eq. 0 ) ) stop 17
+  if ( ( nr8v .ne. 0 ) .or. ( idx .eq. 0 ) ) stop 20
+  errstr_len = 0
+  call ufbseq ( 11, r8val, 1, 0, nr8v, 'CLON' )
+  idx = index( errstr(1:errstr_len), 'UFBSEQ - 4th ARG. (INPUT) IS .LE. 0' )
+  if ( ( nr8v .ne. 0 ) .or. ( idx .eq. 0 ) ) stop 21
 
   ! Test ufbcnt.
   call ufbcnt(11, kmsg, ksub)
-  if ( kmsg.ne.29 .or. ksub.ne.88) stop 18
+  if ( kmsg.ne.29 .or. ksub.ne.88) stop 22
 
   ! Rewind the file and get a total count of the subsets.
   call ufbtab ( -11, r8val, 1, 1, nsub, ' ' )
-  if ( ( nsub .ne. 402 ) .or. ( ibfms ( r8val(1,1) ) .ne. 1 ) ) stop 19
+  if ( ( nsub .ne. 402 ) .or. ( ibfms ( r8val(1,1) ) .ne. 1 ) ) stop 23
 
   print *, 'SUCCESS!'
 end program intest7

test/outtest1.F90

@@ -158,7 +158,8 @@ program outtest1
   call writcp ( 11 )
 
   acrn = 'TESTSWA193'
-  call writlc ( 11, acrn, 'ACRN' )
+  ! note that 'ACRN#1' is functionally equivalent to 'ACRN' in the following call
+  call writlc ( 11, acrn, 'ACRN#1' )
 
   ! Close the output file.
   call closbf ( 11 )

test/outtest4.F90

@@ -3,7 +3,36 @@
 ! Writes test file 'testfiles/OUT_4' using OPENBF IO = 'NODX' and IO = 'QUIET', and using STRCPT, WRDXTB and WRITSA
 !
 ! J. Ator, 2/17/2023
+
+module Share_errstr
+  ! This module is needed in order to share information between the test program and subroutine errwrt, because
+  ! the latter is not called by the former but rather is called directly from within the NCEPLIBS-bufr software.
+
+  character*800 errstr
+
+  integer errstr_len
+end module Share_errstr
+
+subroutine errwrt(str)
+  ! This subroutine supersedes the subroutine of the same name within the NCEPLIBS-bufr software, so that we can
+  ! easily test the generation of error messages from within the library.
+
+  use Share_errstr
+
+  character*(*) str
+
+  integer str_len
+
+  str_len = len(str)
+  errstr ( errstr_len + 1 : errstr_len + str_len + 1 ) = str
+  errstr_len = errstr_len + str_len
+
+  return
+end subroutine errwrt
+
 program outtest4
+  use Share_errstr
+
   implicit none
 
   integer*4 isetprm, ireadsb, igetmxby, icbfms, iupbs01, igetdate
@@ -107,7 +136,11 @@ program outtest4
 
     write ( unit = smid, fmt = '(A,I1.1)' ) 'STATION#', nsub
     if ( nsub .eq. 1 ) then
+      call openbf ( 12, 'QUIET', 1 )
+      errstr_len = 0
       call readlc ( 12, dummystr, 'DUMMYSTR' )
+      if ( index( errstr(1:errstr_len), 'NOT LOCATED IN REPORT SUBSET - RETURN WITH MISSING' ) .eq. 0 ) stop 6
+      call openbf ( 12, 'QUIET', -1 )
       if ( icbfms( dummystr, 9 ) .eq. 0 ) smid = dummystr
     end if
 
@@ -118,32 +151,50 @@ program outtest4
     call ufbseq ( 12, r8arr1, mxval1, 1, nlv, 'CLINRVSD' )
     call ufbseq ( 13, r8arr1, mxval1, 1, nlv, 'CLINRVSD' )
     call ufbseq ( 12, r8arr2, mxval2, mxlvl, nlv2, 'TDWPRAOB' )
+    if ( nsub .eq. 1 ) then
+      call openbf ( 12, 'QUIET', 1 )
+      errstr_len = 0
+      call ufbseq ( 13, r8arr1, mxval1, 1, nlv, 'DUMMYVAL' )
+      if ( index( errstr(1:errstr_len), 'UFBSEQ - NO SPECIFIED VALUES WRITTEN OUT' ) .eq. 0 ) stop 7
+      call openbf ( 12, 'QUIET', -1 )
+    end if
 
     call drfini ( 13, nlv2, 1, '(TDWPRAOB)' )
     call ufbseq ( 13, r8arr2, mxval2, nlv2, nlv, 'TDWPRAOB' )
 
     call hold4wlc ( 13, smid, 'SMID' )
+    if ( nsub .eq. 1 ) then
+      call openbf ( 12, 'QUIET', 1 )
+      errstr_len = 0
+      call writlc ( 13, dummystr, 'DUMMYSTR' )
+      if ( index( errstr(1:errstr_len), 'INTO SUBSET, BECAUSE NO SUBSET WAS OPEN FOR WRITING' ) .eq. 0 ) stop 8
+      call openbf ( 12, 'QUIET', -1 )
+    end if
     call writsa ( 13, mxbfmg, mgbf, lmgbf )
     if ( nsub .eq. 1 ) then
+      call openbf ( 12, 'QUIET', 1 )
+      errstr_len = 0
       call writlc ( 13, dummystr, 'DUMMYSTR' )
+      if ( index( errstr(1:errstr_len), 'INTO SUBSET, BECAUSE IT WASN''T FOUND IN THE SUBSET' ) .eq. 0 ) stop 9
+      call openbf ( 12, 'QUIET', -1 )
     end if
 
   end do
 
   call writsa ( -13, mxbfmg, mgbf, lmgbf )
 
-  ! Get Section 1 date (returns 8-byte ints for KIND_8).
+  ! Get Section 1 date.
   idate = igetdate(mgbf, mear, mmon, mday, mour)
-  if (idate.ne.20100111 .or. mear.ne.20 .or. mmon.ne.10 .or. mday.ne.1 .or. mour.ne.11) stop 6
+  if (idate.ne.20100111 .or. mear.ne.20 .or. mmon.ne.10 .or. mday.ne.1 .or. mour.ne.11) stop 10
 
   ! Close the output file.
   call closbf ( 13 )
 
-  ! Test atrcpt, which should add 6 bytes to mgbf
+  ! Test atrcpt, which should add 6 bytes to mgbf.
   mgbf2 = mgbf
   ilena = iupbs01(mgbf2, 'LENM')
   call atrcpt(mgbf, lmgbf, mgbf2)
   ilenb = iupbs01(mgbf2, 'LENM')
-  IF (ilenb-ilena .ne. 6) stop 7
+  IF (ilenb-ilena .ne. 6) stop 11
 
 end program outtest4