var/external/bufr/parusr.f

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