C =====================================================================
C pgm: SHOUT .. Output shef message data into the "shefout" binary file
C
C use: CALL SHOUT(ID,IYR,IMO,IDA,IHR,IMN,ISE,KYR,KMO,KDA,KHR,KMN,
C use: $ KSE,PARCOD,IDUR,CODP,VALU,IQUAL,IREV,JID,ITIME,
C use: $ QUO,IERR)
C
C in: ID ........ station identification name - CHAR*8
C in: IYR,IMO,IDA,IHR,IMN,ISE .. zulu date-time for data - INT
C in: KYR,KMO,KDA,KHR,KMN,KSE .. zulu dte-tm for creation date - INT
C in: PARCOD .... parameter code for data - CHAR*8
C in: IDUR ...... duration code - INT
C in: CODP ...... probability code - REAL
C in: VALU ...... data value - DOUBLE PRECISION
C in: IQUAL ..... data qualifier code - CHAR*1
C in: IREV ...... if 1 then revision data, else 0 - INT
C in: JID ....... group or source code, else blank - CHAR*8
C in: ITIME ..... time series code (0=no ts,1=first,2=oth elem) - INT
C in: QUO ....... quote about data value - CHAR*(*)
C in: (subrtn) .. enter logical unit number outside this rtn with:
C in: CALL SHSAVU('P_SHEFOUT',<number>)
C out: IERR ...... "IOSTAT" from write stmt, zero if no error - INT
C
C rqd: SHSAVU
C
C cmt: NAME TYPE I/O DIM DESCRIPTION
C cmt:
C cmt: ID A I *8 8 CHAR STATION ID
C cmt: IYR I I 1 YEAR OF OBSERVATION DATE(4 DIGITS)
C cmt: IMO I I 1 MONTH OF OBSERVATION DATE
C cmt: IDA I I 1 DAY OF OBSERVATION DATE
C cmt: IHR I I 1 HOUR OF OBSERVATION DATE (0-23)
C cmt: IMN I I 1 MINUTE OF OBSERVATION DATE
C cmt: ISE I I 1 SECOND OF OBSERVATION DATE
C cmt: KYR I I 1 YEAR OF CREATION DATE (4 DIGITS)
C cmt: KMO I I 1 MONTH OF CREATION DATE
C cmt: KDA I I 1 DAY OF CREATION DATE
C cmt: KHR I I 1 HOUR OF CREATION DATE
C cmt: KMN I I 1 MINUTE OF CREATION DATE
C cmt: KSE I I 1 SECOND OF CREATION DATE
C cmt: PARCOD(1:1) A1 I 1 FIRST CHAR OF PHYSICAL ELEMENT CODE
C cmt: PARCOD(2:2) A1 I 1 SECOND CHAR OF PE CODE
C cmt: IDUR I I 1 ENCODED DURATION CODE
C cmt: PARCOD(4:4) A1 I 1 TYPE CODE
C cmt: PARCOD(5:5) A1 I 1 SOURCE CODE
C cmt: PARCOD(6:6) A1 I 1 EXTREMUM CODE
C cmt: CODP R I 1 CODE PROBABILITY
C cmt: VALU R I 1 DATA VALUE
C cmt: IQUAL A I *1 DATA QUALIFIER
C cmt: IREV I I 1 REVISION CODE (0=not a rev,1=rev)
C cmt: JID A I *8 DATA SOURCE
C cmt: ITIME I I 1 TIME SERIES INDICATOR
C cmt: (0=no ts,1=first elem,2=othr elem)
C cmt: PARCOD(1:8) A8 I *8 FULL PARAMETER CODE
C cmt: QUO(1:#) A# I *# QUOTE STRING (# may be 80 or so)
C =====================================================================
SUBROUTINE SHOUT(ID,IYR,IMO,IDA,IHR,IMN,ISE,KYR,KMO,KDA,KHR,KMN,
$ KSE,PARCOD,IDUR,CODP,VALU,IQUAL,IREV,JID,ITIME,
$ QUO,IERR)
EXTERNAL SHSAVU
INCLUDE 'sfcmn_pe.cmn'
CHARACTER*(*) QUO
CHARACTER*80 LMSG
CHARACTER*8 ID,JID,PARCOD
CHARACTER*4 BLNK4
CHARACTER*3 BLNK3
CHARACTER*1 IQUAL
INTEGER IYR,IMO,IDA,IHR,IMN,ISE,KYR,KMO,KDA,KHR,KMN,KSE
INTEGER IDUR,IREV,ITIME,IERR
REAL CODP
DOUBLE PRECISION VALU
INTEGER INITZ,LUNO
SAVE INITZ,LUNO
C
C ================================= RCS keyword statements ==========
CHARACTER*68 RCSKW1,RCSKW2
DATA RCSKW1,RCSKW2 / '
.$Source: /fs/hseb/ob5/rfc/ofs/src/shefpars_driv/RCS/shout.f,v $
. $', '
.$Id: shout.f,v 1.4 1997/12/31 20:33:36 page Exp $
. $' /
C ===================================================================
C
DATA INITZ,BLNK4,BLNK3,LUNO / 0, ' ', ' ', -1 /
C On first pass, get and save unit-no, format-type
IF (INITZ .EQ. 0) THEN
INITZ = 1
CALL SHSAVU('G_SHEFOUT ',LUNO)
ENDIF
C Uncomment the statements below if 2-digit years are needed
CC IYR = IYR - ( (IYR/100)*100 )
CC KYR = KYR - ( (KYR/100)*100 )
C Write data to "shefout" file
C IF (LUNO.GE.0 .AND. LUNO.LE.99) THEN
IF (npecod.GT.0) THEN
C Does the current PE code match one of the ones on the
C command line?
IPOS = 0
II = 1
DO WHILE ( ( II .LE. npecod ) .AND. ( IPOS .EQ. 0 ) )
IF ( ( PARCOD(1:2) .EQ. pecod(II)(1:2) ) .OR.
$ ( ( PARCOD(1:1) .EQ. pecod(II)(1:1) ) .AND.
$ ( pecod(II)(2:2) .EQ. '.' ) ) ) THEN
IPOS = II
ELSE
II = II + 1
ENDIF
ENDDO
IF (IPOS.GT.0) THEN
WRITE(iunpef,200,IOSTAT=IERR) IYR,IMO,IDA,IHR,IMN,ID,PARCOD(1:1),
$ PARCOD(2:2),IDUR,PARCOD(4:4),PARCOD(5:5),PARCOD(6:6),
$ CODP,VALU,IQUAL,IREV,JID,ITIME
200 FORMAT (I4,1X,4(I2,1X),A8,1X,2(A1,1X),I4,1X,3(A1,1X),F5.2,1X,
$ F9.3,1X,A1,1X,I1,1X,A8,1X,I1)
ENDIF
ENDIF
IF (PARCOD(4:4).EQ.'F') THEN
WRITE(LMSG,300,IOSTAT=IERR) 'FORECAST CREATION DATE: ',
$ KYR,KMO,KDA,KHR,KMN
CALL DC_WLOG ( 3, 'DC', 2, LMSG, IERWLG )
ENDIF
WRITE(LMSG,300,IOSTAT=IERR) 'SHEFLIB OUTPUT: ',
$ IYR,IMO,IDA,IHR,IMN,ID,PARCOD(1:1),PARCOD(2:2),
$ IDUR,PARCOD(4:4),PARCOD(5:5),PARCOD(6:6),
$ VALU,IQUAL,IREV
300 FORMAT (3X,A,I4,1X,4(I2,1X),A8,1X,2(A1,1X),I4,3X,3(A1,1X),
$ F11.4,1X,A1,1X,I1)
CALL DC_WLOG ( 3, 'DC', 2, LMSG, IERWLG )
C ENDIF
CALL SF_INTF( KYR, KMO, KDA, KHR, KMN,
+ IYR, IMO, IDA, IHR, IMN,
+ ID, PARCOD, IDUR, VALU, IQUAL, IREV )
RETURN
END