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