<HTML> <BODY BGCOLOR=#ccccdd LINK=#0000aa VLINK=#0000ff ALINK=#ff0000 ><BASE TARGET="bottom_target"><PRE>
<A NAME='UFBRW'><A href='../../html_code/bufr/ufbrw.f.html#UFBRW' TARGET='top_target'><IMG SRC="../../gif/bar_red.gif" border=0></A>
SUBROUTINE UFBRW(LUN,USR,I1,I2,IO,IRET) 3,4
C$$$ SUBPROGRAM DOCUMENTATION BLOCK
C
C SUBPROGRAM: UFBRW
C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06
C
C ABSTRACT: THIS SUBROUTINE WRITES OR READS SPECIFIED VALUES TO OR FROM
C THE CURRENT BUFR DATA SUBSET WITHIN INTERNAL ARRAYS, WITH THE
C DIRECTION OF THE DATA TRANSFER DETERMINED BY THE CONTEXT OF IO
C (I.E., IF IO INDICATES LUN POINTS TO A BUFR FILE THAT IS OPEN FOR
C INPUT, THEN DATA VALUES ARE READ FROM THE INTERNAL DATA SUBSET;
C OTHERWISE, DATA VALUES ARE WRITTEN TO THE INTERNAL DATA SUBSET).
C THE DATA VALUES CORRESPOND TO INTERNAL ARRAYS REPRESENTING PARSED
C STRINGS OF MNEMONICS WHICH ARE PART OF A DELAYED-REPLICATION
C SEQUENCE, OR FOR WHICH THERE IS NO REPLICATION AT ALL.
C
C THIS SUBROUTINE SHOULD NEVER BE CALLED BY ANY APPLICATION PROGRAM;
C INSTEAD, APPLICATION PROGRAMS SHOULD ALWAYS CALL BUFR ARCHIVE
C LIBRARY SUBROUTINE UFBINT.
C
C PROGRAM HISTORY LOG:
C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR
C 1996-12-11 J. WOOLLEN -- REMOVED A HARD ABORT FOR USERS WHO TRY TO
C WRITE NON-EXISTING MNEMONICS
C 1998-07-08 J. WOOLLEN -- IMPROVED MACHINE PORTABILITY
C 1998-10-27 J. WOOLLEN -- MODIFIED TO CORRECT PROBLEMS CAUSED BY IN-
C LINING CODE WITH FPP DIRECTIVES
C 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE
C OPENED AT ONE TIME INCREASED FROM 10 TO 32
C (NECESSARY IN ORDER TO PROCESS MULTIPLE
C BUFR FILES UNDER THE MPI)
C 2002-05-14 J. WOOLLEN -- REMOVED OLD CRAY COMPILER DIRECTIVES
C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE
C INTERDEPENDENCIES
C 2003-11-04 D. KEYSER -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES)
C INCREASED FROM 15000 TO 16000 (WAS IN
C VERIFICATION VERSION); UNIFIED/PORTABLE FOR
C WRF; ADDED DOCUMENTATION (INCLUDING
C HISTORY)
<A NAME='IBFMS'><A href='../../html_code/bufr/ufbrw.f.html#IBFMS' TARGET='top_target'><IMG SRC="../../gif/bar_green.gif" border=0></A>
C 2007-01-19 J. ATOR -- USE FUNCTION IBFMS 2,53
C 2009-03-31 J. WOOLLEN -- ADD DOCUMENTATION
C 2009-04-21 J. ATOR -- USE ERRWRT; USE LSTJPB INSTEAD OF LSTRPS
C
C USAGE: CALL UFBRW
(LUN, USR, I1, I2, IO, IRET)
C INPUT ARGUMENT LIST:
C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS
C USR - ONLY IF BUFR FILE OPEN FOR OUTPUT:
C REAL*8: (I1,I2) STARTING ADDRESS OF DATA VALUES
C WRITTEN TO DATA SUBSET
C I1 - INTEGER: LENGTH OF FIRST DIMENSION OF USR
C I2 - INTEGER: LENGTH OF SECOND DIMENSION OF USR
C IO - INTEGER: STATUS INDICATOR FOR BUFR FILE ASSOCIATED
C WITH LUN:
C 0 = input file
C 1 = output file
C
C OUTPUT ARGUMENT LIST:
C USR - ONLY IF BUFR FILE OPEN FOR INPUT:
C REAL*8: (I1,I2) STARTING ADDRESS OF DATA VALUES
C READ FROM DATA SUBSET
C IRET - INTEGER:
C - IF BUFR FILE OPEN FOR INPUT: NUMBER OF "LEVELS" OF
C DATA VALUES READ FROM DATA SUBSET (MUST BE NO
C LARGER THAN I2)
C -1 = NONE OF THE MNEMONICS IN THE STRING PASSED
C TO UFBINT WERE FOUND IN THE SUBSET TEMPLATE
C - IF BUFR FILE OPEN FOR OUTPUT: NUMBER OF "LEVELS"
C OF DATA VALUES WRITTEN TO DATA SUBSET (SHOULD BE
C SAME AS I2)
C -1 = NONE OF THE MNEMONICS IN THE STRING PASSED
C TO UFBINT WERE FOUND IN THE SUBSET TEMPLATE
C
C REMARKS:
C THIS ROUTINE CALLS: CONWIN DRSTPL ERRWRT GETWIN
C IBFMS INVWIN LSTJPB NEWWIN
C NXTWIN
C THIS ROUTINE IS CALLED BY: TRYBUMP UFBINT
C Normally not called by any application
C programs (they should call UFBINT).
C
C ATTRIBUTES:
C LANGUAGE: FORTRAN 77
C MACHINE: PORTABLE TO ALL PLATFORMS
C
C$$$
INCLUDE 'bufrlib.prm'
COMMON /BTABLES/ MAXTAB,NTAB,TAG(MAXJL),TYP(MAXJL),KNT(MAXJL),
. JUMP(MAXJL),LINK(MAXJL),JMPB(MAXJL),
. IBT(MAXJL),IRF(MAXJL),ISC(MAXJL),
. ITP(MAXJL),VALI(MAXJL),KNTI(MAXJL),
. ISEQ(MAXJL,2),JSEQ(MAXJL)
COMMON /USRINT/ NVAL(NFILES),INV(MAXSS,NFILES),VAL(MAXSS,NFILES)
COMMON /USRSTR/ NNOD,NCON,NODS(20),NODC(10),IVLS(10),KONS(10)
COMMON /QUIET / IPRT
CHARACTER*128 ERRSTR
CHARACTER*10 TAG
CHARACTER*3 TYP
REAL*8 USR(I1,I2),VAL
C----------------------------------------------------------------------
C----------------------------------------------------------------------
IRET = 0
C LOOP OVER COND WINDOWS
C ----------------------
INC1 = 1
INC2 = 1
1 CALL CONWIN(LUN,INC1,INC2)
IF(NNOD.EQ.0) THEN
IRET = I2
GOTO 100
ELSEIF(INC1.EQ.0) THEN
GOTO 100
ELSE
DO I=1,NNOD
IF(NODS(I).GT.0) THEN
INS2 = INC1
CALL GETWIN(NODS(I),LUN,INS1,INS2)
IF(INS1.EQ.0) GOTO 100
GOTO 2
ENDIF
ENDDO
IRET = -1
GOTO 100
ENDIF
C LOOP OVER STORE NODES
C ---------------------
2 IRET = IRET+1
IF(IPRT.GE.2) THEN
CALL ERRWRT('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++')
WRITE ( UNIT=ERRSTR, FMT='(5(A,I4))' )
. 'BUFRLIB: UFBRW - IRET:INS1:INS2:INC1:INC2 = ',
. IRET, ':', INS1, ':', INS2, ':', INC1, ':', INC2
CALL ERRWRT(ERRSTR)
KK = INS1
DO WHILE ( ( INS2 - KK ) .GE. 5 )
WRITE ( UNIT=ERRSTR, FMT='(5A10)' )
. (TAG(INV(I,LUN)),I=KK,KK+4)
CALL ERRWRT(ERRSTR)
KK = KK+5
ENDDO
WRITE ( UNIT=ERRSTR, FMT='(5A10)' )
. (TAG(INV(I,LUN)),I=KK,INS2)
CALL ERRWRT(ERRSTR)
CALL ERRWRT('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++')
CALL ERRWRT(' ')
ENDIF
C WRITE USER VALUES
C -----------------
IF(IO.EQ.1 .AND. IRET.LE.I2) THEN
DO I=1,NNOD
IF(NODS(I).GT.0) THEN
IF(IBFMS(USR(I,IRET)).EQ.0) THEN
INVN = INVWIN(NODS(I),LUN,INS1,INS2)
IF(INVN.EQ.0) THEN
CALL DRSTPL(NODS(I),LUN,INS1,INS2,INVN)
IF(INVN.EQ.0) THEN
IRET = 0
GOTO 100
ENDIF
CALL NEWWIN(LUN,INC1,INC2)
VAL(INVN,LUN) = USR(I,IRET)
ELSEIF(LSTJPB(NODS(I),LUN,'RPS').EQ.0) THEN
VAL(INVN,LUN) = USR(I,IRET)
ELSEIF(IBFMS(VAL(INVN,LUN)).NE.0) THEN
VAL(INVN,LUN) = USR(I,IRET)
ELSE
CALL DRSTPL(NODS(I),LUN,INS1,INS2,INVN)
IF(INVN.EQ.0) THEN
IRET = 0
GOTO 100
ENDIF
CALL NEWWIN(LUN,INC1,INC2)
VAL(INVN,LUN) = USR(I,IRET)
ENDIF
ENDIF
ENDIF
ENDDO
ENDIF
C READ USER VALUES
C ----------------
IF(IO.EQ.0 .AND. IRET.LE.I2) THEN
DO I=1,NNOD
USR(I,IRET) = BMISS
IF(NODS(I).GT.0) THEN
INVN = INVWIN(NODS(I),LUN,INS1,INS2)
IF(INVN.GT.0) USR(I,IRET) = VAL(INVN,LUN)
ENDIF
ENDDO
ENDIF
C DECIDE WHAT TO DO NEXT
C ----------------------
IF(IO.EQ.1.AND.IRET.EQ.I2) GOTO 100
CALL NXTWIN(LUN,INS1,INS2)
IF(INS1.GT.0 .AND. INS1.LT.INC2) GOTO 2
IF(NCON.GT.0) GOTO 1
C EXIT
C ----
100 RETURN
END