PACK.inc
References to this file elsewhere.
1 SUBROUTINE PACK (Z,IDA,STAND,AMP,NGRID)
2 C
3 REAL*8 Z(NGRID), DMAX, DMIN
4 Crizvi INTEGER*2 IDA(NGRID)
5 INTEGER IDA(NGRID)
6
7 CMAX=32767.0
8
9 * ******* SCALING PART *******
10
11 Crizvi DMAX = -1.0E75
12 Crizvi DMIN = 1.0E75
13 DMAX = -1.0E38
14 DMIN = 1.0E38
15 DO 20 I=1,NGRID
16 DMAX = MAX(DMAX,Z(I))
17 DMIN = MIN(DMIN,Z(I))
18 20 CONTINUE
19 STAND=(DMAX+DMIN)*0.5
20 AMP =(DMAX-STAND)/CMAX
21
22 * ***** PACKING PART *******
23
24 IF(AMP.EQ.0.0) THEN
25 RAMP=1.0
26 ELSE
27 RAMP=1.0/AMP
28 END IF
29 C
30 DO 40 I=1,NGRID
31 WORK=(Z(I)-STAND)*RAMP
32 IF(WORK.GT.0.0) THEN
33 IDA(I)=INT(WORK+0.5)
34 ELSE
35 IDA(I)=INT(WORK-0.5)
36 END IF
37 40 CONTINUE
38 C
39 RETURN
40 END SUBROUTINE PACK
41
42 C*********************************************************************
43 SUBROUTINE CR4I2V(RDATA,BASE,AMP,IDATA,LM)
44 ************************************************************************
45 * ( IN ) RDATA R*4(LM) : 実数配列
46 * ( OUT) BASE R*4 : 基準値
47 * ( OUT) AMP R*4 : 係数
48 * ( OUT) IDATA I*2(LM) : 整数配列
49 * ( IN ) LM I*4 : データ数
50 *
51 ************************************************************************
52 *
53 Crizvi REAL*4 RDATA(LM),RMAX,RMIN,DIST,DBASE,EXPV
54 REAL RDATA(LM),RMAX,RMIN,DIST,DBASE,EXPV
55 INTEGER*4 IDATA(*)
56 Crizvi REAL*4 DVAL/32760.E0/
57 REAL DVAL/32760.E0/
58 Crizvi INTEGER*2 HZERO/0/,HWORK
59 INTEGER HZERO/0/,HWORK
60 *
61 * GET BASE,AMP
62 *
63 RMAX=RDATA(1)
64 RMIN=RDATA(1)
65 DO 10 I=2,LM
66 IF (RDATA(I).GT.RMAX) RMAX=RDATA(I)
67 IF (RDATA(I).LT.RMIN) RMIN=RDATA(I)
68 10 CONTINUE
69 DIST=(RMAX-RMIN)/2
70 DBASE=(RMIN+RMAX)/2
71 BASE=DBASE
72 AMP=DIST/DVAL
73 *
74 * PACK
75 *
76 IF (DIST.EQ.0) THEN ! ALL SAME
77 DO 20 I=1,LM/2
78 IDATA(I)=0
79 20 CONTINUE
80 IF ((LM/2)*2.NE.LM) THEN ! LM ODD
81 Crizvi CALL MOVEC(IDATA(LM/2+1),1,HZERO,1,2)
82 IDATA(LM/2+1) = HZERO * 65536
83
84 END IF
85 ELSE ! NORMAL DATA
86 EXPV=DVAL/DIST
87 *cdir nodep
88 DO 30 I=2,LM,2
89 IWORK=NINT((RDATA(I)-DBASE)*EXPV) ! EVEN PART
90 IF (IWORK.GE.0) THEN
91 IDATA(I/2)=NINT((RDATA(I-1)-DBASE)*EXPV)*65536+IWORK
92 ELSE
93 IDATA(I/2)=(NINT((RDATA(I-1)-DBASE)*EXPV)+1)*65536+IWORK
94 END IF
95 30 CONTINUE
96 IF ((LM/2)*2.NE.LM) THEN ! LM ODD
97 HWORK=NINT((RDATA(LM)-DBASE)*EXPV)
98 Crizvi CALL MOVEC(IDATA(LM/2+1),1,HWORK,1,2)
99 IDATA(LM/2+1) = HWORK * 65536
100 END IF
101 END IF
102 *
103 RETURN
104 END SUBROUTINE CR4I2V
105
106 C*********************************************************************
107 C >>> データをアンパックする（ベクトル版） <<<
108 C*********************************************************************
109 SUBROUTINE CI2R4V(RDATA,BASE,AMP,IDATA,LM)
110 ************************************************************************
111 *
112 * 数値予報課流２バイト整数型データ配列を４バイト実数に変換する。
113 * （Ｓ３８００ベクトル処理用）
114 * 1995.11.06 中野尚
115 * 引数
116 * ( OUT) RDATA R*4(LM) : 実数配列
117 * ( IN ) BASE R*4 : 基準値
118 * ( IN ) AMP R*4 : 係数
119 * ( IN ) IDATA I*2(LM) : 整数配列
120 * ( IN ) LM I*4 : データ数
121 *
122 * 必要なサブルーチン 無し
123 * 注意：ＩＤＡＴＡは語境界にあること。
124 *
125 ************************************************************************
126 *
127 Crizvi REAL*4 RDATA(LM)
128 REAL RDATA(LM)
129 cshc-rizvi start
130 INTEGER*4 IDATA(*)
131 c INTEGER*2 IDATA(*)
132 cshc-rizvi end
133 INTEGER*2 HWORK
134 C INTEGER HWORK
135 *
136 DO 10 I=2,LM,2
137 IWRK=IDATA(I/2)/65536
138 IRMN=IDATA(I/2)-IWRK*65536
139 IF (IRMN.EQ.0) THEN ! LOWER-HALF=0
140 RDATA(I-1)=BASE+AMP*IWRK
141 RDATA(I) =BASE
142 ELSE IF (IRMN.GT.0) THEN
143 RDATA(I-1)=BASE+AMP*IWRK
144 IF (IRMN.LT.32768) THEN
145 RDATA(I)=BASE+AMP*IRMN
146 ELSE
147 RDATA(I)=BASE+AMP*(IRMN-65536)
148 END IF
149 ELSE
150 RDATA(I-1)=BASE+AMP*(IWRK-1)
151 IF (IRMN.LT.-32768) THEN
152 RDATA(I)=BASE+AMP*(IRMN+65536)
153 ELSE
154 RDATA(I)=BASE+AMP*IRMN
155 END IF
156 END IF
157 10 CONTINUE
158 IF ((LM/2)*2.NE.LM) THEN ! LM ODD
159 Crizvi CALL MOVEC(HWORK,1,IDATA(LM/2+1),1,2)
160 HWORK=IDATA(LM/2+1)/65536
161 RDATA(LM)=BASE+AMP*HWORK
162 END IF
163 *
164 RETURN
165 END SUBROUTINE CI2R4V
166
167 C*********************************************************************
168 C >>> データをアンパックする（ベクトル版） <<<
169 C*********************************************************************
170 SUBROUTINE CI2R8V(RDATA,BASE,AMP,IDATA,LM)
171 ************************************************************************
172 *
173 * 数値予報課流２バイト整数型データ配列を８バイト実数に変換する。
174 * （Ｓ３８００ベクトル処理用）
175 * 1995.11.07 中野尚
176 * 引数
177 * ( OUT) RDATA R*8(LM) : 実数配列
178 * ( IN ) BASE R*4 : 基準値
179 * ( IN ) AMP R*4 : 係数
180 * ( IN ) IDATA I*2(LM) : 整数配列
181 * ( IN ) LM I*4 : データ数
182 *
183 * 必要なサブルーチン 無し
184 * 注意：ＲＤＡＴＡは２語境界、ＩＤＡＴＡは語境界にあること。
185 *
186 ************************************************************************
187 *
188 REAL*8 RDATA(LM)
189 INTEGER*4 IDATA(*)
190 INTEGER*2 HWORK
191 c INTEGER HWORK
192 *
193 DO 10 I=2,LM,2
194 IWRK=IDATA(I/2)/65536
195 IRMN=IDATA(I/2)-IWRK*65536
196 IF (IRMN.EQ.0) THEN ! LOWER-HALF=0
197 RDATA(I-1)=BASE+AMP*IWRK
198 RDATA(I) =BASE
199 ELSE IF (IRMN.GT.0) THEN
200 RDATA(I-1)=BASE+AMP*IWRK
201 IF (IRMN.LT.32768) THEN
202 RDATA(I)=BASE+AMP*IRMN
203 ELSE
204 RDATA(I)=BASE+AMP*(IRMN-65536)
205 END IF
206 ELSE
207 RDATA(I-1)=BASE+AMP*(IWRK-1)
208 IF (IRMN.LT.-32768) THEN
209 RDATA(I)=BASE+AMP*(IRMN+65536)
210 ELSE
211 RDATA(I)=BASE+AMP*IRMN
212 END IF
213 END IF
214 10 CONTINUE
215 IF ((LM/2)*2.NE.LM) THEN ! LM ODD
216 Crizvi CALL MOVEC(HWORK,1,IDATA(LM/2+1),1,2)
217 HWORK=IDATA(LM/2+1)/65536
218 RDATA(LM)=BASE+AMP*HWORK
219 END IF
220 *
221 RETURN
222 END SUBROUTINE CI2R8V
223 *
224 C*********************************************************************
225 SUBROUTINE MOVERD(DATIN,DATOUT,N)
226 DIMENSION DATIN(N)
227 REAL*8 DATOUT(N)
228 C
229 DO 100 I=1,N
230 DATOUT(I)=DATIN(I)
231 100 CONTINUE
232 C
233 RETURN
234 END SUBROUTINE MOVERD
235
236 C*********************************************************************
237 SUBROUTINE GETTYP(NFL,IOTYP)
238 CHARACTER*4 GVSD
239 REWIND NFL
240 C
241 READ(NFL,'(2A4)',ERR=10) GVSD, GVSD
242 10 REWIND NFL
243 IF( GVSD.EQ.'GVD1' ) THEN
244 IOTYP=1
245 RETURN
246 ENDIF
247 C
248 READ(NFL,ERR=20) GVSD
249 20 REWIND NFL
250 IF( GVSD.EQ.'GVS1' ) THEN
251 IOTYP=3
252 RETURN
253 ENDIF
254 C
255 IOTYP=-1
256 C
257 RETURN
258 END SUBROUTINE GETTYP
259