w3ft33.f

Go to the documentation of this file.

C> @file
C> @brief Thicken thinned wafs grib grid 37-44
C> @author Ralph Peterson @date 1994
 
C> Subroutine thickens one thinned wafs grib grid to a
C> real array of 5329 numbers (73,73) 1.25 degree grid.
C>
C> ### Program History Log:
C> Date | Programmer | Comment
C> -----|------------|--------
C> 1994-??-?? | Ralph Peterson
C> 1994-11-07 | Ralph Jones | Add doc block, change call to 3 parameters.
C> Replace cos with table lookup.
C> 1995-06-02 | Ralph Peterson | Changes to correct miss-position
C> between + or - 8.75 n/s.
C> 1995-06-03 | Ralph Jones | Changes so 8 rows with 73 values
C> are not thickened, 10% faster.
C>
C> @param[in] AIN Real 3447 word array with unpacked thinned wafs
C> grib type 37-44.
C> @param[in] NSFLAG Integer = 1 AIN is wafs grib grid 37-40 n. hemi.
C> = -1 AIN is wafs grib grid 41-44 s. hemi.
C> @param[out] OUT Real (73,73) word array with thickened wafs grib grid 37-44.
C>
C> @remark The pole point for u and v wind components will have only
C> one point. If you need the pole row corrected see page 9 section
C> 1 in office note 388. You need both u and v to make the
C> correction.
C>
C> @author Ralph Peterson @date 1994
      SUBROUTINE w3ft33(AIN,OUT,NSFLAG)
C
         parameter(nx=73,ny=73)
         parameter(nin=3447)
C
         REAL      AIN(*)
         REAL      OUT(NX,NY)
C
         INTEGER   IPOINT(NX)
C
         SAVE
C
      DATA  ipoint/
     & 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/
C
         nxm   = nx - 1
         fnxm  = float(nxm)
C
C        TEST FOR GRIDS (37-40)
C
         IF (nsflag.GT.0) THEN
C
C          DO NOT THICKEN 8 ROWS WITH 73 VALUES, MOVE DATA
C          TO OUT ARRAY. GRIDS (37-40) N.
C
           is = 0
           DO j = 1,8
             DO i = 1,nx
               is       = is + 1
               out(i,j) = ain(is)
             END DO
           END DO
C
           ie = nx * 8
           DO j = 9,ny
             npoint   = ipoint(j)
             is       = ie + 1
             ie       = is + npoint - 1
             dpts     = (float(npoint)-1.) / fnxm
             pw       = 1.0
             pe       = pw + dpts
             out(1,j) = ain(is)
             valw     = ain(is)
             vale     = ain(is+1)
             dval     = (vale-valw)
             DO i = 2,nxm
               wght     = pe -float(ifix(pe))
               out(i,j) = valw + wght * dval
               pw       = pe
               pe       = pe + dpts
               IF (ifix(pw).NE.ifix(pe)) THEN
                 is   = is + 1
                 valw = vale
                 vale = ain(is+1)
                 dval = (vale - valw)
               END IF
             END DO
             out(nx,j) = ain(ie)
           END DO
C
         ELSE
C
C         DO NOT THICKEN 8 ROWS WITH 73 VALUES, MOVE DATA
C         TO OUT ARRAY. GRIDS (41-44) S.
C
           is = nin - (8 * nx)
           DO j = 66,ny
             DO i = 1,nx
               is       = is + 1
               out(i,j) = ain(is)
             END DO
           END DO
C
           ie = 0
           DO j = 1,65
             npoint   = ipoint(74-j)
             is       = ie + 1
             ie       = is + npoint - 1
             dpts     = (float(npoint)-1.) / fnxm
             pw       = 1.0
             pe       = pw + dpts
             out(1,j) = ain(is)
             valw     = ain(is)
             vale     = ain(is+1)
             dval     = (vale-valw)
             DO i = 2,nxm
               wght     = pe -float(ifix(pe))
               out(i,j) = valw + wght * dval
               pw       = pe
               pe       = pe + dpts
               IF (ifix(pw).NE.ifix(pe)) THEN
                 is   = is + 1
                 valw = vale
                 vale = ain(is+1)
                 dval = (vale - valw)
               END IF
             END DO
             out(nx,j) = ain(ie)
           END DO
         END IF
C
         RETURN
         END