wrfv2_fire/var/external/bufr/parusr.inc

   1       SUBROUTINE PARUSR(STR,LUN,I1,IO)
   2
   3 !$$$  SUBPROGRAM DOCUMENTATION BLOCK
   4 !
   5 ! SUBPROGRAM:    PARUSR
   6 !   PRGMMR: WOOLLEN          ORG: NP20       DATE: 1994-01-06
   7 !
   8 ! ABSTRACT: THIS SUBROUTINE INITATES THE PROCESS TO PARSE OUT MNEMONICS
   9 !   (NODES) FROM A USER-SPECIFIED CHARACTER STRING, AND SEPARATES THEM
  10 !   INTO STORE AND CONDITION NODES.  INFORMATION ABOUT THE STRING
  11 !   "PIECES" (I.E., THE MNEMONICS) IS STORED IN ARRAYS IN COMMON BLOCK
  12 !   /USRSTR/.  CONDITION NODES ARE SORTED IN THE ORDER EXPECTED IN THE
  13 !   INTERNAL JUMP/LINK TABLES AND SEVERAL CHECKS ARE PERFORMED ON THE
  14 !   NODES.
  15 !
  16 ! PROGRAM HISTORY LOG:
  17 ! 1994-01-06  J. WOOLLEN -- ORIGINAL AUTHOR
  18 ! 1998-07-08  J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE
  19 !                           "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB
  20 !                           ROUTINE "BORT"; IMPROVED MACHINE
  21 !                           PORTABILITY
  22 ! 2003-11-04  S. BENDER  -- ADDED REMARKS/BUFRLIB ROUTINE
  23 !                           INTERDEPENDENCIES
  24 ! 2003-11-04  D. KEYSER  -- UNIFIED/PORTABLE FOR WRF; ADDED
  25 !                           DOCUMENTATION (INCLUDING HISTORY); OUTPUTS
  26 !                           MORE COMPLETE DIAGNOSTIC INFO WHEN ROUTINE
  27 !                           TERMINATES ABNORMALLY; CHANGED CALL FROM
  28 !                           BORT TO BORT2; RESPONDED TO CHANGE IN
  29 !                           PARUTG (WHICH THIS ROUTINE CALLS) TO NO
  30 !                           LONGER EXPECT AN ALTERNATE RETURN TO A
  31 !                           STATEMENT NUMBER IN THIS ROUTINE WHICH
  32 !                           CALLED BORT (BORT IS NOW CALLED IN PARUTG)
  33 ! 2007-01-19  J. ATOR    -- REPLACED CALL TO PARSEQ WITH CALL TO PARSTR
  34 !
  35 ! USAGE:    CALL PARUSR (STR, LUN, I1, IO)
  36 !   INPUT ARGUMENT LIST:
  37 !     STR      - CHARACTER*(*): STRING OF BLANK-SEPARATED MNEMONICS
  38 !     LUN      - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS
  39 !     I1       - INTEGER: A NUMBER GREATER THAN OR EQUAL TO THE NUMBER
  40 !                OF BLANK-SEPARATED MNEMONICS IN STR
  41 !     IO       - INTEGER: STATUS INDICATOR FOR BUFR FILE ASSOCIATED
  42 !                WITH LUN:
  43 !                       0 = input file
  44 !                       1 = output file
  45 !
  46 ! REMARKS:
  47 !    THIS ROUTINE CALLS:        BORT2    LSTRPC   PARSTR   PARUTG
  48 !    THIS ROUTINE IS CALLED BY: STRING
  49 !                               Normally not called by any application
  50 !                               programs.
  51 !
  52 ! ATTRIBUTES:
  53 !   LANGUAGE: FORTRAN 77
  54 !   MACHINE:  PORTABLE TO ALL PLATFORMS
  55 !
  56 !$$$
  57
  58       COMMON /USRSTR/ NNOD,NCON,NODS(20),NODC(10),IVLS(10),KONS(10)
  59       COMMON /ACMODE/ IAC
  60
  61       CHARACTER*(*) STR
  62       CHARACTER*128 BORT_STR1,BORT_STR2
  63       CHARACTER*80  UST
  64       CHARACTER*20  UTG(30)
  65       LOGICAL       BUMP
  66
  67       DATA MAXUSR /30/
  68       DATA MAXNOD /20/
  69       DATA MAXCON /10/
  70
  71 !----------------------------------------------------------------------
  72 !----------------------------------------------------------------------
  73
  74       UST  = STR
  75       IF(LEN(STR).GT.80) GOTO 900
  76
  77       NCON = 0
  78       NNOD = 0
  79
  80 !  PARSE OUT STRING PIECES(S) (UTG's or MNEMONICS)
  81 !  -----------------------------------------------
  82
  83       CALL PARSTR(UST,UTG,MAXUSR,NTOT,' ',.TRUE.)
  84
  85       DO N=1,NTOT
  86
  87 !  DETERMINE IF THIS UTG IS A CONDITION NODE OR A STORE NODE
  88 !  ---------------------------------------------------------
  89
  90       CALL PARUTG(LUN,IO,UTG(N),NOD,KON,VAL_S)
  91       IF(KON.NE.0) THEN
  92 !  .... it is a condition node
  93          NCON = NCON+1
  94          IF(NCON.GT.MAXCON) GOTO 901
  95          NODC(NCON) = NOD
  96          KONS(NCON) = KON
  97          IVLS(NCON) = NINT(VAL_S)
  98       ELSE
  99 !  .... it is a store node
 100          NNOD = NNOD+1
 101          IF(NNOD.GT.MAXNOD) GOTO 902
 102          NODS(NNOD) = NOD
 103       ENDIF
 104       ENDDO
 105
 106 !  SORT CONDITION NODES IN JUMP/LINK TABLE ORDER
 107 !  ---------------------------------------------
 108
 109       DO I=1,NCON
 110       DO J=I+1,NCON
 111       IF(NODC(I).GT.NODC(J)) THEN
 112          NOD     = NODC(I)
 113          NODC(I) = NODC(J)
 114          NODC(J) = NOD
 115
 116          KON     = KONS(I)
 117          KONS(I) = KONS(J)
 118          KONS(J) = KON
 119
 120          VAL_S     = IVLS(I)
 121          IVLS(I) = IVLS(J)
 122          IVLS(J) = VAL_S
 123       ENDIF
 124       ENDDO
 125       ENDDO
 126
 127 !  CHECK ON SPECIAL RULES FOR CONDITIONAL NODES THAT ARE BUMP NODES
 128 !  ----------------------------------------------------------------
 129
 130       BUMP = .FALSE.
 131
 132       DO N=1,NCON
 133       IF(KONS(N).EQ.5) THEN
 134          IF(IO.EQ.0)   GOTO 903
 135          IF(N.NE.NCON) GOTO 904
 136          BUMP = .TRUE.
 137       ENDIF
 138       ENDDO
 139
 140 !  CHECK STORE NODE COUNT AND ALIGNMENT
 141 !  ------------------------------------
 142
 143       IF(.NOT.BUMP .AND. NNOD.EQ.0) GOTO 905
 144       IF(NNOD.GT.I1)                GOTO 906
 145
 146       IRPC = -1
 147       DO I=1,NNOD
 148       IF(NODS(I).GT.0) THEN
 149          IF(IRPC.LT.0) IRPC = LSTRPC(NODS(I),LUN)
 150          IF(IRPC.NE.LSTRPC(NODS(I),LUN).AND.IAC.EQ.0) GOTO 907
 151       ENDIF
 152       ENDDO
 153
 154 !  EXITS
 155 !  -----
 156
 157       RETURN
 158 900   WRITE(BORT_STR1,'("BUFRLIB: PARUSR - INPUT STRING (",A,") HAS ")') &
 159        STR
 160       WRITE(BORT_STR2,'(18X,"LENGTH (",I4,"), > LIMIT OF 80 CHAR.")') &
 161        LEN(STR)
 162       CALL BORT2(BORT_STR1,BORT_STR2)
 163 901   WRITE(BORT_STR1,'("BUFRLIB: PARUSR - THE NUMBER OF CONDITION '// &
 164        'NODES IN INPUT STRING")')
 165       WRITE(BORT_STR2,'(18X,A,") EXCEEDS THE MAXIMUM (",I3,")")') &
 166        STR,MAXCON
 167       CALL BORT2(BORT_STR1,BORT_STR2)
 168 902   WRITE(BORT_STR1,'("BUFRLIB: PARUSR - THE NUMBER OF STORE NODES '// &
 169        'IN INPUT STRING")')
 170        WRITE(BORT_STR2,'(18X,A,") EXCEEDS THE MAXIMUM (",I3,")")') &
 171        STR,MAXNOD
 172       CALL BORT2(BORT_STR1,BORT_STR2)
 173 903   WRITE(BORT_STR1,'("BUFRLIB: PARUSR - BUMP NODE (^ IN INPUT '// &
 174        'STRING ",A)') STR
 175       WRITE(BORT_STR2,'(18X,"IS SPECIFIED FOR A BUFR FILE OPEN FOR '// &
 176        'INPUT, THE BUFR FILE MUST BE OPEN FOR OUTPUT")')
 177       CALL BORT2(BORT_STR1,BORT_STR2)
 178 904   WRITE(BORT_STR1,'("BUFRLIB: PARUSR - INPUT STRING (",A,") '// &
 179        'CONTAINS")') STR
 180       WRITE(BORT_STR2,'(18X,"CONDITIONAL NODES IN ADDITION TO BUMP '// &
 181        'NODE - THE BUMP MUST BE ON THE INNER NODE")')
 182       CALL BORT2(BORT_STR1,BORT_STR2)
 183 905   WRITE(BORT_STR1,'("BUFRLIB: PARUSR - INPUT STRING (",A,") HAS")') &
 184        STR
 185       WRITE(BORT_STR2,'(18X,"NO STORE NODES")')
 186       CALL BORT2(BORT_STR1,BORT_STR2)
 187 906   WRITE(BORT_STR1,'("BUFRLIB: PARUSR - INPUT STRING (",A,")")') STR
 188       WRITE(BORT_STR2,'(18X,"HAS",I5," STORE NODES (MNEMONICS) - THE '// &
 189        'LIMIT {THIRD (INPUT) ARGUMENT} IS",I5)') NNOD,I1
 190       CALL BORT2(BORT_STR1,BORT_STR2)
 191 907   WRITE(BORT_STR1,'("BUFRLIB: PARUSR - INPUT STRING (",A,") '// &
 192        'CONTAINS")') STR
 193       WRITE(BORT_STR2,'(18X,"STORE NODES (MNEMONICS) THAT ARE IN MORE'// &
 194        ' THAN ONE REPLICATION GROUP")')
 195       CALL BORT2(BORT_STR1,BORT_STR2)
 196       END SUBROUTINE PARUSR