ipxwafs.F90

Go to the documentation of this file.

 
 
 
 SUBROUTINE ipxwafs(IDIR, NUMPTS_THIN, NUMPTS_FULL, KM, NUM_OPT, &
                    OPT_PTS, IGDTLEN, IGDTMPL_THIN, DATA_THIN,  &
                    IGDTMPL_FULL, DATA_FULL, IRET)
 IMPLICIT NONE
!
 INTEGER,               INTENT(IN   ) :: NUM_OPT
 INTEGER,               INTENT(INOUT) :: OPT_PTS(NUM_OPT)
 INTEGER,               INTENT(IN   ) :: IDIR, KM, NUMPTS_THIN, NUMPTS_FULL
 INTEGER,               INTENT(IN   ) :: IGDTLEN
 INTEGER,               INTENT(INOUT) :: IGDTMPL_THIN(IGDTLEN)
 INTEGER,               INTENT(INOUT) :: IGDTMPL_FULL(IGDTLEN)
 INTEGER,               INTENT(  OUT) :: IRET
!
 REAL,                  INTENT(INOUT) :: DATA_THIN(NUMPTS_THIN,KM)
 REAL,                  INTENT(INOUT) :: DATA_FULL(NUMPTS_FULL,KM)
!
 INTEGER,               PARAMETER     :: MISSING=-1
!
 INTEGER                              :: SCAN_MODE, I, J, K, IDLAT, IDLON
 INTEGER                              :: IA, IB, IM, IM1, IM2, NPWAFS(73)
 INTEGER                              :: IS1, IS2, ISCAN, ISCALE
!
 LOGICAL                              :: TEST1, TEST2
!
 REAL                                 :: DLON, HI
 REAL                                 :: RAT1, RAT2, RLON1, RLON2
 REAL                                 :: 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
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!  REG LAT/LON GRIDS HAVE 19 GDT ELEMENTS.
 IF (igdtlen /= 19 .OR. numpts_thin/=3447 .OR. numpts_full/=5329) THEN
   iret=1
   RETURN
 ENDIF
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!  EXPAND THINNED GDS TO FULL GDS
 IF(idir.GT.0) THEN
   scan_mode=igdtmpl_thin(19)
   iscale=igdtmpl_thin(10)*igdtmpl_thin(11)
   IF(iscale==0) iscale=10**6
   idlat=nint(1.25*float(iscale))
   test1=all(opt_pts==npwafs)
   test2=all(opt_pts==npwafs(73:1:-1))
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!  SOME CHECKS TO ENSURE THIS IS A WAFS GRID
   IF(scan_mode==64 .AND. igdtmpl_thin(9)==73 .AND. &
      idlat==igdtmpl_thin(18) .AND. (test1 .OR. test2) ) THEN
     igdtmpl_full=igdtmpl_thin
     im=73
     igdtmpl_full(8)=im
     rlon1=float(igdtmpl_full(13))/float(iscale)
     rlon2=float(igdtmpl_full(16))/float(iscale)
     iscan=mod(igdtmpl_full(19)/128,2)
     hi=(-1.)**iscan
     dlon=hi*(mod(hi*(rlon2-rlon1)-1+3600,360.)+1)/(im-1)
     igdtmpl_full(17)=nint(dlon*float(iscale))
   ELSE
     iret=1
   ENDIF
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!  CONTRACT FULL GDS TO THINNED GDS
 ELSEIF(idir.LT.0) THEN
   scan_mode=igdtmpl_full(19)
   iscale=igdtmpl_full(10)*igdtmpl_full(11)
   IF(iscale==0) iscale=10**6
   idlat=nint(1.25*float(iscale))
   idlon=idlat
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!  SOME CHECKS TO ENSURE THIS IS A WAFS GRID
   IF(scan_mode==64 .AND. igdtmpl_full(8)==73 .AND. igdtmpl_full(9)==73 .AND. &
      num_opt==73 .AND. idlat==igdtmpl_full(18) .AND. idlon==igdtmpl_full(17))THEN
     igdtmpl_thin=igdtmpl_full
     igdtmpl_thin(8)=missing
     igdtmpl_thin(17)=missing
     IF(igdtmpl_thin(12)==0) THEN  ! IS LATITUDE OF ROW 1 THE EQUATOR?
       opt_pts=npwafs
     ELSE
       opt_pts=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
       DO j=1,igdtmpl_full(9)
         im1=opt_pts(j)
         im2=igdtmpl_full(8)
         rat1=float(im1-1)/float(im2-1)
         DO i=1,im2
           x1=(i-1)*rat1+1
           ia=int(x1)
           ia=min(max(ia,1),im1-1)
           ib=ia+1
           wa=ib-x1
           wb=x1-ia
           data_full(is2+i,k)=wa*data_thin(is1+ia,k)+wb*data_thin(is1+ib,k)
         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
       DO j=1,igdtmpl_full(9)
         im1=opt_pts(j)
         im2=igdtmpl_full(8)
         rat2=float(im2-1)/float(im1-1)
         DO i=1,im1
           x2=(i-1)*rat2+1
           ia=int(x2)
           ia=min(max(ia,1),im2-1)
           ib=ia+1
           wa=ib-x2
           wb=x2-ia
           data_thin(is1+i,k)=wa*data_full(is2+ia,k)+wb*data_full(is2+ib,k)
         ENDDO
         is1=is1+im1
         is2=is2+im2
       ENDDO
     ENDDO
   ENDIF
 ENDIF
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 END SUBROUTINE ipxwafs