PROGRAM NAM_STNMLIST
C$$$ MAIN PROGRAM DOCUMENTATION BLOCK
C
C MAIN PROGRAM: NAM_STNMLIST
C PRGMMR: KEYSER ORG: NP22 DATE: 2006-02-02
C
C ABSTRACT: TAKES BUFR OUTPUT FROM THE ETA SOUNDING POST-PROCESSOR IN
C MONOLITHIC FORM AND WRITES OUT INDIVIDUAL STATIONS' OUTPUT INTO
C SEPARATE FILES.
C
C PROGRAM HISTORY LOG:
C 1995-11-22 WOOLLEN - ORIGINAL AUTHOR
C 1999-03-16 BALDWIN - ADD DOCBLOCK FOR OPERATIONAL VERSION
C 1999-05-14 BRILL - ADDED IOTYPE FLAG (READ FROM UNIT 5)
C 2006-02-02 KEYSER - UPDATED DOCBLOCK, ADDED COMMENTS, STREAMLINED
C CODE; REMOVED IN-LINE SUBROUTINE UFBPOS SINCE
C IT WAS ADDED TO 1/31/2006 VERSION OF BUFRLIB
C 2011-04-11 ROGERS INCREASED LENGTH OF OUTFIL CHARACTER STRING
C FROM 80 TO 95 SO IT WOULD READ IN NAM NEST
C HISTORY FILE
C
C USAGE:
C INPUT FILES:
C UNIT 05 - SEE REMARKS
C UNIT 20 - MONOLITHIC BUFR INPUT FILE
C
C OUTPUT FILES:
C UNIT 06 - STANDARD OUTPUT PRINT
C UNIT 50 - INDIVIDUAL OUTPUT FILES FOR EACH STATION (OPENED
C WITHIN CODE, SEE REMARKS FOR FILE NAME STRUCTURE)
C
C SUBPROGRAMS CALLED:
C LIBRARY:
C W3LIB - W3TAGB W3TAGE ERREXIT
C BUFRLIB - DATELEN OPENBF OPENMB CLOSBF UFBTAB
C UFBCPY READMG WRITSB UFBPOS
C
C EXIT STATES:
C COND = 0 - SUCCESSFUL RUN
C > 0 - ABNORMAL TERMINATION
C
C REMARKS:
C CONTENTS OF STANDARD INPUT IN UNIT 05:
C RECORD 1 - FLAG FOR OUTPUT TYPE - IOTYPE
C IOTYPE = 0 => 5-digit ID; 8-digit date-time
C stamp
C IOTYPE = 1 => 6-digit ID; 10-digit date-time
C stamp
C RECORD 2 - COMPLETE PATH TO INPUT BUFR FILE
C RECORD 3 - NAME OF DIRECTORY CONTAINING OUTPUT FILES -
C DIRD, COMPLETE PATH TO OUTPUT FILES IS:
C "DIRD.STATION_ID.DATE" , WHERE THE STATION
C ID AND DATE ARE READ FROM THE BUFR FILE -
C FORMAT IS:
C ('(A,".",I5.5,".",I8.8)') FOR IOTYPE = 0
C ('(A,".",I6.6,".",I10)') FOR IOTYPE = 1
C RECORD 4-end - OPTIONAL LIST OF STATIONS SELECTED FOR OUTPUT
C IN (I5) FORMAT
C IF LIST OF STATIONS IS NOT PRESENT IN UNIT 05,
C THEN ALL STATIONS IN INPUT BUFR FILE ARE
C SELECTED
C
C ATTRIBUTES:
C LANGUAGE: FORTRAN 90
C MACHINE: IBM-CCS
C
C$$$
PARAMETER (MXTS=5,MXTB=150000,MXLS=1600)
CHARACTER*255 OUTFIL,DIRD,BFRFIL
CHARACTER*80 FMTO,TSTR
CHARACTER*8 SUBSET
REAL*8 TAB(MXTS,MXTB)
DIMENSION LIST(MXLS)
LOGICAL ONLIST
DATA TSTR /'STNM IREC ISUB'/
DATA BMISS /10E10/
DATA LUBFI / 20/
DATA LUBFO / 50/
DATA IWROT / 0/
C-----------------------------------------------------------------------
C-----------------------------------------------------------------------
CALL W3TAGB('NAM_STNMLIST',2006,0033,0061,'NP22')
DIRD = ' '
READ (5,'(I1)') IOTYPE
READ (5,'(A)') BFRFIL
READ (5,'(A)') DIRD
LSS = LEN(DIRD)
DO WHILE(DIRD(LSS:LSS).EQ.' ')
LSS = LSS - 1
ENDDO
C FORMAT FOR ASSIGN STATEMENT THAT ASSIGNS THE OUTPUT FILE NAMES
C --------------------------------------------------------------
IF(IOTYPE.EQ.1) THEN
FMTO = '(A,".",I6.6,".",I10)'
IDTLN = 10
ELSE
FMTO = '(A,".",I5.5,".",I8.8)'
IDTLN = 8
ENDIF
ccccc CALL OPENBF(0,'QUIET',2) ! Uncomment for extra print from bufrlib
C SEE IF THERE IS A LIST OF STATIONS
C ----------------------------------
DO N=1,MXLS
READ(5,'(I5)',END=1) LIST(N)
IF(LIST(N).EQ.0) GO TO 1
ENDDO
WRITE (6,'("MXLS (=",I6,") IS TOO SMALL FOR THE LIST")') MXLS
CALL W3TAGE('NAM_STNMLIST')
CALL ERREXIT(99)
1 CONTINUE
NLIST = N-1
WRITE (6,*) ' BEGINNING BREAKOUT'
C CHECK FOR VALID INPUT FILE, GET DATE, MAKE TABLE OF ID & POINTERS
C -----------------------------------------------------------------
OPEN(UNIT=LUBFI,FILE=BFRFIL,STATUS='OLD',FORM='UNFORMATTED',
. IOSTAT=IOS)
IF(IOS.NE.0) THEN
WRITE (6,'("Error opening input BUFR file, IOS = ",I5)') IOS
CALL W3TAGE('NAM_STNMLIST')
CALL ERREXIT(99)
END IF
CALL UFBTAB(LUBFI,TAB,MXTS,MXTB,NTAB,TSTR)
IF(NTAB.EQ.0) GOTO 901
OPEN(UNIT=LUBFI,FILE=BFRFIL,STATUS='OLD',FORM='UNFORMATTED',
. IOSTAT=IOS)
CALL OPENBF(LUBFI,'IN',LUBFI)
CALL DATELEN(IDTLN)
CALL READMG(LUBFI,SUBSET,IDATE,IRET)
IF(IRET.NE.0) GOTO 900
C COPY OFF STATIONS ON THE LIST INTO THEIR OWN FILES
C --------------------------------------------------
DO N=1,NTAB
IF(TAB(1,N).GE.BMISS) CYCLE
print *, 'IDNM, IREC, ISUB: ',TAB(1,N),TAB(2,N),TAB(3,N)
IDNM = TAB(1,N)
IREC = TAB(2,N)
ISUB = TAB(3,N)
IF(NLIST.GT.0) THEN
ONLIST = .FALSE.
DO L=1,NLIST
ONLIST = (LIST(L).EQ.IDNM.OR.ONLIST)
ENDDO
ELSE
ONLIST = .TRUE.
ENDIF
IF(.NOT.ONLIST) CYCLE
CALL CLOSBF(LUBFO)
WRITE(OUTFIL,FMTO) DIRD(1:LSS),IDNM,IDATE
OPEN(UNIT=LUBFO,FILE=OUTFIL,STATUS='NEW',FORM='UNFORMATTED',
. IOSTAT=IOS)
IF(IOS.NE.0) THEN
WRITE (6,'(" CANNOT open ",A,", IOS = ",I5)') OUTFIL,IOS
CALL W3TAGE('NAM_STNMLIST')
CALL ERREXIT(99)
END IF
CALL SETBLOCK(1)
CALL OPENBF(LUBFO,'OUT',LUBFI)
CALL UFBPOS(LUBFI,IREC,ISUB,SUBSET,JDATE)
CALL OPENMB(LUBFO,SUBSET,JDATE)
CALL UFBCPY(LUBFI,LUBFO)
CALL WRITSB(LUBFO)
IWROT = IWROT + 1
TAB(1,N) = BMISS
DO M=N+1,NTAB
JDNM = TAB(1,M)
IREC = TAB(2,M)
ISUB = TAB(3,M)
IF(IDNM.EQ.JDNM) THEN
CALL UFBPOS(LUBFI,IREC,ISUB,SUBSET,JDATE)
CALL OPENMB(LUBFO,SUBSET,JDATE)
CALL UFBCPY(LUBFI,LUBFO)
CALL WRITSB(LUBFO)
TAB(1,M) = BMISS
ENDIF
ENDDO
CALL CLOSBF(LUBFO)
ENDDO
IF(IWROT.EQ.0) GOTO 902
CALL W3TAGE('NAM_STNMLIST')
STOP
900 CONTINUE
WRITE (6,*) 'MISSING INPUT BUFR FILE'
CALL W3TAGE('NAM_STNMLIST')
CALL ERREXIT(99)
901 CONTINUE
WRITE (6,*) 'NO DATA IN INPUT BUFR FILE'
CALL W3TAGE('NAM_STNMLIST')
CALL ERREXIT(99)
902 CONTINUE
WRITE (6,*) 'NO STATION ID DATA IN INPUT BUFR FILE'
CALL W3TAGE('NAM_STNMLIST')
CALL ERREXIT(99)
END