112 lines
3 KiB
Fortran
112 lines
3 KiB
Fortran
SUBROUTINE DM_RCLH ( iflno, ipos, iheadr, iret )
|
|
C************************************************************************
|
|
C* DM_RCLH *
|
|
C* *
|
|
C* This subroutine reads a column header from a DM file. *
|
|
C* *
|
|
C* DM_RCLH ( IFLNO, IPOS, IHEADR, IRET ) *
|
|
C* *
|
|
C* Input parameters: *
|
|
C* IFLNO INTEGER File number *
|
|
C* IPOS INTEGER Location *
|
|
C* *
|
|
C* Output parameters: *
|
|
C* IHEADR (*) INTEGER Header array *
|
|
C* IRET INTEGER Return code *
|
|
C* 0 = normal return *
|
|
C* -4 = file is not open *
|
|
C* -9 = invalid column *
|
|
C* -11 = undefined header *
|
|
C** *
|
|
C* Log: *
|
|
C* M. desJardins/GSFC 4/87 *
|
|
C************************************************************************
|
|
INCLUDE 'GEMPRM.PRM'
|
|
INCLUDE 'dmcmn.cmn'
|
|
INCLUDE 'dbcmn.cmn'
|
|
C
|
|
INTEGER iheadr (*)
|
|
C
|
|
INTEGER istid(2), intdtf (3)
|
|
C------------------------------------------------------------------------
|
|
C
|
|
C* For A2DB requests - set the needed information.
|
|
C
|
|
IF ( dbread ) THEN
|
|
IF ( dbdatasrc .eq. 'grid' ) THEN
|
|
C
|
|
C* For grid data - set the time.
|
|
C
|
|
CALL ST_LSTR ( dbtime, ldbtime, ier )
|
|
IF ( ldbtime .gt. 0 ) THEN
|
|
CALL TG_CTOI ( dbtime, intdtf, ier )
|
|
CALL TG_ITOF ( intdtf, iheadr, ier )
|
|
ELSE
|
|
iret = -9
|
|
RETURN
|
|
END IF
|
|
ELSE
|
|
C
|
|
C* For point data - set the station id.
|
|
C
|
|
CALL ST_LSTR (dbstid, lstr, ier)
|
|
IF ( lstr .eq. 4 .and. dbstid(1:1) .eq. 'K' ) THEN
|
|
ist=2
|
|
ELSE
|
|
ist = 1
|
|
END IF
|
|
IF ( dbdatasrc .eq. 'metar' ) THEN
|
|
CALL ST_STOI (dbstid(ist:lstr), 8, nv, istid, ier )
|
|
iheadr(1) = istid(1)
|
|
iheadr(2) = IMISSD
|
|
ELSE IF ( dbdatasrc .eq. 'bufrua' ) THEN
|
|
iheadr(1) = IMISSD
|
|
CALL ST_NUMB (dbstid(ist:lstr), istid2, ier )
|
|
iheadr(2) = istid2
|
|
END IF
|
|
iheadr(3) = dbstlt
|
|
iheadr(4) = dbstln
|
|
iheadr(5) = dbstel
|
|
iheadr(8) = IMISSD
|
|
END IF
|
|
iret = 0
|
|
RETURN
|
|
END IF
|
|
C
|
|
C* Check that the file number is valid.
|
|
C
|
|
CALL DM_CHKF ( iflno, iret )
|
|
IF ( iret .ne. 0 ) RETURN
|
|
C
|
|
C* Check for valid position.
|
|
C
|
|
IF ( (ipos .le. 0) .or. (ipos .gt. kcol (iflno))) THEN
|
|
iret = -9
|
|
DO i = 1, kckeys ( iflno )
|
|
iheadr (i) = IMISSD
|
|
END DO
|
|
ELSE
|
|
C
|
|
C* Check that this header is defined.
|
|
C
|
|
jloc = ipos + krow ( iflno )
|
|
IF ( kheadr ( 0, jloc, iflno ) .ne. IMISSD ) THEN
|
|
C
|
|
C* Retrieve row header.
|
|
C
|
|
DO i = 1, kckeys (iflno)
|
|
iheadr (i) = kheadr ( i, jloc, iflno )
|
|
END DO
|
|
C
|
|
C* Set error return.
|
|
C
|
|
ELSE
|
|
iret = -11
|
|
DO i = 1, kckeys ( iflno )
|
|
iheadr (i) = IMISSD
|
|
END DO
|
|
END IF
|
|
END IF
|
|
C*
|
|
RETURN
|
|
END
|