SUBROUTINE IPXWAFS3(IDIR,M1,M2,KM,KGDS1,IB1,L1,F1,KGDS2,IB2,L2,F2,IRET)
!$$$  SUBPROGRAM DOCUMENTATION BLOCK
!
! SUBPROGRAM:  IPXWAFS3   EXPAND OR CONTRACT WAFS GRIDS
!   PRGMMR: IREDELL       ORG: W/NMC23       DATE: 96-04-10
!
! ABSTRACT: THIS SUBPROGRAM TRANSFORMS BETWEEN THE THINNED WAFS GRIDS
!           AS USED FOR TRANSMITTING TO THE AVIATION COMMUNITY
!           AND THEIR FULL EXPANSION AS USED FOR GENERAL INTERPOLATION
!           AND GRAPHICS.  THE WAFS GRIDS ARE LATITUDE-LONGITUDE GRIDS
!           THINNED ONLY IN THE ZONAL DIRECTION AS INDICATED
!           BY THE PL PARAMETERS IN THE GRIB GRID DESCRIPTION SECTION.
!           THE PL PARAMETERS MUST BE SUPPLIED FOR CONTRACTION
!           (STARTING AT KGDS1(22)).  OTHERWISE (IF KGDS1(22)<=0)
!           GRID CONTRACTION IS PERFORMED SPECIFICALLY FOR
!           THE 1.25 DEGREE NCEP WAFS GRID IDENTIFICATIONS 37-44.
!           THE EXPANSION AND CONTRACTION OF THE FIELDS ARE DONE
!           BY NEAREST NEIGHBOUR INTERPOLATION, SO THAT THEY ARE NOT 
!           REVERSIBLE.
!           THIS VERSION ALLOWS A BITMAP.
!
! PROGRAM HISTORY LOG:
!   96-04-10  IREDELL
!   99-01-25  Gilbert   - changed bitmap fields from LOGICAL to LOGICAL*1
!   07-07-13  Trojan    - made it IPXWAFS3
!
! USAGE:    CALL IPXWAFS3(IDIR,M1,M2,KM,
!    &                    KGDS1,IB1,L1,F1,KGDS2,IB2,L2,F2,IRET)
!
!   INPUT ARGUMENT LIST:
!     IDIR     - INTEGER TRANSFORM OPTION
!                (+1 TO EXPAND THINNED FIELDS TO FULL FIELDS)
!                (-1 TO CONTRACT FULL FIELDS TO THINNED FIELDS)
!     M1       - INTEGER SKIP NUMBER BETWEEN THINNED GRID FIELDS
!     M2       - INTEGER SKIP NUMBER BETWEEN FULL GRID FIELDS
!     KM       - INTEGER NUMBER OF FIELDS TO TRANSFORM
!     KGDS1    - INTEGER (200) GDS PARMS OF THINNED GRID IF IDIR>0
!                (IF IDIR<0, THEN EITHER THE PL PARAMETERS STARTING AT
!                 KGDS1(22) MUST BE SUPPLIED OR IF KGDS1(22)<=0,
!                 THEN THE PL PARAMETERS DEFAULT TO THOSE FOR
!                 SPECIFIC NCEP WAFS GRIDS 37-44).
!     IB1      - INTEGER (KM) THINNED BITMAP FLAGS IF IDIR>0
!     L1       - LOGICAL*1 (M1,KM) THINNED BITMAP FIELDS IF IDIR>0
!     F1       - REAL (M1,KM) THINNED GRID FIELDS IF IDIR>0
!     KGDS2    - INTEGER (200) GDS PARMS OF FULL GRID IF IDIR<0
!     IB2      - INTEGER (KM) FULL BITMAP FLAGS IF IDIR<0
!     L2       - LOGICAL*1 (M1,KM) FULL BITMAP FIELDS IF IDIR<0
!     F2       - REAL (M2,KM) FULL GRID FIELDS IF IDIR<0
!
!   OUTPUT ARGUMENT LIST:
!     KGDS1    - INTEGER (200) GDS PARMS OF THINNED GRID IF IDIR<0
!     IB1      - INTEGER (KM) THINNED BITMAP FLAGS IF IDIR<0
!     L1       - LOGICAL*1 (M1,KM) THINNED BITMAP FIELDS IF IDIR<0
!     F1       - REAL (M1,KM) THINNED GRID FIELDS IF IDIR<0
!     KGDS2    - INTEGER (200) GDS PARMS OF FULL GRID IF IDIR>0
!     IB2      - INTEGER (KM) FULL BITMAP FLAGS IF IDIR>0
!     L2       - LOGICAL*1 (M1,KM) FULL BITMAP FIELDS IF IDIR>0
!     F2       - REAL (M2,KM) FULL GRID FIELDS IF IDIR>0
!     IRET     - INTEGER RETURN CODE
!                0    SUCCESSFUL TRANSFORMATION
!                1    IMPROPER GRID SPECIFICATION
!
! ATTRIBUTES:
!   LANGUAGE: FORTRAN 90
!
!$$$
 IMPLICIT NONE
