-
Notifications
You must be signed in to change notification settings - Fork 0
/
Copy pathdmrfhr.f
121 lines (121 loc) · 3.32 KB
/
dmrfhr.f
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
SUBROUTINE DM_RFHR ( iflno, fhdnam, mxword, rheadr, nword,
+ iret )
C************************************************************************
C* DM_RFHR *
C* *
C* This subroutine reads a real file header from a DM file. The *
C* length of the file header must be less than MXWORD. *
C* *
C* DM_RFHR ( IFLNO, FHDNAM, MXWORD, RHEADR, NWORD, IRET ) *
C* *
C* Input parameters: *
C* IFLNO INTEGER File number *
C* FHDNAM CHAR*4 File header name *
C* MXWORD INTEGER Maximum words to return *
C* *
C* Output parameters: *
C* RHEADR (NWORD) REAL File header *
C* NWORD INTEGER Header length *
C* IRET INTEGER Return code *
C* 0 = normal return *
C* -4 = file not open *
C* -6 = write error *
C* -7 = read error *
C* -8 = file header undefined *
C* -18 = file header too long *
C* -21 = incorrect data type *
C* -29 = invalid file hdr name *
C** *
C* Log: *
C* M. desJardins/GSFC 4/87 *
C* M. desJardins/GSFC 5/90 Add translation for diff machines *
C* m. gamazaychikov/CWS 04/11 Add code for A2DB connectivity *
C************************************************************************
INCLUDE 'GEMPRM.PRM'
INCLUDE 'dmcmn.cmn'
INCLUDE 'dbcmn.cmn'
C
CHARACTER*(*) fhdnam
REAL rheadr (*)
C------------------------------------------------------------------------
nword = 0
C
C* For A2DB requests - get the grid navigation array.
C
IF ( dbread ) THEN
IF ( INDEX(dbdatasrc,'grid') .gt. 0 ) THEN
print *, "A2DB requests not implemented."
iret = -7
C CALL DM_GETGNAV ( iflno, fhdnam, mxword, rheadr, nword,
C + iret )
RETURN
END IF
END IF
C
C* Check that file is open.
C
CALL DM_CHKF ( iflno, iret )
IF ( iret .ne. 0 ) RETURN
C
C* Check that this is a valid file header name.
C
knt = 0
DO i = 1, kfhdrs ( iflno )
IF ( kfhnam ( i, iflno ) .eq. fhdnam ) knt = i
END DO
C
C* Check for invalid name.
C
IF ( knt .eq. 0 ) THEN
iret = -29
C
C* Check for valid data type.
C
ELSE IF ( kfhtyp ( knt, iflno ) .ne. MDREAL ) THEN
iret = -21
END IF
IF ( iret .ne. 0 ) RETURN
C
C* Compute header location.
C
iread = kpfile ( iflno ) + 3 * kfhdrs ( iflno )
DO i = 1, knt - 1
iread = iread + kfhlen ( i, iflno ) + 1
END DO
C
C* Read actual length and return error if too long.
C
CALL DM_RINT ( iflno, iread, 1, nword, iret )
IF ( iret .ne. 0 ) RETURN
IF ( nword .gt. mxword ) THEN
iret = -18
nword = 0
ELSE IF ( nword .le. 0 ) THEN
iret = -8
ELSE
C
C* Read in header. If this is the grid navigation block,
C* do not convert projection name which is in word 2.
C
IF ( ( fhdnam .eq. 'NAVB' ) .and.
+ ( kmachn ( iflno ) .ne. MTMACH ) ) THEN
iread = iread + 1
CALL DM_RFLT ( iflno, iread, 1, rheadr, iret )
IF ( iret .ne. 0 ) RETURN
machin = kmachn ( iflno )
kmachn ( iflno ) = MTMACH
iread = iread + 1
CALL DM_RFLT ( iflno, iread, 1, rheadr (2), iret )
IF ( iret .ne. 0 ) RETURN
kmachn ( iflno ) = machin
iread = iread + 1
nword = nword - 2
CALL DM_RFLT ( iflno, iread, nword, rheadr (3), iret )
ELSE
iread = iread + 1
CALL DM_RFLT ( iflno, iread, nword, rheadr, iret )
END IF
END IF
C*
RETURN
END