-
Notifications
You must be signed in to change notification settings - Fork 0
/
dpfile.f
144 lines (144 loc) · 4.27 KB
/
dpfile.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
SUBROUTINE DP_FILE ( prmfil, nparm, parms, logscl, ioffst,
+ nbits, pkflg, iret )
C************************************************************************
C* DP_FILE *
C* *
C* This subroutine reads a parameter-packing file. The parameters in *
C* the file and the data-packing terms are returned. If none of the *
C* data is to be packed, PKFLG is set to false. If some of the data *
C* is to be packed and some is not, an error is returned. *
C* *
C* Parameter-packing file format: *
C* *
C* Each parameter in the file must be described on a single line *
C* containing the following items separated by blanks or tabs: *
C* *
C* parameter name CHAR*4 *
C* minimum data value REAL *
C* maximum data value REAL *
C* resolution REAL *
C* *
C* The resolution should be an integral power of 10. If not, the *
C* next smaller resolution will be used (e.g., res = .5 will *
C* become .1). If the resolution is 0 or if the minimum, maximum *
C* and resolution are not present, the data will not be packed. *
C* *
C* DP_FILE ( PRMFIL, NPARM, PARMS, LOGSCL, IOFFST, NBITS, PKFLG, *
C* IRET ) *
C* *
C* Input parameters: *
C* PRMFIL CHAR* Parameter packing file name *
C* *
C* Output parameters: *
C* NPARM INTEGER Number of parameters *
C* PARMS (NPARM) CHAR* Parameter names *
C* LOGSCL (NPARM) INTEGER Log10 of scale factor *
C* IOFFST (NPARM) INTEGER Offset *
C* NBITS (NPARM) INTEGER Number of bits *
C* PKFLG LOGICAL Packing flag *
C* IRET INTEGER Return code *
C* 0 = normal return *
C* -3 = invalid number of parms *
C* -7 = packing file not opened *
C* -8 = file read error *
C* -9 = packed and unpacked data *
C* mixed *
C** *
C* Log: *
C* I. Graffman/RDS 4/87 GEMPAK4 *
C* M. desJardins/GSFC 10/88 Eliminated TB_RPPK *
C* J. Whistler/SSAI 6/91 Eliminated error message after FL_TOPN *
C* D. Keiser/GSC 12/95 Changed FL_TOPN to FL_TBOP *
C************************************************************************
INCLUDE 'GEMPRM.PRM'
C*
CHARACTER*(*) prmfil, parms (*)
INTEGER logscl (*), ioffst (*), nbits (*)
LOGICAL pkflg
C*
CHARACTER pm*4, record*80, clst(4)*24
REAL xmn (MMPARM), xmx (MMPARM), xres (MMPARM)
C*
INCLUDE 'ERMISS.FNC'
C------------------------------------------------------------------------
iret = 0
nparm = 0
C
C* Open the packing file.
C
CALL FL_TBOP ( prmfil, 'pack', ipklun, ier )
IF ( ier .ne. 0 ) THEN
iret = -7
RETURN
END IF
C
C* Read in the parameters.
C
iostat = 0
knt = 0
DO WHILE ( iostat .eq. 0 )
READ ( ipklun, 1000, IOSTAT = iostat ) record
1000 FORMAT ( A )
IF ( ( iostat .eq. 0 ) .and. ( record .ne. ' ' ) ) THEN
C
C* Break input into 4 character strings.
C
CALL ST_LCUC ( record, record, ier )
CALL ST_RNAN ( record, record, n, ier )
CALL ST_CLST ( record, ' ', ' ', 4, clst, n, ier )
pm = clst (1)
CALL ST_RLST ( clst (2), ' ', RMISSD, 1, ymn, n, ier )
CALL ST_RLST ( clst (3), ' ', RMISSD, 1, ymx, n, ier )
CALL ST_RLST ( clst (4), ' ', RMISSD, 1, yres, n, ier )
C
C* Add to list of parameters.
C
knt = knt + 1
IF ( knt .gt. MMPARM ) THEN
iret = -3
RETURN
ELSE
parms (knt) = pm
xmn (knt) = ymn
xmx (knt) = ymx
xres (knt) = yres
IF ( ( ERMISS (ymn) ) .or. ( ERMISS (ymx) ) .or.
+ ( ERMISS (yres) ) ) THEN
IF ( knt .eq. 1 ) THEN
pkflg = .false.
ELSE IF ( pkflg ) THEN
iret = -9
RETURN
END IF
ELSE
IF ( knt .eq. 1 ) THEN
pkflg = .true.
ELSE IF ( .not. pkflg ) THEN
iret = -9
RETURN
END IF
END IF
END IF
END IF
END DO
C
C* Set terms in DP package.
C
IF ( pkflg ) THEN
DO i = 1, knt
CALL DP_TERM ( xmn (i), xmx (i), xres (i),
+ logscl (i), ioffst (i), nbits (i), ier )
IF ( ier .ne. 0 ) iret = ier
END DO
END IF
C
C* Close the packing file.
C
CALL FL_CLOS ( ipklun, ier )
C
C* Set the number of parameters.
C
nparm = knt
C*
RETURN
END