NCEPLIBS-w3emc  2.9.2
w3ft205.f
Go to the documentation of this file.
1 C> @file
2 C
3 C> SUBROUTINE: W3FT205 CONVERT (361,91) GRID TO (45,39) 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 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 60 DEG. W. POLE
10 C> POINT IS AT (I,J) = (27,57). NEW MAP IS AWIPS MAP 205.
11 C>
12 C> PROGRAM HISTORY LOG:
13 C> 93-10-19 R.E.JONES
14 C>
15 C> USAGE: CALL W3FT205(ALOLA,APOLA,INTERP)
16 C>
17 C> INPUT ARGUMENTS: ALOLA - 361*91 GRID 1.0 LAT,LON GRID N. HEMISPHERE
18 C> 32851 POINT GRID. 360 * 181 ONE DEGREE
19 C> GRIB GRID 3 WAS FLIPPED, GREENWISH ADDED
20 C> TO RIGH 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 - 45*39 GRID OF NORTHERN HEMISPHERE.
26 C> 1755 POINT GRID IS AWIPS GRID TYPE 205
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 45*39 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: SiliconGraphics 3.5 FORTRAN 77
47 C> MACHINE: SiliconGraphics IRIS-4D/25, 35, INDIGO, Indy
48 C>
49  SUBROUTINE w3ft205(ALOLA,APOLA,INTERP)
50 C
51  parameter(npts=1755,ii=45,jj=39)
52  parameter(orient=60.0,ipole=27,jpole=57)
53  parameter(xmesh=190.5)
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  xii(1647) = 1.0
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 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  1400 CONTINUE
161 C
162  IF (lin) GO TO 1700
163 C
164  DO 1500 kk = 1,npts
165  IF (jv(kk).LT.2.OR.jv(kk).GT.89) xj2tm(kk) = 0.0
166  1500 CONTINUE
167 C
168  1700 CONTINUE
169 C
170  IF (.NOT.lin) THEN
171  DO 2000 kk = 1,npts
172  IF (jy(kk,1).LT.1) jy(kk,1) = 1
173  2000 CONTINUE
174  ENDIF
175 C
176  2100 CONTINUE
177  IF (lin) THEN
178 C
179 C LINEAR INTERPOLATION
180 C
181  DO 2200 kk = 1,npts
182  eras(kk,2) = (alola(ip1(kk),jy(kk,2))-alola(iv(kk),jy(kk,2)))
183  & * xdeli(kk) + alola(iv(kk),jy(kk,2))
184  eras(kk,3) = (alola(ip1(kk),jy(kk,3))-alola(iv(kk),jy(kk,3)))
185  & * xdeli(kk) + alola(iv(kk),jy(kk,3))
186  2200 CONTINUE
187 C
188  DO 2300 kk = 1,npts
189  apola(kk) = eras(kk,2) + (eras(kk,3) - eras(kk,2))
190  & * xdelj(kk)
191  2300 CONTINUE
192 C
193  ELSE
194 C
195 C QUADRATIC INTERPOLATION
196 C
197  DO 2400 kk = 1,npts
198  eras(kk,1)=(alola(ip1(kk),jy(kk,1))-alola(iv(kk),jy(kk,1)))
199  & * xdeli(kk) + alola(iv(kk),jy(kk,1)) +
200  & ( alola(im1(kk),jy(kk,1)) - alola(iv(kk),jy(kk,1))
201  & - alola(ip1(kk),jy(kk,1))+alola(ip2(kk),jy(kk,1)))
202  & * xi2tm(kk)
203  eras(kk,2)=(alola(ip1(kk),jy(kk,2))-alola(iv(kk),jy(kk,2)))
204  & * xdeli(kk) + alola(iv(kk),jy(kk,2)) +
205  & ( alola(im1(kk),jy(kk,2)) - alola(iv(kk),jy(kk,2))
206  & - alola(ip1(kk),jy(kk,2))+alola(ip2(kk),jy(kk,2)))
207  & * xi2tm(kk)
208  eras(kk,3)=(alola(ip1(kk),jy(kk,3))-alola(iv(kk),jy(kk,3)))
209  & * xdeli(kk) + alola(iv(kk),jy(kk,3)) +
210  & ( alola(im1(kk),jy(kk,3)) - alola(iv(kk),jy(kk,3))
211  & - alola(ip1(kk),jy(kk,3))+alola(ip2(kk),jy(kk,3)))
212  & * xi2tm(kk)
213  eras(kk,4)=(alola(ip1(kk),jy(kk,4))-alola(iv(kk),jy(kk,4)))
214  & * xdeli(kk) + alola(iv(kk),jy(kk,4)) +
215  & ( alola(im1(kk),jy(kk,4)) - alola(iv(kk),jy(kk,4))
216  & - alola(ip1(kk),jy(kk,4))+alola(ip2(kk),jy(kk,4)))
217  & * xi2tm(kk)
218  2400 CONTINUE
219 C
220  DO 2500 kk = 1,npts
221  apola(kk) = eras(kk,2) + (eras(kk,3) - eras(kk,2))
222  & * xdelj(kk) + (eras(kk,1) - eras(kk,2)
223  & - eras(kk,3) + eras(kk,4)) * xj2tm(kk)
224  2500 CONTINUE
225 C
226 C NO POLE POINT
227 C
228  ENDIF
229 C
230  RETURN
231  END
w3ft205
subroutine w3ft205(ALOLA, APOLA, INTERP)
SUBROUTINE: W3FT205 CONVERT (361,91) GRID TO (45,39) N.
Definition: w3ft205.f:50