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