w3ft206.f

Go to the documentation of this file.

C> @file
C> @brief Convert (361,91) grid to (51,41) lambert grid
C> @author Ralph Jones @date 1994-05-18
 
C> Convert a northern hemisphere 1.0 degree lat.,lon. 361 by
C> 91 grid to a lambert conformal 51 by 41 awips grib 206.
C>
C> ### Program History Log:
C> Date | Programmer | Comment
C> -----|------------|--------
C> 1994-05-18 | Ralph Jones | Initial.
C>
C> @param[in] ALOLA 361*91 grid 1.0 deg. lat,lon grid n. hemi.
C> 32851 point grid. 360 * 181 one degree grib grid 3 was flipped, greenwish added
C> to right side and cut to 361 * 91.
C> @param[in] INTERP 1 linear interpolation , ne.1 biquadratic
C> @param[out] ALAMB 51*41 regional - central us mard
C> (lambert conformal). 2091 point grid is awips grid type 206
C>
C> @note
C> - 1. W1 and w2 are used to store sets of constants which are
C> reusable for repeated calls to the subroutine. 11 other array
C> are saved and reused on the next call.
C> - 2. Wind components are not rotated to the 51*41 grid orientation
C> after interpolation. You may use w3fc08() to do this.
C>
C> @author Ralph Jones @date 1994-05-18
      SUBROUTINE w3ft206(ALOLA,ALAMB,INTERP)
C
       parameter(npts=2091,ii=51,jj=41)
       parameter(alatan=25.000)
       parameter(pi=3.1416)
       parameter(dx=81270.500)
       parameter(alat1=22.289)
       parameter(elon1=242.00962)
       parameter(elonv=265.000)
       parameter(iii=361,jjj=91)
C
       REAL        ALOLA(III,JJJ)
       REAL        ALAMB(NPTS)
       REAL        W1(NPTS),    W2(NPTS),   ERAS(NPTS,4)
       REAL        XDELI(NPTS), XDELJ(NPTS)
       REAL        XI2TM(NPTS), XJ2TM(NPTS)
C
       INTEGER     IV(NPTS),      JV(NPTS),    JY(NPTS,4)
       INTEGER     IM1(NPTS),     IP1(NPTS),   IP2(NPTS)
C
       LOGICAL     LIN
C
       SAVE
C
       DATA  iswt  /0/
       DATA  intrpo/99/
C
       lin = .false.
       IF (interp.EQ.1) lin = .true.
C
       IF (iswt.EQ.1) GO TO 900
c      print *,'iswt = ',iswt
       n  = 0
       DO j = 1,jj
         DO i = 1,ii
           xj = j
           xi = i
           CALL w3fb12(xi,xj,alat1,elon1,dx,elonv,alatan,alat,
     &     elon,ierr)
           n       = n    + 1
           w1(n) = elon + 1.0
           w2(n) = alat + 1.0
         END DO
       END DO
C
       iswt = 1
       intrpo = interp
       GO TO 1000
C
C     AFTER THE 1ST CALL TO W3FT206 TEST INTERP, IF IT HAS
C     CHANGED RECOMPUTE SOME CONSTANTS
C
 900   CONTINUE
         IF (interp.EQ.intrpo) GO TO 2100
         intrpo = interp
C
 1000 CONTINUE
        DO 1100 k = 1,npts
          iv(k)    = w1(k)
          jv(k)    = w2(k)
          xdeli(k) = w1(k) - iv(k)
          xdelj(k) = w2(k) - jv(k)
          ip1(k)   = iv(k) + 1
          jy(k,3)  = jv(k) + 1
          jy(k,2)  = jv(k)
 1100   CONTINUE
C
      IF (lin) GO TO 2100
C
      DO 1200 k = 1,npts
        ip2(k)   = iv(k) + 2
        im1(k)   = iv(k) - 1
        jy(k,1)  = jv(k) - 1
        jy(k,4)  = jv(k) + 2
        xi2tm(k) = xdeli(k) * (xdeli(k) - 1.0) * .25
        xj2tm(k) = xdelj(k) * (xdelj(k) - 1.0) * .25
 1200 CONTINUE
C
 2100 CONTINUE
      IF (lin) THEN
C
C     LINEAR INTERPOLATION
C
      DO 2200 kk = 1,npts
        eras(kk,2) = (alola(ip1(kk),jy(kk,2))-alola(iv(kk),jy(kk,2)))
     &             * xdeli(kk) + alola(iv(kk),jy(kk,2))
        eras(kk,3) = (alola(ip1(kk),jy(kk,3))-alola(iv(kk),jy(kk,3)))
     &             * xdeli(kk) + alola(iv(kk),jy(kk,3))
 2200 CONTINUE
C
      DO 2300 kk = 1,npts
        alamb(kk) = eras(kk,2) + (eras(kk,3) - eras(kk,2))
     &            * xdelj(kk)
 2300 CONTINUE
C
      ELSE
C
C     QUADRATIC INTERPOLATION
C
      DO 2400 kk = 1,npts
        eras(kk,1)=(alola(ip1(kk),jy(kk,1))-alola(iv(kk),jy(kk,1)))
     &            * xdeli(kk) + alola(iv(kk),jy(kk,1)) +
     &            ( alola(im1(kk),jy(kk,1)) - alola(iv(kk),jy(kk,1))
     &            - alola(ip1(kk),jy(kk,1))+alola(ip2(kk),jy(kk,1)))
     &            * xi2tm(kk)
        eras(kk,2)=(alola(ip1(kk),jy(kk,2))-alola(iv(kk),jy(kk,2)))
     &            * xdeli(kk) + alola(iv(kk),jy(kk,2)) +
     &            ( alola(im1(kk),jy(kk,2)) - alola(iv(kk),jy(kk,2))
     &            - alola(ip1(kk),jy(kk,2))+alola(ip2(kk),jy(kk,2)))
     &            * xi2tm(kk)
        eras(kk,3)=(alola(ip1(kk),jy(kk,3))-alola(iv(kk),jy(kk,3)))
     &            * xdeli(kk) + alola(iv(kk),jy(kk,3)) +
     &            ( alola(im1(kk),jy(kk,3)) - alola(iv(kk),jy(kk,3))
     &            - alola(ip1(kk),jy(kk,3))+alola(ip2(kk),jy(kk,3)))
     &            * xi2tm(kk)
        eras(kk,4)=(alola(ip1(kk),jy(kk,4))-alola(iv(kk),jy(kk,4)))
     &            * xdeli(kk) + alola(iv(kk),jy(kk,4)) +
     &            ( alola(im1(kk),jy(kk,4)) - alola(iv(kk),jy(kk,4))
     &            - alola(ip1(kk),jy(kk,4))+alola(ip2(kk),jy(kk,4)))
     &            * xi2tm(kk)
 2400      CONTINUE
C
       DO 2500 kk = 1,npts
         alamb(kk) = eras(kk,2) + (eras(kk,3) - eras(kk,2))
     &             * xdelj(kk)  + (eras(kk,1) - eras(kk,2)
     &             - eras(kk,3) + eras(kk,4)) * xj2tm(kk)
 2500  CONTINUE
C
      ENDIF
C
      RETURN
      END