PROGRAM TSTRED C************************************************************************ C* Program to test read a BUFR sounding data file. * C* * C* Log: * C* K. Brill/NMC 1/95 * C* K. Brill/EMC 11/98 CALL new SNMRBF routine * C************************************************************************ PARAMETER ( MAXSND = 2048 ) PARAMETER ( MXPROF = 4 ) PARAMETER ( MAXSFC = 128 ) CHARACTER*8 tblde (16) CHARACTER*128 snefil CHARACTER*1 one INTEGER iday (3), npsn (MXPROF), nz (MXPROF) REAL snbufr (MAXSND,MXPROF), sfbufr (MAXSFC) LOGICAL done, more, degree, next C------------------------------------------------------------------------ C C* Open the BUFR file. C WRITE (6,*) ' Enter the BUFR file name:' READ (5,11) snefil 11 FORMAT (A) WRITE (6,*) ' Enter 1 to create bufr_table.dump file.' READ (5,11) one IF ( one .eq. '1' ) THEN CALL SNMINV ( snefil, ier ) END IF CALL SNMPRE ( snefil, lunin, tblde, nde, degree, iret ) WRITE (6,*) ' RETURN CODE from SNMPRE = ', iret done = .false. DO WHILE ( .not. done ) C C* Read the next sounding. C CALL SNMRBF ( lunin, MAXSND, MXPROF, MAXSFC, + tblde, nde, degree, ihr, iday, ifct, istnm, + slat, slon, selv, npsn, nz, nprofs, npsf, + snbufr, sfbufr, iclass, iret ) C* WRITE (6,*) ' RETURN CODE from SNMRBF = ', iret C C C C************************************************************************ C* SNMRBF * C* * C* This subroutine returns the next sounding subset of MODEL profile * C* and surface point data stored in a BUFR file. * C* * C* Note: the BUFR file is assumed open and connected to unit LUNBUF. * C* The BUFR file is opened using JB_OPEN. * C* * C* The output sounding data is ordered parameter-wise, that is, the * C* first element is parameter 1 on level 1, the next element is * C* parameter 2 on level 1, . . ., the last element is parameter NPSN * C* on level NZ. This applies to each profile data set encountered. * C* The first one is in SNBUFR (*,1), the second in SNBUFR (*,2), etc. * C* The * represents the range of index values required to accomodate * C* the sounding data ordered parameter-wise as described above. Each * C* sounding data set is assumed to have a TABLE D entry having PROFIL * C* as the first six characters. * C* * C* On RETURN, the output arrays will have the following dimensions * C* * C* SNBUFR (MAXSND,NPROFS) with first index limited to * C* NPSN(i) * NZ (i) for each profile set * C* NPSN (NPROFS) * C* NZ (NPROFS) * C* SFBUFR (NPSF) * C* * C* The HEADR TABLE D entry will be the source of the station data. * C* All of the other TABLE D entries that do not begin with PROFIL will * C* be assumed to be surface data, even if replicated. Such data will * C* be loaded into SFBUFR in the order implied by the BUFR table. * C* * C* If this is an old BUFR file, the SLAT, SLON, were stored as radians * C* in the BUFR file. In that case, the values in the table file will * C* be scaled by five and have the reference -158000 for latitude and * C* -315000 for longitude. For this case DEGREE must be set to FALSE * C* in SNMPRP. * C* * C* The TBLDE array contains the list of table D entries in the order * C* of occurrence in the file as generated by a call to SNMPRP. * C* * C* SNMRBF ( LUNBUF, MAXSND, MXPROF, MAXSFC, TBLDE, NDE, DEGREE, * C* IHR, IDAY, IFCT, ISTNM, SLAT, SLON, SELV, * C* NPSN, NZ, NPROFS, NPSF, SNBUFR, SFBUFR, ICLASS, IRET ) * C* * C* Input parameters: * C* LUNBUF INTEGER Unit number of the BUFR file * C* MAXSND INTEGER Maximum 1st dimension of SNBUFR * C* MXPROF INTEGER Maximum 2nd dimension of SNBUFR * C* MAXSFC INTEGER Maximum dimension of SFBUFR * C* TBLDE (NDE) CHAR*(*) TABLE D entries from BUFR table * C* NDE INTEGER # of TABLE D entries * C* DEGREE LOGICAL Flag for lat/lon in degrees * C* * C* Output parameters: * C* IHR INTEGER Cycle hour * C* IDAY (3) INTEGER Starting month, day, year * C* IFCT INTEGER Forecast time (seconds) * C* ISTNM INTEGER Station ID number * C* SLAT REAL Station latitude (deg) * C* SLON REAL Station longitude (deg, + east) * C* SELV REAL Station elevation (m) * C* NPSN (MXPROF) INTEGER Number of sounding parameters * C* NZ (MXPROF) INTEGER Number of sounding levels * C* NPROFS INTEGER Number of profile sets * C* NPSF INTEGER Number of surface parameters * C* SNBUFR(MAXSND, * C* MXPROF) REAL Output profile data values * C* SFBUFR (MAXSFC) REAL Output surface data values * C* ICLASS INTEGER Class of profile output * C* IRET INTEGER Return code * C* 0 = normal * C* +1 = end of input file * C* -12 = error reading input file * C* -20 = sequence name not found * C* -21 = no parameters requested * C* -22 = missing forecast time * C* -23 = missing station number * C* -24 = missing station lat * C* -25 = missing station lon * C* -26 = missing station elevation * C* -36 = too many profiles * C** * C* Log: * C* D. Kidwell/NCEP 8/98 * C* K. Brill/EMC 8/98 Check missing values; ICLASS missing = 0* C* K. Brill/EMC 9/98 CALL JTB_SPLT rather than BTB_SPLT * C************************************************************************ C C C IF ( iret .ne. 0 ) THEN WRITE (6,*) ' SNMRBF error - iret = ', iret IF ( iret .gt. 0 ) STOP END IF WRITE (6,101) istnm, iday(3), iday(1), iday(2), ihr, ifct 101 FORMAT ( ' STN = ', I5, ' CYCLE = ',I4,3I2.2, + ' FCST = ', I10 ) WRITE (6,103) slat, slon, selv, iclass 103 FORMAT ( ' STN LAT/LON = ', F6.2, ' / ', F7.2, + ' STN ELEV = ', + F5.0, ' CLASS = ', I2 ) WRITE (6,105) npsf, nprofs 105 FORMAT ( ' # SFC PARMS = ', I4, ' # SND PROFILES = ', I4 ) DO k = 1, nprofs WRITE (6,131) k, npsn (k), nz (k) 131 FORMAT ( ' FOR SND SET # ', I3, ',', + ' # SND PARMS = ', I4, ' # SND LEVLS = ', I4 ) END DO WRITE (6,*) ' SURFACE PARAMETER VALUES ARE: ' WRITE (6,107) (sfbufr(ij),ij=1,npsf) 107 FORMAT ( 5 ( X, E11.4, 2X ) ) next = .true. DO WHILE ( next ) WRITE (6,*) ' Enter number of sounding set (1 to ', + nprofs, ')' WRITE (6,*) ' Enter 0 for next STN, -1 to STOP:' READ (5,*) kset k = 0 IF ( kset .le. 0 .or. kset .gt. nprofs ) THEN next = .false. more = .false. IF ( kset .lt. 0 ) k = -1 ELSE more = .true. END IF DO WHILE ( more ) WRITE (6,*) ' Enter number of level to print data. ' WRITE (6,*) ' Enter 0 for next sounding set.' READ (5,*) k IF ( k .gt. nz (kset) ) k = nz (kset) IF ( k .le. 0 ) THEN more = .false. ELSE k1 = ( k - 1 ) * npsn (kset) + 1 k2 = k * npsn (kset) WRITE ( 6, 111 ) k 111 FORMAT ( ' LEVEL ', I4, ' DATA VALUES ARE:' ) WRITE ( 6, 107 ) + ( snbufr (kkk,kset), kkk = k1, k2 ) END IF END DO IF ( k .lt. 0 ) done = .true. END DO END DO CALL JB_CLOS ( lunin, iret ) STOP END