NCEPLIBS-ip 5.2.0
Loading...
Searching...
No Matches
ipxwafs2.F90
Go to the documentation of this file.
1
5
89SUBROUTINE ipxwafs2(IDIR, NUMPTS_THIN, NUMPTS_FULL, KM, NUM_OPT, OPT_PTS, &
90 IGDTLEN, IGDTMPL_THIN, DATA_THIN, IB_THIN, BITMAP_THIN, &
91 IGDTMPL_FULL, DATA_FULL, IB_FULL, BITMAP_FULL, IRET)
92 IMPLICIT NONE
93 !
94 INTEGER, INTENT(IN ) :: NUM_OPT
95 INTEGER, INTENT(INOUT) :: OPT_PTS(NUM_OPT)
96 INTEGER, INTENT(IN ) :: IDIR, KM, NUMPTS_THIN, NUMPTS_FULL
97 INTEGER, INTENT(IN ) :: IGDTLEN
98 INTEGER, INTENT(INOUT) :: IGDTMPL_THIN(IGDTLEN)
99 INTEGER, INTENT(INOUT) :: IGDTMPL_FULL(IGDTLEN)
100 INTEGER, INTENT(INOUT) :: IB_THIN(KM), IB_FULL(KM)
101 INTEGER, INTENT( OUT) :: IRET
102 !
103 LOGICAL(KIND=1), INTENT(INOUT) :: BITMAP_THIN(NUMPTS_THIN,KM)
104 LOGICAL(KIND=1), INTENT(INOUT) :: BITMAP_FULL(NUMPTS_FULL,KM)
105 !
106 REAL, INTENT(INOUT) :: DATA_THIN(NUMPTS_THIN,KM)
107 REAL, INTENT(INOUT) :: DATA_FULL(NUMPTS_FULL,KM)
108 !
109 INTEGER, PARAMETER :: MISSING=-1
110 !
111 INTEGER :: SCAN_MODE, I, J, K, IDLAT, IDLON
112 INTEGER :: IA, IB, IM, IM1, IM2, NPWAFS(73)
113 INTEGER :: IS1, IS2, ISCAN, ISCALE
114 !
115 LOGICAL :: TEST1, TEST2
116 !
117 REAL :: DLON, HI
118 REAL :: RAT1, RAT2, RLON1, RLON2
119 REAL :: WA, WB, X1, X2
120 !
121 DATA npwafs/ &
122 73, 73, 73, 73, 73, 73, 73, 73, 72, 72, 72, 71, 71, 71, 70,&
123 70, 69, 69, 68, 67, 67, 66, 65, 65, 64, 63, 62, 61, 60, 60,&
124 59, 58, 57, 56, 55, 54, 52, 51, 50, 49, 48, 47, 45, 44, 43,&
125 42, 40, 39, 38, 36, 35, 33, 32, 30, 29, 28, 26, 25, 23, 22,&
126 20, 19, 17, 16, 14, 12, 11, 9, 8, 6, 5, 3, 2/
127 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
128 ! TRANSFORM GDS
129 iret=0
130 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
131 ! REG LAT/LON GRIDS HAVE 19 GDT ELEMENTS.
132 IF (igdtlen /= 19 .OR. numpts_thin/=3447 .OR. numpts_full/=5329) THEN
133 iret=1
134 RETURN
135 ENDIF
136 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
137 ! EXPAND THINNED GDS TO FULL GDS
138 IF(idir.GT.0) THEN
139 scan_mode=igdtmpl_thin(19)
140 iscale=igdtmpl_thin(10)*igdtmpl_thin(11)
141 IF(iscale==0) iscale=10**6
142 idlat=nint(1.25*float(iscale))
143 test1=all(opt_pts==npwafs)
144 test2=all(opt_pts==npwafs(73:1:-1))
145 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
146 ! SOME CHECKS TO ENSURE THIS IS A WAFS GRID
147 IF(scan_mode==64 .AND. igdtmpl_thin(9)==73 .AND. &
148 idlat==igdtmpl_thin(18) .AND. (test1 .OR. test2) ) THEN
149 igdtmpl_full=igdtmpl_thin
150 im=73
151 igdtmpl_full(8)=im
152 rlon1=float(igdtmpl_full(13))/float(iscale)
153 rlon2=float(igdtmpl_full(16))/float(iscale)
154 iscan=mod(igdtmpl_full(19)/128,2)
155 hi=(-1.)**iscan
156 dlon=hi*(mod(hi*(rlon2-rlon1)-1+3600,360.)+1)/(im-1)
157 igdtmpl_full(17)=nint(dlon*float(iscale))
158 ELSE
159 iret=1
160 ENDIF
161 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
162 ! CONTRACT FULL GDS TO THINNED GDS
163 ELSEIF(idir.LT.0) THEN
164 scan_mode=igdtmpl_full(19)
165 iscale=igdtmpl_full(10)*igdtmpl_full(11)
166 IF(iscale==0) iscale=10**6
167 idlat=nint(1.25*float(iscale))
168 idlon=idlat
169 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
170 ! SOME CHECKS TO ENSURE THIS IS A WAFS GRID
171 IF(scan_mode==64 .AND. igdtmpl_full(8)==73 .AND. igdtmpl_full(9)==73 .AND. &
172 num_opt==73 .AND. idlat==igdtmpl_full(18) .AND. idlon==igdtmpl_full(17))THEN
173 igdtmpl_thin=igdtmpl_full
174 igdtmpl_thin(8)=missing
175 igdtmpl_thin(17)=missing
176 IF(igdtmpl_thin(12)==0) THEN ! IS LATITUDE OF ROW 1 THE EQUATOR?
177 opt_pts=npwafs
178 ELSE
179 opt_pts=npwafs(73:1:-1)
180 ENDIF
181 ELSE
182 iret=1
183 ENDIF
184 ENDIF
185 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
186 ! TRANSFORM FIELDS
187 IF(iret.EQ.0) THEN
188 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
189 ! EXPAND THINNED FIELDS TO FULL FIELDS
190 IF(idir.EQ.1) THEN
191 DO k=1,km
192 is1=0
193 is2=0
194 ib_full(k)=0
195 DO j=1,igdtmpl_full(9)
196 im1=opt_pts(j)
197 im2=igdtmpl_full(8)
198 rat1=float(im1-1)/float(im2-1)
199 DO i=1,im2
200 x1=(i-1)*rat1+1
201 ia=int(x1)
202 ia=min(max(ia,1),im1-1)
203 ib=ia+1
204 wa=ib-x1
205 wb=x1-ia
206 IF(ib_thin(k)==0.OR.(bitmap_thin(is1+ia,k).AND.bitmap_thin(is1+ib,k))) THEN
207 data_full(is2+i,k)=wa*data_thin(is1+ia,k)+wb*data_thin(is1+ib,k)
208 bitmap_full(is2+i,k)=.true.
209 ELSE
210 data_full(is2+i,k)=0.0
211 bitmap_full(is2+i,k)=.false.
212 ib_full(k)=1
213 ENDIF
214 ENDDO
215 is1=is1+im1
216 is2=is2+im2
217 ENDDO
218 ENDDO
219 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
220 ! CONTRACT FULL FIELDS TO THINNED FIELDS
221 ELSEIF(idir.EQ.-1) THEN
222 DO k=1,km
223 is1=0
224 is2=0
225 ib_thin(k)=0
226 DO j=1,igdtmpl_full(9)
227 im1=opt_pts(j)
228 im2=igdtmpl_full(8)
229 rat2=float(im2-1)/float(im1-1)
230 DO i=1,im1
231 x2=(i-1)*rat2+1
232 ia=int(x2)
233 ia=min(max(ia,1),im2-1)
234 ib=ia+1
235 wa=ib-x2
236 wb=x2-ia
237 IF(ib_full(k)==0.OR.(bitmap_full(is2+ia,k).AND.bitmap_full(is2+ib,k))) THEN
238 data_thin(is1+i,k)=wa*data_full(is2+ia,k)+wb*data_full(is2+ib,k)
239 bitmap_thin(is1+i,k)=.true.
240 ELSE
241 data_thin(is1+i,k)=0.0
242 bitmap_thin(is1+i,k)=.false.
243 ib_thin(k)=1
244 ENDIF
245 ENDDO
246 is1=is1+im1
247 is2=is2+im2
248 ENDDO
249 ENDDO
250 ENDIF
251 ENDIF
252 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
253END SUBROUTINE ipxwafs2
ipxwafs2
subroutine ipxwafs2(idir, numpts_thin, numpts_full, km, num_opt, opt_pts, igdtlen, igdtmpl_thin, data_thin, ib_thin, bitmap_thin, igdtmpl_full, data_full, ib_full, bitmap_full, iret)
Expand or contract wafs grids using linear interpolation and account for bitmapped data.
Definition ipxwafs2.F90:92