-
Notifications
You must be signed in to change notification settings - Fork 0
/
dmwdtr.f
163 lines (163 loc) · 4.14 KB
/
dmwdtr.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
SUBROUTINE DM_WDTR ( iflno, irow, icol, part, idthdr, rdata,
+ nword, iret )
C************************************************************************
C* DM_WDTR *
C* *
C* This subroutine writes real data to a DM file. *
C* *
C* DM_WDTR ( 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* IDTHDR (*) INTEGER Data header *
C* RDATA (NWORD) REAL Data *
C* NWORD INTEGER Length of data array *
C* *
C* Output parameters: *
C* IRET INTEGER Return code *
C* 0 = normal return *
C* -4 = file not open *
C* -6 = write error *
C* -9 = invalid row or column *
C* -10 = invalid part name *
C* -13 = no write access *
C* -21 = incorrect data type *
C** *
C* Log: *
C* M. desJardins/GSFC 4/87 *
C* M. desJardins/GSFC 3/89 Modified for grid packing *
C************************************************************************
INCLUDE 'GEMPRM.PRM'
INCLUDE 'dmcmn.cmn'
C
CHARACTER*(*) part
REAL rdata (*)
INTEGER idthdr (*)
C------------------------------------------------------------------------
C* Check that file is open.
C
CALL DM_CHKF ( iflno, iret )
IF ( iret .ne. 0 ) RETURN
C
C* Check that file was opened for write access.
C
IF ( .not. wflag (iflno) ) THEN
iret = -13
RETURN
END IF
C
C* Check for valid length.
C
IF ( nword .le. 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 ) .eq. MDREAL ) THEN
kword = nword
C
C* Pack the data into an integer array for packed data type.
C
ELSE IF ( ktyprt ( iprt, iflno ) .eq. MDRPCK ) THEN
CALL DM_PACK ( iflno, iprt, nword, rdata, kword, intarr,
+ iret )
IF ( iret .ne. 0 ) RETURN
ELSE IF ( ktyprt ( iprt, iflno ) .eq. MDGRID ) THEN
CALL DM_PKGDC ( rdata, nword, kword, ipktyp, nbits, misflg,
+ kxky, kx, ref, scale, difmin, iret )
ELSE
iret = -21
RETURN
END IF
C
C* Get length of data header.
C
ilenhd = klnhdr ( iprt, iflno )
C
C* Check to see if data has already been written.
C* First 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 length of previous data.
C
IF ( istart .ne. 0 ) THEN
CALL DM_RINT ( iflno, istart, 1, lenold, iret )
ELSE
lenold = 0
END IF
C
C* If old space is correct length, use it.
C
lennew = kword + ilenhd
IF ( lenold .ne. lennew ) THEN
C
C* Otherwise, free old space.
C
IF ( lenold .gt. 0 ) THEN
length = lenold + 1
CALL DM_AFRE ( iflno, length, istart, ier )
END IF
C
C* Get space for current data.
C
length = lennew + 1
CALL DM_GSPC ( iflno, length, istart, iret )
C
C* Write length to file.
C
CALL DM_WINT ( iflno, istart, 1, lennew, iret )
IF ( iret .ne. 0 ) RETURN
END IF
C
C* Write header to file.
C
isword = istart + 1
IF ( ilenhd .gt. 0 ) THEN
CALL DM_WINT ( iflno, isword, ilenhd, idthdr, iret )
IF ( iret .ne. 0 ) RETURN
isword = isword + ilenhd
END IF
C
C* Write data to file.
C
IF ( ktyprt ( iprt, iflno ) .eq. MDREAL ) THEN
CALL DM_WFLT ( iflno, isword, kword, rdata, iret )
ELSE IF ( ktyprt ( iprt, iflno ) .eq. MDGRID ) THEN
CALL DM_WPKGC ( iflno, rdata, isword, kword, ipktyp,
+ nbits, misflg, kxky, kx, ref, scale,
+ difmin, iret )
ELSE
CALL DM_WINT ( iflno, isword, kword, intarr, iret )
END IF
IF ( iret .ne. 0 ) RETURN
C
C* Write pointer to file.
C
CALL DM_WINT ( iflno, ipoint, 1, istart, iret )
C*
RETURN
END