NCEPLIBS-ip  4.2.0
ipxwafs2.F90
Go to the documentation of this file.
1 
5 
89 SUBROUTINE 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  ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
253 END 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