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