268 lines
7.4 KiB
FortranFixed
268 lines
7.4 KiB
FortranFixed
|
SUBROUTINE CCBOXT (cval, clabel, ilabel, start, ill, jll,
|
||
|
|
+ idirc, scflag, iret)
|
||
|
|
C************************************************************************
|
||
|
|
C* CCBOXT *
|
||
|
|
C* *
|
||
|
|
C* This subroutine draws a contour line through a box defined by four *
|
||
|
|
C* grid points. *
|
||
|
|
C* *
|
||
|
|
C* CCBOXT ( CVAL, CLABEL, ILABEL, START, ILL, JLL, IDIRC, SCFLAG, *
|
||
|
|
C* IRET ) *
|
||
|
|
C* *
|
||
|
|
C* Input parameters: *
|
||
|
|
C* CVAL REAL Contour level *
|
||
|
|
C* CLABEL CHAR* Contour label *
|
||
|
|
C* ILABEL INTEGER Label type *
|
||
|
|
C* START LOGICAL Start flag *
|
||
|
|
C* SCFLAG LOGICAL Suppress small contour flag *
|
||
|
|
C* *
|
||
|
|
C* Input and output parameters: *
|
||
|
|
C* ILL INTEGER Lower left x value for box *
|
||
|
|
C* JLL INTEGER Lower left y value for box *
|
||
|
|
C* IDIRC INTEGER Direction entering box *
|
||
|
|
C* *
|
||
|
|
C* Output parameters: *
|
||
|
|
C* IRET INTEGER Return code *
|
||
|
|
C* 0 = normal return *
|
||
|
|
C* -3 = edge reached *
|
||
|
|
C** *
|
||
|
|
C* Log: *
|
||
|
|
C* WOLFPLOT Original code for SACC *
|
||
|
|
C* M. desJardins/GSFC 7/85 Adapted from AOIPS code for GEMPAK 3.1 *
|
||
|
|
C* M. desJardins/GSFC 6/89 Rewritten for GEMPAK 5 *
|
||
|
|
C* J. Whistler/SSAI 6/91 Set internal grids to size LLMXDG *
|
||
|
|
C* M. desJardins/NMC 12/91 Renamed: CBOXIT-->CCBOXT *
|
||
|
|
C* K. Brill/NMC 02/92 Shorten some too-long lines of code *
|
||
|
|
C* G. Krueger/EAI 12/94 Conditional CCOEFF; CCGTBX call->CCCRSS *
|
||
|
|
C* S. Jacobs/NCEP 5/99 Modified check for multiple directions *
|
||
|
|
C* C. Bailey/HPC 6/06 Added contour label to calling sequence *
|
||
|
|
C* C. Bailey/HPC 10/06 Added suppress small contour flag *
|
||
|
|
C************************************************************************
|
||
|
|
INCLUDE 'GEMPRM.PRM'
|
||
|
|
INCLUDE 'CONTUR.CMN'
|
||
|
|
C*
|
||
|
|
CHARACTER*24 clabel(LLCLEV)
|
||
|
|
LOGICAL start, scflag
|
||
|
|
C*
|
||
|
|
REAL box (4), boxmod (4)
|
||
|
|
LOGICAL tstr, tsts, tstl, edge
|
||
|
|
C*
|
||
|
|
INTEGER ippt1 (4), ippt2 (4), ippt3 (4), ippt4 (4)
|
||
|
|
DATA ippt1 / 4, 1, 2, 3 /, ippt2 / 3, 4, 1, 2 /,
|
||
|
|
+ ippt3 / 2, 3, 4, 1 /, ippt4 / 1, 2, 3, 4 /
|
||
|
|
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------------------------------------------------------------------------
|
||
|
|
iret = 0
|
||
|
|
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
|
||
|
|
CALL CCCRSS ( 0, 0, ill, jll, cval, iret )
|
||
|
|
IF ( iret .eq. -2 .or. iret .eq. -1 ) THEN
|
||
|
|
iret = -3
|
||
|
|
RETURN
|
||
|
|
END IF
|
||
|
|
C
|
||
|
|
C* Compute the coefficients to evaluate points inside box, if we
|
||
|
|
C* are subboxing.
|
||
|
|
C
|
||
|
|
IF ( numsub .gt. 2 ) CALL CCOEFF ( ill, jll, ier )
|
||
|
|
C
|
||
|
|
C* For a new contour line, find the point to start.
|
||
|
|
C
|
||
|
|
IF ( start ) THEN
|
||
|
|
CALL CCSTRT ( cval, ill, jll, idirc, 1, illbox, jllbox,
|
||
|
|
+ iret )
|
||
|
|
IF ( iret .ne. 0 ) RETURN
|
||
|
|
C
|
||
|
|
C* Otherwise, check if point left by last box needs to be
|
||
|
|
C* modified for new coefficients.
|
||
|
|
C
|
||
|
|
ELSE
|
||
|
|
CALL CCCHCK ( cval, ill, jll, idirc, illbox, jllbox, iret )
|
||
|
|
IF ( iret .ne. 0 ) RETURN
|
||
|
|
END IF
|
||
|
|
C
|
||
|
|
C* Loop through all the grid boxes until an edge is reached.
|
||
|
|
C
|
||
|
|
knt = 1
|
||
|
|
maxk = 4 * numsub
|
||
|
|
edge = .false.
|
||
|
|
DO WHILE ( ( iret .eq. 0 ) .and. ( .not. edge ) )
|
||
|
|
C
|
||
|
|
C* Get corners of this subbox.
|
||
|
|
C
|
||
|
|
CALL CCGTSB ( illbox, jllbox, ill, jll, cval, box, boxmod,
|
||
|
|
+ iret )
|
||
|
|
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 = ( boxmod ( ip1 ) * boxmod ( ip2 ) .lt. 0. )
|
||
|
|
tsts = ( boxmod ( ip2 ) * boxmod ( ip3 ) .lt. 0. )
|
||
|
|
tstl = ( boxmod ( ip3 ) * boxmod ( 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
|
||
|
|
iret = -3
|
||
|
|
RETURN
|
||
|
|
END IF
|
||
|
|
C
|
||
|
|
C* Compute value based on new direction.
|
||
|
|
C
|
||
|
|
IF ( idirn .eq. 1 ) THEN
|
||
|
|
x1 = xll + ( illbox - 1. + dist ) * fincxy
|
||
|
|
y1 = yll + ( jllbox ) * fincxy
|
||
|
|
jllbox = jllbox + 1
|
||
|
|
IF ( jllbox .eq. numsub ) THEN
|
||
|
|
edge = .true.
|
||
|
|
jll = jll + 1
|
||
|
|
IF ( jll .ge. jsize ) THEN
|
||
|
|
iret = -3
|
||
|
|
ihline ( (jll-1)*isize+ill ) =
|
||
|
|
+ ihline ( (jll-1)*isize+ill ) + 1
|
||
|
|
ELSE IF ( ihline ( (jll-1)*isize+ill ) .gt. 1 )
|
||
|
|
+ THEN
|
||
|
|
iret = -5
|
||
|
|
END IF
|
||
|
|
END IF
|
||
|
|
ELSE IF ( idirn .eq. 2 ) THEN
|
||
|
|
x1 = xll + ( illbox ) * fincxy
|
||
|
|
y1 = yll + ( jllbox - 1. + dist ) * fincxy
|
||
|
|
illbox = illbox + 1
|
||
|
|
IF ( illbox .eq. numsub ) THEN
|
||
|
|
edge = .true.
|
||
|
|
ill = ill + 1
|
||
|
|
IF ( ill .ge. isize ) THEN
|
||
|
|
iret = -3
|
||
|
|
ivline ( (jll-1)*isize+ill ) =
|
||
|
|
+ ivline ( (jll-1)*isize+ill ) + 1
|
||
|
|
ELSE IF ( ivline ( (jll-1)*isize+ill ) .gt. 1 )
|
||
|
|
+ THEN
|
||
|
|
iret = -5
|
||
|
|
END IF
|
||
|
|
END IF
|
||
|
|
ELSE IF ( idirn .eq. 3 ) THEN
|
||
|
|
x1 = xll + ( illbox - 1. + dist ) * fincxy
|
||
|
|
y1 = yll + ( jllbox - 1. ) * fincxy
|
||
|
|
jllbox = jllbox - 1
|
||
|
|
IF ( jllbox .lt. 1 ) THEN
|
||
|
|
edge = .true.
|
||
|
|
jll = jll - 1
|
||
|
|
IF ( jll .lt. 1 ) THEN
|
||
|
|
iret = -3
|
||
|
|
ihline ( ill ) =
|
||
|
|
+ ihline ( ill ) + 1
|
||
|
|
ELSE IF ( ihline ( (jll)*isize+ill ) .gt.
|
||
|
|
+ 1 ) THEN
|
||
|
|
iret = -5
|
||
|
|
END IF
|
||
|
|
END IF
|
||
|
|
ELSE IF ( idirn .eq. 4 ) THEN
|
||
|
|
x1 = xll + ( illbox - 1. ) * fincxy
|
||
|
|
y1 = yll + ( jllbox - 1. + dist ) * fincxy
|
||
|
|
illbox = illbox - 1
|
||
|
|
IF ( illbox .lt. 1 ) THEN
|
||
|
|
edge = .true.
|
||
|
|
ill = ill - 1
|
||
|
|
IF ( ill .lt. 1 ) THEN
|
||
|
|
iret = -3
|
||
|
|
ivline ( (jll-1)*isize+1 ) =
|
||
|
|
+ ivline ( (jll-1)*isize+1 )
|
||
|
|
+ + 1
|
||
|
|
ELSE IF ( ivline ( (jll-1)*isize+ill+1 ) .gt. 1 )
|
||
|
|
+ THEN
|
||
|
|
iret = -5
|
||
|
|
END IF
|
||
|
|
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
|
||
|
|
C
|
||
|
|
C* Check for looping within box.
|
||
|
|
C
|
||
|
|
knt = knt + 1
|
||
|
|
IF ( knt .gt. maxk ) THEN
|
||
|
|
iret = -5
|
||
|
|
edge = .true.
|
||
|
|
END IF
|
||
|
|
END DO
|
||
|
|
C*
|
||
|
|
RETURN
|
||
|
|
END
|