wrfv2_fire/var/external/bufr/ufbrw.inc

   1       SUBROUTINE UFBRW(LUN,USR,I1,I2,IO,IRET)
   2
   3 !$$$  SUBPROGRAM DOCUMENTATION BLOCK
   4 !
   5 ! SUBPROGRAM:    UFBRW (docblock incomplete)
   6 !   PRGMMR: WOOLLEN          ORG: NP20       DATE: 1994-01-06
   7 !
   8 ! ABSTRACT: THIS SUBROUTINE WRITES OR READS SPECIFIED VALUES TO OR FROM
   9 !   THE CURRENT BUFR DATA SUBSET WITHIN INTERNAL ARRAYS, WITH THE
  10 !   DIRECTION OF THE DATA TRANSFER DETERMINED BY THE CONTEXT OF IO
  11 !   (I.E., IF IO INDICATES LUN POINTS TO A BUFR FILE THAT IS OPEN FOR
  12 !   INPUT, THEN DATA VALUES ARE READ FROM THE INTERNAL DATA SUBSET;
  13 !   OTHERWISE, DATA VALUES ARE WRITTEN TO THE INTERNAL DATA SUBSET.
  14 !   THE DATA VALUES CORRESPOND TO INTERNAL ARRAYS REPRESENTING PARSED
  15 !   STRINGS OF MNEMONICS WHICH ARE PART OF A DELAYED-REPLICATION
  16 !   SEQUENCE, OR FOR WHICH THERE IS NO REPLICATION AT ALL.  THIS
  17 !   ROUTINE SHOULD NEVER BE CALLED BY ANY APPLICATION PROGRAM
  18 !   (APPLICATION PROGRAMS SHOULD ALWAYS CALL BUFR ARCHIVE LIBRARY
  19 !   SUBROUTINE UFBINT TO PERFORM THESE FUNCTIONS).
  20 !
  21 ! PROGRAM HISTORY LOG:
  22 ! 1994-01-06  J. WOOLLEN -- ORIGINAL AUTHOR
  23 ! 1996-12-11  J. WOOLLEN -- REMOVED A HARD ABORT FOR USERS WHO TRY TO
  24 !                           WRITE NON-EXISTING MNEMONICS
  25 ! 1998-07-08  J. WOOLLEN -- IMPROVED MACHINE PORTABILITY
  26 ! 1998-10-27  J. WOOLLEN -- MODIFIED TO CORRECT PROBLEMS CAUSED BY IN-
  27 !                           LINING CODE WITH FPP DIRECTIVES
  28 ! 1999-11-18  J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE
  29 !                           OPENED AT ONE TIME INCREASED FROM 10 TO 32
  30 !                           (NECESSARY IN ORDER TO PROCESS MULTIPLE
  31 !                           BUFR FILES UNDER THE MPI)
  32 ! 2002-05-14  J. WOOLLEN -- REMOVED OLD CRAY COMPILER DIRECTIVES
  33 ! 2003-11-04  S. BENDER  -- ADDED REMARKS/BUFRLIB ROUTINE
  34 !                           INTERDEPENDENCIES
  35 ! 2003-11-04  D. KEYSER  -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES)
  36 !                           INCREASED FROM 15000 TO 16000 (WAS IN
  37 !                           VERIFICATION VERSION); UNIFIED/PORTABLE FOR
  38 !                           WRF; ADDED DOCUMENTATION (INCLUDING
  39 !                           HISTORY) (INCOMPLETE)
  40 ! 2007-01-19  J. ATOR    -- USE FUNCTION IBFMS
  41 !
  42 ! USAGE:    CALL UFBRW (LUN, USR, I1, I2, IO, IRET)
  43 !   INPUT ARGUMENT LIST:
  44 !     LUN      - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS
  45 !     USR      - ONLY IF BUFR FILE OPEN FOR OUTPUT:
  46 !                   REAL*8: (I1,I2) STARTING ADDRESS OF DATA VALUES
  47 !                   WRITTEN TO DATA SUBSET
  48 !     I1       - INTEGER: LENGTH OF FIRST DIMENSION OF USR
  49 !     I2       - INTEGER: LENGTH OF SECOND DIMENSION OF USR
  50 !     IO       - INTEGER: STATUS INDICATOR FOR BUFR FILE ASSOCIATED
  51 !                WITH LUN:
  52 !                       0 = input file
  53 !                       1 = output file
  54 !
  55 !   OUTPUT ARGUMENT LIST:
  56 !     USR      - ONLY IF BUFR FILE OPEN FOR INPUT:
  57 !                   REAL*8: (I1,I2) STARTING ADDRESS OF DATA VALUES
  58 !                   READ FROM DATA SUBSET
  59 !     IRET     - INTEGER:
  60 !                  - IF BUFR FILE OPEN FOR INPUT: NUMBER OF "LEVELS" OF
  61 !                    DATA VALUES READ FROM DATA SUBSET (MUST BE NO
  62 !                    LARGER THAN I2)
  63 !                      -1 = ....
  64 !                  - IF BUFR FILE OPEN FOR OUTPUT: NUMBER OF "LEVELS"
  65 !                    OF DATA VALUES WRITTEN TO DATA SUBSET (SHOULD BE
  66 !                    SAME AS I2)
  67 !                      -1 = ....
  68 !
  69 !   OUTPUT FILES:
  70 !     UNIT 06  - STANDARD OUTPUT PRINT
  71 !
  72 ! REMARKS:
  73 !    THIS ROUTINE CALLS:        CONWIN   DRSTPL   GETWIN   IBFMS
  74 !                               INVWIN   LSTRPS   NEWWIN   NXTWIN
  75 !    THIS ROUTINE IS CALLED BY: TRYBUMP  UFBINT
  76 !                               Normally not called by any application
  77 !                               programs (they should call UFBINT).
  78 !
  79 ! ATTRIBUTES:
  80 !   LANGUAGE: FORTRAN 77
  81 !   MACHINE:  PORTABLE TO ALL PLATFORMS
  82 !
  83 !$$$
  84
  85       INCLUDE 'bufrlib.prm'
  86
  87 !     COMMON /TABLES/ MAXTAB,NTAB,TAG(MAXJL),TYP(MAXJL),KNT(MAXJL), &
  88 !                     JUMP(MAXJL),LINK(MAXJL),JMPB(MAXJL), &
  89 !                     IBT(MAXJL),IRF(MAXJL),ISC(MAXJL), &
  90 !                     ITP(MAXJL),VALI(MAXJL),KNTI(MAXJL), &
  91 !                     ISEQ(MAXJL,2),JSEQ(MAXJL)
  92 !     COMMON /USRINT/ NVAL(NFILES),INV(MAXJL,NFILES),VAL(MAXJL,NFILES)
  93       COMMON /USRSTR/ NNOD,NCON,NODS(20),NODC(10),IVLS(10),KONS(10)
  94       COMMON /QUIET / IPRT
  95
  96 !     CHARACTER*10 TAG
  97 !     CHARACTER*3  TYP
  98       REAL*8       USR(I1,I2)!,VAL
  99
 100 !----------------------------------------------------------------------
 101 !----------------------------------------------------------------------
 102
 103       IF ( .NOT. ALLOCATED (NVAL) ) ALLOCATE ( NVAL(NFILES) )
 104       IF ( .NOT. ALLOCATED (INV) ) ALLOCATE ( INV(MAXJL,NFILES) )
 105       IF ( .NOT. ALLOCATED (VAL) ) ALLOCATE ( VAL(MAXJL,NFILES) )
 106
 107       IRET = 0
 108
 109 !  LOOP OVER COND WINDOWS
 110 !  ----------------------
 111
 112       INC1 = 1
 113       INC2 = 1
 114
 115 1     CALL CONWIN(LUN,INC1,INC2,I2)
 116       IF(NNOD.EQ.0) THEN
 117          IRET = I2
 118          GOTO 100
 119       ELSEIF(INC1.EQ.0) THEN
 120          GOTO 100
 121       ELSE
 122          DO I=1,NNOD
 123          IF(NODS(I).GT.0) THEN
 124             INS2 = INC1
 125             CALL GETWIN(NODS(I),LUN,INS1,INS2)
 126             IF(INS1.EQ.0) GOTO 100
 127             GOTO 2
 128          ENDIF
 129          ENDDO
 130          IRET = -1
 131          GOTO 100
 132       ENDIF
 133
 134 !  LOOP OVER STORE NODES
 135 !  ---------------------
 136
 137 2     IRET = IRET+1
 138
 139       IF(IPRT.GE.2)  THEN
 140       PRINT*
 141       PRINT*,'+++++++++++++++++BUFR ARCHIVE LIBRARY++++++++++++++++++++'
 142          PRINT*,'BUFRLIB: UFBRW -  IRET:INS1:INS2:INC1:INC2 = ',IRET, &
 143           ':',INS1,':',INS2,':',INC1,':',INC2
 144          PRINT'(5A10)',(TAG(INV(I,LUN)),I=INS1,INS2)
 145       PRINT*,'+++++++++++++++++BUFR ARCHIVE LIBRARY++++++++++++++++++++'
 146       PRINT*
 147       ENDIF
 148
 149 !  WRITE USER VALUES
 150 !  -----------------
 151
 152       IF(IO.EQ.1 .AND. IRET.LE.I2) THEN
 153          DO I=1,NNOD
 154          IF(NODS(I).GT.0) THEN
 155             IF(IBFMS(USR(I,IRET)).EQ.0) THEN
 156                INVN = INVWIN(NODS(I),LUN,INS1,INS2)
 157                IF(INVN.EQ.0) THEN
 158                   CALL DRSTPL(NODS(I),LUN,INS1,INS2,INVN)
 159                   IF(INVN.EQ.0) THEN
 160                      IRET = 0
 161                      GOTO 100
 162                   ENDIF
 163                   CALL NEWWIN(LUN,INC1,INC2)
 164                   VAL(INVN,LUN) = USR(I,IRET)
 165                ELSEIF(LSTRPS(NODS(I),LUN).EQ.0) THEN
 166                   VAL(INVN,LUN) = USR(I,IRET)
 167                ELSEIF(IBFMS(VAL(INVN,LUN)).NE.0) THEN
 168                   VAL(INVN,LUN) = USR(I,IRET)
 169                ELSE
 170                   CALL DRSTPL(NODS(I),LUN,INS1,INS2,INVN)
 171                   IF(INVN.EQ.0) THEN
 172                      IRET = 0
 173                      GOTO 100
 174                   ENDIF
 175                   CALL NEWWIN(LUN,INC1,INC2)
 176                   VAL(INVN,LUN) = USR(I,IRET)
 177                ENDIF
 178             ENDIF
 179          ENDIF
 180          ENDDO
 181       ENDIF
 182
 183 !  READ USER VALUES
 184 !  ----------------
 185
 186       IF(IO.EQ.0 .AND. IRET.LE.I2) THEN
 187          DO I=1,NNOD
 188          USR(I,IRET) = BMISS
 189          IF(NODS(I).GT.0) THEN
 190             INVN = INVWIN(NODS(I),LUN,INS1,INS2)
 191             IF(INVN.GT.0) USR(I,IRET) = VAL(INVN,LUN)
 192          ENDIF
 193          ENDDO
 194       ENDIF
 195
 196 !  DECIDE WHAT TO DO NEXT
 197 !  ----------------------
 198
 199       IF(IO.EQ.1.AND.IRET.EQ.I2) GOTO 100
 200       CALL NXTWIN(LUN,INS1,INS2)
 201       IF(INS1.GT.0 .AND. INS1.LT.INC2) GOTO 2
 202       IF(NCON.GT.0) GOTO 1
 203
 204 !  EXIT
 205 !  ----
 206
 207 100   RETURN
 208       END SUBROUTINE UFBRW