-
Notifications
You must be signed in to change notification settings - Fork 0
/
dmrhda.f
187 lines (187 loc) · 5.42 KB
/
dmrhda.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
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
SUBROUTINE DM_RHDA ( iflno, iret )
C************************************************************************
C* DM_RHDA *
C* *
C* This subroutine reads all the row and column headers from a *
C* DM file. *
C* *
C* DM_RHDA ( IFLNO, IRET ) *
C* *
C* Input parameters: *
C* IFLNO INTEGER File number *
C* *
C* Output parameters: *
C* IRET INTEGER Return code *
C* 0 = normal return *
C* -6 = write error *
C* -7 = read error *
C** *
C* Log: *
C* M. desJardins/GSFC 6/86 *
C* M. desJardins/GSFC 5/90 Added check for character headers *
C* K. Brill/NMC 3/91 Add calls to MV_ functions *
C* M. desJardins/GSFC 5/91 Add logical vars for machine type *
C* S. Jacobs/NCEP 2/97 Added check for swapping GVCD *
C* S. Jacobs/NCEP 4/98 Added check for swapping STD2 *
C************************************************************************
INCLUDE 'GEMPRM.PRM'
INCLUDE 'dmcmn.cmn'
C*
INTEGER ibuff (MBLKSZ)
CHARACTER type*4, type2*4
C------------------------------------------------------------------------
C* Read the row and column headers which are together in the file.
C
istart = kprowh (iflno)
CALL DM_RINT ( iflno, istart, MBLKSZ, ibuff, iret )
istart = istart + MBLKSZ
length = 1
knt = 1
klstrw ( iflno ) = 0
klstcl ( iflno ) = 0
C
C* Save the row headers.
C
DO i = 1, krow (iflno)
DO j = 0, krkeys (iflno)
IF ( length .gt. MBLKSZ ) THEN
CALL DM_RINT ( iflno, istart, MBLKSZ, ibuff, iret )
IF ( iret .ne. 0 ) RETURN
istart = istart + MBLKSZ
length = 1
END IF
kheadr ( j, knt, iflno ) = ibuff ( length )
length = length + 1
END DO
IF ( kheadr ( 0, knt, iflno ) .ne. IMISSD )
+ klstrw (iflno) = knt
knt = knt + 1
END DO
IF ( iret .ne. 0 ) RETURN
C
C* Save the column headers.
C
DO i = 1, kcol (iflno)
DO j = 0, kckeys (iflno)
IF ( length .gt. MBLKSZ ) THEN
CALL DM_RINT ( iflno, istart, MBLKSZ, ibuff, iret )
IF ( iret .ne. 0 ) RETURN
istart = istart + MBLKSZ
length = 1
END IF
kheadr ( j, knt, iflno ) = ibuff ( length )
length = length + 1
END DO
IF ( kheadr ( 0, knt, iflno ) .ne. IMISSD )
+ klstcl ( iflno ) = knt - krow ( iflno )
knt = knt + 1
END DO
C
C* If the file was created on a different machine, make sure
C* that the bytes are not swapped for character keywords.
C
IF ( ( kmachn (iflno) .ne. MTMACH ) .and.
+ ( ( kvmst ( iflno ) .and. ( .not. mvmst ) ) .or.
+ ( mvmst .and. ( .not. kvmst ( iflno ) ) ) ) ) THEN
C
C* Check for STID and STD2.
C
CALL DM_FKEY ( iflno, 'STID', type, loc, ier )
CALL DM_FKEY ( iflno, 'STD2', type2, loc2, ier )
IF ( type .eq. 'ROW' ) THEN
DO i = 1, krow (iflno)
ier = MV_SWP4 ( 1, kheadr (loc,i,iflno),
+ kheadr (loc,i,iflno) )
IF ( loc2 .gt. 0 )
+ ier = MV_SWP4 ( 1, kheadr (loc2,i,iflno),
+ kheadr (loc2,i,iflno) )
END DO
ELSE IF ( type .eq. 'COL' ) THEN
knt = krow (iflno) + 1
DO i = 1, kcol (iflno)
ier = MV_SWP4 ( 1, kheadr (loc,knt,iflno),
+ kheadr (loc,knt,iflno) )
IF ( loc2 .gt. 0 )
+ ier = MV_SWP4 ( 1, kheadr (loc2,knt,iflno),
+ kheadr (loc2,knt,iflno) )
knt = knt + 1
END DO
END IF
C
C* Check for STAT.
C
CALL DM_FKEY ( iflno, 'STAT', type, loc, ier )
IF ( type .eq. 'ROW' ) THEN
DO i = 1, krow (iflno)
ier = MV_SWP4 ( 1, kheadr (loc,i,iflno),
+ kheadr (loc,i,iflno) )
END DO
ELSE IF ( type .eq. 'COL' ) THEN
knt = krow (iflno) + 1
DO i = 1, kcol (iflno)
ier = MV_SWP4 ( 1, kheadr (loc,knt,iflno),
+ kheadr (loc,knt,iflno) )
knt = knt + 1
END DO
END IF
C
C* Check for COUN.
C
CALL DM_FKEY ( iflno, 'COUN', type, loc, ier )
IF ( type .eq. 'ROW' ) THEN
DO i = 1, krow (iflno)
ier = MV_SWP4 ( 1, kheadr (loc,i,iflno),
+ kheadr (loc,i,iflno) )
END DO
ELSE IF ( type .eq. 'COL' ) THEN
knt = krow (iflno) + 1
DO i = 1, kcol (iflno)
ier = MV_SWP4 ( 1, kheadr (loc,knt,iflno),
+ kheadr (loc,knt,iflno) )
knt = knt + 1
END DO
END IF
C
C* Check for GPM1 which is the start of three words.
C
CALL DM_FKEY ( iflno, 'GPM1', type, loc, ier )
IF ( type .eq. 'ROW' ) THEN
DO i = 1, krow (iflno)
ier = MV_SWP4 ( 3, kheadr (loc,i,iflno),
+ kheadr (loc,i,iflno) )
END DO
ELSE IF ( type .eq. 'COL' ) THEN
knt = krow (iflno) + 1
DO i = 1, kcol (iflno)
ier = MV_SWP4 ( 3, kheadr (loc,knt,iflno),
+ kheadr (loc,knt,iflno) )
knt = knt + 1
END DO
END IF
C
C* Check for GVCD. Swap only if the value is greater
C* than the number of standard vertical coordinates.
C
nvstd = 6
CALL DM_FKEY ( iflno, 'GVCD', type, loc, ier )
IF ( type .eq. 'ROW' ) THEN
DO i = 1, krow (iflno)
IF ( kheadr (loc,knt,iflno) .gt. nvstd ) THEN
ier = MV_SWP4 ( 1, kheadr (loc,i,iflno),
+ kheadr (loc,i,iflno) )
END IF
END DO
ELSE IF ( type .eq. 'COL' ) THEN
knt = krow (iflno) + 1
DO i = 1, kcol (iflno)
IF ( kheadr (loc,knt,iflno) .gt. nvstd ) THEN
ier = MV_SWP4 ( 1, kheadr (loc,knt,iflno),
+ kheadr (loc,knt,iflno) )
END IF
knt = knt + 1
END DO
END IF
END IF
C*
RETURN
END