NCEPLIBS-w3emc  2.9.2
w3ft210.f
Go to the documentation of this file.
1 C> @file
2 C
3 C> SUBROUTINE: W3FT210 CONVERT (361,91) GRID TO (25,25) 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 - PUERTO RICO (MERCATOR) 25*25 AWIPS 210
8 C> GRID.
9 C>
10 C> PROGRAM HISTORY LOG:
11 C> 93-10-19 R.E.JONES
12 C>
13 C> USAGE: CALL W3FT210(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 - 25*25 GRID OF NORTHERN MERCATOR
24 C> 625 POINT GRID IS AWIPS GRID TYPE 210
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 w3ft210(ALOLA,AMERC,INTERP)
46 C
47  parameter(npts=625,ii=25,jj=25)
48  parameter(alatin=20.000)
49  parameter(pi=3.1416)
50  parameter(dx=80000.0)
51  parameter(alat1=9.000)
52  parameter(alon1=283.000)
53 C
54  REAL R2(NPTS), WLON(NPTS)
55  REAL XLAT(NPTS), XI(II,JJ), XJ(II,JJ)
56  REAL XII(NPTS), XJJ(NPTS), ANGLE(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  lin = .false.
82  IF (interp.EQ.1) lin = .true.
83 C
84  IF (iswt.EQ.1) GO TO 900
85 C
86  deg = 1.0
87 C
88 C NEXT 32 LINES OF CODE PUTS SUBROUTINE W3FB09 IN LINE
89 C
90  DO 100 j = 1,jj
91  DO 100 i = 1,ii
92  xi(i,j) = i
93  xj(i,j) = j
94  100 CONTINUE
95 C
96  DO 200 kk = 1,npts
97  xlat(kk) = 2.0*atan(exp(dellon*(djeo + xjj(kk)-1.)))
98  & * degpr - 90.0
99  200 CONTINUE
100 C
101  DO 300 kk = 1,npts
102  wlon(kk) = (xii(kk) -1.0) * dellon * degpr + alon1
103  300 CONTINUE
104 C
105  DO 400 kk = 1,npts
106  w1(kk) = wlon(kk) + 1.0
107  w2(kk) = xlat(kk) + 1.0
108  400 CONTINUE
109 C
110  iswt = 1
111  intrpo = interp
112  GO TO 1000
113 C
114 C AFTER THE 1ST CALL TO W3FT210 TEST INTERP, IF IT HAS
115 C CHANGED RECOMPUTE SOME CONSTANTS
116 C
117  900 CONTINUE
118  IF (interp.EQ.intrpo) GO TO 2100
119  intrpo = interp
120 C
121  1000 CONTINUE
122  DO 1100 k = 1,npts
123  iv(k) = w1(k)
124  jv(k) = w2(k)
125  xdeli(k) = w1(k) - iv(k)
126  xdelj(k) = w2(k) - jv(k)
127  ip1(k) = iv(k) + 1
128  jy(k,3) = jv(k) + 1
129  jy(k,2) = jv(k)
130  1100 CONTINUE
131 C
132  IF (.NOT.lin) THEN
133  DO 1200 k = 1,npts
134  ip2(k) = iv(k) + 2
135  im1(k) = iv(k) - 1
136  jy(k,1) = jv(k) - 1
137  jy(k,4) = jv(k) + 2
138  xi2tm(k) = xdeli(k) * (xdeli(k) - 1.0) * .25
139  xj2tm(k) = xdelj(k) * (xdelj(k) - 1.0) * .25
140  1200 CONTINUE
141  END IF
142 C
143  2100 CONTINUE
144  IF (lin) THEN
145 C
146 C LINEAR INTERPOLATION
147 C
148  DO 2200 kk = 1,npts
149  eras(kk,2) = (alola(ip1(kk),jy(kk,2))-alola(iv(kk),jy(kk,2)))
150  & * xdeli(kk) + alola(iv(kk),jy(kk,2))
151  eras(kk,3) = (alola(ip1(kk),jy(kk,3))-alola(iv(kk),jy(kk,3)))
152  & * xdeli(kk) + alola(iv(kk),jy(kk,3))
153  2200 CONTINUE
154 C
155  DO 2300 kk = 1,npts
156  amerc(kk) = eras(kk,2) + (eras(kk,3) - eras(kk,2))
157  & * xdelj(kk)
158  2300 CONTINUE
159 C
160  ELSE
161 C
162 C QUADRATIC INTERPOLATION
163 C
164  DO 2400 kk = 1,npts
165  eras(kk,1)=(alola(ip1(kk),jy(kk,1))-alola(iv(kk),jy(kk,1)))
166  & * xdeli(kk) + alola(iv(kk),jy(kk,1)) +
167  & ( alola(im1(kk),jy(kk,1)) - alola(iv(kk),jy(kk,1))
168  & - alola(ip1(kk),jy(kk,1))+alola(ip2(kk),jy(kk,1)))
169  & * xi2tm(kk)
170  eras(kk,2)=(alola(ip1(kk),jy(kk,2))-alola(iv(kk),jy(kk,2)))
171  & * xdeli(kk) + alola(iv(kk),jy(kk,2)) +
172  & ( alola(im1(kk),jy(kk,2)) - alola(iv(kk),jy(kk,2))
173  & - alola(ip1(kk),jy(kk,2))+alola(ip2(kk),jy(kk,2)))
174  & * xi2tm(kk)
175  eras(kk,3)=(alola(ip1(kk),jy(kk,3))-alola(iv(kk),jy(kk,3)))
176  & * xdeli(kk) + alola(iv(kk),jy(kk,3)) +
177  & ( alola(im1(kk),jy(kk,3)) - alola(iv(kk),jy(kk,3))
178  & - alola(ip1(kk),jy(kk,3))+alola(ip2(kk),jy(kk,3)))
179  & * xi2tm(kk)
180  eras(kk,4)=(alola(ip1(kk),jy(kk,4))-alola(iv(kk),jy(kk,4)))
181  & * xdeli(kk) + alola(iv(kk),jy(kk,4)) +
182  & ( alola(im1(kk),jy(kk,4)) - alola(iv(kk),jy(kk,4))
183  & - alola(ip1(kk),jy(kk,4))+alola(ip2(kk),jy(kk,4)))
184  & * xi2tm(kk)
185  2400 CONTINUE
186 C
187  DO 2500 kk = 1,npts
188  amerc(kk) = eras(kk,2) + (eras(kk,3) - eras(kk,2))
189  & * xdelj(kk) + (eras(kk,1) - eras(kk,2)
190  & - eras(kk,3) + eras(kk,4)) * xj2tm(kk)
191  2500 CONTINUE
192 C
193  ENDIF
194 C
195  RETURN
196  END
w3ft210
subroutine w3ft210(ALOLA, AMERC, INTERP)
SUBROUTINE: W3FT210 CONVERT (361,91) GRID TO (25,25) MERCATOR GRID AUTHOR: JONES,R....
Definition: w3ft210.f:46