wrfv2_fire/var/external/bufr/writsa.inc

   1       SUBROUTINE WRITSA (LUNXX, MSGT, MSGL)
   2
   3 !$$$  SUBPROGRAM DOCUMENTATION BLOCK
   4 !
   5 ! SUBPROGRAM:    WRITSA
   6 !   PRGMMR: WOOLLEN          ORG: NP20       DATE: 1994-01-06
   7 !
   8 ! ABSTRACT: THIS SUBROUTINE SHOULD ONLY BE CALLED WHEN LOGICAL UNIT
   9 !   ABS(LUNXX) HAS BEEN OPENED FOR OUTPUT OPERATIONS.
  10 !
  11 !   WHEN LUNXX IS GREATER THAN ZERO, IT PACKS UP THE CURRENT SUBSET
  12 !   WITHIN MEMORY AND THEN TRIES TO ADD IT TO THE BUFR MESSAGE THAT IS
  13 !   CURRENTLY OPEN WITHIN MEMORY FOR ABS(LUNXX).  THE DETERMINATION AS
  14 !   TO WHETHER OR NOT THE SUBSET CAN BE ADDED TO THE MESSAGE IS MADE
  15 !   VIA AN INTERNAL CALL TO ONE OF THE BUFR ARCHIVE LIBRARY SUBROUTINES
  16 !   WRCMPS OR MSGUPD, DEPENDING UPON WHETHER OR NOT THE MESSAGE IS
  17 !   COMPRESSED.  IF IT TURNS OUT THAT THE SUBSET CANNOT BE ADDED TO THE
  18 !   CURRENTLY OPEN MESSAGE, THEN THAT MESSAGE IS FLUSHED TO ABS(LUNXX)
  19 !   AND A NEW ONE IS CREATED IN ORDER TO HOLD THE SUBSET.  AS LONG AS
  20 !   LUNXX IS GREATER THAN ZERO, WRITSA FUNCTIONS EXACTLY LIKE BUFR
  21 !   ARCHIVE LIBRARY SUBROUTINE WRITSB, EXCEPT THAT WRITSA ALSO RETURNS
  22 !   A COPY OF EACH COMPLETED BUFR MESSAGE TO THE APPLICATION PROGRAM
  23 !   IN THE FIRST MSGL WORDS OF ARRAY MSGT.
  24 !
  25 !   ALTERNATIVELY, WHEN LUNXX IS LESS THAN ZERO, THIS IS A SIGNAL TO
  26 !   FORCE ANY CURRENT MESSAGE IN MEMORY TO BE FLUSHED TO ABS(LUNXX) AND
  27 !   RETURNED IN ARRAY MSGT.  IN SUCH CASES, ANY CURRENT SUBSET IN MEMORY
  28 !   IS IGNORED.  THIS OPTION IS NECESSARY BECAUSE ANY MESSAGE RETURNED
  29 !   IN MSGT FROM A CALL TO THIS ROUTINE NEVER CONTAINS THE ACTUAL SUBSET
  30 !   THAT WAS PACKED UP AND STORED DURING THE SAME CALL TO THIS ROUTINE.
  31 !   THEREFORE, THE ONLY WAY TO ENSURE THAT EVERY LAST BUFR SUBSET IS
  32 !   RETURNED WITHIN A BUFR MESSAGE IN MSGT BEFORE, E.G., EXITING THE
  33 !   APPLICATION PROGRAM, IS TO DO ONE FINAL CALL TO THIS ROUTINE WITH
  34 !   LUNXX LESS THAN ZERO IN ORDER TO FORCIBLY FLUSH OUT AND RETURN ONE
  35 !   FINAL BUFR MESSAGE.
  36 !
  37 ! PROGRAM HISTORY LOG:
  38 ! 1994-01-06  J. WOOLLEN -- ORIGINAL AUTHOR
  39 ! 1998-07-08  J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE
  40 !                           "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB
  41 !                           ROUTINE "BORT"
  42 ! 2000-09-19  J. WOOLLEN -- MAXIMUM MESSAGE LENGTH INCREASED FROM
  43 !                           10,000 TO 20,000 BYTES
  44 ! 2003-11-04  S. BENDER  -- ADDED REMARKS/BUFRLIB ROUTINE
  45 !                           INTERDEPENDENCIES
  46 ! 2003-11-04  D. KEYSER  -- UNIFIED/PORTABLE FOR WRF; ADDED
  47 !                           DOCUMENTATION (INCLUDING HISTORY); OUTPUTS
  48 !                           MORE COMPLETE DIAGNOSTIC INFO WHEN ROUTINE
  49 !                           TERMINATES ABNORMALLY
  50 ! 2004-08-18  J. ATOR    -- ADD POST-MSGUPD CHECK FOR AND RETURN OF
  51 !                           MESSAGE WITHIN MSGT IN ORDER TO PREVENT
  52 !                           LOSS OF MESSAGE IN CERTAIN SITUATIONS;
  53 !                           MAXIMUM MESSAGE LENGTH INCREASED FROM
  54 !                           20,000 TO 50,000 BYTES
  55 ! 2005-03-09  J. ATOR    -- ADDED CAPABILITY FOR COMPRESSED MESSAGES
  56 !
  57 ! USAGE:    CALL WRITSA (LUNXX, MSGT, MSGL)
  58 !   INPUT ARGUMENT LIST:
  59 !     LUNXX    - INTEGER: ABSOLUTE VALUE IS FORTRAN LOGICAL UNIT NUMBER
  60 !                FOR BUFR FILE {IF LUNXX IS LESS THAN ZERO, THEN ANY
  61 !                CURRENT MESSAGE IN MEMORY WILL BE FORCIBLY FLUSHED TO
  62 !                ABS(LUNXX) AND TO ARRAY MSGT}
  63 !
  64 !   OUTPUT ARGUMENT LIST:
  65 !     MSGT     - INTEGER: *-WORD PACKED BINARY ARRAY CONTAINING BUFR
  66 !                MESSAGE (FIRST MSGL WORDS FILLED)
  67 !     MSGL     - INTEGER: NUMBER OF WORDS FILLED IN MSGT
  68 !                       0 = no message was returned
  69 !
  70 ! REMARKS:
  71 !    THIS ROUTINE CALLS:        BORT     CLOSMG   MSGUPD   STATUS
  72 !                               WRCMPS   WRTREE
  73 !    THIS ROUTINE IS CALLED BY: None
  74 !                               Normally called only by application
  75 !                               programs.
  76 !
  77 ! ATTRIBUTES:
  78 !   LANGUAGE: FORTRAN 77
  79 !   MACHINE:  PORTABLE TO ALL PLATFORMS
  80 !
  81 !$$$
  82
  83       INCLUDE 'bufrlib.prm'
  84
  85       COMMON / BUFRMG / MSGLEN, MSGTXT (MXMSGLD4)
  86       COMMON / MSGCMP / CCMF
  87
  88       CHARACTER(1) CCMF
  89
  90       DIMENSION MSGT ( * )
  91
  92 !----------------------------------------------------------------------
  93 !----------------------------------------------------------------------
  94
  95       LUNIT = ABS (LUNXX)
  96
  97 !  CHECK THE FILE STATUS
  98 !  ---------------------
  99
 100       CALL STATUS (LUNIT, LUN, IL, IM)
 101       IF (IL.EQ.0) GOTO 900
 102       IF (IL.LT.0) GOTO 901
 103       IF (IM.EQ.0) GOTO 902
 104
 105 !  IF LUNXX < 0, FORCE MEMORY MSG TO BE WRITTEN (W/O ANY CURRENT SUBSET)
 106 !  ---------------------------------------------------------------------
 107
 108       IF (LUNXX.LT.0) CALL CLOSMG (LUNIT)
 109
 110 !  IS THERE A COMPLETED BUFR MESSAGE TO BE RETURNED?
 111 !  -------------------------------------------------
 112
 113       IF (MSGLEN.GT.0) THEN
 114          MSGL = MSGLEN
 115          DO N = 1, MSGL
 116          MSGT (N) = MSGTXT (N)
 117          ENDDO
 118          MSGLEN = 0
 119       ELSE
 120          MSGL = 0
 121       ENDIF
 122
 123       IF (LUNXX.LT.0) GOTO 100
 124
 125 !  PACK UP THE SUBSET AND PUT IT INTO THE MESSAGE
 126 !  ----------------------------------------------
 127
 128       CALL WRTREE (LUN)
 129       IF (CCMF.EQ.'Y') THEN
 130          CALL WRCMPS (LUNIT)
 131       ELSE
 132          CALL MSGUPD (LUNIT, LUN)
 133       ENDIF
 134
 135 !  IF THE JUST-COMPLETED CALL TO WRCMPS OR MSGUPD FOR THIS SUBSET CAUSED
 136 !  A PREVIOUS MESSAGE TO BE FLUSHED TO ABS(LUNXX), THEN RETRIEVE AND
 137 !  RETURN THAT MESSAGE NOW.  OTHERWISE, WE RUN THE RISK THAT THE NEXT
 138 !  CALL TO OPENMB OR OPENMG MIGHT CAUSE A NEWER MESSAGE (WHICH WOULD
 139 !  CONTAIN THE CURRENT SUBSET!) TO BE FLUSHED AND THUS OVERWRITE THE
 140 !  PREVIOUS MESSAGE WITHIN ARRAY MSGTXT BEFORE WE HAD THE CHANCE TO
 141 !  RETRIEVE IT DURING THE NEXT CALL TO WRITSA!
 142
 143 !  NOTE ALSO THAT, IF THE MOST RECENT CALL TO OPENMB OR OPENMG HAD
 144 !  CAUSED A MESSAGE TO BE FLUSHED, IT WOULD HAVE DONE SO IN ORDER TO
 145 !  CREATE A NEW MESSAGE TO HOLD THE CURRENT SUBSET.  THUS, IN SUCH
 146 !  CASES, IT SHOULD NOT BE POSSIBLE THAT THE JUST-COMPLETED CALL TO
 147 !  WRCMPS OR MSGUPD (FOR THIS SAME SUBSET!) WOULD HAVE ALSO CAUSED A
 148 !  MESSAGE TO BE FLUSHED, AND THUS IT SHOULD NOT BE POSSIBLE TO HAVE
 149 !  TWO (2) SEPARATE BUFR MESSAGES RETURNED FROM ONE (1) CALL TO WRITSA!
 150
 151       IF (MSGLEN.GT.0) THEN
 152          IF (MSGL.NE.0) GOTO 903
 153          MSGL = MSGLEN
 154          DO N = 1, MSGL
 155          MSGT (N) = MSGTXT (N)
 156          ENDDO
 157          MSGLEN = 0
 158       ENDIF
 159
 160 !  EXITS
 161 !  -----
 162
 163   100 RETURN
 164   900 CALL BORT ('BUFRLIB: WRITSA - OUTPUT BUFR FILE IS CLOSED, IT '//  &
 165       'MUST BE OPEN FOR OUTPUT')
 166   901 CALL BORT ('BUFRLIB: WRITSA - OUTPUT BUFR FILE IS OPEN FOR '//    &
 167       'INPUT, IT MUST BE OPEN FOR OUTPUT')
 168   902 CALL BORT ('BUFRLIB: WRITSA - A MESSAGE MUST BE OPEN IN OUTPUT '//&
 169       'BUFR FILE, NONE ARE')
 170   903 CALL BORT ('BUFRLIB: WRITSA - TWO BUFR MESSAGES WERE RETRIEVED '//&
 171       'BY ONE CALL TO THIS ROUTINE')
 172       END SUBROUTINE WRITSA