NCEPLIBS-w3emc  2.9.2
w3ft202.f
Go to the documentation of this file.
1 C> @file
2 C
3 C> SUBROUTINE: W3FT202 CONVERT (361,91) GRID TO (65,43) 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 65 BY 43 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 105 DEG. W.
10 C>
11 C> PROGRAM HISTORY LOG:
12 C> 94-05-18 R.E.JONES
13 C>
14 C> USAGE: CALL W3FT202(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 - 65*43 GRID OF NORTHERN HEMISPHERE.
23 C> 2795 POINT GRID IS AWIPS GRID TYPE 202
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 65*43 GRID ORIENTATION
33 C> AFTER INTERPOLATION. YOU MAY USE W3FC08 TO DO THIS.
34 C>
35 C> 3. THE GRID POINTS VALUES ON THE EQUATOR HAVE BEEN EXTRAPOLATED
36 C> OUTWARD TO ALL THE GRID POINTS OUTSIDE THE EQUATOR ON THE 65*43
37 C> GRID (ABOUT 1100 POINTS).
38 C>
39 C> RETURN CONDITIONS: NORMAL SUBROUTINE EXIT
40 C>
41 C> SUBPROGRAMS CALLED:
42 C> UNIQUE : NONE
43 C>
44 C> LIBRARY: ASIN , ATAN2
45 C>
46 C> ATTRIBUTES:
47 C> LANGUAGE: CRAY CFT77 FORTRAN
48 C> MACHINE: CRAY C916-128, CRAY Y-MP8/864, CRAY Y-MP EL2/256
49 C>
50  SUBROUTINE w3ft202(ALOLA,APOLA,INTERP)
51 C
52  parameter(npts=2795,ii=65,jj=43)
53  parameter(orient=105.0,ipole=33,jpole=45)
54  parameter(xmesh=190.5)
55 C
56  REAL R2(NPTS), WLON(NPTS)
57  REAL XLAT(NPTS), XI(II,JJ), XJ(II,JJ)
58  REAL XII(NPTS), XJJ(NPTS), ANGLE(NPTS)
59  REAL ALOLA(361,91), APOLA(NPTS), ERAS(NPTS,4)
60  REAL W1(NPTS), W2(NPTS)
61  REAL XDELI(NPTS), XDELJ(NPTS)
62  REAL XI2TM(NPTS), XJ2TM(NPTS)
63 C
64  INTEGER IV(NPTS), JV(NPTS), JY(NPTS,4)
65  INTEGER IM1(NPTS), IP1(NPTS), IP2(NPTS)
66 C
67  LOGICAL LIN
68 C
69  SAVE
70 C
71  equivalence(xi(1,1),xii(1)),(xj(1,1),xjj(1))
72 C
73  DATA degprd/57.2957795/
74  DATA earthr/6371.2/
75  DATA intrpo/99/
76  DATA iswt /0/
77 C
78  lin = .false.
79  IF (interp.EQ.1) lin = .true.
80 C
81  IF (iswt.EQ.1) GO TO 900
82 C
83  deg = 1.0
84  gi2 = (1.86603 * earthr) / xmesh
85  gi2 = gi2 * gi2
86 C
87 C NEXT 32 LINES OF CODE PUTS SUBROUTINE W3FB01 IN LINE
88 C
89  DO 100 j = 1,jj
90  xj1 = j - jpole
91  DO 100 i = 1,ii
92  xi(i,j) = i - ipole
93  xj(i,j) = xj1
94  100 CONTINUE
95 C
96  DO 200 kk = 1,npts
97  r2(kk) = xjj(kk) * xjj(kk) + xii(kk) * xii(kk)
98  xlat(kk) = degprd *
99  & asin((gi2 - r2(kk)) / (gi2 + r2(kk)))
100  200 CONTINUE
101 C
102  DO 300 kk = 1,npts
103  angle(kk) = degprd * atan2(xjj(kk),xii(kk))
104  300 CONTINUE
105 C
106  DO 400 kk = 1,npts
107  IF (angle(kk).LT.0.0) angle(kk) = angle(kk) + 360.0
108  400 CONTINUE
109 C
110  DO 500 kk = 1,npts
111  wlon(kk) = 270.0 + orient - angle(kk)
112  500 CONTINUE
113 C
114  DO 600 kk = 1,npts
115  IF (wlon(kk).LT.0.0) wlon(kk) = wlon(kk) + 360.0
116  600 CONTINUE
117 C
118  DO 700 kk = 1,npts
119  IF (wlon(kk).GE.360.0) wlon(kk) = wlon(kk) - 360.0
120  700 CONTINUE
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 W3FT202 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 2100
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  2100 CONTINUE
161  IF (lin) THEN
162 C
163 C LINEAR INTERPOLATION
164 C
165  DO 2200 kk = 1,npts
166  eras(kk,2) = (alola(ip1(kk),jy(kk,2))-alola(iv(kk),jy(kk,2)))
167  & * xdeli(kk) + alola(iv(kk),jy(kk,2))
168  eras(kk,3) = (alola(ip1(kk),jy(kk,3))-alola(iv(kk),jy(kk,3)))
169  & * xdeli(kk) + alola(iv(kk),jy(kk,3))
170  2200 CONTINUE
171 C
172  DO 2300 kk = 1,npts
173  apola(kk) = eras(kk,2) + (eras(kk,3) - eras(kk,2))
174  & * xdelj(kk)
175  2300 CONTINUE
176 C
177  ELSE
178 C
179 C QUADRATIC INTERPOLATION
180 C
181  DO 2400 kk = 1,npts
182  eras(kk,1)=(alola(ip1(kk),jy(kk,1))-alola(iv(kk),jy(kk,1)))
183  & * xdeli(kk) + alola(iv(kk),jy(kk,1)) +
184  & ( alola(im1(kk),jy(kk,1)) - alola(iv(kk),jy(kk,1))
185  & - alola(ip1(kk),jy(kk,1))+alola(ip2(kk),jy(kk,1)))
186  & * xi2tm(kk)
187  eras(kk,2)=(alola(ip1(kk),jy(kk,2))-alola(iv(kk),jy(kk,2)))
188  & * xdeli(kk) + alola(iv(kk),jy(kk,2)) +
189  & ( alola(im1(kk),jy(kk,2)) - alola(iv(kk),jy(kk,2))
190  & - alola(ip1(kk),jy(kk,2))+alola(ip2(kk),jy(kk,2)))
191  & * xi2tm(kk)
192  eras(kk,3)=(alola(ip1(kk),jy(kk,3))-alola(iv(kk),jy(kk,3)))
193  & * xdeli(kk) + alola(iv(kk),jy(kk,3)) +
194  & ( alola(im1(kk),jy(kk,3)) - alola(iv(kk),jy(kk,3))
195  & - alola(ip1(kk),jy(kk,3))+alola(ip2(kk),jy(kk,3)))
196  & * xi2tm(kk)
197  eras(kk,4)=(alola(ip1(kk),jy(kk,4))-alola(iv(kk),jy(kk,4)))
198  & * xdeli(kk) + alola(iv(kk),jy(kk,4)) +
199  & ( alola(im1(kk),jy(kk,4)) - alola(iv(kk),jy(kk,4))
200  & - alola(ip1(kk),jy(kk,4))+alola(ip2(kk),jy(kk,4)))
201  & * xi2tm(kk)
202  2400 CONTINUE
203 C
204  DO 2500 kk = 1,npts
205  apola(kk) = eras(kk,2) + (eras(kk,3) - eras(kk,2))
206  & * xdelj(kk) + (eras(kk,1) - eras(kk,2)
207  & - eras(kk,3) + eras(kk,4)) * xj2tm(kk)
208  2500 CONTINUE
209 C
210  ENDIF
211 C
212  RETURN
213  END
w3ft202
subroutine w3ft202(ALOLA, APOLA, INTERP)
SUBROUTINE: W3FT202 CONVERT (361,91) GRID TO (65,43) N.
Definition: w3ft202.f:51