-
Notifications
You must be signed in to change notification settings - Fork 0
/
Copy pathdmrdtr.f
199 lines (198 loc) · 5.86 KB
/
dmrdtr.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
188
189
190
191
192
193
194
195
196
197
198
199
SUBROUTINE DM_RDTR ( iflno, irow, icol, part, idthdr, rdata,
+ nword, iret )
C************************************************************************
C* DM_RDTR *
C* *
C* This subroutine reads real data from a DM file. *
C* *
C* DM_RDTR ( IFLNO, IROW, ICOL, PART, IDTHDR, RDATA, NWORD, IRET ) *
C* *
C* Input parameters: *
C* IFLNO INTEGER File number *
C* IROW INTEGER Row number *
C* ICOL INTEGER Column number *
C* PART CHAR*4 Part name *
C* *
C* Output parameters: *
C* IDTHDR (*) INTEGER Data header *
C* RDATA (NWORD) REAL Data *
C* NWORD INTEGER Length of data array *
C* IRET INTEGER Return code *
C* 0 = normal return *
C* -4 = file not open *
C* -6 = write error *
C* -7 = read error *
C* -9 = invalid location *
C* -10 = invalid part name *
C* -15 = data not available *
C* -21 = incorrect data type *
C* -34 = incorrect record length *
C** *
C* Log: *
C* M. desJardins/GSFC 4/87 *
C* M. desJardins/GSFC 3/89 Modified for grid packing *
C* K. Tyle/GSC 1/97 Check for excessive record length *
C* m. gamazaychikov/CWS 04/11 Add code for A2DB connectivity *
C* X. Guo/CWS 09/11 Increased recode size from 10M to 20M *
C************************************************************************
INCLUDE 'GEMPRM.PRM'
INCLUDE 'dmcmn.cmn'
INCLUDE 'dbcmn.cmn'
C
CHARACTER*(*) part
REAL rdata (*)
INTEGER idthdr (*)
C
CHARACTER qtype*8, src*21, part2*5, datauri*254
INTEGER idtarr(5)
C------------------------------------------------------------------------
C* For A2DB requests - set the parms for data query.
C
nword = 0
IF ( dbread ) THEN
print *, 'A2DB requests not available!'
iret = -15
IF (INDEX(dbdatasrc,'grid') .gt. 0 ) THEN
C qtype="gridDat"
C ione = 1
C CALL ST_NULL ( qtype, qtype, lstr, iret)
C CALL ST_LCUC ( dbdatasrc, src,ier )
C CALL ST_NULL ( src, src, lstr, ier )
C CALL ST_NULL ( part, part2, lstr, iret)
C CALL ST_NULL ( dbstid, dbstid, lstr, iret)
C CALL ST_NULL ( dburi, datauri, lstr, iret)
C nsize = dimx*dimy
C CALL ST_INCH ( nsize, dbdttm, iret)
C CALL ST_NULL ( dbdttm, dbdttm, lstr, iret)
C CALL DB_RDTR ( qtype, src, part2, dbdttm, dbstid,
C + datauri, ione, rdata, nword, iret)
C IF ( iret .ne. 0 ) THEN
C iret = -7
C RETURN
C END IF
C idthdr(1) = dimx
C idthdr(2) = dimy
RETURN
ELSE
C qtype="obrvqry"
C ione = 1
C CALL ST_NULL ( qtype, qtype, lstr, iret)
C CALL ST_LCUC ( dbdatasrc, src,ier )
C CALL ST_NULL ( src, src, lstr, ier )
C CALL ST_NULL ( part, part2, lstr, iret)
C CALL ST_NULL ( dbdttm, dbdttm, lstr, iret)
C CALL ST_NULL ( dbstid, dbstid, lstr, iret)
c CALL DB_RDTR ( qtype, src, part2, dbdttm, dbstid,
c + ione, rdata, nword, iret)
C CALL TI_CTOI ( dbdttm, idtarr, iret )
C idthdr(1) = idtarr(4) * 100 + idtarr(5)
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 for valid row and column positions.
C
IF ( ( irow .lt. 1 ) .or. ( irow .gt. krow (iflno) ) .or.
+ ( icol .lt. 1 ) .or. ( icol .gt. kcol (iflno) ) ) THEN
iret = -9
RETURN
END IF
C
C* Get part number.
C
iprt = 0
DO i = 1, kprt ( iflno )
IF ( kprtnm ( i, iflno ) .eq. part ) iprt = i
END DO
IF ( iprt .eq. 0 ) THEN
iret = -10
RETURN
END IF
C
C* Check for valid data type.
C
IF ( ( ktyprt ( iprt, iflno ) .ne. MDREAL ) .and.
+ ( ktyprt ( iprt, iflno ) .ne. MDGRID ) .and.
+ ( ktyprt ( iprt, iflno ) .ne. MDRPCK ) ) THEN
iret = -21
RETURN
END IF
C
C* Get length of data header.
C
ilenhd = klnhdr ( iprt, iflno )
C
C* Get pointer to data.
C
ipoint = kpdata (iflno) + (irow-1) * kcol (iflno) * kprt (iflno)
+ + (icol-1) * kprt (iflno) + (iprt-1)
CALL DM_RINT ( iflno, ipoint, 1, istart, iret )
C
C* Read from file.
C
IF ( istart .ne. 0 ) THEN
C
C* Read the first word which is the length.
C
CALL DM_RINT ( iflno, istart, 1, length, iret )
isword = istart + 1
C
C* Check that length includes header and data.
C
IF ( length .le. ilenhd ) THEN
iret = -15
C
C* Check for an unrealistically large record length,
C* which is indicative of an earlier write error.
C
ELSE IF ( ABS(length) .gt. 20000000 ) THEN
iret = -34
ELSE
C
C* Read header.
C
CALL DM_RINT ( iflno, isword, ilenhd, idthdr, iret )
IF ( iret .ne. 0 ) RETURN
C
C* Read data.
C
nword = length - ilenhd
isword = isword + ilenhd
IF ( ktyprt ( iprt, iflno ) .eq. MDREAL ) THEN
CALL DM_RFLT ( iflno, isword, nword, rdata, iret )
IF ( iret .ne. 0 ) nword = 0
ELSE IF ( ktyprt ( iprt, iflno ) .eq. MDGRID ) THEN
CALL DM_RPKG ( iflno, isword, nword, rdata, mword,
+ iret )
nword = mword
IF ( iret .ne. 0 ) nword = 0
ELSE
C
C* Since the data is packed into integers, read them
C* and convert into real numbers. The maximum size
C* of the integer array is MMSPCE which is the size of
C* the scratch space.
C
CALL DM_RINT ( iflno, isword, nword, intarr, iret )
IF ( iret .eq. 0 ) THEN
CALL DM_UNPK ( iflno, iprt, nword, intarr,
+ nrword, rdata, iret )
END IF
IF ( iret .eq. 0 ) THEN
nword = nrword
ELSE
nword = 0
END IF
END IF
END IF
ELSE
iret = -15
END IF
C*
RETURN
END