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