w3ft33.f

Go to the documentation of this file.

C> @file
C                .      .    .                                       .
C> SUBPROGRAM:    W3FT33      THICKEN THINNED WAFS GRIB GRID 37-44
C>   PRGMMR: RALPH PETTERSON  ORG: W/NMCXX    DATE: 94-11-13
C>
C> ABSTRACT: 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>   94-??-??  RALPH PETERSON
C>   94-11-07  R.E.JONES        ADD DOC BLOCK, CHANGE CALL TO 3
C>                              PARAMETERS. REPLACE COS WITH TABLE
C>                              LOOKUP.
C>   95-06-02  RALPH PETERSON   CHANGES TO CORRECT MISS-POSITION
C>                              BETWEEN + OR - 8.75 N/S.
C>   95-06-03  R.E.JONES        CHANGES SO 8 ROWS WITH 73 VALUES
C>                              ARE NOT THICKENED, 10% FASTER.  
C>
C> USAGE:    CALL W3FT33(AIN, OUT, NSFLAG)
C>   INPUT ARGUMENT LIST:
C>     AIN      - REAL 3447 WORD ARRAY WITH UNPACKED THINNED WAFS
C>                GRIB TYPE 37-44.
C>     NSFLAG   - INTEGER =  1  AIN IS WAFS GRIB GRID 37-40  N. HEMI.
C>                        = -1  AIN IS WAFS GRIB GRID 41-44  S. HEMI.   
C>
C>   OUTPUT ARGUMENT LIST:  
C>     OUT      - REAL (73,73) WORD ARRAY WITH THICKENED WAFS GRIB
C>                GRID 37-44.
C>
C> REMARKS: 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> ATTRIBUTES:
C>   LANGUAGE: SiliconGraphics 5.2 FORTRAN 77
C>   MACHINE:  SiliconGraphics IRIS-4D/25, 35, INDIGO, Indy
C>
      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