!
 INTEGER,             INTENT(IN   ):: IDIR, KM, M1, M2
 INTEGER,             INTENT(INOUT):: KGDS1(200), KGDS2(200)
 INTEGER,             INTENT(INOUT):: IB1(KM), IB2(KM)
 INTEGER,             INTENT(  OUT):: IRET
!
 LOGICAL*1,           INTENT(INOUT):: L1(M1,KM),L2(M2,KM)
!
 REAL,                INTENT(INOUT):: F1(M1,KM),F2(M2,KM)
!
 INTEGER                           :: I, J, K, NPWAFS(73)
 INTEGER                           :: IA, IB, ISCAN
 INTEGER                           :: IM, IM1, IM2, IS1, IS2
!
 REAL                              :: DLON, HI, RLON1, RLON2
 REAL                              :: RAT1, RAT2, WA, WB, X1, X2
!
 DATA NPWAFS/ &
     73, 73, 73, 73, 73, 73, 73, 73, 72, 72, 72, 71, 71, 71, 70, &
     70, 69, 69, 68, 67, 67, 66, 65, 65, 64, 63, 62, 61, 60, 60, &
     59, 58, 57, 56, 55, 54, 52, 51, 50, 49, 48, 47, 45, 44, 43, &
     42, 40, 39, 38, 36, 35, 33, 32, 30, 29, 28, 26, 25, 23, 22, &
     20, 19, 17, 16, 14, 12, 11,  9,  8,  6,  5,  3,  2/
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!  TRANSFORM GDS
 IRET=0
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!  EXPAND THINNED GDS TO FULL GDS
 IF(IDIR.GT.0) THEN
   IF(MOD(KGDS1(11)/32,2).EQ.0.AND.KGDS1(20).EQ.33) THEN
     KGDS2(1:18)=KGDS1(1:18)
     IM=0
     DO J=22,21+KGDS1(3)
       IM=MAX(IM,KGDS1(J))
     ENDDO
     KGDS2(2)=IM
     RLON1=KGDS2(5)*1.E-3
     RLON2=KGDS2(8)*1.E-3
     ISCAN=MOD(KGDS2(11)/128,2)
     HI=(-1.)**ISCAN
     DLON=HI*(MOD(HI*(RLON2-RLON1)-1+3600,360.)+1)/(IM-1)
     KGDS2(9)=NINT(DLON*1.E3)
     KGDS2(19)=0
     KGDS2(20)=255
     KGDS2(21)=0
     KGDS2(22)=0
   ELSE
     IRET=1
   ENDIF
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!  CONTRACT FULL GDS TO THINNED GDS
 ELSEIF(IDIR.LT.0) THEN
!  PL PARAMETERS PROVIDED
   IF(MOD(KGDS2(11)/32,2).EQ.0.AND.KGDS2(20).EQ.255.AND.KGDS1(22).GT.0) THEN
     KGDS1(1:18)=KGDS2(1:18)
     KGDS1(2)=65535
     KGDS1(9)=65535
     KGDS1(19)=0
     KGDS1(20)=33
     KGDS1(21)=0
     DO J=1,KGDS2(3)
       KGDS1(21)=KGDS1(21)+KGDS1(21+J)
     ENDDO
