NCEPLIBS-w3emc  2.9.2
w3ft208.f
Go to the documentation of this file.
1 C> @file
2 C
3 C> SUBROUTINE: W3FT208 CONVERT (361,91) GRID TO (29,27) MERCATOR 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 REGIONAL - HAWAII (MERCATOR) 29*27 AWIPS 208
8 C> GRID.
9 C>
10 C> PROGRAM HISTORY LOG:
11 C> 93-10-19 R.E.JONES
12 C>
13 C> USAGE: CALL W3FT208(ALOLA,AMERC,INTERP)
14 C>
15 C> INPUT ARGUMENTS: ALOLA - 361*91 GRID 1.0 DEG. LAT,LON GRID N. HEMI.
16 C> 32851 POINT GRID. 360 * 181 ONE DEGREE
17 C> GRIB GRID 3 WAS FLIPPED, GREENWISH ADDED
18 C> TO RIGHT SIDE AND CUT TO 361 * 91.
19 C> INTERP - 1 LINEAR INTERPOLATION , NE.1 BIQUADRATIC
20 C>
21 C> INPUT FILES: NONE
22 C>
23 C> OUTPUT ARGUMENTS: AMERC - 29*27 GRID OF NORTHERN MERCATOR
24 C> 783 POINT GRID IS AWIPS GRID TYPE 208
25 C>
26 C> OUTPUT FILES: ERROR MESSAGE TO FORTRAN OUTPUT FILE
27 C>
28 C> WARNINGS:
29 C>
30 C> 1. W1 AND W2 ARE USED TO STORE SETS OF CONSTANTS WHICH ARE
31 C> REUSABLE FOR REPEATED CALLS TO THE SUBROUTINE. 20 OTHER ARRAY
32 C> ARE SAVED AND REUSED ON THE NEXT CALL.
33 C>
34 C> RETURN CONDITIONS: NORMAL SUBROUTINE EXIT
35 C>
36 C> SUBPROGRAMS CALLED:
37 C> UNIQUE : NONE
38 C>
39 C> LIBRARY: ASIN , ATAN2
40 C>
41 C> ATTRIBUTES:
42 C> LANGUAGE: CRAY CFT77 FORTRAN
43 C> MACHINE: CRAY C916-128, CRAY Y-MP8/864, CRAY Y-MP EL2/256
44 C>
45  SUBROUTINE w3ft208(ALOLA,AMERC,INTERP)
46 C
47  parameter(npts=783,ii=29,jj=27)
48  parameter(alatin=20.000)
49  parameter(pi=3.1416)
50  parameter(dx=80000.0)
51  parameter(alat1=9.343)
52  parameter(alon1=192.685)
53 C
54  REAL WLON(NPTS), XLAT(NPTS)
55  REAL XI(II,JJ), XJ(II,JJ)
56  REAL XII(NPTS), XJJ(NPTS)
57  REAL ALOLA(361,91), AMERC(NPTS), ERAS(NPTS,4)
58  REAL W1(NPTS), W2(NPTS)
59  REAL XDELI(NPTS), XDELJ(NPTS)
60  REAL XI2TM(NPTS), XJ2TM(NPTS)
61 C
62  INTEGER IV(NPTS), JV(NPTS), JY(NPTS,4)
63  INTEGER IM1(NPTS), IP1(NPTS), IP2(NPTS)
64 C
65  LOGICAL LIN
66 C
67  SAVE
68 C
69  equivalence(xi(1,1),xii(1)),(xj(1,1),xjj(1))
70 C
71 C DATA DEGPR /57.2957795/
72  DATA rerth /6.3712e+6/
73  DATA intrpo/99/
74  DATA iswt /0/
75 C
76  degpr = 180.0 / pi
77  radpd = pi / 180.0
78  clain = cos(radpd * alatin)
79  dellon = dx / (rerth * clain)
80  djeo = (alog(tan(0.5*((alat1+90.0)*radpd))))/dellon
81 C
82  lin = .false.
83  IF (interp.EQ.1) lin = .true.
84 C
85  IF (iswt.EQ.1) GO TO 900
86 C
87  deg = 1.0
88 C
89 C NEXT 32 LINES OF CODE PUTS SUBROUTINE W3FB09 IN LINE
90 C
91  DO 100 j = 1,jj
92  DO 100 i = 1,ii
93  xi(i,j) = i
94  xj(i,j) = j
95  100 CONTINUE
96 C
97  DO 200 kk = 1,npts
98  xlat(kk) = 2.0*atan(exp(dellon*(djeo + xjj(kk)-1.)))
99  & * degpr - 90.0
100  200 CONTINUE
101 C
102  DO 300 kk = 1,npts
103  wlon(kk) = (xii(kk) -1.0) * dellon * degpr + alon1
104  300 CONTINUE
105 C
106  DO 400 kk = 1,npts
107  w1(kk) = wlon(kk) + 1.0
108  w2(kk) = xlat(kk) + 1.0
109  400 CONTINUE
110 C
111  iswt = 1
112  intrpo = interp
113  GO TO 1000
114 C
115 C AFTER THE 1ST CALL TO W3FT208 TEST INTERP, IF IT HAS
116 C CHANGED RECOMPUTE SOME CONSTANTS
117 C
118  900 CONTINUE
119  IF (interp.EQ.intrpo) GO TO 2100
120  intrpo = interp
121 C
122  1000 CONTINUE
123  DO 1100 k = 1,npts
124  iv(k) = w1(k)
125  jv(k) = w2(k)
126  xdeli(k) = w1(k) - iv(k)
127  xdelj(k) = w2(k) - jv(k)
128  ip1(k) = iv(k) + 1
129  jy(k,3) = jv(k) + 1
130  jy(k,2) = jv(k)
131  1100 CONTINUE
132 C
133  IF (.NOT.lin) THEN
134  DO 1200 k = 1,npts
135  ip2(k) = iv(k) + 2
136  im1(k) = iv(k) - 1
137  jy(k,1) = jv(k) - 1
138  jy(k,4) = jv(k) + 2
139  xi2tm(k) = xdeli(k) * (xdeli(k) - 1.0) * .25
140  xj2tm(k) = xdelj(k) * (xdelj(k) - 1.0) * .25
141  1200 CONTINUE
142  END IF
143 C
144  2100 CONTINUE
145  IF (lin) THEN
146 C
147 C LINEAR INTERPOLATION
148 C
149  DO 2200 kk = 1,npts
150  eras(kk,2) = (alola(ip1(kk),jy(kk,2))-alola(iv(kk),jy(kk,2)))
151  & * xdeli(kk) + alola(iv(kk),jy(kk,2))
152  eras(kk,3) = (alola(ip1(kk),jy(kk,3))-alola(iv(kk),jy(kk,3)))
153  & * xdeli(kk) + alola(iv(kk),jy(kk,3))
154  2200 CONTINUE
155 C
156  DO 2300 kk = 1,npts
157  amerc(kk) = eras(kk,2) + (eras(kk,3) - eras(kk,2))
158  & * xdelj(kk)
159  2300 CONTINUE
160 C
161  ELSE
162 C
163 C BI-QUADRATIC INTERPOLATION
164 C
165  DO 2400 kk = 1,npts
166  eras(kk,1)=(alola(ip1(kk),jy(kk,1))-alola(iv(kk),jy(kk,1)))
167  & * xdeli(kk) + alola(iv(kk),jy(kk,1)) +
168  & ( alola(im1(kk),jy(kk,1)) - alola(iv(kk),jy(kk,1))
169  & - alola(ip1(kk),jy(kk,1))+alola(ip2(kk),jy(kk,1)))
170  & * xi2tm(kk)
171  eras(kk,2)=(alola(ip1(kk),jy(kk,2))-alola(iv(kk),jy(kk,2)))
172  & * xdeli(kk) + alola(iv(kk),jy(kk,2)) +
173  & ( alola(im1(kk),jy(kk,2)) - alola(iv(kk),jy(kk,2))
174  & - alola(ip1(kk),jy(kk,2))+alola(ip2(kk),jy(kk,2)))
175  & * xi2tm(kk)
176  eras(kk,3)=(alola(ip1(kk),jy(kk,3))-alola(iv(kk),jy(kk,3)))
177  & * xdeli(kk) + alola(iv(kk),jy(kk,3)) +
178  & ( alola(im1(kk),jy(kk,3)) - alola(iv(kk),jy(kk,3))
179  & - alola(ip1(kk),jy(kk,3))+alola(ip2(kk),jy(kk,3)))
180  & * xi2tm(kk)
181  eras(kk,4)=(alola(ip1(kk),jy(kk,4))-alola(iv(kk),jy(kk,4)))
182  & * xdeli(kk) + alola(iv(kk),jy(kk,4)) +
183  & ( alola(im1(kk),jy(kk,4)) - alola(iv(kk),jy(kk,4))
184  & - alola(ip1(kk),jy(kk,4))+alola(ip2(kk),jy(kk,4)))
185  & * xi2tm(kk)
186  2400 CONTINUE
187 C
188  DO 2500 kk = 1,npts
189  amerc(kk) = eras(kk,2) + (eras(kk,3) - eras(kk,2))
190  & * xdelj(kk) + (eras(kk,1) - eras(kk,2)
191  & - eras(kk,3) + eras(kk,4)) * xj2tm(kk)
192  2500 CONTINUE
193 C
194  ENDIF
195 C
196  RETURN
197  END
w3ft208
subroutine w3ft208(ALOLA, AMERC, INTERP)
SUBROUTINE: W3FT208 CONVERT (361,91) GRID TO (29,27) MERCATOR GRID AUTHOR: JONES,R....
Definition: w3ft208.f:46