c#######################################################################
c
c This file contains subroutine that interface ZXPLOT main
c library package with the NCAR graphics low-level premitives.
c
c Written by Ming Xue, CAPS, University of Oklahoma,
c 100 E. Boyd, Norman, OK 73019. mxue@uoknor.edu.
c
c Copyright to Ming Xue. All rights reserved. 1986-1996.
c
c#######################################################################
c
SUBROUTINE XDEVIC 10,18
SAVE NZXCAL, MBORDR
DATA NZXCAL /0/ ,MBORDR/0/
COMMON /XPSIZE/ PSIZE
COMMON /XPSD01/ XSIDE, YSIDE
integer ncunique
integer icoltable
common /xcltbl/ ncunique,icoltable
integer iasf(13)
data iasf /13*1/
PARAMETER (IERRF=6, LUNIT=2, IWTYPE=1, IWKID=1)
c
c#######################################################################
c
C Set up divice by calling NCAR GKS package.
c
c#######################################################################
c
c CALL opngks
CALL GOPKS (IERRF, ISZDM)
CALL GOPWK (IWKID, LUNIT, IWTYPE)
CALL GACWK (IWKID)
c
c#######################################################################
c
c Turn off the clipping indicator (GKS routine)
c
c#######################################################################
c
call gsclip(0)
c
c#######################################################################
c
c Set all aspect source flags to "individual" (GKS routine)
c
c#######################################################################
c
call gsasf (iasf)
c
c#######################################################################
C
C Define 16 different color indices, for indices 0 through 15.
c The color corresponding to index 0 is black and the color
c corresponding to index 1 is white.
c
c#######################################################################
C
CALL XICHAR
c
c#######################################################################
c
C XDSPAC must prceeds all other calls to ZXPLOT routines.
c
c#######################################################################
c
CALL XDSPAC( 1.0 )
CALL XMINIT
NZXCAL=1
CALL XSETCLRS(icoltable)
CALL xcolor(1)
c
RETURN
ENTRY XFRAME
c
c#######################################################################
c
C Advance plotting onto next frame
c
c#######################################################################
c
CALL XQMAP ( X1,X2,Y1,Y2 )
CALL XLPNUP(X1,Y1)
CALL FRAME
RETURN
ENTRY XGREND
c
c#######################################################################
c
C Terminate graphic plotting
c
c#######################################################################
c
IF( NZXCAL.EQ.0) THEN
PRINT*,' XGREND called before device is set up.'
RETURN
ENDIF
CALL XQMAP ( X1,X2,Y1,Y2 )
CALL XLPNUP(X1,Y1)
call plotif(0.0, 0.0, 2)
CALL GDAWK (IWKID)
CALL GCLWK (IWKID)
CALL GCLKS
c CALL clsgks
RETURN
ENTRY XFBORD(MBORD)
MBORDR=MBORD
RETURN
END
SUBROUTINE XDSPAC(PSIZE) 13,3
c
c#######################################################################
c
C Define a normalized device (ND) space (0.0,XSIDE,0.0,YSIDE) on
c device provided. The size of this space is 'PSIZE' times of the
c max device space.
c YSIDE should be 1.0, XSIDE can be bigger or smaller that 1.0
c depending on device. XSIDE, YSIDE should be passed to ZXPLOT
c through common block PSIDES.
c
C This routine sets up the ND space based on NCAR graphics.
c
c#######################################################################
c
C
COMMON /XPSIZE/ PSIZE1
COMMON /XPSD01/ XSIDE, YSIDE
save xp1,xp2,yp1,yp2,x1,x2,y1,y2
PSIZE1=PSIZE
C
XSIDE=1.0
YSIDE=1.0
IF( PSIZE.LE.0.0) THEN
PRINT*,'Zero or negative values for PSIZE not permitted!'
PRINT*,'It should be in range of 0.1 to 1.,please reset value'
STOP
ENDIF
EDGEX=0.5*XSIDE*(1.0/PSIZE-1)
EDGEY=EDGEX
X1=-EDGEX
X2= EDGEX+XSIDE
Y1=-EDGEY
Y2= EDGEY+YSIDE
xp1 = 0.0
xp2 = 1.0
yp1 = 0.0
yp2 = 1.0
CALL Set(xp1,xp2,yp1,yp2, X1,X2,Y1,Y2, 1)
return
c
c#######################################################################
c
entry xqset(xp1a,xp2a,yp1a,yp2a,x1a,x2a,y1a,y2a)
xp1a = xp1
xp2a = xp2
yp1a = yp1
yp2a = yp2
x1a = x1
x2a = x2
y1a = y1
y2a = y2
RETURN
c
entry xzx2ncar( xpos, ypos )
c
c#######################################################################
c
c Find the corrdinate in the ncargraphic device space
c given its corrdinate in the zxplot non-dimensional
c device space.
c
c#######################################################################
c
xpos = 0.0 + (xpos-x1)/(x2-x1)*1.0
ypos = 0.0 + (ypos-y1)/(y2-y1)*1.0
return
END
SUBROUTINE PPENUP(X1,Y1) 10,1
c
c#######################################################################
c
C Connect pen up routines
c
c#######################################################################
c
X=X1
Y=Y1
CALL Frstpt(X,Y)
RETURN
ENTRY PPENDN(X1,Y1)
c
c#######################################################################
c
C Connect pen down routines
c
c#######################################################################
c
X=X1
Y=Y1
CALL Vector(X,Y)
RETURN
END
SUBROUTINE ZFILLN(X,Y,NP) 1,2
integer np
real x(np),y(np)
CALL XFILAREA(x,y,np)
RETURN
END
SUBROUTINE XFILAREA(X,Y,NP) 16,11
c
c#######################################################################
c
C To fill a polygon defined by (x(i),y(i),i=1,np) with predefined
c color (set by CALL COLOR).
c
c Modified by Ming Xue to use GKS area fill routine GFA instead of
c Ncar Graphics soft fill routine SFWRLD. (1/17/96).
c
c#######################################################################
c
REAL X(*),Y(*)
parameter (npmax=100000)
REAL xra(npmax),yra(npmax)
common /xwndw1/ xw1,xw2,yw1,yw2, iwndon
real x1,x2,y1,y2
c
c#######################################################################
c
c GSFAIS(INTS) is called first to set the area fill style, where
c INTS=0 for hollow fill,
c =1 for solid fill,
c =2 for pattern fill and
C =3 for hatch fill.
c
c Then GSAFSI(istyle) can be called to set the hatch or pattern style.
c for INIT=2 and 3.
c In NCAR graphics, hatch options are 1 for horizontal, 2 for vertical,
c 3 for right slanting, 4 for left slanting line, and 5 to horizontal and
c vertical lines, 6 for right and left slanting lines.
c
c#######################################################################
c
if(iwndon.eq.1)then
nn=0
do i=1,np-1
x1=x(i)
x2=x(i+1)
y1=y(i)
y2=y(i+1)
call xtstwd(x1,y1,x2,y2,idispl)
if(idispl.ne.0) then
nn=nn+1
IF( nn.gt.npmax) GOTO 999
xra(nn)=x1
yra(nn)=y1
nn=nn+1
IF( nn.gt.npmax) GOTO 999
xra(nn)=x2
yra(nn)=y2
end if
end do
else
IF( np.gt.npmax) then
write(6,'(1x,a,/1x,a,i6)')
: 'Work array xra and yra defined in XFILAREA not large enough.',
: 'Only ',npmax,' number of pointed were used.'
endif
do i=1,min(npmax,np)
xra(i) = x(i)
yra(i) = y(i)
enddo
nn = min(npmax,np)
end if
if(nn .ge. 3) then
DO 100 I=1,nn
CALL XTRANS(xra(I),yra(I))
100 CONTINUE
CALL GFA(nn, xra, yra)
endif
RETURN
999 write(6,'(1x,a,/1x,a,i6)')
:'Work array xra and yra defined in XFILAREA were too small',
:'Please increase the array size to more than ',npmax
RETURN
END
SUBROUTINE XICHAR 2
c
c#######################################################################
c
C To build an equivalence between READING amdahl CHAR function and
C LONDON cray CHAR function.
c
C CHAR( I ) (london) = CHAR( ICRAM(I) ) (reading)
C ICHAR( C ) (reading)= ICRAM( ICHAR( C ) (london) )
c
c#######################################################################
c
COMMON /XCHR30/ NCRAM
INTEGER ICRAM(127) ,NCRAM(256)
DATA ICRAM /
C 1-30
: 32, 32, 32, 32, 32, 32, 32, 32, 32, 32, 32, 32, 32, 32, 32,
: 32, 32, 32, 32, 32, 32, 32, 32, 32, 32, 32, 32, 32, 32, 32,
C 31-60
: 32, 32, 90,127,123, 91,108, 80,125, 77, 93, 92, 78,107, 96,
: 75, 97,240,241,242,243,244,245,246,247,248,249,122, 94, 76,
C 61-90
: 126,110,111, 32,193,194,195,196,197,198,199,200,201,209,210,
: 211,212,213,214,215,216,217,226,227,228,229,230,231,232,233,
C 91-120
: 173,224,189,113,109,121,129,130,131,132,133,134,135,136,137,
: 145,146,147,148,149,150,151,152,153,162,163,164,165,166,167,
C 121-127
: 168,169,192, 32,208, 95, 32 /
DO 5 I=1,127
5 NCRAM(I)=ICRAM(I)
DO 6 I=128, 256
6 NCRAM(I)= 32
RETURN
END
subroutine psftnm(a)
return
end
subroutine psgray(a) 2,2
return
end
SUBROUTINE XDFCLRS
c
c#######################################################################
C
C Define a set of RGB color triples for colors 1 through 15.
c
c#######################################################################
C
DIMENSION RGBV(3,0:15)
c
c#######################################################################
C
C Define the RGB color triples needed below.
c
c#######################################################################
C
DATA RGBV / 0.0 , 0.0 , 0.0 ,
+ 1.00 , 1.00 , 1.00 ,
+ 0.70 , 0.70 , 0.70 ,
+ 0.75 , 0.50 , 1.00 ,
+ 0.50 , 0.00 , 1.00 ,
+ 0.00 , 0.00 , 1.00 ,
+ 0.00 , 0.50 , 1.00 ,
+ 0.00 , 1.00 , 1.00 ,
+ 0.00 , 1.00 , 0.60 ,
+ 0.00 , 1.00 , 0.00 ,
+ 0.70 , 1.00 , 0.00 ,
+ 1.00 , 1.00 , 0.00 ,
+ 1.00 , 0.75 , 0.00 ,
+ 1.00 , 0.38 , 0.38 ,
+ 1.00 , 0.00 , 0.38 ,
+ 1.00 , 0.00 , 0.00 /
c
c#######################################################################
C
C Define 16 different color indices, for indices 0 through 15. The
C color corresponding to index 0 is black and the color corresponding
C to index 1 is white.
c
c#######################################################################
C
DO 101 I=0,15
CALL GSCR (1,I,RGBV(1,I),RGBV(2,I),RGBV(3,I))
101 CONTINUE
RETURN
C
END
subroutine xafstyl(nstyle) 4
c
c#######################################################################
c
c Set area fill style
c
c nstyle = 0 hollow fill
c = 1 solid fill
c = 2 pattern fill
c = 3 hatch fill
c
c#######################################################################
c
nt = nstyle
if( nstyle.lt.0 .or. nstyle.gt.3 ) nt = 0
c
call gsfais( nt )
return
end
subroutine xafpatn(npat)
c
c#######################################################################
c
c Set the hatch pattern when the fill style is hatch fill
c
c npat = 1 horizontal lines
c = 2 vertical lines
c = 3 lines of positive slope
c = 4 lines of negative slope
c = 5 horizontal and vertical lines
c = 6 lines of postive and negative slope
c
c#######################################################################
c
np = npat
if( npat.lt.1 .or. npat.gt.6 ) np = 1
call gsfasi(np)
return
end
subroutine xlncinx(ind)
c
c#######################################################################
c
c Set the line color index defined in xdfclrs
c
c#######################################################################
c
indx = ind
if( ind .lt.0 .or. ind.gt.15 ) indx = 0
call gsplci(indx)
return
end
subroutine xafcinx(ind)
c
c#######################################################################
c
c Set the area fill color index that is defined in xdfclrs
c
c#######################################################################
c
indx = ind
if( ind .lt.0 .or. ind.gt.15 ) indx = 0
call gsfaci(indx)
return
end
c
c Ncargraphic strmline routine with modefications so that
c originally hard wired parameters can be altered through
c common blocks.
c
SUBROUTINE STRMLN (U,V,WORK,IMAX,IPTSX,JPTSY,NSET,IER) 1,2
C
C +-----------------------------------------------------------------+
C | |
C | Copyright (C) 1989 by UCAR |
C | University Corporation for Atmospheric Research |
C | All Rights Reserved |
C | |
C | NCARGRAPHICS Version 3.00 |
C | |
C +-----------------------------------------------------------------+
C
C SUBROUTINE STRMLN (U,V,WORK,IMAX,IPTSX,JPTSY,NSET,IER)
C
C DIMENSION OF U(IMAX,JPTSY) , V(IMAX,JPTSY) ,
C ARGUMENTS WORK(2*IMAX*JPTSY)
C
C PURPOSE STRMLN draws a streamline representation of
C the flow field. The representation is
C independent of the flow speed.
C
C USAGE If the following assumptions are met, use
C
C CALL EZSTRM (U,V,WORK,IMAX,JMAX)
C
C Assumptions:
C --The whole array is to be processed.
C --The arrays are dimensioned
C U(IMAX,JMAX) , V(IMAX,JMAX) and
C WORK(2*IMAX*JMAX).
C --Window and viewport are to be chosen
C by STRMLN.
C --PERIM is to be called.
C
C If these assumptions are not met, use
C
C CALL STRMLN (U,V,WORK,IMAX,IPTSX,JPTSY,
C NSET,IER)
C
C The user must call FRAME in the calling
C routine.
C
C The user may change various internal
C parameters via common blocks. See below.
C
C ARGUMENTS
C
C ON INPUT U, V
C Two dimensional arrays containing the
C velocity fields to be plotted.
C
C Note: If the U AND V components
C are, for example, defined in Cartesian
C coordinates and the user wishes to plot them
C on a different projection (i.e., stereo-
C graphic), then the appropriate
C transformation must be made to the U and V
C components via the functions FU and FV
C (located in DRWSTR).
C
C WORK
C User provided work array. The dimension
C of this array must be .GE. 2*IMAX*JPTSY.
C
C Caution: This routine does not check the
C size of the work array.
C
C IMAX
C The first dimension of U and V in the
C calling program. (X-direction)
C
C IPTSX
C The number of points to be plotted in the
C first subscript direction. (X-direction)
C
C JPTSY
C The number of points to be plotted in the
C second subscript direction. (Y-direction)
C
C NSET
C Flag to control scaling
C > 0 STRMLN assumes that the window
C and viewport have been set by the
C user in such a way as to properly
C scale the plotting instructions
C generated by STRMLN. PERIM is not
C called.
C = 0 STRMLN will establish the window and
C viewport to properly scale the
C plotting instructions to the standard
C configuration. PERIM is called to draw
C the border.
C < 0 STRMLN establishes the window
C and viewport so as to place the
C streamlines within the limits
C of the user's window. PERIM is
C not called.
C
C ON OUTPUT Only the IER argument may be changed. All
C other arguments are unchanged.
C
C
C IER
C = 0 when no errors are detected
C = -1 when the routine is called with ICYC
C .NE. 0 and the data are not cyclic
C (ICYC is an internal parameter
C described below); in this case the
C routine will draw the
C streamlines with the non-cyclic
C interpolation formulas.
C
C ENTRY POINTS STRMLN, DRWSTR, EZSTRM, GNEWPT, CHKCYC
C
C COMMON BLOCKS STR01, STR02, STR03, STR04
C
C REQUIRED LIBRARY GRIDAL, GBYTES, and the SPPS
C ROUTINES
C
C REQUIRED GKS LEVEL 0A
C
C I/O None
C
C PRECISION Single
C
C LANGUAGE FORTRAN 77
C
C HISTORY Written and standardized in November 1973.
C
C Converted to FORTRAN 77 and GKS in June, 1984.
C
C
C PORTABILITY FORTRAN 77
C
C ALGORITHM Wind components are normalized to the value
C of DISPL. The least significant two
C bits of the work array are
C utilized as flags for each grid box. Flag 1
C indicates whether any streamline has
C previously passed through this box. Flag 2
C indicates whether a directional arrow has
C already appeared in a box. Judicious use
C of these flags prevents overcrowding of
C streamlines and directional arrows.
C Experience indicates that a final pleasing
C picture is produced when streamlines are
C initiated in the center of a grid box. The
C streamlines are drawn in one direction then
C in the opposite direction.
C
C REFERENCE The techniques utilized here are described
C in an article by Thomas Whittaker (U. of
C Wisconsin) which appeared in the notes and
C correspondence section of Monthly Weather
C Review, June 1977.
C
C TIMING Highly variable
C It depends on the complexity of the
C flow field and the parameters: DISPL,
C DISPC , CSTOP , INITA , INITB , ITERC ,
C and IGFLG. (See below for a discussion
C of these parameters.) If all values
C are default, then a simple linear
C flow field for a 40 x 40 grid will
C take about 0.4 seconds on the CRAY1-A;
C a fairly complex flow field will take about
C 1.5 seconds on the CRAY1-A.
C
C
C INTERNAL PARAMETERS
C
C NAME DEFAULT FUNCTION
C ---- ------- --------
C
C EXT 0.25 Lengths of the sides of the
C plot are proportional to
C IPTSX and JPTSY except in
C the case when MIN(IPTSX,JPT)
C / MAX(IPTSX,JPTSY) .LT. EXT;
C in that case a square
C graph is plotted.
C
C SIDE 0.90 Length of longer edge of
C plot. (See also EXT.)
C
C XLT 0.05 Left hand edge of the plot.
C (0.0 = left edge of frame)
C (1.0 = right edge of frame)
C
C YBT 0.05 Bottom edge of the plot.
C (0.0 = bottom ; 1.0 = top)
C
C (YBT+SIDE and XLT+SIDE must
C be .LE. 1. )
C
C INITA 2 Used to precondition grid
C boxes to be eligible to
C start a streamline.
C For example, a value of 4
C means that every fourth
C grid box is eligible ; a
C value of 2 means that every
C other grid box is eligible.
C (see INITB)
C
C INITB 2 Used to precondition grid
C boxes to be eligible for
C direction arrows.
C If the user changes the
C default values of INITA
C and/or INITB, it should
C be done such that
C MOD(INITA,INITB) = 0 .
C For a dense grid try
C INITA=4 and INITB=2 to
C reduce the CPU time.
C
C AROWL 0.33 Length of direction arrow.
C For example, 0.33 means
C each directional arrow will
C take up a third of a grid
C box.
C
C ITERP 35 Every 'ITERP' iterations
C the streamline progress
C is checked.
C
C ITERC -99 The default value of this
C parameter is such that
C it has no effect on the
C code. When set to some
C positive value, the program
C will check for streamline
C crossover every 'ITERC'
C iterations. (The routine
C currently does this every
C time it enters a new grid
C box.)
C Caution: When this
C parameter is activated,
C CPU time will increase.
C
C IGFLG 0 A value of zero means that
C the sixteen point Bessel
C Interpolation Formula will
C be utilized where possible;
C when near the grid edges,
C quadratic and bi-linear
C interpolation will be
C used. This mixing of
C interpolation schemes can
C sometimes cause slight
C raggedness near the edges
C of the plot. If IGFLG.NE.0,
C then only the bilinear
C interpolation formula
C is used; this will generally
C result in slightly faster
C plot times but a less
C pleasing plot.
C
C IMSG 0 If zero, then no missing
C U and V components are
C present.
C If .NE. 0, STRMLN will
C utilize the
C bi-linear interpolation
C scheme and terminate if
C any data points are missing.
C
C UVMSG 1.E+36 Value assigned to a missing
C point.
C
C ICYC 0 Zero means the data are
C non-cyclic in the X
C direction.
C If .NE 0, the
C cyclic interpolation
C formulas will be used.
C (Note: Even if the data
C are cyclic in X, leaving
C ICYC = 0 will do no harm.)
C
C DISPL 0.33 The wind speed is
C normalized to this value.
C (See the discussion below.)
C
C DISPC 0.67 The critical displacement.
C If after 'ITERP' iterations
C the streamline has not
C moved this distance, the
C streamline will be
C terminated.
C
C CSTOP 0.50 This parameter controls
C the spacing between
C streamlines. The checking
C is done when a new grid
C box is entered.
C
C DISCUSSION OF Assume a value of 0.33 for DISPL. This
C DISPL,DISPC means that it will take three steps to move
C AND CSTOP across one grid box if the flow was all in the
C X direction. If the flow is zonal, then a
C larger value of DISPL is in order.
C If the flow is highly turbulent, then
C a smaller value is in order. The smaller
C DISPL, the more the CPU time. A value
C of 2 to 4 times DISPL is a reasonable value
C for DISPC. DISPC should always be greater
C than DISPL. A value of 0.33 for CSTOP would
C mean that a maximum of three stream-
C lines will be drawn per grid box. This max
C will normally only occur in areas of singular
C points.
C
C ***************************
C Any or all of the above
C parameters may be changed
C by utilizing common blocks
C STR02 and/or STR03
C ***************************
C
C UXSML A number which is small
C compared to the average
C normalized u component.
C Set automatically.
C
C NCHK 750 This parameter is located
C in DRWSTR. It specifies the
C length of the circular
C lists used for checking
C for STRMLN crossovers.
C For most plots this number
C may be reduced to 500
C or less and the plots will
C not be altered.
C
C ISKIP Number of bits to be
C skipped to get to the
C least two significant bits
C in a floating point number.
C The default value is set to
C I1MACH(5) - 2 . This value
C may have to be changed
C depending on the target
C computer; see subroutine
C DRWSTR.
C
C
C
DIMENSION U(IMAX,JPTSY) ,V(IMAX,JPTSY) ,
1 WORK(IMAX*JPTSY+1)
DIMENSION WNDW(4) ,VWPRT(4)
C
COMMON /STR01/ IS ,IEND ,JS ,JEND
1 , IEND1 ,JEND1 ,I ,J
2 , X ,Y ,DELX ,DELY
3 , ICYC1 ,IMSG1 ,IGFL1
COMMON /STR02/ EXT , SIDE , XLT , YBT
COMMON /STR03/ INITA , INITB , AROWL , ITERP , ITERC , IGFLG
1 , IMSG , UVMSG , ICYC , DISPL , DISPC , CSTOP
C
SAVE
C
C THE FOLLOWING CALL IS FOR MONITORING LIBRARY USE AT NCAR
C
CALL Q8QST4 ( 'GRAPHX', 'STRMLN', 'STRMLN', 'VERSION 01')
C
IER = 0
C
C LOAD THE COMMUNICATION COMMON BLOCK WITH PARAMETERS
C
IS = 1
IEND = IPTSX
JS = 1
JEND = JPTSY
IEND1 = IEND-1
JEND1 = JEND-1
IEND2 = IEND-2
JEND2 = JEND-2
XNX = FLOAT(IEND-IS+1)
XNY = FLOAT(JEND-JS+1)
ICYC1 = ICYC
IGFL1 = IGFLG
IMSG1 = 0
C
C IF ICYC .NE. 0 THEN CHECK TO MAKE SURE THE CYCLIC CONDITION EXISTS.
C
IF (ICYC1.NE.0) CALL CHKCYC (U,V,IMAX,JPTSY,IER)
C
C SAVE ORIGINAL NORMALIZATION TRANSFORMATION NUMBER
C
CALL GQCNTN ( IERR,NTORIG )
C
C SET UP SCALING
C
IF (NSET) 10 , 20 , 60
10 CALL GETUSV ( 'LS' , ITYPE )
CALL GQNT ( NTORIG,IERR,WNDW,VWPRT )
CALL GETUSV('LS',IOLLS)
X1 = VWPRT(1)
X2 = VWPRT(2)
Y1 = VWPRT(3)
Y2 = VWPRT(4)
X3 = IS
X4 = IEND
Y3 = JS
Y4 = JEND
GO TO 55
C
20 ITYPE = 1
X1 = XLT
X2 = (XLT+SIDE)
Y1 = YBT
Y2 = (YBT+SIDE)
X3 = IS
X4 = IEND
Y3 = JS
Y4 = JEND
IF (AMIN1(XNX,XNY)/AMAX1(XNX,XNY).LT.EXT) GO TO 50
IF (XNX-XNY) 30, 50, 40
30 X2 = (SIDE*(XNX/XNY) + XLT)
GO TO 50
40 Y2 = (SIDE*(XNY/XNX) + YBT)
50 CONTINUE
C
C CENTER THE PLOT
C
DX = 0.25*( 1. - (X2-X1) )
DY = 0.25*( 1. - (Y2-Y1) )
X1 = (XLT+DX)
X2 = (X2+DX )
Y1 = (YBT+DY)
Y2 = (Y2+DY )
C
55 CONTINUE
C
C SAVE NORMALIZATION TRANSFORMATION 1
C
CALL GQNT ( 1,IERR,WNDW,VWPRT )
C
C DEFINE AND SELECT NORMALIZATION TRANS, SET LOG SCALING
C
CALL SET(X1,X2,Y1,Y2,X3,X4,Y3,Y4,ITYPE)
C
IF (NSET.EQ.0) CALL PERIM (1,0,1,0)
C
60 CONTINUE
C
C DRAW THE STREAMLINES
C . BREAK THE WORK ARRAY INTO TWO PARTS. SEE DRWSTR FOR FURTHER
C . COMMENTS ON THIS.
C
CALL DRWSTR (U,V,WORK(1),WORK(IMAX*JPTSY+1),IMAX,JPTSY)
C
C RESET NORMALIATION TRANSFORMATION 1 TO ORIGINAL VALUES
C
IF (NSET .LE. 0) THEN
CALL SET(VWPRT(1),VWPRT(2),VWPRT(3),VWPRT(4),
- WNDW(1),WNDW(2),WNDW(3),WNDW(4),IOLLS)
ENDIF
CALL GSELNT (NTORIG)
C
RETURN
END
BLOCK DATA
c
c#######################################################################
c
c Initialize parameters for STRMLN.
c
c#######################################################################
c
COMMON /STR01/ IS ,IEND ,JS ,JEND
1 , IEND1 ,JEND1 ,I ,J
2 , X ,Y ,DELX ,DELY
3 , ICYC1 ,IMSG1 ,IGFL1
COMMON /STR02/ EXT , SIDE , XLT , YBT
COMMON /STR03/ INITA , INITB , AROWL , ITERP , ITERC , IGFLG
1 , IMSG , UVMSG , ICYC , DISPL , DISPC , CSTOP
C
DATA EXT / 0.25/,
: SIDE / 0.90/,
: XLT / 0.05/,
: YBT / 0.05/,
: INITA/ 6/,
: INITB/ 6/,
: AROWL/ 0.33/,
: ITERP/ 35/,
: ITERC/ -99/,
: IGFLG/ 0/,
: ICYC / 0/,
: IMSG / 0/,
: UVMSG/ 1.E+36/,
: DISPL/ 0.33/,
: DISPC/ 0.67/,
: CSTOP/ 0.50/
END
SUBROUTINE XWRTCTBL(rgb_table,nc_max) 1,2
c#######################################################################
c
c Activate pre-defined color table in rgb_table
c
c#######################################################################
integer nc_max,j,jj
real rgb_table(3,nc_max)
integer ncoltable
CALL XQCLRTBL( ncoltable )
if( ncoltable.lt.0 ) goto 100
if( ncoltable.eq.0 ) then
rgb_table(1,1) = 0.
rgb_table(2,1) = 0.
rgb_table(3,1) = 0.
DO j=2,nc_max
rgb_table(1,j) = 1.
rgb_table(2,j) = 1.
rgb_table(3,j) = 1.
END DO
elseif( ncoltable.ne.4. ) then
rgb_table(1,1) = 0.
rgb_table(2,1) = 0.
rgb_table(3,1) = 0.
rgb_table(1,2) = 1.
rgb_table(2,2) = 1.
rgb_table(3,2) = 1.
endif
100 continue
DO j=1,nc_max
jj = j -1
CALL gscr(1,jj,rgb_table(1,j),rgb_table(2,j),rgb_table(3,j))
END DO
CALL gsplci(1)
CALL gspmci(1)
CALL gstxci(1)
CALL xafstyl(1) ! Set default area fill pattern to solid
RETURN
END
c
SUBROUTINE COLOR (icolor) 36,2
integer icolor
call xcolor(icolor)
RETURN
END
SUBROUTINE XCOLOR(icolor) 86,1
c
c#######################################################################
c
c PURPOSE:
c
c Set the color index for line, text, marker and area fill.
c
c#######################################################################
c
c INPUT:
c
c icolor color index corresponding to the color table set by
c setcolors.
c
c#######################################################################
c
c Variable Declarations.
c
c#######################################################################
c
implicit none
c
integer icolor,ii
integer kolor,lcolor
save kolor
data kolor /1/
c
C@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
C
C Beginning of executable code...
C
C@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
c
c
c To set the polyline color index, use
kolor = icolor
CALL SFLUSH ! flush line segments before changing color
ii = Min (icolor,299)
ii = Max (ii,0)
CALL GSPLCI (ii)
c To set the polymarker color index, use
CALL GSPMCI (ii)
c To set the text color index, use
CALL GSTXCI (ii)
c To set the fill area color index, use
CALL GSFACI (ii)
RETURN
ENTRY XQCOLOR(lcolor)
lcolor = kolor
RETURN
END
subroutine xpsfn(fn) 2
character fn*(*)
return
end
subroutine xpaprlnth(yside) 2
real yside
return
end
subroutine xpscmnt(ch) 10,1
character*(*) ch
return
end