awips2/ncep/gov.noaa.nws.ncep.ui.nsharp/AwcNsharp/ccdrw2.f
Steve Harris 676ea3192f 12.5.1-15 baseline
Former-commit-id: b13cbb7e00 [formerly 4909e0dd166e43c22a34d96aa744f51db8a7d6c0]
Former-commit-id: 3904c4ccf5
2012-06-08 13:39:48 -05:00

328 lines
8.2 KiB
Fortran

SUBROUTINE CCDRW2 ( cval, clabel, ilabel, intror, ii, jj,
+ idire, scflag, iret )
C************************************************************************
C* CCDRW2 *
C* *
C* This subroutine draws contours. *
C* *
C* CCDRW2 ( CVAL, CLABEL, ILABEL, INTROR, II, JJ, IDIRE, SCFLAG, *
C* IRET ) *
C* *
C* Input parameters: *
C* CVAL REAL Contour level *
C* CLABEL CHAR* Contour label *
C* ILABEL INTEGER Label type *
C* INTROR LOGICAL Interior start flag *
C* II INTEGER Lower left column of box *
C* JJ INTEGER Lower left row of box *
C* IDIRE INTEGER Direction entering box *
C* SCFLAG LOGICAL Suppress small contour flag *
C* *
C* Output parameters: *
C* IRET INTEGER Return code *
C* 0 = normal return *
C* -5 = TROUBLE *
C** *
C* Log: *
C* M. Li/GSC 1/00 Copied from CCDRAW *
C* J. Wu/GSC 07/00 Moved INCLUDE 'ERMISS.FNC' before the *
C* DATA statement *
C* C. Bailey/HPC 6/06 Added contour label string *
C* C. Bailey/HPC 10/06 Added suppress small contour flag *
C************************************************************************
INCLUDE 'GEMPRM.PRM'
INCLUDE 'CONTUR.CMN'
C*
CHARACTER*24 clabel(LLCLEV)
LOGICAL intror, scflag
C*
LOGICAL start, edge, closed, revers, cont,
+ tstr, tsts, tstl
C*
REAL box (4), bval (4)
C*
INTEGER ippt1 (4), ippt2 (4), ippt3 (4), ippt4 (4),
+ ip1arr (4), ip2arr (4)
INCLUDE 'ERMISS.FNC'
DATA ippt1 / 4, 1, 2, 3 /,
+ ippt2 / 3, 4, 1, 2 /,
+ ippt3 / 2, 3, 4, 1 /,
+ ippt4 / 1, 2, 3, 4 /,
+ ip1arr / 1, 1, 2, 4 /,
+ ip2arr / 4, 2, 3, 3 /
C*
C
C* This statement function gets the fractional distance along a
C* side to the value 0.
C
FIND0 ( x, y ) = x / ( x - y )
C
C* Statement function to get grid value.
C
FVAL ( i, j ) = z ( (j-1) * isize + i )
C*
C------------------------------------------------------------------------
iret = 0
jlabel = ilabel
C
C* Initialize variables.
C
number = 0
ill = ii
jll = jj
idirc = idire
revers = .false.
edge = .false.
closed = .false.
start = .true.
cont = .true.
C
C* Save initial points.
C
ills = ill
jlls = jll
idirs = idirc
C
C* Draw grid till the edge is reached.
C
knt = 0
DO WHILE ( ( .not. edge ) .and. ( .not. closed ) )
knt = knt + 1
IF ( knt .gt. 2048 ) THEN
iret = -5
RETURN
END IF
C*
xll = FLOAT ( ill )
yll = FLOAT ( jll )
C
C* Set flag indicating we've been here.
C
IF ( idirc .eq. 1 ) THEN
ihline ( (jll-1)*isize+ill ) =
+ ihline ( (jll-1)*isize+ill ) + 1
ELSE IF ( idirc .eq. 2 ) THEN
ivline ( (jll-1)*isize+ill ) =
+ ivline ( (jll-1)*isize+ill ) + 1
ELSE IF ( idirc .eq. 3 ) THEN
ihline ( (jll)*isize+ill ) =
+ ihline ( (jll)*isize+ill ) + 1
ELSE IF ( idirc .eq. 4 ) THEN
ivline ( (jll-1)*isize+ill+1 ) =
+ ivline ( (jll-1)*isize+ill+1 ) + 1
END IF
C
C* First check for missing data.
C
bval (1) = FVAL ( ill, jll )
bval (2) = FVAL ( ill, jll+1 )
bval (3) = FVAL ( ill+1, jll+1 )
bval (4) = FVAL ( ill+1, jll )
IF ( ERMISS ( bval(1) ) .or. ERMISS ( bval(2) ) .or.
+ ERMISS ( bval(3) ) .or. ERMISS ( bval(4) ) ) THEN
cont = .false.
edge = .true.
END IF
C
C* If the points are ok, continue.
C
IF ( cont ) THEN
C
C* Get corners of this box.
C
DO k = 1, 4
box (k) = bval (k) - cval
END DO
C
C* Start the contour.
C
IF ( start ) THEN
ip1 = ip1arr ( idirc )
ip2 = ip2arr ( idirc )
IF ( box ( ip1 ) * box ( ip2 ) .lt. 0. ) THEN
dist = FIND0 ( box ( ip1 ), box ( ip2 ) )
IF ( idirc .eq. 1 ) THEN
x1 = xll + dist
y1 = yll
ELSE IF ( idirc .eq. 2 ) THEN
x1 = xll
y1 = yll + dist
ELSE IF ( idirc .eq. 3 ) THEN
x1 = xll + dist
y1 = yll + 1
ELSE IF ( idirc .eq. 4 ) THEN
x1 = xll + 1
y1 = yll + dist
END IF
number = number + 1
xval ( number ) = x1
yval ( number ) = y1
END IF
END IF
C
C* Get points to look to right, straight and left.
C
ip1 = ippt1 ( idirc )
ip2 = ippt2 ( idirc )
ip3 = ippt3 ( idirc )
ip4 = ippt4 ( idirc )
C
C* Check for crossings to right, straight and left.
C
tstr = ( box ( ip1 ) * box ( ip2 ) .lt. 0. )
tsts = ( box ( ip2 ) * box ( ip3 ) .lt. 0. )
tstl = ( box ( ip3 ) * box ( ip4 ) .lt. 0. )
C
C* If there is more than one possible direction, the top
C* and bottom sides turn left, and the left and right
C* sides turn right.
C
IF ( tstr .and. tstl ) THEN
IF ( ( idirc .eq. 1 ) .or.
+ ( idirc .eq. 3 ) ) THEN
tstr = .false.
ELSE
tstl = .false.
END IF
tsts = .false.
END IF
C
C* Get new direction and points to interpolate.
C
IF ( tstr ) THEN
idirn = idirc + 1
IF ( idirn .eq. 5 ) idirn = 1
dist = FIND0 ( box (ip1), box (ip2) )
IF ( ( idirc .eq. 3 ) .or. ( idirc .eq. 4 ) )
+ dist = 1. - dist
ELSE IF ( tsts ) THEN
idirn = idirc
dist = FIND0 ( box (ip2), box (ip3) )
IF ( ( idirc .eq. 1 ) .or. ( idirc .eq. 4 ) )
+ dist = 1. - dist
ELSE IF ( tstl ) THEN
idirn = idirc - 1
IF ( idirn .eq. 0 ) idirn = 4
dist = FIND0 ( box (ip3), box (ip4) )
IF ( ( idirc .eq. 1 ) .or. ( idirc .eq. 2 ) )
+ dist = 1. - dist
ELSE
cont = .false.
END IF
END IF
C
C* If there are no errors, continue.
C
IF ( cont ) THEN
C
C* Compute value based on new direction.
C
IF ( idirn .eq. 1 ) THEN
x1 = xll + dist
y1 = yll + 1
jll = jll + 1
IF ( jll .ge. jsize ) THEN
edge = .true.
ihline ( (jll-1)*isize+ill ) =
+ ihline ( (jll-1)*isize+ill ) + 1
ELSE IF (ihline((jll-1)*isize+ill) .gt. 1) THEN
edge = .true.
END IF
ELSE IF ( idirn .eq. 2 ) THEN
x1 = xll + 1
y1 = yll + dist
ill = ill + 1
IF ( ill .ge. isize ) THEN
edge = .true.
ivline ( (jll-1)*isize+ill ) =
+ ivline ( (jll-1)*isize+ill ) + 1
ELSE IF (ivline((jll-1)*isize+ill) .gt. 1) THEN
edge = .true.
END IF
ELSE IF ( idirn .eq. 3 ) THEN
x1 = xll + dist
y1 = yll
jll = jll - 1
IF ( jll .lt. 1 ) THEN
edge = .true.
ihline ( ill ) = ihline ( ill ) + 1
ELSE IF (ihline((jll)*isize+ill) .gt. 1) THEN
edge = .true.
END IF
ELSE IF ( idirn .eq. 4 ) THEN
x1 = xll
y1 = yll + dist
ill = ill - 1
IF ( ill .lt. 1 ) THEN
edge = .true.
ivline ( (jll-1)*isize+1 ) =
+ ivline ( (jll-1)*isize+1 ) + 1
ELSE IF (ivline((jll-1)*isize+ill+1) .gt. 1) THEN
edge = .true.
END IF
END IF
C
C* Add point to buffer.
C
number = number + 1
IF ( number .eq. 1024 ) THEN
number = 1023
xval1 = xval (1023)
yval1 = yval (1023)
CALL CCPLOT ( cval, clabel, ilabel, scflag, iret )
xval (1) = xval1
yval (1) = yval1
number = 2
END IF
xval (number) = x1
yval (number) = y1
C
C* Set new direction.
C
idirc = idirn
END IF
C*
IF ( cont ) THEN
IF ( start ) THEN
x1save = xval (1)
y1save = yval (1)
start = .false.
END IF
C
C* Check for closed curve. In this case, set the last point
C* to be the same as the first point to ensure closure.
C
closed = ( idirc .eq. idirs ) .and.
+ ( ills .eq. ill ) .and.
+ ( jlls .eq. jll )
IF ( closed ) THEN
number = number + 1
xval ( number ) = x1save
yval ( number ) = y1save
END IF
END IF
C
C* If an edge has been reached and the curve is not closed,
C* reverse directions and start again.
C
IF ( edge .and. ( .not. revers ) .and. intror ) THEN
revers = .true.
idirc = 4
ill = ills - 1
jll = jlls
edge = .false.
CALL CCPLOT ( cval, clabel, jlabel, scflag, ier )
jlabel = 0
number = 1
xval (1) = x1save
yval (1) = y1save
cont = .true.
END IF
END DO
C
C* Contour has reached an edge so we are done.
C
CALL CCPLOT ( cval, clabel, ilabel, scflag, ier )
C*
RETURN
END