[Dart-dev] [3303] DART/trunk/ncep_obs/prep_bufr/lib:
remove old ncep lib files which are not in the current version
nancy at subversion.ucar.edu
nancy at subversion.ucar.edu
Wed Apr 9 16:14:40 MDT 2008
An HTML attachment was scrubbed...
URL: http://mailman.ucar.edu/pipermail/dart-dev/attachments/20080409/8fc196cb/attachment-0001.html
-------------- next part --------------
Deleted: DART/trunk/ncep_obs/prep_bufr/lib/irderm.f
===================================================================
--- DART/trunk/ncep_obs/prep_bufr/lib/irderm.f 2008-04-09 22:09:06 UTC (rev 3302)
+++ DART/trunk/ncep_obs/prep_bufr/lib/irderm.f 2008-04-09 22:14:39 UTC (rev 3303)
@@ -1,177 +0,0 @@
-C-----------------------------------------------------------------------
-C-----------------------------------------------------------------------
- FUNCTION IRDERM(LUNIT,MBAY)
-
- CHARACTER*4 SEVN
- CHARACTER*1 BAY(5000*8)
- CHARACTER*36 SEC013,SECSAV
- DIMENSION MBAY(5000),KBAY(5000)
- EQUIVALENCE (BAY(1),KBAY(1),SEC013)
-
-C-----------------------------------------------------------------------
-C-----------------------------------------------------------------------
-
- DO I=1,5000
- KBAY(I) = 0
- ENDDO
- IBSKIP = 0
-
-C FIND A BUFR MESSAGE
-C -------------------
-
-1 READ(LUNIT,END=100,ERR=100) SEC013(1:32)
- LASTRD = 32
-2 IBUFR = INDEX(SEC013(1:32),'BUFR')
- IF(IBUFR.EQ.0) THEN
- IBSKIP = IBSKIP + LASTRD
- IF(INDEX(SEC013(1:32),'B').EQ.0) THEN
- READ(LUNIT,END=100,ERR=100) SEC013(1:32)
- LASTRD = 32
- ELSE IF(SEC013(32:32).EQ.'B') THEN
- SEC013(1:1) = 'B'
- READ(LUNIT,END=100,ERR=100) SEC013(2:32)
- LASTRD = 31
- ELSE IF(INDEX(SEC013(1:32),'BU').EQ.0) THEN
- READ(LUNIT,END=100,ERR=100) SEC013(1:32)
- LASTRD = 32
- ELSE IF(SEC013(31:32).EQ.'BU') THEN
- SEC013(1:2) = 'BU'
- READ(LUNIT,END=100,ERR=100) SEC013(3:32)
- LASTRD = 30
- ELSE IF(INDEX(SEC013(1:32),'BU').LT.30) THEN
- READ(LUNIT,END=100,ERR=100) SEC013(1:32)
- LASTRD = 32
- ELSE IF(SEC013(30:32).EQ.'BUF') THEN
- SEC013(1:3) = 'BUF'
- READ(LUNIT,END=100,ERR=100) SEC013(4:32)
- LASTRD = 29
- ELSE
- READ(LUNIT,END=100,ERR=100) SEC013(1:32)
- LASTRD = 32
- ENDIF
- GOTO 2
- ELSE IF(IBUFR.GT.1) THEN
- SECSAV = SEC013
- SEC013(1:33-IBUFR) = SECSAV(IBUFR:32)
- READ(LUNIT,END=100,ERR=100) SEC013(34-IBUFR:32)
- IBSKIP = IBSKIP + IBUFR - 1
- ENDIF
-
-C IF THIS IS BUFR RELEASE 0, THE FOLLOWING WILL ACCOUNT FOR SECTION-1
-C -------------------------------------------------------------------
-
- J = IUPM(BAY(5),24)
- I = J + 8
-
- IF(J.LE.32) THEN
-
-C DETERMINE WHETHER BYTE COUNT IS FOR SECTION-0 OR SECTION-1
-C ----------------------------------------------------------
-
- SEVN = SEC013(J-3:J)
- IF(SEVN.EQ.'7777') THEN
- IF(J.LT.32) THEN
- SECSAV = SEC013
- SEC013(1:32-J) = SECSAV(J+1:32)
- ENDIF
- READ(LUNIT,END=100,ERR=100) SEC013(33-J:32)
- PRINT*,'SHORT RECORD SKIPPED'
- GOTO 2
- ENDIF
-
-C IF THIS IS BUFR RELEASE 0, SHIFT BYTES 5 AND UP 4 BYTES TO THE RIGHT
-C --------------------------------------------------------------------
-
- SECSAV = SEC013
- SEC013(9:36) = SECSAV(5:32)
-
-C IF SECTION-2 IS ABSENT, BEGIN WITH SECTION-3
-C --------------------------------------------
-
- IF(IUPM(BAY(16),1).GT.0) THEN
- KCONT = 2
- ELSE
- KCONT = 3
- ENDIF
-
-C DETERMINE WHETHER SECTION-2 AND SECTION-3 ARE IN BYTES 9-36
-C -----------------------------------------------------------
-
- KREST = 0
- DO K=KCONT,3
- IF(I.LE.33) THEN
- I = I + IUPM(BAY(I+1),24)
- IF(I.GT.36) THEN
- READ(LUNIT,END=100,ERR=100) (BAY(J),J=37,I)
- ENDIF
- KREST = K + 1
- ELSE IF(I.LE.35) THEN
- READ(LUNIT,END=100,ERR=100) (BAY(J),J=37,I+3),
- . (BAY(J),J=I+4,I+IUPM(BAY(I+1),24))
- I = I + IUPM(BAY(I+1),24)
- KREST = K + 1
- ENDIF
- ENDDO
- IF(KREST.NE.0) KCONT = KREST
- ELSE
- READ(LUNIT,END=100,ERR=100) (BAY(K),K=33,J)
-
-C DETERMINE WHETHER BYTE COUNT IS FOR SECTION-0 OR SECTION-1
-C ----------------------------------------------------------
-
- SEVN = BAY(J-3)//BAY(J-2)//BAY(J-1)//BAY(J)
- IF(SEVN.EQ.'7777') GOTO 50
-
-C IF THIS IS BUFR RELEASE 0, SHIFT BYTES 5 AND UP 4 BYTES TO THE RIGHT
-C --------------------------------------------------------------------
-
- READ(LUNIT,END=100,ERR=100) (BAY(K),K=J+5,J+8)
- DO K=J,33,-1
- BAY(K+4) = BAY(K)
- ENDDO
- SECSAV = SEC013
- SEC013(9:36) = SECSAV(5:32)
-
-C IF SECTION-2 IS ABSENT, BEGIN WITH SECTION-3
-C --------------------------------------------
-
- IF(IUPM(BAY(16),1).GT.0) THEN
- KCONT = 2
- ELSE
- KCONT = 3
- ENDIF
-
- ENDIF
-
-C FOR REMAINING SECTIONS (UP TO SECTION-4) READ BYTE COUNT AND BYTES
-C ------------------------------------------------------------------
-
- DO K=KCONT,4
- READ(LUNIT,END=100,ERR=100) (BAY(J),J=I+1,I+3),
- . (BAY(J),J=I+4,I+IUPM(BAY(I+1),24))
- I = I + IUPM(BAY(I+1),24)
- ENDDO
-
-C CHECK ON SECTION 5 FOR BAD RECORD INDICATOR
-C -------------------------------------------
-
- READ(LUNIT,END=100,ERR=100) SEVN
- IF(SEVN.NE.'7777') THEN
- PRINT*,'BAD RECORD SKIPPED'
- GOTO 1
- ENDIF
- I = I+4
-
-C FILL IN THE ARRAY TO RETURN
-C ---------------------------
-
-50 DO I=1,5000
- MBAY(I) = KBAY(I)
- ENDDO
-
- IRDERM = 0
- RETURN
-
-100 IRDERM = -1
- RETURN
- END
Deleted: DART/trunk/ncep_obs/prep_bufr/lib/ireaderm.f
===================================================================
--- DART/trunk/ncep_obs/prep_bufr/lib/ireaderm.f 2008-04-09 22:09:06 UTC (rev 3302)
+++ DART/trunk/ncep_obs/prep_bufr/lib/ireaderm.f 2008-04-09 22:14:39 UTC (rev 3303)
@@ -1,14 +0,0 @@
-C-----------------------------------------------------------------------
-C-----------------------------------------------------------------------
- FUNCTION IREADERM(LUNIT,SUBSET,IDATE)
- CHARACTER*8 SUBSET
- CALL READERM(LUNIT,SUBSET,IDATE,IRET)
- IREADERM = IRET
- RETURN
-
- ENTRY IREADERS(LUNIT)
- CALL READERS(LUNIT,IRET)
- IREADERS = IRET
- RETURN
-
- END
Deleted: DART/trunk/ncep_obs/prep_bufr/lib/jstify.f
===================================================================
--- DART/trunk/ncep_obs/prep_bufr/lib/jstify.f 2008-04-09 22:09:06 UTC (rev 3302)
+++ DART/trunk/ncep_obs/prep_bufr/lib/jstify.f 2008-04-09 22:14:39 UTC (rev 3303)
@@ -1,101 +0,0 @@
-C-----------------------------------------------------------------------
-C-----------------------------------------------------------------------
- SUBROUTINE JSTIFY
-C************************************************************************
-C* JSTIFY *
-C* *
-C* This subroutine consists solely of two separate entry points for *
-C* left-justifying strings containing integer and non-integer values. *
-C* *
-C** *
-C* Log: *
-C* J. Woollen/NCEP ??/?? *
-C* J. Ator/NCEP 05/01 Added documentation *
-C************************************************************************
-
- CHARACTER*(*) STR
- CHARACTER*1 SIGN
-
-C-----------------------------------------------------------------------
-C-----------------------------------------------------------------------
-
- ENTRY JSTCHR(STR)
-C************************************************************************
-C* JSTCHR *
-C* *
-C* This entry point removes all leading blanks from a string. *
-C* *
-C* JSTCHR ( STR ) *
-C* *
-C* Input parameters: *
-C* STR CHARACTER*(*) String *
-C* *
-C* Output parameters: *
-C* STR CHARACTER*(*) Copy of input STR with leading *
-C* blanks removed *
-C************************************************************************
-
- LSTR = LEN(STR)
-
- IF(STR.EQ.' ') GOTO 900
-1 IF(STR(1:1).EQ.' ') THEN
- STR = STR(2:LSTR)
- GOTO 1
- ENDIF
- RETURN
-
-C-----------------------------------------------------------------------
-C-----------------------------------------------------------------------
-
- ENTRY JSTNUM(STR,SIGN,IRET)
-C************************************************************************
-C* JSTNUM *
-C* *
-C* This entry point removes all leading blanks from a string containing *
-C* an encoded integer value. If the value has a leading sign character *
-C* ('+' or '-'), then this character is also removed and is returned *
-C* separately within SIGN. *
-C* *
-C* JSTNUM ( STR ) *
-C* *
-C* Input parameters: *
-C* STR CHARACTER*(*) String containing encoded *
-C* integer value *
-C* *
-C* Output parameters: *
-C* STR CHARACTER*(*) Copy of input STR with leading *
-C* blanks and sign character *
-C* removed *
-C* SIGN CHARACTER Sign of encoded integer value: *
-C* '+' = positive value *
-C* '-' = negative value *
-C* IRET INTEGER Return code: *
-C* 0 = normal return *
-C* -1 = encoded value within STR *
-C* was not an integer *
-C************************************************************************
-
- IRET = 0
- LSTR = LEN(STR)
-
- IF(STR.EQ.' ') GOTO 900
-2 IF(STR(1:1).EQ.' ') THEN
- STR = STR(2:LSTR)
- GOTO 2
- ENDIF
- IF(STR(1:1).EQ.'+') THEN
- STR = STR(2:LSTR)
- SIGN = '+'
- ELSEIF(STR(1:1).EQ.'-') THEN
- STR = STR(2:LSTR)
- SIGN = '-'
- ELSE
- SIGN = '+'
- ENDIF
-
- CALL STRNUM(STR,NUM)
- IF(NUM.LT.0) IRET = -1
- RETURN
-
-900 CALL BORT('JSTIFY - BLANK STRING NOT ALLOWED')
- END
Deleted: DART/trunk/ncep_obs/prep_bufr/lib/nenuck.f
===================================================================
--- DART/trunk/ncep_obs/prep_bufr/lib/nenuck.f 2008-04-09 22:09:06 UTC (rev 3302)
+++ DART/trunk/ncep_obs/prep_bufr/lib/nenuck.f 2008-04-09 22:14:39 UTC (rev 3303)
@@ -1,177 +0,0 @@
- SUBROUTINE NENUCK(NEMO,NUMB,LUN)
-
-C************************************************************************
-C* NENUCK *
-C* *
-C* This subroutine consists solely of two separate entry points for *
-C* checking a mnemonic and FXY value pair that were read from a user *
-C* DX table, in order to make sure that neither value has already been *
-C* defined within the internal BUFR table arrays for the given LUN. *
-C* *
-C** *
-C* Log: *
-C* J. Woollen/NCEP ??/?? *
-C* J. Ator/NCEP 05/01 Added documentation *
-C************************************************************************
-
- COMMON /TABABD/ NTBA(0:32),NTBB(0:32),NTBD(0:32),MTAB(50,32),
- . IDNA(50,32,2),IDNB(250,32),IDND(250,32),
- . TABA(50,32),TABB(250,32),TABD(250,32)
-
- CHARACTER*600 TABD
- CHARACTER*128 TABB
- CHARACTER*128 TABA
- CHARACTER*8 NEMO
- CHARACTER*6 NUMB
-
-C-----------------------------------------------------------------------
-C-----------------------------------------------------------------------
-
-C CHECK TABLE A
-C -------------
-
- ENTRY NENUAA(NEMO,NUMB,LUN)
-C************************************************************************
-C* NENUAA *
-C* *
-C* This entry point checks a mnemonic and FXY value pair that were read *
-C* from a user DX table, in order to make sure that neither value has *
-C* already been defined within internal BUFR table A for the given LUN. *
-C* If either value has already been defined for this LUN, then an *
-C* appropriate call is made to subroutine BORT. *
-C* *
-C* NENUAA ( NEMO, NUMB, LUN ) *
-C* *
-C* Input parameters: *
-C* NEMO CHARACTER*(*) Mnemonic *
-C* NUMB INTEGER FXY value associated with NEMO *
-C* LUN INTEGER I/O stream index into internal *
-C* arrays for this user DX table *
-C************************************************************************
-C* *
-C* EXAMPLE SHOWING LAYOUT OF INTERNAL BUFR TABLE A *
-C* (FROM A DBX DEBUG SESSION USING "bufrtab.002", AND WHERE LUN = 1) *
-C* *
-C* (dbx) print NTBA[1] *
-C* 8 *
-C* *
-C* (dbx) print TABA[1,1] *
-C* 0x1002c764 = "218NC002001 MESSAGE TYPE 002-001 RAWINSONDE - FIXED LAND " *
-C* (dbx) print TABA[2,1] *
-C* 0x1002c7e4 = "219NC002002 MESSAGE TYPE 002-002 RAWINSONDE - MOBIL LAND " *
-C* (dbx) print TABA[3,1] *
-C* 0x1002c864 = "220NC002003 MESSAGE TYPE 002-003 RAWINSONDE - SHIP " *
-C* *
-C* and so on, up through TABA[8,1] ( = TABA[NTBA[LUN],LUN] ) *
-C* *
-C************************************************************************
-
- DO N=1,NTBA(LUN)
- IF(NUMB(4:6).EQ.TABA(N,LUN)(1: 3)) GOTO 900
- IF(NEMO .EQ.TABA(N,LUN)(4:11)) GOTO 900
- ENDDO
-
- RETURN
-
-C CHECK TABLE B AND D
-C -------------------
-
- ENTRY NENUBD(NEMO,NUMB,LUN)
-C************************************************************************
-C* NENUBD *
-C* *
-C* This entry point checks a mnemonic and FXY value pair that were read *
-C* from a user DX table, in order to make sure that neither value has *
-C* already been defined within internal BUFR table B or D for the given *
-C* LUN. If either value has already been defined for this LUN, then an *
-C* appropriate call is issued to subroutine BORT. *
-C* *
-C* NENUBD ( NEMO, NUMB, LUN ) *
-C* *
-C* Input parameters: *
-C* NEMO CHARACTER*(*) Mnemonic *
-C* NUMB INTEGER FXY value associated with NEMO *
-C* LUN INTEGER I/O stream index into internal *
-C* arrays for this user DX table *
-C************************************************************************
-C* *
-C* EXAMPLE SHOWING LAYOUT OF INTERNAL BUFR TABLE B *
-C* (FROM A DBX DEBUG SESSION USING "bufrtab.002", AND WHERE LUN = 1) *
-C* *
-C* (dbx) print NTBB[1] *
-C* 95 *
-C* *
-C* (dbx) print TABB[1,1] *
-C* 0x1003c164 = "063000BYTCNT BYTES +0 +0 16 " *
-C* *
-C* (dbx) print TABB[2,1] *
-C* 0x1003c1e4 = "063255BITPAD NONE +0 +0 1 " *
-C* *
-C* (dbx) print TABB[3,1] *
-C* 0x1003c264 = "031000DRF1BIT NUMERIC +0 +0 1 " *
-C* *
-C* (dbx) print TABB[8,1] *
-C* 0x1003c4e4 = "001003WMOR WMO REGION NUMBER CODE TABLE +0 +0 3 " *
-C* *
-C* (dbx) print TABB[11,1] *
-C* 0x1003c664 = "001194BUHD BULLETIN HEADER CCITT IA5 +0 +0 64 " *
-C* *
-C* (dbx) print TABB[21,1] *
-C* 0x1003cb64 = "004003DAYS DAY DAY +0 +0 6 " *
-C* *
-C* (dbx) print TABB[33,1] *
-C* 0x1003d164 = "005002CLAT LATITUDE (COARSE ACCURACY) DEGREES +2 -9000 15 " *
-C* *
-C* *
-C* and so on, up through TABB[95,1] ( = TABB[NTBB[LUN],LUN] ) *
-C* *
-C************************************************************************
-C* *
-C* EXAMPLE SHOWING LAYOUT OF INTERNAL BUFR TABLE D *
-C* (FROM A DBX DEBUG SESSION USING "bufrtab.002", AND WHERE LUN = 1) *
-C* *
-C* (dbx) print NTBD[1] *
-C* 43 *
-C* *
-C* (dbx) &TABD[1,1]/14c *
-C* 1008a364: '3' '6' '0' '0' '0' '1' 'D' 'R' 'P' '1' '6' 'B' 'I' 'T' *
-C* *
-C* (dbx) &TABD[2,1]/14c *
-C* 1008a5bc: '3' '6' '0' '0' '0' '2' 'D' 'R' 'P' '8' 'B' 'I' 'T' ' ' *
-C* *
-C* (dbx) &TABD[3,1]/14c *
-C* 1008a814: '3' '6' '0' '0' '0' '3' 'D' 'R' 'P' 'S' 'T' 'A' 'K' ' ' *
-C* *
-C* (dbx) &TABD[4,1]/14c *
-C* 1008aa6c: '3' '6' '0' '0' '0' '4' 'D' 'R' 'P' '1' 'B' 'I' 'T' ' ' *
-C* *
-C* (dbx) &TABD[5,1]/14c *
-C* 1008acc4: '3' '6' '3' '2' '1' '8' 'N' 'C' '0' '0' '2' '0' '0' '1' *
-C* *
-C* (dbx) &TABD[6,1]/14c *
-C* 1008af1c: '3' '6' '3' '2' '1' '9' 'N' 'C' '0' '0' '2' '0' '0' '2' *
-C* *
-C* (dbx) &TABD[24,1]/14c *
-C* 1008d94c: '3' '6' '1' '1' '3' '0' 'U' 'A' 'A' 'D' 'F' ' ' ' ' ' ' *
-C* *
-C* and so on, up through TABD[43,1] ( = TABD[NTBD[LUN],LUN] ) *
-C* *
-C************************************************************************
-
- DO N=1,NTBB(LUN)
- IF(NUMB.EQ.TABB(N,LUN)(1: 6)) GOTO 900
- IF(NEMO.EQ.TABB(N,LUN)(7:14)) GOTO 900
- ENDDO
-
- DO N=1,NTBD(LUN)
- IF(NUMB.EQ.TABD(N,LUN)(1: 6)) GOTO 900
- IF(NEMO.EQ.TABD(N,LUN)(7:14)) GOTO 900
- ENDDO
-
- RETURN
-
-C ERROR EXIT
-C ----------
-
-900 CALL BORT('NENUCK - DUPLICATE NEM/NUM '//NEMO//' '//NUMB)
- END
Deleted: DART/trunk/ncep_obs/prep_bufr/lib/readerm.f
===================================================================
--- DART/trunk/ncep_obs/prep_bufr/lib/readerm.f 2008-04-09 22:09:06 UTC (rev 3302)
+++ DART/trunk/ncep_obs/prep_bufr/lib/readerm.f 2008-04-09 22:14:39 UTC (rev 3303)
@@ -1,52 +0,0 @@
-C-----------------------------------------------------------------------
-C-----------------------------------------------------------------------
- SUBROUTINE READERM(LUNIT,SUBSET,JDATE,IRET)
-
- COMMON /HRDWRD/ NBYTW,NBITW,NREV,IORD(8)
- COMMON /MSGCWD/ NMSG(32),NSUB(32),MSUB(32),INODE(32),IDATE(32)
- COMMON /BITBUF/ MAXBYT,IBIT,IBAY(5000),MBYT(32),MBAY(5000,32)
-
- CHARACTER*8 SUBSET
-
-C-----------------------------------------------------------------------
-C-----------------------------------------------------------------------
-
- IRET = 0
-
-C CHECK THE FILE STATUS
-C ---------------------
-
- CALL STATUS(LUNIT,LUN,IL,IM)
- IF(IL.EQ.0) GOTO 900
- IF(IL.GT.0) GOTO 901
- CALL WTSTAT(LUNIT,LUN,IL, 1)
-
-C READ A MESSAGE INTO A MESSAGE BUFFER
-C ------------------------------------
-
-1 IF(IRDERM(LUNIT,MBAY(1,LUN)).NE.0) GOTO100
-
-C PARSE THE MESSAGE SECTION CONTENTS
-C ----------------------------------
-
- CALL CKTABA(LUN,SUBSET,JDATE,IRET)
- IF(IRET.NE.0) GOTO 1
- RETURN
-
-C EOF ON ATTEMPTED READ
-C ---------------------
-
-100 CALL WTSTAT(LUNIT,LUN,IL,0)
- INODE(LUN) = 0
- IDATE(LUN) = 0
- SUBSET = ' '
- JDATE = 0
- IRET = -1
- RETURN
-
-C ERROR EXITS
-C -----------
-
-900 CALL BORT('READERM - FILE IS CLOSED ')
-901 CALL BORT('READERM - FILE IS OPEN FOR OUTPUT ')
- END
Deleted: DART/trunk/ncep_obs/prep_bufr/lib/readtj.f
===================================================================
--- DART/trunk/ncep_obs/prep_bufr/lib/readtj.f 2008-04-09 22:09:06 UTC (rev 3302)
+++ DART/trunk/ncep_obs/prep_bufr/lib/readtj.f 2008-04-09 22:14:39 UTC (rev 3303)
@@ -1,65 +0,0 @@
-C-----------------------------------------------------------------------
-C-----------------------------------------------------------------------
- SUBROUTINE READTJ(LUNIT,SUBSET,JDATE,IRET)
-
- COMMON /HRDWRD/ NBYTW,NBITW,NREV,IORD(8)
- COMMON /MSGCWD/ NMSG(32),NSUB(32),MSUB(32),INODE(32),IDATE(32)
- COMMON /BITBUF/ MAXBYT,IBIT,IBAY(5000),MBYT(32),MBAY(5000,32)
-
- CHARACTER*8 SEC0,SUBSET
- CHARACTER*4 BUFR
- DIMENSION IEC0(2)
- EQUIVALENCE (SEC0,IEC0)
-
-C-----------------------------------------------------------------------
-C-----------------------------------------------------------------------
-
- IRET = 0
-
-C CHECK THE FILE STATUS
-C ---------------------
-
- CALL STATUS(LUNIT,LUN,IL,IM)
- IF(IL.EQ.0) GOTO 900
- IF(IL.GT.0) GOTO 901
- CALL WTSTAT(LUNIT,LUN,IL, 1)
-
-C READ A MESSAGE INTO A MESSAGE BUFFER - SKIP DX MESSAGES
-C -------------------------------------------------------
-
-1 MBIT = 0
- SEC0 = ' '
- IMSG = 8/NBYTW+1
- READ(LUNIT,ERR=902,END=100) SEC0,(MBAY(I,LUN),I=IMSG,LMSG(SEC0))
- CALL CHRTRNA(BUFR,SEC0,4)
- IF(BUFR.NE.'BUFR') GOTO 100
- DO I=1,IMSG-1
- MBAY(I,LUN) = IEC0(I)
- ENDDO
-
-C PARSE THE MESSAGE SECTION CONTENTS
-C ----------------------------------
-
- CALL CKTABA(LUN,SUBSET,JDATE,IRET)
- IF(IRET.NE.0) GOTO 1
- RETURN
-
-C EOF ON ATTEMPTED READ
-C ---------------------
-
-100 CALL WTSTAT(LUNIT,LUN,IL,0)
- INODE(LUN) = 0
- IDATE(LUN) = 0
- SUBSET = ' '
- JDATE = 0
- IRET = -1
- RETURN
-
-C ERROR EXITS
-C -----------
-
-900 CALL BORT('READTJ - FILE IS CLOSED ')
-901 CALL BORT('READTJ - FILE IS OPEN FOR OUTPUT ')
-902 CALL BORT('READTJ - I/O ERROR READING MESSAGE ')
-903 CALL BORT('READTJ - MSGTYPE MISMATCH FOR '//SUBSET )
- END
Deleted: DART/trunk/ncep_obs/prep_bufr/lib/standard.f
===================================================================
--- DART/trunk/ncep_obs/prep_bufr/lib/standard.f 2008-04-09 22:09:06 UTC (rev 3302)
+++ DART/trunk/ncep_obs/prep_bufr/lib/standard.f 2008-04-09 22:14:39 UTC (rev 3303)
@@ -1,154 +0,0 @@
-C-----------------------------------------------------------------------
-C SUBROUTINE STANDARD WILL REWRITE A MESSAGE WRITTEN BY THE NCEP BUFR
-C INTERFACE PROGRAM INTO A MORE STANDARD BUFR FORM. SECTION THREE IS
-C REWRITTEN AS THE EXPANSION (1 LEVEL DEEP) OF THE NCEP SUBSET SEQUENCE
-C DESCRIPTOR. SECTION FOUR IS REWRITTEN TO CONFORM TO THE NEW SECTION
-C THREE DESCRIPTOR LIST. ALL SUBSET BYTE COUNTERS AND BIT PADS ARE REMO
-C FROM THE DATA. IF THE 1 LEVEL EXPANSION OF THE SUBSET SEQUENCE DESCRI
-C CONTAINS ONLY STANDARD DESCRIPTORS, THEN THE NEW MESSAGE IS ENTIRLY
-C AND STRICTLY STANDARD.
-C
-C THE SUBROUTINE ARGUMENTS ARE:
-C
-C INPUT: LUNIT - UNIT OPENED WITH BUFR TABLES USING OPENBF
-C MSGIN - ARRAY CONTAINING AN NCEP BUFR MESSAGE
-C
-C OUTPUT: MSGOT - ARRAY CONTAINING STANDARDIZED FORM OF THE INPUT MESSA
-C
-C ----------------------------------------------
-C NOTE: MSGIN AND MSGOT MUST BE SEPARATE ARRAYS.
-C ----------------------------------------------
-C
-C-----------------------------------------------------------------------
- SUBROUTINE STANDARD(LUNIT,MSGIN,MSGOT)
-
- DIMENSION MSGIN(*),MSGOT(*)
-
- CHARACTER*8 SUBSET
- CHARACTER*4 SEVN
- CHARACTER*1 TAB
-
-C-----------------------------------------------------------------------
-C-----------------------------------------------------------------------
-
-C LUNIT MUST POINT TO AN OPEN BUFR FILE
-C -------------------------------------
-
- CALL STATUS(LUNIT,LUN,IL,IM)
- IF(IL.EQ.0) CALL BORT('STANDARD - NO OPEN BUFR FILE!!')
-
-C IDENTIFY THE SECTION LENGTHS AND ADDRESSES IN MSGIN
-C ---------------------------------------------------
-
- IAD0 = 0
- LEN0 = 8
- LENN = IUPB(MSGIN,IAD0+5,24)
-
- IAD1 = IAD0+LEN0
- LEN1 = IUPB(MSGIN,IAD1+1,24)
- LEN2 = IUPB(MSGIN,IAD1+8,1)
-
- IAD2 = IAD1+LEN1
- LEN2 = IUPB(MSGIN,IAD2+1,24)*LEN2
-
- IAD3 = IAD2+LEN2
- LEN3 = IUPB(MSGIN,IAD3+1,24)
-
- IAD4 = IAD3+LEN3
- LEN4 = IUPB(MSGIN,IAD4+1,24)
-
- LENM = LEN0+LEN1+LEN2+LEN3+LEN4+4
-
- IF(LENN.NE.LENM) CALL BORT('STANDARD - BAD INPUT BYTE COUNTS')
-
- MBIT = (LENN-4)*8
- CALL UPC(SEVN,4,MSGIN,MBIT)
- IF(SEVN.NE.'7777') CALL BORT('STANDARD - CANT FIND 7777')
-
-C COPY SECTIONS 0 THROUGH PART OF SECTION 3 INTO MSGOT
-C ----------------------------------------------------
-
- CALL MVB(MSGIN,1,MSGOT,1,LEN0+LEN1+LEN2+7)
-
-C REWRITE NEW SECTION 3 IN A "STANDARD" FORM
-C ------------------------------------------
-
- NSUB = IUPB(MSGIN,IAD3+ 5,16)
- ISUB = IUPB(MSGIN,IAD3+10,16)
- IBIT = (IAD3+7)*8
-
-C LOOK UP THE SUBSET DESCRIPTOR AND ITS LENGTH IN DESCRIPTORS
-C -----------------------------------------------------------
-
- CALL NUMTAB(LUN,ISUB,SUBSET,TAB,ITAB)
- IF(ITAB.EQ.0) CALL BORT('STANDARD - UNKNOWN SUBSET DESCRIPTOR')
- CALL UPTDD(ITAB,LUN,0,NSEQ)
-
-C COPY EACH DESCRIPTOR IN THE SUBSET SEQUENCE INTO THE NEW SECTION 3
-C ------------------------------------------------------------------
-
- DO N=1,NSEQ
- CALL UPTDD(ITAB,LUN,N,IDSC)
- CALL PKB(IDSC,16,MSGOT,IBIT)
- IF(N.EQ.NSEQ) CALL PKB(0,8,MSGOT,IBIT)
- ENDDO
-
- IBIT = IAD3*8
- LEN3 = 8+NSEQ*2
- NAD4 = IAD3+LEN3
- CALL PKB(LEN3,24,MSGOT,IBIT)
-
-C NOW THE TRICKY PART - NEW SECTION 4
-C -----------------------------------
-
- IBIT = (IAD4+4)*8
- JBIT = (NAD4+4)*8
-
-C COPY THE SUBSETS, MINUS THE BYTE COUNTER AND PAD, INTO THE NEW SECTIO
-C ---------------------------------------------------------------------
-
- DO 10 I=1,NSUB
- CALL UPB(LSUB,16,MSGIN,IBIT)
-
- DO L=1,LSUB-2
- CALL UPB(NVAL,8,MSGIN,IBIT)
- CALL PKB(NVAL,8,MSGOT,JBIT)
- ENDDO
-
- DO K=1,8
- KBIT = IBIT-K-8
- CALL UPB(KVAL,8,MSGIN,KBIT)
- IF(KVAL.EQ.K) THEN
- JBIT = JBIT-K-8
- GOTO 10
- ENDIF
- ENDDO
- CALL BORT('STANDARD - KBIT ERROR')
-
-10 ENDDO
-
-C MAKE SURE NEW SECTION 4 HAS AN EVEN NUMBER OF BYTES AND ENTER THE COU
-C ---------------------------------------------------------------------
-
- DO WHILE(.NOT.(MOD(JBIT,8).EQ.0 .AND. MOD(JBIT/8,2).EQ.0))
- CALL PKB(0,1,MSGOT,JBIT)
- ENDDO
-
- IBIT = NAD4*8
- LEN4 = JBIT/8 - NAD4
- CALL PKB(LEN4,24,MSGOT,IBIT)
-
-C FINISH THE NEW MESSAGE WITH AN UPDATED SECTION-0 BYTE COUNT
-C -----------------------------------------------------------
-
- IBIT = 32
- LENM = LEN0+LEN1+LEN2+LEN3+LEN4+4
- CALL PKB(LENM,24,MSGOT,IBIT)
-
-C NORMAL EXIT
-C -----------
-
- CALL PKC('7777', 4,MSGOT,JBIT)
-
- RETURN
- END
More information about the Dart-dev
mailing list