172 lines
4.3 KiB
Fortran
172 lines
4.3 KiB
Fortran
SUBROUTINE FFDRIV ( nlvl, clvl, lincol, lintyp, linwid, linlbl,
|
|
+ linflg, iret )
|
|
C************************************************************************
|
|
C* FFDRIV *
|
|
C* *
|
|
C* This subroutine draws filled contours. *
|
|
C* *
|
|
C* FFDRIV ( NLVL, CLVL, LINCOL, LINTYP, LINWID, LINLBL, LINFLG, IRET ) *
|
|
C* *
|
|
C* Input parameters: *
|
|
C* NLVL INTEGER Number of contour levels *
|
|
C* CLVL (NLVL) REAL Contour levels *
|
|
C* LINCOL (NLVL) INTEGER Contour colors *
|
|
C* LINTYP (NLVL) INTEGER Contour line types *
|
|
C* LINWID (NLVL) INTEGER Contour line widths *
|
|
C* LINLBL (NLVL) INTEGER Contour label types *
|
|
C* LINFLG LOGICAL Flag to draw lines *
|
|
C* *
|
|
C* Output parameters: *
|
|
C* IRET INTEGER Return code *
|
|
C** *
|
|
C* Log: *
|
|
C* M. desJardins/NMC 11/91 *
|
|
C* D.W.Plummer/NCEP 1/97 Remove call to GEPLOT prior to RETURN *
|
|
C* T. Lee/SAIC 10/01 Query and restore fill attributes *
|
|
C************************************************************************
|
|
INCLUDE 'GEMPRM.PRM'
|
|
INCLUDE 'CONTUR.CMN'
|
|
C*
|
|
REAL clvl (*)
|
|
INTEGER lincol (*), lintyp (*), linwid (*), linlbl (*)
|
|
LOGICAL linflg
|
|
C*
|
|
REAL box (4), xpt (250), ypt (250)
|
|
LOGICAL onelev
|
|
C------------------------------------------------------------------------
|
|
iret = 0
|
|
C
|
|
C* Query current fill type.
|
|
C
|
|
CALL GQFILL ( szfil, iftyp, iret )
|
|
C
|
|
C* Loop through all the grid boxes.
|
|
C
|
|
DO jll = 1, jsize - 1
|
|
DO ill = 1, isize - 1
|
|
C
|
|
C* Get points on this box and check to see if the entire box
|
|
C* is one color.
|
|
C
|
|
CALL FGTBOX ( ill, jll, box, xx1, yy1, xx2, yy2, iret )
|
|
C
|
|
C* If the return code is not 0, there is missing data.
|
|
C
|
|
IF ( iret .eq. 0 ) THEN
|
|
CALL FGTCOR ( box, nlvl, clvl, icornr, levl, onelev,
|
|
+ ier )
|
|
END IF
|
|
C
|
|
C* Do nothing if there is missing data.
|
|
C
|
|
IF ( iret .ne. 0 ) THEN
|
|
C
|
|
C* Fill entire box if it is all one color.
|
|
C
|
|
ELSE IF ( onelev .and. ( .not. linflg ) ) THEN
|
|
C
|
|
C* Plot the entire box.
|
|
C
|
|
ipt = 1
|
|
xpt (ipt) = xx1
|
|
ypt (ipt) = yy1
|
|
DO jj = 1, numsub - 2
|
|
ipt = ipt + 1
|
|
xpt (ipt) = xx1
|
|
ypt (ipt) = FLOAT ( jj ) * fincxy + yy1
|
|
END DO
|
|
ipt = ipt + 1
|
|
xpt (ipt) = xx1
|
|
ypt (ipt) = yy2
|
|
DO ii = 1, numsub - 2
|
|
ipt = ipt + 1
|
|
xpt (ipt) = FLOAT ( ii ) * fincxy + xx1
|
|
ypt (ipt) = yy2
|
|
END DO
|
|
ipt = ipt + 1
|
|
xpt (ipt) = xx2
|
|
ypt (ipt) = yy2
|
|
DO jj = numsub - 2, 1, -1
|
|
ipt = ipt + 1
|
|
xpt (ipt) = xx2
|
|
ypt (ipt) = FLOAT ( jj ) * fincxy + yy1
|
|
END DO
|
|
ipt = ipt + 1
|
|
xpt (ipt) = xx2
|
|
ypt (ipt) = yy1
|
|
DO ii = numsub - 2, 1, -1
|
|
ipt = ipt + 1
|
|
xpt (ipt) = FLOAT ( ii ) * fincxy + xx1
|
|
ypt (ipt) = yy1
|
|
END DO
|
|
CALL FFPLOT ( ipt, xpt, ypt, linflg, lincol (levl),
|
|
+ lintyp (levl), linwid (levl), ier )
|
|
C
|
|
C* If box is not subdivided, fill in the whole box.
|
|
C
|
|
ELSE IF ( numsub .le. 2 ) THEN
|
|
CALL FILBOX ( box, xx1, yy1, xx2, yy2, nlvl, clvl,
|
|
+ lincol, lintyp, linwid, icornr, levl,
|
|
+ linflg, ier )
|
|
C
|
|
C* Subdivide the box.
|
|
C
|
|
ELSE
|
|
C
|
|
C* Set up the coefficients for this box.
|
|
C
|
|
CALL CCOEFF ( ill, jll, ier )
|
|
C
|
|
C* Loop through all the subboxes.
|
|
C
|
|
DO jsub = 1, numsub - 1
|
|
DO isub = 1, numsub - 1
|
|
C
|
|
C* Get the points on this subbox and check for a single
|
|
C* color.
|
|
C
|
|
CALL FGTSUB ( ill, jll, isub, jsub, box, xx1, yy1,
|
|
+ xx2, yy2, ier )
|
|
CALL FGTCOR ( box, nlvl, clvl, icornr, levl, onelev,
|
|
+ ier )
|
|
C
|
|
C* Fill the entire box if it is all one color.
|
|
C
|
|
IF ( onelev ) THEN
|
|
C
|
|
C* Plot the entire box.
|
|
C
|
|
xpt (1) = xx1
|
|
ypt (1) = yy1
|
|
xpt (2) = xx1
|
|
ypt (2) = yy2
|
|
xpt (3) = xx2
|
|
ypt (3) = yy2
|
|
xpt (4) = xx2
|
|
ypt (4) = yy1
|
|
ipt = 4
|
|
CALL FFPLOT ( ipt, xpt, ypt, linflg, lincol (levl),
|
|
+ lintyp (levl), linwid (levl), ier )
|
|
C
|
|
C* Fill in this box.
|
|
C
|
|
ELSE
|
|
CALL FILBOX (box, xx1, yy1, xx2, yy2, nlvl, clvl,
|
|
+ lincol, lintyp, linwid, icornr,
|
|
+ levl, linflg, ier )
|
|
END IF
|
|
END DO
|
|
END DO
|
|
END IF
|
|
END DO
|
|
END DO
|
|
999 continue
|
|
C
|
|
C* Restore fill type setup.
|
|
C
|
|
CALL GSFILL ( szfil, iftyp, iret )
|
|
C
|
|
C* End plotting.
|
|
C
|
|
RETURN
|
|
END
|