w3ft00.f

Go to the documentation of this file.

C> @file
C> @brief Data field tranformation subroutine.
C> @author J. McDonell @date 1974-09-01
 
C> Transforms data contained in a grid array by translation, rotation about a
C> common point and dilatation to a new grid array.
C>
C> ### Program History Log:
C> Date | Programmer | Comments
C> -----|------------|---------
C> 1974-09-01 | J. McDonell | Initial.
C> 1984-06-27 | Ralph Jones | Change to ibm vs fortran.
C>
C> @param[in] IA (Integer) i-dimension of the input array fa
C> @param[in] JA (Integer) j-dimension of the input array fa
C> @param[in] IB (Integer) i-dimension of the output array fb
C> @param[in] JB (Integer) j-dimension of the output array fb
C> @param[in] SC (Real) Scale change (dilation) expressed as a ratio of the
C> transformed to the origional field.
C> @param[in] ARG (Real) Degree measure of the angle required to rotate the
C> j-row of the origional grid into coincidence with the new grid. (+ counter-
C> clockwise, - clockwise)
C> @param[in] LIN (Integer) Interpolation method switch
C> - .eq. 1 bilinear interpolation
C> - .ne. 1 biquadratic interpolation
C> @param FLD
C> @param B
C> @param CIP
C> @param CJP
C> @param FIPB
C> @param FJPB
C>
C> @remark In general 'fa' and 'fb' cannot be equivalenced although there are
C> situations in which it would be safe to do so. care should be taken that
C> all of the new grid points lie within the origional grid, no error checks
C> are made.
C>
C> @author J. McDonell @date 1974-09-01
      SUBROUTINE w3ft00(FLD,B,IA,JA,IB,JB,CIP,CJP,FIPB,FJPB,SC,ARG,LIN)
C
      REAL  B(IB,JB)
      REAL  ERAS(4)
      REAL  FLD(IA,JA)
C
      equivalence(ci,sti), (cj,stj)
C
      theta = arg * (3.14159 / 180.0)
      sint  = sin(theta)
      cost  = cos(theta)
C
      DO 180 jn = 1,jb
        fjn   = jn
        fj    = fjn - fjpb
      DO 180 in = 1,ib
        fin   = in
        fi    = fin - fipb
        ioff  = 0
        joff  = 0
        kquad = 0
        ci    = cip + sc * (fi * cost - fj * sint)
        cj    = cjp + sc * (fi * sint + fj * cost)
        im    = ci
        jm    = cj
        IF ((im - 1).GT.0) GO TO 20
        IF ((im - 1).EQ.0) GO TO 40
          ii   = 1
          ioff = 1
          GO TO 50
C
 20   CONTINUE
        IF ((ia - im - 1).GT.0) GO TO 50
        IF ((ia - im - 1).EQ.0) GO TO 40
          ii   = ia
          ioff = 1
          GO TO 50
C
 40   CONTINUE
        kquad = 5
C
 50   CONTINUE
        IF ((jm - 1).GT.0) GO TO 70
        IF ((jm - 1).EQ.0) GO TO 90
        jj   = 1
        joff = 1
        GO TO 100
C
 70   CONTINUE
        IF ((ja - jm - 1).GT.0) GO TO 100
        IF ((ja - jm - 1).EQ.0) GO TO 90
        jj   = ja
        joff = 1
        GO TO 100
C
 90   CONTINUE
        kquad = 5
C
 100  CONTINUE
        IF ((ioff + joff) .EQ. 0)  GO TO 120
        IF ((ioff + joff) .EQ. 2)  GO TO 110
        IF (ioff .EQ. 1)  jj = cj
        IF (joff .EQ. 1)  ii = ci
C
 110  CONTINUE
        b(in,jn) = fld(ii,jj)
        GO TO 180
C
 120  CONTINUE
        i     = sti
        j     = stj
        fix   = i
        xdeli = sti - fix
        fjx   = j
        xdelj = stj - fjx
        IF ((kquad - 5).EQ.0) GO TO 140
C
        IF ((lin-1).NE.0) GO TO 150
C
 140  CONTINUE
        eras(1) = fld(i,j)
        eras(4) = fld(i,j+1)
        eras(2) = eras(1) + (fld(i+1,j)   - eras(1)) * xdeli
        eras(3) = eras(4) + (fld(i+1,j+1) - eras(4)) * xdeli
        di      = eras(2) + (eras(3)      - eras(2)) * xdelj
        GO TO 170
C
 150  CONTINUE
        xi2tm = xdeli * (xdeli - 1.0) * 0.25
        xj2tm = xdelj * (xdelj - 1.0) * 0.25
        j1 = j - 1
C
      DO 160 k = 1,4
        eras(k) = (fld(i+1,j1) - fld(i,j1)) * xdeli + fld(i,j1) +
     & (fld(i-1,j1) - fld(i,j1) - fld(i+1,j1) + fld(i+2,j1)) * xi2tm
        j1 = j1 + 1
 160  CONTINUE
C
        di = eras(2) + (eras(3) - eras(2)) * xdelj + (eras(1) -
     &       eras(2) -  eras(3) + eras(4)) * xj2tm
C
 170  CONTINUE
        b(in,jn) = di
C
 180  CONTINUE
C
      RETURN
      END