!  PL PARAMETERS DEFAULT TO THOSE FOR NCEP GRIDS 37-44
   ELSEIF(MOD(KGDS2(11)/32,2).EQ.0.AND.KGDS2(20).EQ.255.AND. &
          KGDS1(22).LE.0.AND. &
          KGDS2(1).EQ.0.AND.KGDS2(2).EQ.73.AND.KGDS2(3).EQ.73.AND. &
          KGDS2(9).EQ.1250.AND.KGDS2(10).EQ.1250.AND. &
         (KGDS2(4).EQ.0.OR.KGDS2(4).EQ.-90000)) THEN
     KGDS1(1:18)=KGDS2(1:18)
     KGDS1(2)=65535
     KGDS1(9)=65535
     KGDS1(19)=0
     KGDS1(20)=33
     KGDS1(21)=3447
     IF(KGDS1(4).EQ.0) THEN
       KGDS1(22:94)=NPWAFS
     ELSE
       KGDS1(22:94)=NPWAFS(73:1:-1)
     ENDIF
   ELSE
     IRET=1
   ENDIF
 ENDIF
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!  TRANSFORM FIELDS
 IF(IRET.EQ.0) THEN
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!  EXPAND THINNED FIELDS TO FULL FIELDS
   IF(IDIR.EQ.1) THEN
     DO K=1,KM
       IS1=0
       IS2=0
       IB2(K)=0
       DO J=1,KGDS2(3)
         IM1=KGDS1(21+J)
         IM2=KGDS2(2)
         RAT1=REAL(IM1-1)/REAL(IM2-1)
         DO I=1,IM2
           X1=(I-1)*RAT1+1
           IA=X1
           IA=MIN(MAX(IA,1),IM1-1)
           IB=IA+1
           WA=IB-X1
           WB=X1-IA
           IF(WA.GE.WB) THEN
             IF(IB1(K).EQ.0.OR.L1(IS1+IA,K)) THEN
               F2(IS2+I,K)=F1(IS1+IA,K)
               L2(IS2+I,K)=.TRUE.
             ELSE
               F2(IS2+I,K)=0
               L2(IS2+I,K)=.FALSE.
               IB2(K)=1
             ENDIF
           ELSE
             IF(IB1(K).EQ.0.OR.L1(IS1+IB,K)) THEN
               F2(IS2+I,K)=F1(IS1+IB,K)
               L2(IS2+I,K)=.TRUE.
             ELSE
               F2(IS2+I,K)=0
               L2(IS2+I,K)=.FALSE.
               IB2(K)=1
             ENDIF
           ENDIF
         ENDDO
         IS1=IS1+IM1
         IS2=IS2+IM2
       ENDDO
     ENDDO
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!  CONTRACT FULL FIELDS TO THINNED FIELDS
   ELSEIF(IDIR.EQ.-1) THEN
     DO K=1,KM
       IS1=0
       IS2=0
       IB1(K)=0
       DO J=1,KGDS2(3)
         IM1=KGDS1(21+J)
         IM2=KGDS2(2)
         RAT2=REAL(IM2-1)/REAL(IM1-1)
         DO I=1,IM1
           X2=(I-1)*RAT2+1
           IA=X2
           IA=MIN(MAX(IA,1),IM2-1)
           IB=IA+1
           WA=IB-X2
           WB=X2-IA
           IF(WA.GE.WB) THEN
             IF(IB2(K).EQ.0.OR.L2(IS2+IA,K)) THEN
               F1(IS1+I,K)=F2(IS2+IA,K)
               L1(IS1+I,K)=.TRUE.
             ELSE
               F1(IS1+I,K)=0
               L1(IS1+I,K)=.FALSE.
               IB1(K)=1
             ENDIF
           ELSE
             IF(IB2(K).EQ.0.OR.L2(IS2+IB,K)) THEN
               F1(IS1+I,K)=F2(IS2+IB,K)
               L1(IS1+I,K)=.TRUE.
             ELSE
               F1(IS1+I,K)=0
               L1(IS1+I,K)=.FALSE.
               IB1(K)=1
             ENDIF
           ENDIF
         ENDDO
         IS1=IS1+IM1
         IS2=IS2+IM2
       ENDDO
     ENDDO
   ENDIF
 ENDIF
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 END SUBROUTINE IPXWAFS3