w3ft206.f

Go to the documentation of this file.

C> @file
C
C> SUBROUTINE: W3FT206   CONVERT (361,91) GRID TO (51,41) LAMBERT GRID
C>   AUTHOR:  JONES,R.E.        ORG:  W342         DATE: 94-05-18
C>
C> ABSTRACT:  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>   94-05-18  R.E.JONES  
C>
C> USAGE:  CALL W3FT206(ALOLA,ALAMB,INTERP)
C>
C>   INPUT ARGUMENTS:  ALOLA  - 361*91 GRID 1.0 DEG. LAT,LON GRID N. HEMI.
C>                              32851 POINT GRID. 360 * 181 ONE DEGREE
C>                              GRIB GRID 3 WAS FLIPPED, GREENWISH ADDED
C>                              TO RIGHT SIDE AND CUT TO 361 * 91.  
C>                     INTERP - 1 LINEAR INTERPOLATION , NE.1 BIQUADRATIC
C>
C>   INPUT FILES:  NONE
C>
C>   OUTPUT ARGUMENTS: ALAMB  - 51*41 REGIONAL - CENTRAL US MARD
C>                              (LAMBERT CONFORMAL). 2091 POINT GRID 
C>                              IS AWIPS GRID TYPE 206
C>
C>   OUTPUT FILES: ERROR MESSAGE TO FORTRAN OUTPUT FILE
C>
C>   WARNINGS:
C>
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>
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>   RETURN CONDITIONS: NORMAL SUBROUTINE EXIT
C>
C>   SUBPROGRAMS CALLED:
C>     UNIQUE :  NONE
C>
C>     LIBRARY:  W3FB12
C>
C> ATTRIBUTES:
C>   LANGUAGE: CRAY CFT77 FORTRAN
C>   MACHINE:  CRAY C916-128, CRAY Y-MP8/864, CRAY Y-MP EL2/256
C>
      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