var/external/bufr/rdmems.f

   1       SUBROUTINE RDMEMS(ISUB,IRET)
   2
   3 C$$$  SUBPROGRAM DOCUMENTATION BLOCK
   4 C
   5 C SUBPROGRAM:    RDMEMS
   6 C   PRGMMR: WOOLLEN          ORG: NP20       DATE: 1994-01-06
   7 C
   8 C ABSTRACT: THIS SUBROUTINE READS A PARTICULAR SUBSET FROM A BUFR
   9 C   MESSAGE IN INTERNAL MEMORY (ARRAY MBAY IN COMMON BLOCK /BITBUF/)
  10 C   INTO INTERNAL SUBSET ARRAYS BASED ON THE SUBSET NUMBER IN THE
  11 C   MESSAGE.
  12 C
  13 C PROGRAM HISTORY LOG:
  14 C 1994-01-06  J. WOOLLEN -- ORIGINAL AUTHOR
  15 C 1998-07-08  J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE
  16 C                           "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB
  17 C                           ROUTINE "BORT"
  18 C 1998-10-27  J. WOOLLEN -- MODIFIED TO CORRECT PROBLEMS CAUSED BY IN-
  19 C                           LINING CODE WITH FPP DIRECTIVES
  20 C 1999-11-18  J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE
  21 C                           OPENED AT ONE TIME INCREASED FROM 10 TO 32
  22 C                           (NECESSARY IN ORDER TO PROCESS MULTIPLE
  23 C                           BUFR FILES UNDER THE MPI)
  24 C 2000-09-19  J. WOOLLEN -- MAXIMUM MESSAGE LENGTH INCREASED FROM
  25 C                           10,000 TO 20,000 BYTES
  26 C 2001-08-15  D. KEYSER  -- PARAMETER MAXMEM (THE MAXIMUM NUMBER OF
  27 C                           BYTES REQUIRED TO STORE ALL MESSAGES
  28 C                           INTERNALLY) WAS INCREASED FROM 8 MBYTES TO
  29 C                           16 MBYTES
  30 C 2003-11-04  S. BENDER  -- ADDED REMARKS/BUFRLIB ROUTINE
  31 C                           INTERDEPENDENCIES
  32 C 2003-11-04  D. KEYSER  -- PARAMETER MAXMSG (THE MAXIMUM NUMBER OF
  33 C                           BUFR MESSAGES WHICH CAN BE STORED
  34 C                           INTERNALLY) INCREASED FROM 50000 TO 200000;
  35 C                           UNIFIED/PORTABLE FOR WRF; ADDED
  36 C                           DOCUMENTATION (INCLUDING HISTORY); OUTPUTS
  37 C                           MORE COMPLETE DIAGNOSTIC INFO WHEN ROUTINE
  38 C                           TERMINATES ABNORMALLY OR UNUSUAL THINGS
  39 C                           HAPPEN
  40 C 2004-08-09  J. ATOR    -- MAXIMUM MESSAGE LENGTH INCREASED FROM
  41 C                           20,000 TO 50,000 BYTES
  42 C 2004-11-15  D. KEYSER  -- PARAMETER MAXMEM (THE MAXIMUM NUMBER OF
  43 C                           BYTES REQUIRED TO STORE ALL MESSAGES
  44 C                           INTERNALLY) WAS INCREASED FROM 16 MBYTES TO
  45 C                           50 MBYTES
  46 C 2009-04-21  J. ATOR    -- USE ERRWRT
  47 C
  48 C USAGE:    CALL RDMEMS (ISUB, IRET)
  49 C   INPUT ARGUMENT LIST:
  50 C     ISUB     - INTEGER: POINTER TO SUBSET NUMBER TO READ IN BUFR
  51 C                MESSAGE
  52 C
  53 C   OUTPUT ARGUMENT LIST:
  54 C     IRET     - INTEGER: RETURN CODE:
  55 C                       0 = normal return
  56 C                      -1 = ISUB is greater than the number of subsets
  57 C                           in memory
  58 C
  59 C REMARKS:
  60 C    THIS ROUTINE CALLS:        BORT     ERRWRT   IUPB     READSB
  61 C                               STATUS
  62 C    THIS ROUTINE IS CALLED BY: UFBMMS   UFBMNS   UFBRMS
  63 C                               Normally not called by any application
  64 C                               programs.
  65 C
  66 C ATTRIBUTES:
  67 C   LANGUAGE: FORTRAN 77
  68 C   MACHINE:  PORTABLE TO ALL PLATFORMS
  69 C
  70 C$$$
  71
  72       INCLUDE 'bufrlib.prm'
  73
  74       CHARACTER*128 BORT_STR,ERRSTR
  75
  76       COMMON /MSGMEM/ MUNIT,MLAST,MSGP(0:MAXMSG),MSGS(MAXMEM),
  77      .                MDX(MXDXW),IPDXM(MXDXM),LDXM,NDXM,LDXTS,NDXTS,
  78      .                IFDXTS(MXDXTS),ICDXTS(MXDXTS),IPMSGS(MXDXTS)
  79       COMMON /MSGCWD/ NMSG(NFILES),NSUB(NFILES),MSUB(NFILES),
  80      .                INODE(NFILES),IDATE(NFILES)
  81       COMMON /BITBUF/ MAXBYT,IBIT,IBAY(MXMSGLD4),MBYT(NFILES),
  82      .                MBAY(MXMSGLD4,NFILES)
  83       COMMON /UNPTYP/ MSGUNP(NFILES)
  84       COMMON /QUIET / IPRT
  85
  86 C-----------------------------------------------------------------------
  87 C-----------------------------------------------------------------------
  88
  89 C  CHECK THE MESSAGE REQUEST AND FILE STATUS
  90 C  -----------------------------------------
  91
  92       CALL STATUS(MUNIT,LUN,IL,IM)
  93       IF(IL.EQ.0) GOTO 900
  94       IF(IL.GT.0) GOTO 901
  95       IF(IM.EQ.0) GOTO 902
  96       IF(NSUB(LUN).NE.0) GOTO 903
  97
  98       IF(ISUB.GT.MSUB(LUN)) THEN
  99          IF(IPRT.GE.0) THEN
 100       CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
 101            WRITE ( UNIT=ERRSTR, FMT='(A,I5,A,A,I5,A)' )
 102      .      'BUFRLIB: RDMEMS - REQ. SUBSET #', ISUB, ' (= 1st INPUT ',
 103      .      'ARG.) > # OF SUBSETS IN MEMORY MESSAGE (', MSUB(LUN), ')'
 104            CALL ERRWRT(ERRSTR)
 105            CALL ERRWRT('RETURN WITH IRET = -1')
 106       CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
 107       CALL ERRWRT(' ')
 108          ENDIF
 109          IRET = -1
 110          GOTO 100
 111       ENDIF
 112
 113       MBYM = MBYT(LUN)
 114       NBYT = 0
 115
 116 C  POSITION TO SUBSET NUMBER ISUB IN MEMORY MESSAGE
 117 C  ------------------------------------------------
 118
 119       IF(MSGUNP(LUN).EQ.0) THEN
 120          NSUB(LUN) = ISUB-1
 121          DO I=1,ISUB-1
 122          MBYT(LUN) = MBYT(LUN) + IUPB(MBAY(1,LUN),MBYT(LUN)+1,16)
 123          ENDDO
 124       ELSEIF(MSGUNP(LUN).EQ.1) THEN
 125 c  .... message with "standard" Section 3
 126          DO I=1,ISUB-1
 127          CALL READSB(MUNIT,IRET)
 128          ENDDO
 129       ELSEIF(MSGUNP(LUN).EQ.2) THEN
 130 c  .... compressed message
 131          NSUB(LUN) = ISUB-1
 132       ENDIF
 133
 134 C  NOW READ SUBSET NUMBER ISUB FROM MEMORY MESSAGE
 135 C  -----------------------------------------------
 136
 137       CALL READSB(MUNIT,IRET)
 138 c  .... This should have already been accounted for with stmt. 902 or
 139 c       IRET = -1 above
 140       IF(IRET.NE.0) GOTO 904
 141
 142 C  RESET SUBSET POINTER BACK TO ZERO (BEGINNING OF MESSAGE) AND RETURN
 143 C  -------------------------------------------------------------------
 144
 145       MBYT(LUN) = MBYM
 146       NSUB(LUN) = 0
 147
 148 C  EXITS
 149 C  -----
 150
 151 100   RETURN
 152 900   CALL BORT('BUFRLIB: RDMEMS - INPUT BUFR FILE IS CLOSED, IT '//
 153      . 'MUST BE OPEN FOR INPUT')
 154 901   CALL BORT('BUFRLIB: RDMEMS - INPUT BUFR FILE IS OPEN FOR '//
 155      . 'OUTPUT, IT MUST BE OPEN FOR INPUT')
 156 902   CALL BORT('BUFRLIB: RDMEMS - A MEMORY MESSAGE MUST BE OPEN IN '//
 157      . 'INPUT BUFR FILE, NONE ARE')
 158 903   WRITE(BORT_STR,'("BUFRLIB: RDMEMS - UPON ENTRY, SUBSET POINTER '//
 159      . 'IN MEMORY MESSAGE IS NOT AT BEGINNING (",I3," SUBSETS HAVE '//
 160      . 'BEEN READ, SHOULD BE 0)")') NSUB(LUN)
 161       CALL BORT(BORT_STR)
 162 904   CALL BORT('BUFRLIB: RDMEMS - CALL TO ROUTINE READSB RETURNED '//
 163      . 'WITH IRET = -1 (EITHER MEMORY MESSAGE NOT OPEN OR ALL '//
 164      . 'SUBSETS IN MESSAGE READ')
 165       END