NCEPLIBS-w3emc  2.9.2
w3ft43v.f
Go to the documentation of this file.
1 C> @file
2 C
3 C> SUBROUTINE: W3FT43V CONVERT (361,181) GRID TO (65,65) N. HEMI. GRID
4 C> AUTHOR: JONES,R.E. ORG: W342 DATE: 93-10-19
5 C>
6 C> ABSTRACT: CONVERT A GLOBAL 1.0 DEGREE LAT.,LON. 361 BY
7 C> 181 GRID TO A POLAR STEREOGRAPHIC 65 BY 65 GRID. THE POLAR
8 C> STEREOGRAPHIC MAP PROJECTION IS TRUE AT 60 DEG. N. , THE MESH
9 C> LENGTH IS 381 KM. AND THE ORIENTION IS 80 DEG. W.
10 C>
11 C> PROGRAM HISTORY LOG:
12 C> 93-03-29 R.E.JONES ADD SAVE STATEMENT
13 C>
14 C> USAGE: CALL W3FT43V(ALOLA,APOLA,INTERP)
15 C>
16 C> INPUT ARGUMENTS: ALOLA - 361*181 GRID 1.0 DEG. LAT,LON GRID N. HEMI.
17 C> 65341 POINT GRID. 360 * 181 ONE DEGREE
18 C> GRIB GRID 3 WAS FLIPPED, GREENWISH ADDED
19 C> TO RIGHT SIDE TO MAKE 361 * 181.
20 C> INTERP - 1 LINEAR INTERPOLATION , NE.1 BIQUADRATIC
21 C>
22 C> INPUT FILES: NONE
23 C>
24 C> OUTPUT ARGUMENTS: APOLA - 65*65 GRID OF NORTHERN HEMISPHERE.
25 C> 4225 POINT GRID IS O.N.84 TYPE 27 OR 1B HEX
26 C>
27 C> OUTPUT FILES: ERROR MESSAGE TO FORTRAN OUTPUT FILE
28 C>
29 C> WARNINGS:
30 C>
31 C> 1. W1 AND W2 ARE USED TO STORE SETS OF CONSTANTS WHICH ARE
32 C> REUSABLE FOR REPEATED CALLS TO THE SUBROUTINE. 20 OTHER ARRAYS
33 C> ARE SAVED AND REUSED ON THE NEXT CALLS TO THE SUBROUTINE.
34 C>
35 C> 2. WIND COMPONENTS ARE NOT ROTATED TO THE 65*65 GRID ORIENTATION
36 C> AFTER INTERPOLATION. YOU MAY USE W3FC08 TO DO THIS.
37 C>
38 C> 3. THE ABOUT 1100 POINTS BELOW THE EQUATOR WILL BE IN THIS MAP.
39 C>
40 C> RETURN CONDITIONS: NORMAL SUBROUTINE EXIT
41 C>
42 C> SUBPROGRAMS CALLED:
43 C> UNIQUE : NONE
44 C>
45 C> LIBRARY: ASIN , ATAN2
46 C>
47 C> ATTRIBUTES:
48 C> LANGUAGE: CRAY CFT77 FORTRAN
49 C> MACHINE: CRAY C916/256, Y-MP8/864, Y-MP EL92/256, J916/2048
50 C>
51  SUBROUTINE w3ft43v(ALOLA,APOLA,INTERP)
52 C
53  parameter(npts=4225,ii=65,jj=65)
54  parameter(orient=80.0,ipole=33,jpole=33)
55  parameter(xmesh=381.0)
56 C
57  REAL R2(NPTS), WLON(NPTS)
58  REAL XLAT(NPTS), XI(II,JJ), XJ(II,JJ)
59  REAL XII(NPTS), XJJ(NPTS), ANGLE(NPTS)
60  REAL ALOLA(361,181), APOLA(NPTS), ERAS(NPTS,4)
61  REAL W1(NPTS), W2(NPTS)
62  REAL XDELI(NPTS), XDELJ(NPTS)
63  REAL XI2TM(NPTS), XJ2TM(NPTS)
64 C
65  INTEGER IV(NPTS), JV(NPTS), JY(NPTS,4)
66  INTEGER IM1(NPTS), IP1(NPTS), IP2(NPTS)
67 C
68  LOGICAL LIN
69 C
70  SAVE
71 C
72  equivalence(xi(1,1),xii(1)),(xj(1,1),xjj(1))
73 C
74  DATA degprd/57.2957795/
75  DATA earthr/6371.2/
76  DATA intrpo/99/
77  DATA iswt /0/
78 C
79  lin = .false.
80  IF (interp.EQ.1) lin = .true.
81 C
82  IF (iswt.EQ.1) GO TO 900
83 C
84  deg = 1.0
85  gi2 = (1.86603 * earthr) / xmesh
86  gi2 = gi2 * gi2
87 C
88 C NEXT 32 LINES OF CODE PUTS SUBROUTINE W3FB05 IN LINE
89 C
90  DO 100 j = 1,jj
91  xj1 = j - jpole
92  DO 100 i = 1,ii
93  xi(i,j) = i - ipole
94  xj(i,j) = xj1
95  100 CONTINUE
96 C
97  DO 200 kk = 1,npts
98  r2(kk) = xjj(kk) * xjj(kk) + xii(kk) * xii(kk)
99  xlat(kk) = degprd *
100  & asin((gi2 - r2(kk)) / (gi2 + r2(kk)))
101  200 CONTINUE
102 C
103  xii(2113) = 1.0
104  DO 300 kk = 1,npts
105  angle(kk) = degprd * atan2(xjj(kk),xii(kk))
106  300 CONTINUE
107 C
108  DO 400 kk = 1,npts
109  IF (angle(kk).LT.0.0) angle(kk) = angle(kk) + 360.0
110  400 CONTINUE
111 C
112  DO 500 kk = 1,npts
113  wlon(kk) = 270.0 + orient - angle(kk)
114  500 CONTINUE
115 C
116  DO 600 kk = 1,npts
117  IF (wlon(kk).LT.0.0) wlon(kk) = wlon(kk) + 360.0
118  600 CONTINUE
119 C
120  DO 700 kk = 1,npts
121  IF (wlon(kk).GE.360.0) wlon(kk) = wlon(kk) - 360.0
122  700 CONTINUE
123 C
124  xlat(2113) = 90.0
125  wlon(2113) = 0.0
126 C
127  DO 800 kk = 1,npts
128  w1(kk) = (360.0 - wlon(kk)) / deg + 1.0
129  w2(kk) = xlat(kk) / deg + 91.0
130  800 CONTINUE
131 C
132  iswt = 1
133  intrpo = interp
134  GO TO 1000
135 C
136 C AFTER THE 1ST CALL TO W3FT43V TEST INTERP, IF IT HAS
137 C CHANGED RECOMPUTE SOME CONSTANTS
138 C
139  900 CONTINUE
140  IF (interp.EQ.intrpo) GO TO 2100
141  intrpo = interp
142 C
143  1000 CONTINUE
144  DO 1100 k = 1,npts
145  iv(k) = w1(k)
146  jv(k) = w2(k)
147  xdeli(k) = w1(k) - iv(k)
148  xdelj(k) = w2(k) - jv(k)
149  ip1(k) = iv(k) + 1
150  jy(k,3) = jv(k) + 1
151  jy(k,2) = jv(k)
152  1100 CONTINUE
153 C
154  IF (lin) GO TO 1400
155 C
156  DO 1200 k = 1,npts
157  ip2(k) = iv(k) + 2
158  im1(k) = iv(k) - 1
159  jy(k,1) = jv(k) - 1
160  jy(k,4) = jv(k) + 2
161  xi2tm(k) = xdeli(k) * (xdeli(k) - 1.0) * .25
162  xj2tm(k) = xdelj(k) * (xdelj(k) - 1.0) * .25
163  1200 CONTINUE
164 C
165  DO 1300 kk = 1,npts
166  IF (iv(kk).EQ.1) THEN
167  ip2(kk) = 3
168  im1(kk) = 360
169  ELSE IF (iv(kk).EQ.360) THEN
170  ip2(kk) = 2
171  im1(kk) = 359
172  ENDIF
173  1300 CONTINUE
174 C
175  1400 CONTINUE
176 C
177  IF (lin) GO TO 1700
178 C
179  DO 1500 kk = 1,npts
180  IF (jv(kk).GE.180) xj2tm(kk) = 0.0
181  1500 CONTINUE
182 C
183  DO 1600 kk = 1,npts
184  IF (ip2(kk).LT.1) ip2(kk) = 1
185  IF (im1(kk).LT.1) im1(kk) = 1
186  IF (ip2(kk).GT.361) ip2(kk) = 361
187  IF (im1(kk).GT.361) im1(kk) = 361
188  1600 CONTINUE
189 C
190  1700 CONTINUE
191  DO 1800 kk = 1,npts
192  IF (iv(kk).LT.1) iv(kk) = 1
193  IF (ip1(kk).LT.1) ip1(kk) = 1
194  IF (iv(kk).GT.361) iv(kk) = 361
195  IF (ip1(kk).GT.361) ip1(kk) = 361
196  1800 CONTINUE
197 C
198 C LINEAR INTERPOLATION
199 C
200  DO 1900 kk = 1,npts
201  IF (jy(kk,2).GT.181) jy(kk,2) = 181
202  IF (jy(kk,3).GT.181) jy(kk,3) = 181
203  1900 CONTINUE
204 C
205  IF (.NOT.lin) THEN
206  DO 2000 kk = 1,npts
207  IF (jy(kk,1).GT.181) jy(kk,1) = 181
208  IF (jy(kk,4).GT.181) jy(kk,4) = 181
209  2000 CONTINUE
210  ENDIF
211 C
212  2100 CONTINUE
213  IF (lin) THEN
214 C
215 C LINEAR INTERPOLATION
216 C
217  DO 2200 kk = 1,npts
218  eras(kk,2) = (alola(ip1(kk),jy(kk,2))-alola(iv(kk),jy(kk,2)))
219  & * xdeli(kk) + alola(iv(kk),jy(kk,2))
220  eras(kk,3) = (alola(ip1(kk),jy(kk,3))-alola(iv(kk),jy(kk,3)))
221  & * xdeli(kk) + alola(iv(kk),jy(kk,3))
222  2200 CONTINUE
223 C
224  DO 2300 kk = 1,npts
225  apola(kk) = eras(kk,2) + (eras(kk,3) - eras(kk,2))
226  & * xdelj(kk)
227  2300 CONTINUE
228 C
229  ELSE
230 C
231 C QUADRATIC INTERPOLATION
232 C
233  DO 2400 kk = 1,npts
234  eras(kk,1)=(alola(ip1(kk),jy(kk,1))-alola(iv(kk),jy(kk,1)))
235  & * xdeli(kk) + alola(iv(kk),jy(kk,1)) +
236  & ( alola(im1(kk),jy(kk,1)) - alola(iv(kk),jy(kk,1))
237  & - alola(ip1(kk),jy(kk,1))+alola(ip2(kk),jy(kk,1)))
238  & * xi2tm(kk)
239  eras(kk,2)=(alola(ip1(kk),jy(kk,2))-alola(iv(kk),jy(kk,2)))
240  & * xdeli(kk) + alola(iv(kk),jy(kk,2)) +
241  & ( alola(im1(kk),jy(kk,2)) - alola(iv(kk),jy(kk,2))
242  & - alola(ip1(kk),jy(kk,2))+alola(ip2(kk),jy(kk,2)))
243  & * xi2tm(kk)
244  eras(kk,3)=(alola(ip1(kk),jy(kk,3))-alola(iv(kk),jy(kk,3)))
245  & * xdeli(kk) + alola(iv(kk),jy(kk,3)) +
246  & ( alola(im1(kk),jy(kk,3)) - alola(iv(kk),jy(kk,3))
247  & - alola(ip1(kk),jy(kk,3))+alola(ip2(kk),jy(kk,3)))
248  & * xi2tm(kk)
249  eras(kk,4)=(alola(ip1(kk),jy(kk,4))-alola(iv(kk),jy(kk,4)))
250  & * xdeli(kk) + alola(iv(kk),jy(kk,4)) +
251  & ( alola(im1(kk),jy(kk,4)) - alola(iv(kk),jy(kk,4))
252  & - alola(ip1(kk),jy(kk,4))+alola(ip2(kk),jy(kk,4)))
253  & * xi2tm(kk)
254  2400 CONTINUE
255 C
256  DO 2500 kk = 1,npts
257  apola(kk) = eras(kk,2) + (eras(kk,3) - eras(kk,2))
258  & * xdelj(kk) + (eras(kk,1) - eras(kk,2)
259  & - eras(kk,3) + eras(kk,4)) * xj2tm(kk)
260  2500 CONTINUE
261 C
262  ENDIF
263 C
264 C SET POLE POINT , WMO STANDARD FOR U OR V
265 C
266  apola(2113) = alola(181,181)
267 C
268  RETURN
269  END
w3ft43v
subroutine w3ft43v(ALOLA, APOLA, INTERP)
SUBROUTINE: W3FT43V CONVERT (361,181) GRID TO (65,65) N.
Definition: w3ft43v.f:52