From 071bd3ce1517e5cf17a519d21103528f6734bb2e Mon Sep 17 00:00:00 2001 From: Jeff Ator Date: Tue, 4 Apr 2023 22:49:57 +0000 Subject: [PATCH] more testing of oddball cases --- test/intest7.F90 | 38 +++++++++++++++++++++--------- test/outtest1.F90 | 3 ++- test/outtest4.F90 | 59 +++++++++++++++++++++++++++++++++++++++++++---- 3 files changed, 84 insertions(+), 16 deletions(-) diff --git a/test/intest7.F90 b/test/intest7.F90 index 09879d15..60e9ed01 100644 --- a/test/intest7.F90 +++ b/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 diff --git a/test/outtest1.F90 b/test/outtest1.F90 index 35f5c6ac..3bb2ab06 100644 --- a/test/outtest1.F90 +++ b/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 ) diff --git a/test/outtest4.F90 b/test/outtest4.F90 index b9fee7f6..7e71e565 100644 --- a/test/outtest4.F90 +++ b/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