SUBROUTINE PARUSR(STR,LUN,I1,IO) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: PARUSR C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 C C ABSTRACT: THIS SUBROUTINE INITATES THE PROCESS TO PARSE OUT MNEMONICS C (NODES) FROM A USER-SPECIFIED CHARACTER STRING, AND SEPARATES THEM C INTO STORE AND CONDITION NODES. INFORMATION ABOUT THE STRING C "PIECES" (I.E., THE MNEMONICS) IS STORED IN ARRAYS IN COMMON BLOCK C /USRSTR/. CONDITION NODES ARE SORTED IN THE ORDER EXPECTED IN THE C INTERNAL JUMP/LINK TABLES AND SEVERAL CHECKS ARE PERFORMED ON THE C NODES. C C PROGRAM HISTORY LOG: C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB C ROUTINE "BORT"; IMPROVED MACHINE C PORTABILITY C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE C INTERDEPENDENCIES C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED C DOCUMENTATION (INCLUDING HISTORY); OUTPUTS C MORE COMPLETE DIAGNOSTIC INFO WHEN ROUTINE C TERMINATES ABNORMALLY; CHANGED CALL FROM C BORT TO BORT2; RESPONDED TO CHANGE IN C PARUTG (WHICH THIS ROUTINE CALLS) TO NO C LONGER EXPECT AN ALTERNATE RETURN TO A C STATEMENT NUMBER IN THIS ROUTINE WHICH C CALLED BORT (BORT IS NOW CALLED IN PARUTG) C 2007-01-19 J. ATOR -- REPLACED CALL TO PARSEQ WITH CALL TO PARSTR C 2009-05-07 J. ATOR -- USE LSTJPB INSTEAD OF LSTRPC C C USAGE: CALL PARUSR (STR, LUN, I1, IO) C INPUT ARGUMENT LIST: C STR - CHARACTER*(*): STRING OF BLANK-SEPARATED MNEMONICS C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS C I1 - INTEGER: A NUMBER GREATER THAN OR EQUAL TO THE NUMBER C OF BLANK-SEPARATED MNEMONICS IN STR C IO - INTEGER: STATUS INDICATOR FOR BUFR FILE ASSOCIATED C WITH LUN: C 0 = input file C 1 = output file C C REMARKS: C THIS ROUTINE CALLS: BORT2 LSTJPB PARSTR PARUTG C THIS ROUTINE IS CALLED BY: STRING C Normally not called by any application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ COMMON /USRSTR/ NNOD,NCON,NODS(20),NODC(10),IVLS(10),KONS(10) COMMON /ACMODE/ IAC CHARACTER*(*) STR CHARACTER*128 BORT_STR1,BORT_STR2 CHARACTER*80 UST CHARACTER*20 UTG(30) LOGICAL BUMP DATA MAXUSR /30/ DATA MAXNOD /20/ DATA MAXCON /10/ C---------------------------------------------------------------------- C---------------------------------------------------------------------- UST = STR IF(LEN(STR).GT.80) GOTO 900 NCON = 0 NNOD = 0 C PARSE OUT STRING PIECES(S) (UTG's or MNEMONICS) C ----------------------------------------------- CALL PARSTR(UST,UTG,MAXUSR,NTOT,' ',.TRUE.) DO N=1,NTOT C DETERMINE IF THIS UTG IS A CONDITION NODE OR A STORE NODE C --------------------------------------------------------- CALL PARUTG(LUN,IO,UTG(N),NOD,KON,VAL) IF(KON.NE.0) THEN c .... it is a condition node NCON = NCON+1 IF(NCON.GT.MAXCON) GOTO 901 NODC(NCON) = NOD KONS(NCON) = KON IVLS(NCON) = NINT(VAL) ELSE c .... it is a store node NNOD = NNOD+1 IF(NNOD.GT.MAXNOD) GOTO 902 NODS(NNOD) = NOD ENDIF ENDDO C SORT CONDITION NODES IN JUMP/LINK TABLE ORDER C --------------------------------------------- DO I=1,NCON DO J=I+1,NCON IF(NODC(I).GT.NODC(J)) THEN NOD = NODC(I) NODC(I) = NODC(J) NODC(J) = NOD KON = KONS(I) KONS(I) = KONS(J) KONS(J) = KON VAL = IVLS(I) IVLS(I) = IVLS(J) IVLS(J) = VAL ENDIF ENDDO ENDDO C CHECK ON SPECIAL RULES FOR CONDITIONAL NODES THAT ARE BUMP NODES C ---------------------------------------------------------------- BUMP = .FALSE. DO N=1,NCON IF(KONS(N).EQ.5) THEN IF(IO.EQ.0) GOTO 903 IF(N.NE.NCON) GOTO 904 BUMP = .TRUE. ENDIF ENDDO C CHECK STORE NODE COUNT AND ALIGNMENT C ------------------------------------ IF(.NOT.BUMP .AND. NNOD.EQ.0) GOTO 905 IF(NNOD.GT.I1) GOTO 906 IRPC = -1 DO I=1,NNOD IF(NODS(I).GT.0) THEN IF(IRPC.LT.0) IRPC = LSTJPB(NODS(I),LUN,'RPC') IF(IRPC.NE.LSTJPB(NODS(I),LUN,'RPC').AND.IAC.EQ.0) GOTO 907 ENDIF ENDDO C EXITS C ----- RETURN 900 WRITE(BORT_STR1,'("BUFRLIB: PARUSR - INPUT STRING (",A,") HAS ")') . STR WRITE(BORT_STR2,'(18X,"LENGTH (",I4,"), > LIMIT OF 80 CHAR.")') . LEN(STR) CALL BORT2(BORT_STR1,BORT_STR2) 901 WRITE(BORT_STR1,'("BUFRLIB: PARUSR - THE NUMBER OF CONDITION '// . 'NODES IN INPUT STRING")') WRITE(BORT_STR2,'(18X,A,") EXCEEDS THE MAXIMUM (",I3,")")') . STR,MAXCON CALL BORT2(BORT_STR1,BORT_STR2) 902 WRITE(BORT_STR1,'("BUFRLIB: PARUSR - THE NUMBER OF STORE NODES '// . 'IN INPUT STRING")') WRITE(BORT_STR2,'(18X,A,") EXCEEDS THE MAXIMUM (",I3,")")') . STR,MAXNOD CALL BORT2(BORT_STR1,BORT_STR2) 903 WRITE(BORT_STR1,'("BUFRLIB: PARUSR - BUMP NODE (^ IN INPUT '// . 'STRING ",A)') STR WRITE(BORT_STR2,'(18X,"IS SPECIFIED FOR A BUFR FILE OPEN FOR '// . 'INPUT, THE BUFR FILE MUST BE OPEN FOR OUTPUT")') CALL BORT2(BORT_STR1,BORT_STR2) 904 WRITE(BORT_STR1,'("BUFRLIB: PARUSR - INPUT STRING (",A,") '// . 'CONTAINS")') STR WRITE(BORT_STR2,'(18X,"CONDITIONAL NODES IN ADDITION TO BUMP '// . 'NODE - THE BUMP MUST BE ON THE INNER NODE")') CALL BORT2(BORT_STR1,BORT_STR2) 905 WRITE(BORT_STR1,'("BUFRLIB: PARUSR - INPUT STRING (",A,") HAS")') . STR WRITE(BORT_STR2,'(18X,"NO STORE NODES")') CALL BORT2(BORT_STR1,BORT_STR2) 906 WRITE(BORT_STR1,'("BUFRLIB: PARUSR - INPUT STRING (",A,")")') STR WRITE(BORT_STR2,'(18X,"HAS",I5," STORE NODES (MNEMONICS) - THE '// . 'LIMIT {THIRD (INPUT) ARGUMENT} IS",I5)') NNOD,I1 CALL BORT2(BORT_STR1,BORT_STR2) 907 WRITE(BORT_STR1,'("BUFRLIB: PARUSR - INPUT STRING (",A,") '// . 'CONTAINS")') STR WRITE(BORT_STR2,'(18X,"STORE NODES (MNEMONICS) THAT ARE IN MORE'// . ' THAN ONE REPLICATION GROUP")') CALL BORT2(BORT_STR1,BORT_STR2) END