c
c ZXPLOT plotting package developed by Ming Xue with
c contributions from Zuojun Zhang.
c The author reserves all rights to the package.
c
c Change history:
c
c Version 2.2: Window clipping and multilevel rotated rectangular
c masking added. May, 1991.
c
c Version 2.2a:
c All printing output are routed to fortran unit NCH. 11/30/91.
c Subroutine xstchn(nch) added.
c
c Version 2.2b.
c subroutine xqspac added. (4/3/1992)
c
c Version 2.2c (10/25/1993)
c Added bad value skipping capability in the contour routines.
c Zhang Zuojun and Ming Xue.
c
c This file contains subroutines common to all versions (PS and NCAR graphics
c version)
c
c Correction made in xaxinc (4/20/94)
c
c 8/31/1995
c Wind vector unit is now subject to the limit of vmax also.
c
c 1/24/96.
c Fixed a problem in XVECTU with the first guess of umax,umin,vmax,vmin
c when the first value is missing.
c
c 2/3/96 (M.Xue)
c fixed a problem in xnwpic when the rotation angle is 90.0 for xspace.
c
c 10/13/1998 (M. Xue)
c Added cross-hatching routines (xhatcha etc.) at arbitary angles.
c
c Added routine XCTRHL to label H and L contour centers. It is
c called within XCONTA when XHLLABL is called with argument 1 or 2.
c H and L labeling is off by default.
c
c Reorganized the subroutine into three files. zxplot3.f contains
c common subroutines for all versions (e.g. PS and NCARgraphics versions),
c zxpslib3.f, zxnglib3.f and zxgenlib3.f contains version dependent
c subroutines, and xncar3.f and xpost3.f contain package dependent
c drivers.
c
c ZXPLOT is upgrade to Version 3.0
c
c 11/19/1998 (Ming Xue)
c Added subroutine XSETCLRS and other color related routines.
c
c Streamline routines for color filled maps (XCOLFIL),
c variable colored contours (mode=4 for XCONTA).
c Included map projection setup routines in zxplot3.f.
c Also include map plotting XDRAWMAP.
c
c Added color map number five.
c Added wind barb plotting routines, XBARB and XBARBS.
c
c
c To do list:
c Use buffer to store line segments. Remove redundant movetos.
c Streamline color palette plotting routine.
c Wind barbs scaling still an issue.
c Tune fond sizes for PS
c
c Work on ZXPLOT Version 3.0 User's Guide.
c Document new routines.
c
c Known problems: Missing value handling is not quite right for
c xhatcha.
c
c Known problem: xcontc sometimes run into infinite loop
c and overwrite the arrays for storing the line segments
c
c Added subroutine xcontc1, a simpler but less efficient version
c of contour color mapping routine. Entry xcontcopt added to
c set the option for using xcontc or xcontc1. One can also
c set the option via common block xcontc_opt.
c xcontc1 does not share the problem with xcontc.
c
c Added an option for XCOLFIL to plot pixdel type color fill
c of a 2-D field. Call xcontcopt(3) before call xcolfil to
c activate this option. XPIXELFIL is called by xcolfil in this
c case instead of xcontc or xcontc1.
c
c Added subroutine XCTR_THICK_THIN_RATIO to change to default
c line thinkness ratio between highlighted thick contours to
c thin contours. The default is 2.
c
c Fix dead-loop problem with contouring routines (XCONTR and XCONTJ) (YHW)
c
SUBROUTINE XMINIT 2,5
C To initialize ZXPLOT package (Called by XDEVIC when setting up device)
CHARACTER CLABEL*20
COMMON /XPSD01/ XSIDE, YSIDE
COMMON /XPHY01/ PL,PR,PB,PT,XRANGE,YRANGE
COMMON /XPHO03/ DXPO,DYPO
COMMON /XMAP04/ X1,X2,Y1,Y2,XSCALE,YSCALE
COMMON /XMAO05/ DXMOP,DYMOP
COMMON /XFTR06/ XFACTR,YFACTR
COMMON /XPRF07/ XPREF,YPREF
COMMON /XMRF08/ XMREF,YMREF,XMPREF,YMPREF
COMMON /XAGS09/ DRANG,CRANG,XANGLE,XSYMAN,SRANG,KSR,XA,YA
COMMON /XSCS10/ SINDRA,COSDRA,SINMRA,COSMRA,SINSRA,COSSRA
: ,SINXA,COSXA,SINYA,COSYA ,CHSIN,CHCOS
COMMON /XPEN11/ XPEN,YPEN,FLEN,BLEN,NPD,XMPEN,YMPEN
COMMON /XCHA20/ HCTR,SCTR,CRATIO, KFONT,NUNDLN
COMMON /XASC12/ IASCII(300)
COMMON /XCHP21/ XCHPEN, YCHPEN ,XCHMO,YCHMO,XCHPO,YCHPO
COMMON /XLPN13/ HF1,HB1,HF2,HB2,LFULL,lfull0,LTHICK,DTHICK
COMMON /XLAB14/ DLABEL,WLABEL,HLABEL,SIZLB,KLBTYP,ICLI,ICLON
COMMON /XLAB15/ CLABEL
COMMON /XLAB16/ LCLAB
COMMON /XLBA33/ LABROT
COMMON /XCRF17/ CLREF,LCPTN,LABTYP,ICLF,LHILIT,IHLF,KCT0
COMMON /XAXS18/ KANX,KANY, KTKX,KTKY
COMMON /XCLM19/ NMIN, NMAX
COMMON /XCDV23/ NSUBDV
COMMON /XCMD24/ MTD
COMMON /XCIR25/ XCIR(9) ,YCIR(9) , RPOINT
COMMON /XPRJ26/ KPROJC
COMMON /XCHR31/ CHDATA
COMMON /XCHR32/ ICDATA
COMMON /XFMT33/ LBFMT, AXFMT
COMMON /XFMT34/ LLBFMT,LAXFMT
COMMON /XHCH35/ DH
COMMON /XART36/ KARTYP,KVMODE,VSC
COMMON /XAXM35/ NTMAG, ANMAG, ANSIZ
COMMON /XHLL36/ hllabel
COMMON /ZCHOLE/ NHOLE,SPECIA,nvtrbadv
common /xwndw1/ xw1,xw2,yw1,yw2, iwndon
common /xmask1/ xm1(99),xm2(99),ym1(99),ym2(99),rmangl(99),
: cosmsa(99),sinmsa(99),lvlmsk
common /xcwndw/ icwndw, xcpen, ycpen
common /xoutch/ nch
integer ncunique
integer icoltable
common /xcltbl/ ncunique,icoltable
integer iclrbgn,iclrend ! Beginning and ending colors of contours
common /xctrclor/iclrbgn,iclrend
real ctrmin, ctrmax
common /xctrmx/ ctrmin, ctrmax
integer nctrlvls_max
parameter(nctrlvls_max=1000) ! Max. number of contour values
real ctrlvls(nctrlvls_max) ! contour values dividing the filled areas
integer clrindx(nctrlvls_max) ! plot color index bar color index
integer nctrlvls ! Number of contour levels
common /xcflvls/nctrlvls,ctrlvls,clrindx
common /xfctr1/ fctr
CHARACTER CHDATA(127)*300,LBFMT*50,AXFMT*10
INTEGER ICDATA (0:150, 32:127)
INTEGER NASCII(300)
character cpalnfmt*15
common /xcplnfmt/ cpalnfmt
integer labmask
common /labmask1/ labmask
common /xlimzf/ limzf, zfmax, zfmin
integer icontcopt
common /xcontc_opt/ icontcopt
integer ictr_thick_thin_ratio
common /ctr_thick_thin_ratio/ ictr_thick_thin_ratio
integer icplswitch
common /xcplswitch/ icplswitch
C Note XSIDE and YSIDE are the length of the ND-space x and y sides.
C They should be defined outside this package passing through common
C block PSIDES. The prefered values are XSIDE=1.5, YSIDE=1.0
PL=0.0
PR=XSIDE
PB=0.0
PT=YSIDE
XRANGE=PR-PL
YRANGE=PT-PB
fctr = sqrt( abs(xrange * yrange) )
X1=0.0
X2=1.0
Y1=0.0
Y2=1.0
XSCALE=X2-X1
YSCALE=Y2-Y1
XFACTR=XRANGE/XSCALE
YFACTR=YRANGE/YSCALE
XMREF=X1
YMREF=Y1
XMPREF=PL
YMPREF=PB
XPREF=0.5*(PL+PR)
XPREF=0.5*(PT+PB)
DXPO=0.0
DYPO=0.0
DXMOP=0.0
DYMOP=0.0
XMPEN=XMREF
YMPEN=YMREF
HCTR=0.02
SCTR=0.02/YFACTR
CRATIO=0.75
KFONT=2
NUNDLN=0
DRANG=0.0
CRANG=0.0
SRANG=90.0
KSR=0
XA=0.0
YA=0.0
SINDRA=0.0
COSDRA=1.0
SINMRA=0.0
COSMRA=1.0
SINSRA=1.0
COSSRA=0.0
SINXA=0.0
COSXA=1.0
SINYA=0.0
COSYA=1.0
XANGLE=CRANG+DRANG+(90-SRANG)*KSR+XA
XSYMAN=0.0
CHSIN=0.0
CHCOS=1.0
HHH =0.001*YSIDE
HF1=HHH*10
HB1=HHH*5
HF2=HHH*10
HB2=HHH*5
LFULL =1
LFULL0=1
LTHICK=1
DTHICK=0.0007*YSIDE
ICLI=3
CLABEL=' '
LCLAB=1
DLABEL=XRANGE/ICLI
HLABEL=0.015
SIZLB =0.015
LABROT=1
KLBTYP=-1
WLABEL=HLABEL*LCLAB*0.77
ICLON=0
CLREF=0.0
LCPTN=0
LABTYP=2
ICLF=2
LHILIT=1
IHLF=4
KCT0=1
KANX=-1
KTKX=1
KANY=-1
KTKY=1
AXFMT= '*'
LBFMT= '*'
LLBFMT=1
LAXFMT=1
DH=0.015
KARTYP=2
KVMODE=1
VSC=1.0
NTMAG=0
hllabel=0
NMIN=8
NMAX=20
NSUBDV=4
MTD=0
iwndon=0
icwndw=0
lvlmsk=0
nch = 6
NHOLE=0
nvtrbadv=0
SPECIA=-9999.
ctrmin = 0.0
ctrmax = 0.0
icoltable = 1
iclrbgn = 1
iclrend = 1
nctrlvls=0
cpalnfmt = '*'
labmask = 0
limzf=0
zfmin=-999.0
zfmax= 999.0
icontcopt=1
ictr_thick_thin_ratio = 2
Print*,'icplswitch set to 1 in XMINIT'
icplswitch = 1
PI=4*ATAN(1.)
DO 6 I=1,9
XCIR(I)=COS((I-1)*0.25*PI)
6 YCIR(I)=SIN((I-1)*0.25*PI)
RPOINT=0.0010*YSIDE
KPROJC=0
DO 10 I=1,300
10 IASCII(I)=NASCII(I)
CALL XINTMKR
GOTO ( 501, 502, 503, 504 ) KFONT
501 CALL XCSETB(CHDATA)
GOTO 505
502 CALL XCSETC(CHDATA)
GOTO 505
503 CALL XCSETA(CHDATA)
GOTO 505
504 CALL XCSETD(CHDATA)
505 CONTINUE
DO 1 I=32,127
1 ICDATA(0,I)=0
RETURN
DATA NASCII /
* 1-16
+000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,
* 17-32
+000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,
* 33-48
+000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,
* 49-64
+000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,32 ,
* 65-80
+000,000,000,000,000,000,000,000,000,000,46 ,60 ,40 ,43 ,124,38 ,
* 81-96
+000,000,000,000,000,000,000,000,000,33 ,36 ,42 ,41 ,59 ,126,45 ,
* 97-112
+47 ,000,000,000,000,000,000,000,000,000,44 ,37 ,95 ,62 ,63 ,000,
* 113-128
+94 ,000,000,000,000,000,000,000,96 ,58 ,35 ,64 ,000,61 ,34 ,000,
* 129-144
+97 ,98 ,99 ,100,101,102,103,104,105,000,000,000,000,000,000,000,
* 145-160
+106,107,108,109,110,111,112,113,114,000,000,000,000,000,000,000,
* 161-176
+000,115,116,117,118,119,120,121,122,000,000,000,91 ,000,000,000,
* 177-192
+000,000,000,000,000,000,000,000,000,000,000,000,93 ,000,000,123,
* 193-208
+65 ,66 ,67 ,68 ,69 ,70 ,71 ,72 ,73 ,000,000,000,000,000,000,125,
* 209-224
+74 ,75 ,76 ,77 ,78 ,79 ,80 ,81 ,82 ,000,000,000,000,000,000,92 ,
* 225-240
+000,83 ,84 ,85 ,86 ,87 ,88 ,89 ,90 ,000,000,000,000,000,000,48 ,
* 241-256
+49 ,50 ,51 ,52 ,53 ,54 ,55 ,56 ,57 ,000,000,000,000,000,000,000,
* 257-272
+000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,
* 273-288
+000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,
* 289-300
+000,000,000,000,000,000,000,000,000,000,000,000 /
END
c
SUBROUTINE XSETCLRS(col_tab) 11,1
c
c#######################################################################
c
c PURPOSE:
c
c Setup the color tables for ZXPLOT.
c
c#######################################################################
c
c AUTHOR: Min Zou
c 8/28/94
c
c 1/17/96 (Ming Xue).
c Added call to xafsty to set the default style of area fill
c that uses GFA.
c
c 1/20/96 (Min Zou)
c Added grayscale color table (col_tab=4, and user-specfied
c color table (read in from a file) options.
c
c 4/15/96 (Zuojun Zhang)
c Added multi-color scales (col_tab=5) and eliminate loading
c unreferenced color table definition in the previous version.
c
c 11/16/1998 (Ming Xue)
c Unified the NCAR graphics and PS versions.
c
c#######################################################################
c
c
c INPUT:
c
c col_tab = -1, color table read in from file coltabfn, which
c can be set using entry XSTCTFN.
c = 0, Black and white plot. All lines are black.
c = 1, Predefined color table No. 1.
c = 2, Predefined color table No. 2,
c which is No.1 in reversed order.
c = 3, Predefined color table No. 3.
c = 4, Gray scale color table.
c = 5, predefined 200 multi-spectum color table (zj).
c
c#######################################################################
c
c Variable Declarations.
c
c#######################################################################
c
implicit None
c
integer i,nc_max,col_table_no,j,jj
integer col_tab,sum_colors,lenfil
parameter (nc_max=256,col_table_no=20)
real rgbv(3,25),rgbf(3,18),rgbg(3,18),rgb_zj(3,200),rgb6(3,139)
real rgb_table(3,nc_max)
logical fexist
data rgb_table /768*1./ ! initial set rgb
character*80 coltabfn
character col_tab_fn*(*)
save coltabfn
data coltabfn /'zx_color.tbl'/
integer ncunique , ncoltable
integer icoltable
common /xcltbl/ ncunique,icoltable
c Index: for color table 1
c 0=bLack 1=white 2=yellow 3=dark 4=royal 5=light 6=sky 7=turquoise
c 8=aqua 9=olive 10=yellow-green 11=light 12=bright 13=kelly 14=green
c 15=yellow 16=maize 17=orange 18=red-orange 19=bright 20=red 21=dark
c 22=brown c 23=violet 24= mauve
C
data ((rgbv(i,j),i=1,3),j=1,25)/
: 1.000, 1.000, 1.000, 0.000, 0.000, 0.000,
: 1.000, 0.804, 0.000, 0.000, 0.000, 0.702,
: 0.000, 0.353, 1.000, 0.000, 0.553, 1.000,
: 0.000, 0.753, 1.000, 0.000, 1.000, 1.000,
: 0.631, 1.000, 1.000, 0.073, 0.612, 0.015,
: 0.087, 0.737, 0.018, 0.095, 0.799, 0.019,
: 0.102, 0.862, 0.021, 0.110, 0.924, 0.022,
: 0.119, 1.000, 0.024, 1.000, 1.000, 0.000,
: 1.000, 0.804, 0.000, 1.000, 0.604, 0.000,
: 1.000, 0.400, 0.000, 1.000, 0.000, 0.000,
: 0.804, 0.000, 0.000, 0.604, 0.000, 0.000,
: 0.400, 0.000, 0.000, 0.400, 0.000, 0.400,
: 0.559, 0.085, 0.433 /
C Index for color table 3:
c 0=black 1=white 2=yellow 3=turquoise 4=carolina 5=blue 6=bright
c 7=green 8=dark 9=yellow 10=dark 11=orange 12=bright 13=red 14=dark
c 15=magenta 16=purple 17= white
data ((rgbf(i,j),i=1,3),j=1,18)/
: 1.000, 1.000, 1.000, 0.000, 0.000, 0.000,
: 1.000, 0.804, 0.000, 0.000, 0.925, 0.925,
: 0.004, 0.627, 0.961, 0.000, 0.000, 0.965,
: 0.000, 1.000, 0.000, 0.000, 0.784, 0.000,
: 0.000, 0.565, 0.000, 1.000, 1.000, 0.000,
: 0.906, 0.753, 0.000, 1.000, 0.565, 0.000,
: 1.000, 0.000, 0.000, 0.839, 0.000, 0.000,
: 0.753, 0.000, 0.000, 1.000, 0.000, 1.000,
: 0.600, 0.333, 0.788, 1.000, 1.000, 1.000 /
c
C Index for color table 5:
data ((rgb_zj(i,j),i=1,3),j=1,38)/
: 1.000, 1.000, 1.000, 0.000, 0.000, 0.000,
: 1.000, 0.000, 0.000, 0.000, 1.000, 0.000,
: 0.000, 0.000, 1.000, 1.000, 1.000, 0.000,
: 0.000, 1.000, 1.000, 1.000, 0.000, 1.000,
: 0.631, 1.000, 1.000, 0.000, 0.000, 0.702,
: 0.300, 0.000, 0.000, 0.478, 0.000, 0.000,
: 0.656, 0.000, 0.000, 0.834, 0.000, 0.000,
: 1.000, 0.006, 0.006, 0.992, 0.198, 0.000,
: 1.000, 0.356, 0.012, 1.000, 0.517, 0.029,
: 1.000, 0.688, 0.036, 1.000, 0.883, 0.019,
: 0.902, 1.000, 0.178, 0.818, 1.000, 0.440,
: 0.813, 1.000, 0.623, 0.848, 1.000, 0.766,
: 0.930, 1.000, 0.883, 0.883, 1.000, 0.930,
: 0.766, 1.000, 0.848, 0.623, 1.000, 0.813,
: 0.440, 1.000, 0.818, 0.178, 1.000, 0.902,
: 0.019, 0.883, 1.000, 0.036, 0.688, 1.000,
: 0.029, 0.517, 1.000, 0.012, 0.356, 1.000,
: 0.000, 0.198, 0.992, 0.006, 0.006, 1.000,
: 0.000, 0.000, 0.834, 0.000, 0.000, 0.656/
data ((rgb_zj(i,j),i=1,3),j=39,76)/
: 0.000, 0.000, 0.478, 0.000, 0.000, 0.300,
: 0.300, 0.000, 0.000, 0.567, 0.000, 0.000,
: 0.834, 0.000, 0.000, 1.000, 0.051, 0.051,
: 1.000, 0.184, 0.184, 1.000, 0.358, 0.277,
: 1.000, 0.529, 0.373, 1.000, 0.698, 0.471,
: 1.000, 0.859, 0.577, 1.000, 1.000, 0.702,
: 0.926, 1.000, 0.777, 0.795, 1.000, 0.641,
: 0.644, 1.000, 0.525, 0.483, 1.000, 0.419,
: 0.317, 1.000, 0.317, 0.184, 1.000, 0.184,
: 0.051, 1.000, 0.051, 0.000, 0.834, 0.000,
: 0.000, 0.567, 0.000, 0.000, 0.300, 0.000,
: 0.000, 0.000, 0.300, 0.000, 0.000, 0.567,
: 0.000, 0.000, 0.834, 0.050, 0.050, 1.000,
: 0.184, 0.184, 1.000, 0.353, 0.282, 1.000,
: 0.520, 0.382, 1.000, 0.680, 0.489, 1.000,
: 0.831, 0.605, 1.000, 0.958, 0.745, 1.000,
: 1.000, 0.745, 0.958, 1.000, 0.605, 0.831,
: 1.000, 0.489, 0.680, 1.000, 0.382, 0.520,
: 1.000, 0.282, 0.353, 1.000, 0.184, 0.184/
data ((rgb_zj(i,j),i=1,3),j=77,114)/
: 1.000, 0.051, 0.051, 0.834, 0.000, 0.000,
: 0.567, 0.000, 0.000, 0.300, 0.000, 0.000,
: 0.000, 0.300, 0.000, 0.000, 0.567, 0.000,
: 0.000, 0.834, 0.000, 0.051, 1.000, 0.051,
: 0.184, 1.000, 0.184, 0.277, 1.000, 0.358,
: 0.373, 1.000, 0.529, 0.471, 1.000, 0.698,
: 0.577, 1.000, 0.859, 0.702, 1.000, 1.000,
: 0.777, 0.926, 1.000, 0.641, 0.795, 1.000,
: 0.525, 0.644, 1.000, 0.419, 0.483, 1.000,
: 0.317, 0.317, 1.000, 0.184, 0.184, 1.000,
: 0.050, 0.050, 1.000, 0.000, 0.000, 0.834,
: 0.000, 0.000, 0.567, 0.000, 0.000, 0.300,
: 0.901, 0.901, 0.901, 0.812, 0.812, 0.812,
: 0.723, 0.723, 0.723, 0.634, 0.634, 0.634,
: 0.545, 0.545, 0.545, 0.456, 0.456, 0.456,
: 0.367, 0.367, 0.367, 0.278, 0.278, 0.278,
: 0.189, 0.189, 0.189, 0.100, 0.100, 0.100,
: 0.200, 0.000, 1.000, 0.349, 0.000, 1.000,
: 0.503, 0.000, 1.000, 0.676, 0.000, 1.000/
data ((rgb_zj(i,j),i=1,3),j=115,152)/
: 0.880, 0.000, 1.000, 1.000, 0.100, 0.880,
: 1.000, 0.200, 0.676, 1.000, 0.300, 0.503,
: 1.000, 0.200, 0.349, 1.000, 0.100, 0.200,
: 1.000, 0.200, 0.000, 1.000, 0.349, 0.000,
: 1.000, 0.503, 0.000, 1.000, 0.676, 0.000,
: 1.000, 0.880, 0.000, 0.880, 1.000, 0.000,
: 0.676, 1.000, 0.000, 0.503, 1.000, 0.000,
: 0.349, 1.000, 0.000, 0.200, 1.000, 0.000,
: 0.100, 1.000, 0.200, 0.200, 1.000, 0.349,
: 0.300, 1.000, 0.503, 0.200, 1.000, 0.676,
: 0.100, 1.000, 0.880, 0.000, 0.880, 1.000,
: 0.000, 0.676, 1.000, 0.000, 0.503, 1.000,
: 0.000, 0.349, 1.000, 0.000, 0.200, 1.000,
: 0.300, 0.000, 0.000, 0.567, 0.000, 0.000,
: 0.834, 0.000, 0.000, 1.000, 0.051, 0.051,
: 1.000, 0.184, 0.184, 1.000, 0.317, 0.317,
: 1.000, 0.451, 0.451, 1.000, 0.585, 0.585,
: 1.000, 0.718, 0.718, 1.000, 0.851, 0.851,
: 0.702, 1.000, 1.000, 0.436, 1.000, 1.000/
data ((rgb_zj(i,j),i=1,3),j=153,190)/
: 0.169, 1.000, 1.000, 0.000, 0.951, 0.951,
: 0.000, 0.817, 0.817, 0.000, 0.684, 0.684,
: 0.000, 0.551, 0.551, 0.000, 0.417, 0.417,
: 0.000, 0.284, 0.284, 0.000, 0.150, 0.150,
: 0.000, 0.300, 0.000, 0.000, 0.567, 0.000,
: 0.000, 0.834, 0.000, 0.051, 1.000, 0.051,
: 0.184, 1.000, 0.184, 0.317, 1.000, 0.317,
: 0.451, 1.000, 0.451, 0.585, 1.000, 0.585,
: 0.718, 1.000, 0.718, 0.851, 1.000, 0.851,
: 0.851, 0.851, 1.000, 0.718, 0.718, 1.000,
: 0.585, 0.585, 1.000, 0.451, 0.451, 1.000,
: 0.317, 0.317, 1.000, 0.184, 0.184, 1.000,
: 0.050, 0.050, 1.000, 0.000, 0.000, 0.834,
: 0.000, 0.000, 0.567, 0.000, 0.000, 0.300,
: 0.150, 0.150, 0.000, 0.284, 0.284, 0.000,
: 0.417, 0.417, 0.000, 0.551, 0.551, 0.000,
: 0.684, 0.684, 0.000, 0.817, 0.817, 0.000,
: 0.951, 0.951, 0.000, 1.000, 1.000, 0.169,
: 1.000, 1.000, 0.436, 1.000, 1.000, 0.702/
data ((rgb_zj(i,j),i=1,3),j=191,200)/
: 1.000, 0.702, 1.000, 1.000, 0.436, 1.000,
: 1.000, 0.169, 1.000, 0.951, 0.000, 0.951,
: 0.817, 0.000, 0.817, 0.684, 0.000, 0.684,
: 0.551, 0.000, 0.551, 0.417, 0.000, 0.417,
: 0.284, 0.000, 0.284, 0.150, 0.000, 0.150/
C Index for color table 6:
data ((rgb6(i,j),i=1,3),j=1,57)/
: 1.000,1.000,1.000,0.000,0.000,0.000,0.200,0.200,0.200,
: 0.350,0.350,0.350,0.500,0.500,0.500,0.650,0.650,0.650,
: 0.800,0.800,0.800,1.000,1.000,0.000,0.000,0.553,1.000,
: 0.000,0.753,1.000,0.000,1.000,1.000,0.631,1.000,1.000,
: 0.100,0.800,0.100,0.200,0.900,0.200,0.500,1.000,0.200,
: 0.500,0.900,0.500,1.000,1.000,0.000,1.000,0.804,0.000,
: 1.000,0.604,0.000,1.000,0.400,0.000,1.000,0.000,0.000,
: 0.900,0.300,0.400,0.800,0.000,0.900,0.900,0.000,1.000,
: 0.800,0.700,0.800,0.700,0.600,0.700,0.600,0.500,0.600,
: 0.500,0.400,0.500,0.000,0.925,0.925,0.004,0.627,0.961,
: 0.000,0.000,0.965,0.000,1.000,0.000,0.000,0.784,0.000,
: 0.000,0.565,0.000,1.000,1.000,0.000,0.906,0.753,0.000,
: 1.000,0.565,0.000,1.000,0.000,0.000,0.839,0.000,0.000,
: 0.753,0.000,0.000,1.000,0.000,1.000,0.600,0.333,0.788,
: 0.900,0.900,0.900,1.000,0.000,1.000,0.749,0.000,1.000,
: 0.498,0.000,1.000,0.000,0.000,1.000,0.000,0.349,1.000,
: 0.000,0.549,1.000,0.000,0.749,1.000,0.000,1.000,1.000,
: 0.000,0.902,0.800,0.000,0.800,0.498,0.000,0.702,0.000,
: 0.498,0.800,0.000,0.800,0.902,0.000,1.000,1.000,0.000/
data ((rgb6(i,j),i=1,3),j=58,114)/
: 1.000,0.800,0.000,1.000,0.600,0.000,1.000,0.400,0.000,
: 1.000,0.000,0.000,0.800,0.000,0.000,0.600,0.000,0.000,
: 0.400,0.000,0.000,0.400,0.000,0.400,0.600,0.000,0.600,
: 0.800,0.000,0.800,1.000,0.000,1.000,0.749,0.000,1.000,
: 0.498,0.000,1.000,0.050,0.050,0.050,0.100,0.100,0.100,
: 0.900,0.900,0.900,0.950,0.950,0.950,1.000,0.000,0.800,
: 1.000,0.000,1.000,0.800,0.000,1.000,0.600,0.000,1.000,
: 0.400,0.000,1.000,0.000,0.000,1.000,0.000,0.400,1.000,
: 0.000,0.600,1.000,0.000,0.800,1.000,0.000,1.000,1.000,
: 0.000,1.000,0.800,0.000,1.000,0.600,0.000,1.000,0.000,
: 0.600,1.000,0.000,0.800,1.000,0.000,1.000,1.000,0.000,
: 1.000,0.800,0.000,1.000,0.600,0.000,1.000,0.400,0.000,
: 1.000,0.000,0.000,1.000,0.000,0.400,1.000,0.000,0.600,
: 1.000,0.000,0.800,1.000,0.000,1.000,0.800,0.000,1.000,
: 0.600,0.000,1.000,0.400,0.000,1.000,0.000,0.000,1.000,
: 0.000,0.400,1.000,0.000,0.600,1.000,0.000,0.800,1.000,
: 0.800,0.600,0.400,1.000,0.800,0.600,1.000,1.000,0.600,
: 0.600,1.000,0.400,0.400,1.000,0.600,0.000,1.000,0.000,
: 0.200,0.800,0.600,0.200,0.600,0.400,0.100,0.400,0.200/
data ((rgb6(i,j),i=1,3),j=115,139)/
: 1.000,0.804,0.000,1.000,0.604,0.000,1.000,0.400,0.000,
: 0.000,1.000,1.000,0.000,0.500,1.000,0.000,0.000,1.000,
: 0.400,0.400,1.000,0.600,0.600,1.000,0.800,0.800,1.000,
: 1.000,1.000,1.000,1.000,0.800,0.800,1.000,0.600,0.600,
: 1.000,0.400,0.400,1.000,0.000,0.000,1.000,0.500,0.000,
: 1.000,1.000,0.000,1.000,0.878,0.584,0.898,0.780,0.427,
: 0.761,0.643,0.271,0.624,0.545,0.075,0.486,0.369,0.000,
: 1.000,0.804,0.000,1.000,0.604,0.000,1.000,0.400,0.000,
: 1.000,0.000,0.000/
C
C@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
C
C Beginning of executable code...
C
C@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
c
icoltable = col_tab
IF (col_tab .eq.0 ) THEN ! all lines are black
DO i=1,3
rgb_table(i,1) = 1.
END DO
DO j=2,nc_max
DO i=1,3
rgb_table(i,j) = 0.
END DO
END DO
ncunique = nc_max
ELSE IF (col_tab .eq. 1 ) THEN
ncunique = 25
DO j=1,nc_max
jj=j
IF (j.ge.4) jj = mod(j-4,ncunique-3)+4
DO i=1,3
rgb_table(i,j) = rgbv(i,jj)
END DO
END DO
ELSE IF (col_tab .eq.2 ) THEN
ncunique = 25
DO j=1,nc_max
jj=j
IF (j.ge.4) jj = mod(24-mod(j-1,22),22)+4
DO i=1,3
rgb_table(i,j) = rgbv(i,jj)
END DO
END DO
ELSE IF( col_tab.eq.3) THEN
ncunique = 18
DO j=1,nc_max
jj=j
IF (j.ge.4) jj = mod(j-4,ncunique-3)+4
DO i=1,3
rgb_table(i,j) = rgbf(i,jj)
END DO
END DO
ELSE IF( col_tab.eq.4) THEN ! gray shade
DO j=1,3
DO i=1,3
rgbg(i,j)=rgbv(i,j)
END DO
END DO
c use logarithmic
rgbg(1,4)=0.995
rgbg(2,4)=rgbg(1,4)
rgbg(3,4)=rgbg(1,4)
DO j=5,17
rgbg(1,j) = log10((15.- real(j) + 4.)/15.*10.)
rgbg(2,j)=rgbg(1,j)
rgbg(3,j)=rgbg(1,j)
END DO
rgbg(1,18)=0.0
rgbg(2,18)=rgbg(1,18)
rgbg(3,18)=rgbg(1,18)
c
ncunique = 18
DO j=1,nc_max
jj=j
IF (j.ge.4) jj = mod(j-4,ncunique-3)+4
DO i=1,3
rgb_table(i,j) = rgbg(i,jj)
END DO
END DO
ELSE IF( col_tab.eq.5 ) THEN ! define 200-element color table
DO j=1,nc_max
jj=j
IF (j.ge.4) jj = mod(j-4,197)+4
DO i=1,3
rgb_table(i,j)=rgb_zj(i,jj)
END DO
END DO
ncunique = 200
ELSE IF( col_tab.eq.6 ) THEN ! define 139-element color table
ncunique = 139
DO j=1,nc_max
jj=j
IF (j.ge.4) jj = mod(j-4,ncunique-3)+4
DO i=1,3
rgb_table(i,j)=rgb6(i,jj)
END DO
END DO
ELSE IF( col_tab.eq.7) THEN ! gray shade
DO j=1,3
DO i=1,3
rgbg(i,j)=rgbv(i,j)
END DO
END DO
c use logarithmic
rgbg(1,18)=0.995
rgbg(2,18)=rgbg(1,18)
rgbg(3,18)=rgbg(1,18)
DO jj=5,17
j = 17 - jj + 5
rgbg(1,j) = log10((15.- real(jj) + 4.)/15.*10.)
rgbg(2,j)=rgbg(1,j)
rgbg(3,j)=rgbg(1,j)
END DO
rgbg(1,4)=0.0
rgbg(2,4)=rgbg(1,4)
rgbg(3,4)=rgbg(1,4)
c
ncunique = 18
DO j=1,nc_max
jj=j
IF (j.ge.4) jj = mod(j-4,ncunique-3)+4
DO i=1,3
rgb_table(i,j) = rgbg(i,jj)
END DO
END DO
ELSE IF (col_tab.eq.-1) THEN ! user specifies own color table
lenfil = max(1, index(coltabfn, ' ')-1 )
inquire(file=coltabfn(1:lenfil),exist=fexist)
IF(.not.fexist) THEN
write(6,'(1x,a,a,a/1x,a/1x,a,a)')
: 'Color table file ',coltabfn(1:lenfil),' does not exist.',
: 'Please respecify the file name (this file is required when',
: 'color table option -1 is chosen. ',
: 'The default is zx_color.tbl).'
STOP 101
ENDIF
open(1,file=coltabfn(1:lenfil),form='formatted',status='old')
sum_colors=0
DO j=1,nc_max
read(1,*,end=100) (rgb_table(i,j),i=1,3)
sum_colors=sum_colors+1
END DO
100 CONTINUE
IF(sum_colors.lt.nc_max ) THEN
DO j=sum_colors+1,nc_max
jj=mod(j, sum_colors)
IF(jj.eq.0) jj = sum_colors
DO i=1,3
rgb_table(i,j) = rgb_table(i,jj)
END DO
END DO
ENDIF
ncunique = sum_colors
CLOSE(1)
END IF
c
c#######################################################################
c
c Setup the color index (color table)
c
c#######################################################################
c
CALL XWRTCTBL(rgb_table,nc_max)
RETURN
ENTRY XSTCTFN(col_tab_fn)
c
c#######################################################################
c
c
c PURPOSE:
c
c To be called before SETCOLORS to reset the default filename
c (zx_color.tbl) for the case of user-specified color table.
c
c#######################################################################
c
coltabfn = col_tab_fn
RETURN
ENTRY XQCLRTBL( ncoltable )
c#######################################################################
c
c Return current color table number
c
c#######################################################################
ncoltable = icoltable
RETURN
END
SUBROUTINE SETCOLORS(col_tab) 2,1
integer col_tab
call xsetclrs(col_tab)
RETURN
END
SUBROUTINE XPSPAC( PL0,PR0,PB0,PT0) 32,2
C Define the individual picture plotting area in ND-space
C Its arguments should be in the range of (0.0,1.5,0.0,1.0)
C By default this area covers the whole ND-space .
C All transformations in vector space are reset as default (cancelled)
C when XPSPAC is called.
COMMON /XPHY01/PL,PR,PB,PT,XRANGE,YRANGE
COMMON /XMAP04/ X1,X2,Y1,Y2,XSCALE,YSCALE
COMMON /XFTR06/ XFACTR,YFACTR
COMMON /XPHO03/ DXPO,DYPO
COMMON /XMAO05/ DXMOP,DYMOP
COMMON /XPRF07/XPREF,YPREF
XRANGE0=PR-PL
YRANGE0=PT-PB
PL=PL0
PR=PR0
PB=PB0
PT=PT0
XRANGE=PR-PL
YRANGE=PT-PB
XFACTR=XRANGE/XSCALE
YFACTR=YRANGE/YSCALE
CALL XPSCOF
CALL XMREFP(X1,Y1)
CALL XUNMLC
CALL XMROFF
CALL XSROFF
CALL XOBOFF
if( abs(xrange-xrange0).gt.0.001.or.
: abs(yrange-yrange0).gt.0.001) then
call xqthik(lthick)
call xthick(lthick)
call xbrokn0
endif
RETURN
END
subroutine xstchn(nch0)
common /xoutch/ nch
nch = nch0
return
end
SUBROUTINE XQPSPC(PX1,PX2,PY1, PY2) 12
C Return the current picture space parameters defined by XPSPAC
C subject to no picture scaling.
COMMON /XPHY01/PL,PR,PB,PT,XRANGE,YRANGE
PX1=PL
PX2=PR
PY1=PB
PY2=PT
RETURN
ENTRY XQRANG( RANGEX,RANGEY)
C Return the actual length of picture sides measured in ND-space
C subject to picture scaling. ( X and Y denote direction of axes
C before coordinate rotation but subject to overall picture ratation.)
RANGEX=XRANGE
RANGEY=YRANGE
RETURN
END
SUBROUTINE XSPACE(NUMPH,NUMPV,ROTANG,XLIM, YLIM) 5,3
C
C SUBROUTINE TO SET A GRAPHIC SPACE CONTAINING NUMPH*NUMPV
C PICTURES IN ONE FRAME OF FILM BY MOVING AND ROTATING COORDINATES.
C INPUT : NUMPH,NUMPV- NUMBER OF PICTURES IN HORIZONATL AND VERTICAL
C IN EACH FRAME
C ROTANG- THE ANGLE ATHAT EACH PICTURE IS ROTATED THROUGH
C OUTPUT: XLIMIT,YLIMIT--
C DEFINE THE MAXIMUM PLOTTING AREA FOR EACH PICTURE
C (-XLIMIT/2,XLIMIT/2,-YLIMIT/2,YLIMIT/2),
C ENTRIES: XNWPIC, XNWFRM, XPMAGN
C
C Option to switch off annotation for certain sub-pictures are included
C This is controled by Entry XFAUTO for automatic frame setting.
SAVE NCALLS, NOPIC , KFAUTO
SAVE NCOUNT,NUMPX,NUMPY,NUMPIC,XLIMIT,YLIMIT,XMAGIN,YMAGIN,PANGLE
DATA NCOUNT,NUMPX,NUMPY,NUMPIC,XLIMIT,YLIMIT,XMAGIN,YMAGIN,PANGLE
; / 0, 1, 1, 1, 1.5, 1.0, 0.0, 0.0 , 0.0/
DATA KFAUTO /0/
integer icplswitch
common /xcplswitch/ icplswitch
COMMON /XPSD01/ XSIDE, YSIDE
COMMON /XAXS18/ KANX,KANY, KTKX,KTKY
common /xoutch/ nch
DATA NCALLS /0/
NUMPX=NUMPH
NUMPY=NUMPV
NUMPIC=NUMPX*NUMPY
NCOUNT=0
XLIMIT=XSIDE/NUMPX
YLIMIT=YSIDE/NUMPY
PANGLE=ROTANG
IF(PANGLE.EQ.90.0) THEN
XLIM=YLIMIT
YLIM=XLIMIT
ELSE
XLIM=XLIMIT
YLIM=YLIMIT
ENDIF
RETURN
ENTRY XNWPIC
C Used in relating to XSPACE to define the picture plotting space
C for next picture.
NCALLS=NCALLS+1
NCOUNT=NCOUNT+1
IORIGN= MOD( NCOUNT, NUMPIC)
IF((IORIGN.EQ. 1.OR.NUMPIC.EQ.1).AND.NCALLS.GT.1) CALL XFRAME
NOPIC=IORIGN
IF(IORIGN.EQ.0) NOPIC=NUMPIC
WRITE(NCH,*) 'Picture No. ', NOPIC,' in the frame.'
IF(PANGLE.EQ.90.0) THEN
XOR=XLIMIT*(INT((NOPIC-1)/NUMPY)+0.5)
YOR=YLIMIT*(MOD(NOPIC-1, NUMPY)+0.5)
ELSE
XOR=XLIMIT*(MOD(NOPIC-1,NUMPX)+0.5)
YOR=YLIMIT*(INT(NUMPY-(NOPIC-1)/NUMPX)-0.5)
ENDIF
XRANGE=XLIMIT-2*XMAGIN
YRANGE=YLIMIT-2*YMAGIN
XC=XRANGE/2
YC=YRANGE/2
C
IF(PANGLE.EQ.90.0) THEN
CALL XPSPAC( XOR-YC,XOR+YC,YOR-XC,YOR+XC)
ELSE
CALL XPSPAC( XOR-XC,XOR+XC,YOR-YC,YOR+YC)
ENDIF
C
IF( PANGLE.NE.0.0) THEN
CALL XDREFP( XOR,YOR)
CALL XDRANG( PANGLE)
ENDIF
PPANG=PANGLE
IF( KFAUTO.EQ.0) RETURN
CALL XAXANT(-1,-1)
IF(PANGLE.NE.90.0) THEN
NX=NUMPX
NY=NUMPY
ELSE
NX=NUMPY
NY=NUMPX
ENDIF
NSEQH=MOD(NOPIC,NX)
IF( NSEQH.EQ.0) NSEQH=NX
IF( NSEQH.NE.1) KANY=0
IF( NOPIC.LE. (NY-1)*NX ) KANX=0
icplswitch = 1
if( MOD(NOPIC,NX).ne.0) icplswitch = 0
print*,'NOPIC,NX, MOD(NOPIC,NX),icplswitch=',
: NOPIC,NX, MOD(NOPIC,NX),icplswitch
RETURN
ENTRY XPMAGN( XM,YM)
C Used in XSPACE to set the margins of graghic in the picture space
C provided. If not called ,default values of zero are provided.
XMAGIN=XM
YMAGIN=YM
RETURN
ENTRY XNWFRM
C Used in XSPACE to terminate the current picture frame and move on
C to the next page
IFRAME=1
NCOUNT=0
RETURN
ENTRY XQNPIC(NPIC)
NPIC=NOPIC
RETURN
ENTRY XFAUTO(KFAU)
C* ADDED IN ZXPLOTI *
KFAUTO=KFAU
RETURN
ENTRY XQSPAC(NPICH, NPICV, RANGLE, XLIM, YLIM)
c
NPICH = NUMPX
NPICV = NUMPY
RANGLE = PANGLE
XLIM = XLIMIT
YLIM = YLIMIT
RETURN
END
SUBROUTINE XDRSET(X1,Y1) 2
C Perform rotation around device reference point.
COMMON /XPHY01/PL,PR,PB,PT,XRANGE,YRANGE
COMMON /XPHO03/ DXPO,DYPO
COMMON /XPRF07/ XPREF,YPREF
COMMON /XAGS09/ DRANG,CRANG,XANGLE,XSYMAN,SRANG,KSR,XA,YA
COMMON /XSCS10/ SINDRA,COSDRA,SINMRA,COSMRA,SINSRA,COSSRA
: ,SINXA,COSXA,SINYA,COSYA ,CHSIN,CHCOS
IF( DRANG.EQ.0.0) RETURN
X2=X1-XPREF
Y2=Y1-YPREF
X1=X2*COSDRA-Y2*SINDRA+XPREF
Y1=X2*SINDRA+Y2*COSDRA+YPREF
RETURN
ENTRY XDREFP(XP,YP)
C Define the device reference point in ND-space for overall picture
C rotation.
XPREF=XP
YPREF=YP
RETURN
ENTRY XQDREF(XP1,YP1)
XP1=XPREF
YP1=YPREF
RETURN
ENTRY XDRANG(ANG)
C Set the angle the overall picture is rotated through around the
C device reference point. (Defined by XDREFP )
DRANG=ANG
XANGLE=CRANG+DRANG+(90-SRANG)*KSR+XA
RADANG= ATAN(1.)/45.0*ANG
SINDRA= SIN( RADANG)
COSDRA= COS( RADANG)
RETURN
ENTRY XDROFF
C Switch off rotation around the device reference point.
DRANG=0.0
XANGLE=CRANG+DRANG+(90-SRANG)*KSR+XA
SINDRA=0.0
COSDRA=1.0
RETURN
ENTRY XQDRAG(ANG1)
ANG1=DRANG
RETURN
ENTRY XDLOCA(XPLOC,YPLOC)
C Define the position in ND-space to which the device reference point
C is moved. ( Picture translation in ND-space )
DXPO=XPLOC-XPREF
DYPO=YPLOC-YPREF
RETURN
ENTRY XUNDLC
C Cancel picture translation in ND-space.
DXPO=0.0
DYPO=0.0
RETURN
ENTRY XQDLOC(XPLOC1,YPLOC1)
XPLOC1=XPREF+DXPO
YPLOC1=YPREF+DYPO
RETURN
END
SUBROUTINE XMAP(XL,XR,YB,YT) 40,1
C Map the picture space. (Define maths coordinates on the picture space)
C Transformations in vector space are reset as default when remaped.
COMMON /XPHY01/PL,PR,PB,PT,XRANGE,YRANGE
COMMON /XMAP04/ X1,X2,Y1,Y2,XSCALE,YSCALE
COMMON /XFTR06/ XFACTR,YFACTR
XSCALE=XR-XL
YSCALE=YT-YB
X1=XL
X2=XR
Y1=YB
Y2=YT
XFACTR=XRANGE/XSCALE
YFACTR=YRANGE/YSCALE
CALL XMREFP(X1,Y1)
CALL XPSCOF
CALL XUNMLC
CALL XMROFF
CALL XSROFF
CALL XOBOFF
RETURN
ENTRY XQMAP (XL0,XR0,YB0,YT0)
C Return the range of the current mapping space
XL0=X1
XR0=X2
YB0=Y1
YT0=Y2
RETURN
END
SUBROUTINE XMREFP(XREF,YREF) 2
C Define the picture reference point in mapped vector space as the
C center of picture scaling, deformation, rotation, and translation.
C All these transformations are cancelled when either XPSPAC or XMAP
C is called (But the transformations defined in ND-space remain in
C effect).
COMMON /XPHY01/PL,PR,PB,PT,XRANGE,YRANGE
COMMON /XMAP04/ X1,X2,Y1,Y2,XSCALE,YSCALE
COMMON /XMAO05/ DXMOP,DYMOP
COMMON /XFTR06/ XFACTR,YFACTR
COMMON /XMRF08/ XMREF,YMREF,XMPREF,YMPREF
XMREF=XREF
YMREF=YREF
XMPREF=PL+(XMREF-X1)*(PR-PL)/(X2-X1)
YMPREF=PB+(YMREF-Y1)*(PT-PB)/(Y2-Y1)
RETURN
ENTRY XQMREF(XREF1,YREF1)
XREF1=XMREF
YREF1=YMREF
RETURN
ENTRY XPSCAL(SCALEX,SCALEY)
C Define scaling factors
XRANGE=(PR-PL)*SCALEX
YRANGE=(PT-PB)*SCALEY
XFACTR=XRANGE/XSCALE
YFACTR=YRANGE/YSCALE
RETURN
ENTRY XPSCOF
C Switch off scaling
XRANGE= PR-PL
YRANGE= PT-PB
XFACTR=XRANGE/XSCALE
YFACTR=YRANGE/YSCALE
RETURN
ENTRY XQPSCL(SCALX1,SCALY1)
SCALX1=XRANGE/(PR-PL)
SCALY1=YRANGE/(PT-PB)
RETURN
ENTRY XMLOCA(XLOC,YLOC)
C Translate the picture reference point to the location (XLOC,YLOC)
C defined in mapped vetor space.
DXMOP=(XLOC-XMREF) *XRANGE/XSCALE
DYMOP=(YLOC-YMREF) *YRANGE/YSCALE
RETURN
ENTRY XUNMLC
C Switch off the translation in mapped vector space
DXMOP=0.0
DYMOP=0.0
RETURN
ENTRY XQMLOC(XLOC1,YLOC1)
XLOC1=XMREF+DXMOP*XSCALE/XRANGE
YLOC1=YMREF+DYMOP*YSCALE/YRANGE
RETURN
END
SUBROUTINE XMRSET(X2,Y2) 2
C Perform rotation around picture reference point (XMREF,YMREF)
COMMON /XMRF08/ XMREF,YMREF,XMPREF,YMPREF
COMMON /XAGS09/ DRANG,CRANG,XANGLE,XSYMAN,SRANG,KSR,XA,YA
COMMON /XSCS10/ SINDRA,COSDRA,SINMRA,COSMRA,SINSRA,COSSRA
: ,SINXA,COSXA,SINYA,COSYA ,CHSIN,CHCOS
IF( CRANG.EQ.0.0) RETURN
X1=X2-XMPREF
Y1=Y2-YMPREF
X2=X1*COSMRA-Y1*SINMRA +XMPREF
Y2=X1*SINMRA+Y1*COSMRA +YMPREF
RETURN
ENTRY XMRANG(ANG)
C Set coordinate rotation angle (It supercedes the previous value.)
CRANG=ANG
RADANG= ATAN(1.)/45.0*ANG
SINMRA= SIN( RADANG)
COSMRA= COS( RADANG)
XANGLE=CRANG+DRANG+(90-SRANG)*KSR+XA
RETURN
ENTRY XMROFF
C Turn off coordinate rotation
CRANG=0.0
XANGLE=CRANG+DRANG+(90-SRANG)*KSR+XA
SINMRA=0.0
COSMRA=1.0
RETURN
ENTRY XQMRAG(ANG1)
ANG1=CRANG
RETURN
ENTRY XSRSET(X2,Y2)
C Perform shearing of the picture in x or y direction
IF( SRANG.EQ.90.0) RETURN
IF( KSR.EQ.0) THEN
Y1=Y2-YMPREF
X2=X2+Y1*COSSRA
Y2=YMPREF+Y1*SINSRA
ELSE
X1=X2-XMPREF
Y2=Y2+X1*COSSRA
X2=XMPREF+X1*SINSRA
ENDIF
RETURN
ENTRY XSHEAR( XYANGL, KSHEAR)
C Shear the picture in x or y direction.
C XYANGL The angle between x and y-axis after shearing (default 90.0)
C KSHEAR =0 when X-axis to be is fixed, =1 when Y-axis is to be fixed
SRANG=XYANGL
KSR=KSHEAR
RAD=ATAN(1.0)/45.0*SRANG
SINSRA=SIN(RAD)
COSSRA=COS(RAD)
XANGLE=CRANG+DRANG+(90-SRANG)*KSR+XA
RETURN
ENTRY XSROFF
C Switch off picture shearing
SRANG=90.0
KSR=0
SINSRA=1.0
COSSRA=0.0
XANGLE=CRANG+DRANG+(90-SRANG)*KSR+XA
RETURN
END
SUBROUTINE XOBSET(X2,Y2) 2
C Perform non-orthogonal rotation of coordinate system. (Deformation)
COMMON /XMRF08/ XMREF,YMREF,XMPREF,YMPREF
COMMON /XAGS09/ DRANG,CRANG,XANGLE,XSYMAN,SRANG,KSR,XA,YA
COMMON /XSCS10/ SINDRA,COSDRA,SINMRA,COSMRA,SINSRA,COSSRA
: ,SINXA,COSXA,SINYA,COSYA ,CHSIN,CHCOS
IF( XA.EQ.0.0.AND.YA.EQ.0.0) RETURN
X1=X2-XMPREF
Y1=Y2-YMPREF
X2=X1*COSXA-Y1*SINYA+XMPREF
Y2=X1*SINXA+Y1*COSYA+YMPREF
RETURN
ENTRY XOBANG( XANG, YANG)
C Define angles for non-orthogonal coordiante rotation.
C XANG -- The angle x-axis is rotated through relative to old x-axis.
C YANG -- The angle y-axis is rotated through relative to old y-axis.
XA=XANG
YA=YANG
DR =ATAN(1.0)/45.0
SINXA=SIN(XA*DR)
COSXA=COS(XA*DR)
SINYA=SIN(YA*DR)
COSYA=COS(YA*DR)
XANGLE=CRANG+DRANG+(90-SRANG)*KSR +XA
RETURN
ENTRY XOBOFF
C Switch off non-orthogonal rotation
XA=0.0
YA=0.0
SINXA=0.0
COSXA=1.0
SINYA=0.0
COSYA=1.0
XANGLE=CRANG+DRANG+(90-SRANG)*KSR+XA
RETURN
ENTRY XQOBAG( XANG1, YANG1)
XANG1=XA
YANG1=YA
RETURN
END
FUNCTION XLTRNX(X)
C Perform linear transformation in x-direction
COMMON /XFTR06/ XFACTR,YFACTR
COMMON /XMRF08/ XMREF,YMREF,XMPREF,YMPREF
XLTRNX=(X-XMREF)*XFACTR+XMPREF
RETURN
END
FUNCTION XLTRNY(Y)
C Perform linear transformation in y-direction
COMMON /XFTR06/ XFACTR,YFACTR
COMMON /XMRF08/ XMREF,YMREF,XMPREF,YMPREF
XLTRNY=(Y-YMREF)*YFACTR+YMPREF
RETURN
END
SUBROUTINE XLINVT(X,Y) 10
C Perform inverse linear transformation (from ND-space to mathe space).
COMMON /XFTR06/ XFACTR,YFACTR
COMMON /XMRF08/ XMREF,YMREF,XMPREF,YMPREF
X=XMREF+(X-XMPREF)/XFACTR
Y=YMREF+(Y-YMPREF)/YFACTR
RETURN
END
SUBROUTINE XTRANS(X,Y) 42,4
C TRANSFORM POINT (X,Y) FROM MATHEMATICAL SPACE BACK
C TO ABSOLUTE PICTURE PLOTTING SPACE
COMMON /XPHO03/ DXPO,DYPO
COMMON /XMAO05/ DXMOP,DYMOP
COMMON /XPRJ26/ KPROJC
EXTERNAL XLTRNX,XLTRNY
X1=X
Y1=Y
IF(KPROJC.NE.0) CALL XPROJC(X1,Y1)
X1=XLTRNX(X1)
Y1=XLTRNY(Y1)
C CALL XSRSET(X1,Y1)
CALL XOBSET(X1,Y1)
CALL XMRSET(X1,Y1)
X1=X1+DXMOP
Y1=Y1+DYMOP
CALL XDRSET(X1,Y1)
X=X1+DXPO
Y=Y1+DYPO
RETURN
END
SUBROUTINE XPROJC(X,Y) 2
C A dummy routine which can used to define a projection (transformation)
C by user. XPRJON should called when projection is to be switched on.
RETURN
END
SUBROUTINE XPRJON
COMMON /XPRJ26/ KPROJC
C Switch on user defined projection through XPROJC.
KPROJC=1
RETURN
ENTRY XPRJOF
C Switch off user defined projection through XPROJC.
KPROJC=0
RETURN
END
FUNCTION XPNTSD(X1,Y1,X2,Y2),2
C Measure the distance in ND-space between two points
C (X1,Y1) and (X2,Y2) defined in maths space
PX1=X1
PY1=Y1
CALL XTRANS(PX1,PY1)
PX2=X2
PY2=Y2
CALL XTRANS(PX2,PY2)
XPNTSD=SQRT((PX2-PX1)*(PX2-PX1)+(PY2-PY1)*(PY2-PY1))
RETURN
END
subroutine xmask(x1,x2,y1,y2) 1
common /xmask1/ xm1(99),xm2(99),ym1(99),ym2(99),rmangl(99),
: cosmsa(99),sinmsa(99),lvlmsk
common /xoutch/ nch
if(lvlmsk.ge.98)then
write(nch,'(a)')
: 'Warning: level of masking exceeded 99, it was set to 99.'
endif
lvlmsk=min(99,lvlmsk+1)
xm1(lvlmsk)=x1
xm2(lvlmsk)=x2
ym1(lvlmsk)=y1
ym2(lvlmsk)=y2
rmangl(lvlmsk)=0.0
cosmsa(lvlmsk)=1.0
sinmsa(lvlmsk)=0.0
return
entry xqlmsk(level)
level=lvlmsk
return
end
subroutine xrmask(x0,y0,xl,yl,rangle) 2
common /xmask1/ xm1(99),xm2(99),ym1(99),ym2(99),rmangl(99),
: cosmsa(99),sinmsa(99),lvlmsk
common /xoutch/ nch
if(lvlmsk.ge.98)then
write(nch,'(a)')
: 'Warning: level of masking exceeded 99, it was set to 99.'
endif
lvlmsk=min(99,lvlmsk+1)
pi=4.0*atan(1.0)
rmangl(lvlmsk)=rangle
cosmsa(lvlmsk)=cos(pi*rangle/180.0)
sinmsa(lvlmsk)=sin(pi*rangle/180.0)
xm1(lvlmsk)= x0*cosmsa(lvlmsk)+y0*sinmsa(lvlmsk)
xm2(lvlmsk)= xm1(lvlmsk)+xl
ym1(lvlmsk)=-x0*sinmsa(lvlmsk)+y0*cosmsa(lvlmsk)
ym2(lvlmsk)= ym1(lvlmsk)+yl
return
end
subroutine xmsprj(x,y,level) 3
common /xmask1/ xm1(99),xm2(99),ym1(99),ym2(99),rmangl(99),
: cosmsa(99),sinmsa(99),lvlmsk
lvl=level
x0=x
y0=y
x= x0*cosmsa(lvl)+y0*sinmsa(lvl)
y=-x0*sinmsa(lvl)+y0*cosmsa(lvl)
return
end
subroutine xmsrpr(x,y,level) 4
common /xmask1/ xm1(99),xm2(99),ym1(99),ym2(99),rmangl(99),
: cosmsa(99),sinmsa(99),lvlmsk
lvl=level
x0=x
y0=y
x= x0*cosmsa(lvl)-y0*sinmsa(lvl)
y= x0*sinmsa(lvl)+y0*cosmsa(lvl)
return
end
subroutine xunmsk( level ) 3
common /xmask1/ xm1(99),xm2(99),ym1(99),ym2(99),rmangl(99),
: cosmsa(99),sinmsa(99),lvlmsk
lvlmsk=max(0,level-1)
return
end
subroutine xrsmsk( level ) 4
common /xmask1/ xm1(99),xm2(99),ym1(99),ym2(99),rmangl(99),
: cosmsa(99),sinmsa(99),lvlmsk
lvlmsk=level
return
end
subroutine xtsmsk(x1,y1,x2,y2, lnsegs) 2,8
common /xmask1/ xm1(99),xm2(99),ym1(99),ym2(99),rmangl(99),
: cosmsa(99),sinmsa(99),lvlmsk
common /xoutch/ nch
real x1(199),y1(199),x2(199),y2(199), idispl(199)
dimension ic1(4),ic2(4)
logical xinbdr
if(lvlmsk.eq.0) then
lnsegs=1
return
endif
do 100 lv=1,lvlmsk
lines=lnsegs
do 200 ln=1,lines
idispl(ln)=0
xln1 = x1(ln)
yln1 = y1(ln)
xln2 = x2(ln)
yln2 = y2(ln)
if(rmangl(lv).ne.0.0) then
call xmsprj(x1(ln),y1(ln),lv)
call xmsprj(x2(ln),y2(ln),lv)
endif
call xmscod(x1(ln),y1(ln),lv,ic1)
call xmscod(x2(ln),y2(ln),lv,ic2)
isum1=ic1(1)+ic1(2)+ic1(3)+ic1(4)
isum2=ic2(1)+ic2(2)+ic2(3)+ic2(4)
if(isum1+isum2.eq.0) then ! both ends are inside
idispl(ln)=0
x1(ln) = xln1
y1(ln) = yln1
x2(ln) = xln2
y2(ln) = yln2
goto 200
endif
do 20 i=1,4
if(ic1(i)+ic2(i).eq.2) then ! the line is obviously out side
idispl(ln)=1
x1(ln) = xln1
y1(ln) = yln1
x2(ln) = xln2
y2(ln) = yln2
goto 200
endif
20 continue
if(isum1.eq.0.or.isum2.eq.0) then ! one end is inside
isw=0
if(isum1.eq.0)then
ic01=ic1(1)
ic02=ic1(2)
ic03=ic1(3)
ic04=ic1(4)
do 30 i=1,4
30 ic1(i)=ic2(i)
ic2(1)=ic01
ic2(2)=ic02
ic2(3)=ic03
ic2(4)=ic04
x0=x1(ln)
y0=y1(ln)
x1(ln)=x2(ln)
y1(ln)=y2(ln)
x2(ln)=x0
y2(ln)=y0
isw=1
endif
knt = 0
if(ic1(1).eq.1)then
y0=y1(ln)+(xm1(lv)-x1(ln))*(y2(ln)-y1(ln))
: /(x2(ln)-x1(ln))
x0=xm1(lv)
goto 160
elseif(ic1(2).eq.1)then
y0=y1(ln)+(xm2(lv)-x1(ln))*(y2(ln)-y1(ln))
: /(x2(ln)-x1(ln))
x0=xm2(lv)
goto 160
endif
150 if(ic1(3).eq.1)then
x0=x1(ln)+(ym1(lv)-y1(ln))*(x2(ln)-x1(ln))
: /(y2(ln)-y1(ln))
y0=ym1(lv)
elseif(ic1(4).eq.1)then
x0=x1(ln)+(ym2(lv)-y1(ln))*(x2(ln)-x1(ln))
: /(y2(ln)-y1(ln))
y0=ym2(lv)
endif
160 continue
if(.not.xinbdr(x0,y0,xm1(lv),xm2(lv),ym1(lv),ym2(lv)))then
knt=knt+1
if(knt.gt.10)then
WRITE(NCH,*)'Dead loop encountered in XTSMSK, job stopped.'
stop 991
endif
goto150
endif
if(rmangl(lv).ne.0.0) call xmsrpr(x0,y0,lv)
x2(ln)=x0
y2(ln)=y0
if(isw.eq.1)then
x1(ln) = xln2
y1(ln) = yln2
else
x1(ln) = xln1
y1(ln) = yln1
endif
if(isw.eq.1)then
x0=x1(ln)
y0=y1(ln)
x1(ln)=x2(ln)
y1(ln)=y2(ln)
x2(ln)=x0
y2(ln)=y0
isum2=0
endif
idispl(ln)=1
else ! both ends are outside
xa=x1(ln)
ya=y1(ln)
kount=0
if(ic1(1).eq.1)then
yb=y1(ln)+(xm1(lv)-x1(ln))*(y2(ln)-y1(ln))
: /(x2(ln)-x1(ln))
xb=xm1(lv)
goto 250
elseif(ic1(2).eq.1)then
yb=y1(ln)+(xm2(lv)-x1(ln))*(y2(ln)-y1(ln))
: /(x2(ln)-x1(ln))
xb=xm2(lv)
goto 250
endif
260 if(ic1(3).eq.1)then
xb=x1(ln)+(ym1(lv)-y1(ln))*(x2(ln)-x1(ln))
: /(y2(ln)-y1(ln))
yb=ym1(lv)
elseif(ic1(4).eq.1)then
xb=x1(ln)+(ym2(lv)-y1(ln))*(x2(ln)-x1(ln))
: /(y2(ln)-y1(ln))
yb=ym2(lv)
endif
250 continue
kount = kount+1
if(kount.gt.10)then
WRITE(NCH,*)'Dead loop encountered in XTSMSK, job stopped.'
stop 992
endif
if(.not.xinbdr(xb,yb,xm1(lv),xm2(lv),ym1(lv),ym2(lv))
: .and.kount.eq.1) goto260
if(.not.xinbdr(xb,yb,xm1(lv),xm2(lv),ym1(lv),ym2(lv)))then
idispl(ln)=1
x1(ln) = xln1
y1(ln) = yln1
x2(ln) = xln2
y2(ln) = yln2
goto 200
else
lnsegs=lnsegs+1
x1(lnsegs)=xln1
y1(lnsegs)=yln1
xb0=xb
yb0=yb
if(rmangl(lv).ne.0.0) call xmsrpr(xb0,yb0,lv)
x2(lnsegs)=xb0
y2(lnsegs)=yb0
idispl(lnsegs)=1
x1(ln)=xb
y1(ln)=yb
endif
kount=0
if(ic2(1).eq.1)then
y0=y1(ln)+(xm1(lv)-x1(ln))*(y2(ln)-y1(ln))
: /(x2(ln)-x1(ln))
x0=xm1(lv)
goto 360
elseif(ic2(2).eq.1)then
y0=y1(ln)+(xm2(lv)-x1(ln))*(y2(ln)-y1(ln))
: /(x2(ln)-x1(ln))
x0=xm2(lv)
goto 360
endif
350 continue
if(ic2(3).eq.1)then
x0=x1(ln)+(ym1(lv)-y1(ln))*(x2(ln)-x1(ln))
: /(y2(ln)-y1(ln))
y0=ym1(lv)
elseif(ic2(4).eq.1)then
x0=x1(ln)+(ym2(lv)-y1(ln))*(x2(ln)-x1(ln))
: /(y2(ln)-y1(ln))
y0=ym2(lv)
endif
360 continuE
kount=kount+1
if(kount.gt.10)then
WRITE(NCH,*)'Dead loop encountered in XTSMSK, job stopped.'
stop 993
endif
if(.not.xinbdr(x0,y0,xm1(lv),xm2(lv),ym1(lv),ym2(lv))
: .and. kount.eq.1)goto350
if(rmangl(lv).ne.0.0) call xmsrpr(x0,y0,lv)
x1(ln)=x0
y1(ln)=y0
if(rmangl(lv).ne.0.0) call xmsrpr(x2(ln),y2(ln),lv)
idispl(ln)=1
endif
200 continue
lin = 0
do 400 i=1,lnsegs
if(idispl(i).eq.1)then
lin=lin+1
x1(lin)=x1(i)
x2(lin)=x2(i)
y1(lin)=y1(i)
y2(lin)=y2(i)
endif
400 continue
lnsegs=lin
100 continue
return
end
subroutine xmscod(x,y,level,ic) 2
common /xmask1/ xm1(99),xm2(99),ym1(99),ym2(99),rmangl(99),
: cosmsa(99),sinmsa(99),lvlmsk
integer ic(4)
do 10 i=1,4
10 ic(i)=0
if(x.le.xm1(level)) ic(1)=1
if(x.ge.xm2(level)) ic(2)=1
if(y.le.ym1(level)) ic(3)=1
if(y.ge.ym2(level)) ic(4)=1
return
end
logical function xinbdr(x,y,xw1,xw2,yw1,yw2)
c check if the point is within the border
xinbdr=.false.
if(x.ge.xw1.and.x.le.xw2.and.y.ge.yw1.and.y.le.yw2)xinbdr=.true.
return
end
subroutine xtstwd(x1,y1,x2,y2,idispl) 4,2
common /xwndw1/ xw1,xw2,yw1,yw2, iwndon
dimension ic1(4),ic2(4)
common /xoutch/ nch
knt = 0
5 knt = knt+1
call xencod(x1,y1,ic1)
call xencod(x2,y2,ic2)
isum1=ic1(1)+ic1(2)+ic1(3)+ic1(4)
isum2=ic2(1)+ic2(2)+ic2(3)+ic2(4)
idispl=1
if(isum1+isum2.eq.0) goto 999
idispl=0
do 20 i=1,4
20 if(ic1(i)+ic2(i).eq.2) goto 999
c
c make sure (x1,y1) is outside the window
isw=0
if(isum1.eq.0)then
ic01=ic1(1)
ic02=ic1(2)
ic03=ic1(3)
ic04=ic1(4)
do 30 i=1,4
30 ic1(i)=ic2(i)
ic2(1)=ic01
ic2(2)=ic02
ic2(3)=ic03
ic2(4)=ic04
x0=x1
y0=y1
x1=x2
y1=y2
x2=x0
y2=y0
isw=1
endif
if(ic1(1).eq.1)then
y1=y1+(xw1-x1)*(y2-y1)/(x2-x1)
x1=xw1
elseif(ic1(2).eq.1)then
y1=y1+(xw2-x1)*(y2-y1)/(x2-x1)
x1=xw2
elseif(ic1(3).eq.1)then
x1=x1+(yw1-y1)*(x2-x1)/(y2-y1)
y1=yw1
elseif(ic1(4).eq.1)then
x1=x1+(yw2-y1)*(x2-x1)/(y2-y1)
y1=yw2
endif
if(isw.eq.1)then
x0=x1
y0=y1
x1=x2
y1=y2
x2=x0
y2=y0
endif
idispl=1
if(knt.gt.10)then
WRITE(NCH,*)'Dead loop encountered in XTSTWD, job stopped.'
stop 991
endif
goto 5
999 return
end
subroutine xencod(x,y,ic) 2
common /xwndw1/ xw1,xw2,yw1,yw2, iwndon
integer ic(4)
do 10 i=1,4
10 ic(i)=0
if(x.lt.xw1) ic(1)=1
if(x.gt.xw2) ic(2)=1
if(y.lt.yw1) ic(3)=1
if(y.gt.yw2) ic(4)=1
return
end
subroutine xwindw(x1,x2,y1,y2) 28
common /xwndw1/ xw1,xw2,yw1,yw2, iwndon
common /xcwndw/ icwndw, xcpen, ycpen
xw1=x1
xw2=x2
yw1=y1
yw2=y2
iwndon=1
icwndw=1
return
end
subroutine xqwdwon(kwndon) 3
common /xwndw1/ xw1,xw2,yw1,yw2, iwndon
kwndon = iwndon
return
end
subroutine xwdwof 25
common /xwndw1/ xw1,xw2,yw1,yw2, iwndon
common /xcwndw/ icwndw, xcpen, ycpen
iwndon=0
icwndw=0
return
end
subroutine xqwndw(x1,x2,y1,y2) 3
common /xwndw1/ xw1,xw2,yw1,yw2, iwndon
common /xcwndw/ icwndw, xcpen, ycpen
x1=xw1
x2=xw2
y1=yw1
y2=yw2
return
end
subroutine xtstchwrt(x,y,wrtch) 3,1
common /xwndw1/ xw1,xw2,yw1,yw2, iwndon
common /xmask1/ xm1(99),xm2(99),ym1(99),ym2(99),rmangl(99),
: cosmsa(99),sinmsa(99),lvlmsk
integer wrtchw,wrtchm,wrtch
wrtchw = 0
if(iwndon.eq.0)then
wrtchw=1
elseif(x.ge.xw1.and.x.le.xw2.and.y.ge.yw1.and.y.le.yw2)then
wrtchw=1
endif
c print*,'in xtstchwrt, xw1,xw2,yw1,yw2,wrtchw=',
c : xw1,xw2,yw1,yw2,wrtchw
wrtchm = 1
if(lvlmsk.eq.0) then
wrtchm = 1
else
do 100 lv=1,lvlmsk
x1=x
y1=y
call xmsprj(x1,y1,lv)
if(x1.ge.xm1(lv).and.x1.le.xm2(lv).and.
: y1.ge.ym1(lv).and.y1.le.ym2(lv)) then
wrtchm = 0
endif
100 continue
endif
wrtch=0
if(wrtchw.eq.1.and.wrtchm.eq.1) wrtch=1
return
end
SUBROUTINE xpenup(x,y) 66,2
C position pen at point (x,y) defined in maths space
common /xpen11/ xpen,ypen,flen,blen,npd,xmpen,ympen
xpp= x
ypp= y
xmpen= x
ympen= y
call xtrans(xpp,ypp)
call xtpnup(xpp,ypp)
flen=0.0
blen=0.0
npd=0
return
end
subroutine xpendn(x,y) 87,16
C Join point (x,y) defined in maths space
common /xpen11/ xpen,ypen,flen,blen,npd,xmpen,ympen
common /xlpn13/ hf1,hb1,hf2,hb2,lfull,lfull0,lthick, dthick
common /xwndw1/ xw1,xw2,yw1,yw2, iwndon
common /xmask1/ xm1(99),xm2(99),ym1(99),ym2(99),rmangl(99),
: cosmsa(99),sinmsa(99),lvlmsk
real xa(199),ya(199),xb(199),yb(199)
save hf,hb
xp1=xpen
yp1=ypen
xp2 = x
yp2 = y
xmpen0=xmpen
ympen0=ympen
xmpen = x
ympen = y
x1=xmpen0
y1=ympen0
x2=xmpen
y2=ympen
if(iwndon.eq.1)then
call xtstwd(x1,y1,x2,y2,idispl)
if(idispl.eq.0)then
CALL XTRANS(X2 ,Y2 )
CALL XTPNup(X2 ,Y2 )
return
endif
endif
lnsegs=1
xa(1)=x1
ya(1)=y1
xb(1)=x2
yb(1)=y2
if(lvlmsk.gt.0)then
call xtsmsk(xa,ya,xb,yb,lnsegs)
if(lnsegs.eq.0)then
CALL XTRANS(X2 ,Y2 )
CALL XTPNup(X2 ,Y2 )
return
endif
endif
do 100 lin=1,lnsegs
x1=xa(lin)
y1=ya(lin)
xp2=xb(lin)
yp2=yb(lin)
x2=xp2
y2=yp2
if(x1.ne.xmpen0.or.y1.ne.ympen0.or.lin.ne.1)then
xp1=x1
yp1=y1
CALL XTRANS(XP1 ,YP1 )
CALL XTPNup(XP1 ,YP1 )
endif
CALL XTRANS(XP2 ,YP2 )
IF(LFULL0.EQ.1) THEN
CALL XTPNDN(XP2 ,YP2 )
goto 15
endif
ZL=SQRT((XP2-XP1)*(XP2-XP1)+(YP2-YP1)*(YP2-YP1))
IF( ZL.LT.1.0E-20 ) GO TO 16
XR=(XP2-XP1)/ZL
YR=(YP2-YP1)/ZL
IF(MOD(NPD,2).EQ.0)THEN
HF=HF1
HB=HB1
ELSE
HF=HF2
HB=HB2
ENDIF
IF(BLEN.NE.0.0 ) GOTO 28
20 IF(ZL-(HF-FLEN)) 22,21,21
21 XP1=XP1+(HF-FLEN)*XR
YP1=YP1+(HF-FLEN)*YR
IF( HF.LT.1.0E-10) THEN
CALL XPPONT(XP1,YP1)
ELSE
CALL XTPNDN (XP1,YP1)
ENDIF
ZL=ZL-(HF-FLEN)
FLEN=0.0
28 IF(ZL-(HB-BLEN)) 26,25,25
25 XP1=XP1+(HB-BLEN)*XR
YP1=YP1+(HB-BLEN)*YR
CALL XTPNUP(XP1,YP1)
ZL=ZL-(HB-BLEN)
BLEN=0.0
NPD=NPD+1
IF(MOD(NPD,2).EQ.0)THEN
HF=HF1
HB=HB1
ELSE
HF=HF2
HB=HB2
ENDIF
GO TO 20
22 FLEN=FLEN+ZL
BLEN=0.0
IF( HF.GE.1.0E-10)CALL XTPNDN(XP2,YP2)
GO TO 15
26 BLEN=BLEN+ZL
FLEN=0.0
16 CALL XTPNUP(XP2,YP2)
15 CONTINUE
100 continue
if(iwndon.eq.0.and.lvlmsk.le.0) return
if(x2.ne.xmpen.or.y2.ne.ympen)then
XP2 = Xmpen
YP2 = Ympen
CALL XTRANS(Xp2 ,Yp2 )
CALL XTPNup(Xp2 ,Yp2 )
endif
RETURN
entry xqmpen( xmp, ymp )
xmp=xmpen
ymp=ympen
return
entry xqppen( xpp, ypp )
xpp=xpen
ypp=ypen
return
end
SUBROUTINE XLPNUP(XP,YP) 17,18
C Used in contouring routine in the place of XPENUP to incorperate
C contour labeling.
COMMON /XFTR06/ XFACTR,YFACTR
COMMON /XMAP04/ XL,XR,YB,YT,XSCALE,YSCALE
COMMON /XLAB14/ DLABEL,WLABEL,HLABEL,SIZLB,KLBTYP,ICLI,ICLON
CHARACTER CLABEL*20
COMMON /CLABEL/XP1,YP1,XPP1,YPP1,DL,WL
COMMON /XLAB15/CLABEL
COMMON /XLAB16/ LCLAB
COMMON /XLBA33/ LABROT
common /xwndw1/ xw1,xw2,yw1,yw2, iwndon
REAL XBUF(0:31), YBUF(0:31)
SAVE NCALLS ,XLB1, YLB1 ,XP2,YP2 ,NCALDN,XBUF,YBUF,NBUF
DATA NCALLS ,NCALDN /0, 0/, NBUF/0/
REAL XLBP1, YLBP1
SAVE XLBP1, YLBP1
DATA XLBP1, YLBP1 /0, 0/
integer labmask
common /labmask1/ labmask
real xe(4),ye(4)
IF(NBUF.NE.0.AND. NCALDN.NE.0 ) THEN
CALL XPENUP(XBUF(0), YBUF(0))
DO 200 NN=0,NBUF
200 CALL XPENDN(XBUF(NN),YBUF(NN))
NBUF=0
WL=0.0
ENDIF
NCALLS=NCALLS+1
XP1=XP
YP1=YP
CALL XPENUP(XP1,YP1)
IF( ICLI .EQ.0.OR.ICLON.EQ.0) RETURN
XPP1=XLTRNX(XP)
YPP1=XLTRNY(YP)
DL=DLABEL*ABS(SIN(137.0*NCALLS))*0.5
WL=0.0
NBUF=0
IF( KLBTYP ) 1,2,3
1 SIZLB=0.02*(YT-YB)
3 HLABEL=SIZLB*YFACTR
WLABEL= HLABEL*LCLAB*0.77
2 CONTINUE
RETURN
ENTRY XLPNDN (XP,YP)
C Used in contouring routine in the place of XPENDN to incorperate
C contour labeling.
XP2=XP
YP2=YP
IF( ICLI .EQ.0.OR.ICLON.EQ.0) GOTO 9101
XPP2=XLTRNX(XP)
YPP2=XLTRNY(YP)
D21=SQRT((XPP2-XPP1)*(XPP2-XPP1)+(YPP2-YPP1)*(YPP2-YPP1))
IF(D21.LT.1.0E-10)GOTO 9101
DL=DL+D21
IF(DL-DLABEL) 9101,9102,9102
9102 IF(WL.EQ.0.0) THEN
DRATIO=(DLABEL-DL+D21)/D21
XLB1=XP1+DRATIO*(XP2-XP1)
YLB1=YP1+DRATIO*(YP2-YP1)
XLBP1=XLTRNX(XLB1)
YLBP1=XLTRNY(YLB1)
CALL XPENDN( XLB1,YLB1 )
NCALDN=1
XP1=XLB1
YP1=YLB1
XPP1=XLBP1
YPP1=YLBP1
XBUF(0)=XLB1
YBUF(0)=YLB1
NBUF=0
ENDIF
D21=SQRT((XPP2-XPP1)*(XPP2-XPP1)+(YPP2-YPP1)*(YPP2-YPP1))
WL=SQRT( (XPP2-XLBP1)*(XPP2-XLBP1)+(YPP2-YLBP1)*(YPP2-YLBP1))
IF(WL -WLABEL) 9111,9112,9112
9112 DRATIO=(WLABEL-WL+D21) /D21
XLB2=XP1+DRATIO*(XP2-XP1)
YLB2=YP1+DRATIO*(YP2-YP1)
XLBP2=XLTRNX(XLB2)
YLBP2=XLTRNY(YLB2)
IF( LABROT.EQ.0) THEN
ANG=0.0
DPX=0.0
DPY=HLABEL*0.4
XLB =(XLBP1+ XLBP2)*0.5
YLB =(YLBP1+ YLBP2)*0.5-DPY
GOTO 130
ENDIF
IF(ABS( XLBP2-XLBP1).LE. 1.0E-10) THEN
ANG=90.0
ELSE
ANG=ATAN( (YLBP2-YLBP1)/(XLBP2-XLBP1) )*180/3.1415926535
ENDIF
DX=XLBP2-XLBP1
DY=YLBP2-YLBP1
IF( ABS(DX).LT.1.0E-6) THEN
DPX=HLABEL*0.4
DPY=0.0
ELSE
AK=DY/DX
A=SQRT(1.0+AK*AK)
DPX=HLABEL*AK/A *0.4
DPY=HLABEL/A *0.4
ENDIF
XLB =(XLBP1+ XLBP2)*0.5 +ABS(DPX) *SIGN(1.0, ANG)
YLB =(YLBP1+ YLBP2)*0.5 -ABS(DPY)
130 CONTINUE
CALL XLINVT( XLB, YLB )
IF(iwndon.eq.0 .or. ((xlb-xw1)*(xlb-xw2).le.0.0 .and.
: (ylb-yw1)*(ylb-yw2).le.0.0) ) THEN
C Draw boxes around labels . Usful when wish to blank the labeled area.
IF( labmask.ne.0) then
call xqcolor(kcolor)
call xcolor(0)
DBX=DPX*1.5
DBY=DPY*1.5
XE(1)=XLBP1+DBX
YE(1)=YLBP1-DBY
XE(2)=XLBP1-DBX
YE(2)=YLBP1+DBY
XE(3)=XLBP2-DBX
YE(3)=YLBP2+DBY
XE(4)=XLBP2+DBX
YE(4)=YLBP2-DBY
CALL XLINVT( XE(1),YE(1))
CALL XLINVT( XE(2),YE(2))
CALL XLINVT( XE(3),YE(3))
CALL XLINVT( XE(4),YE(4))
CALL XFILAREA(xe,ye,4)
c CALL XPENUP( XE1,YE1)
c CALL XPENDN( XE2,YE2)
c CALL XPENDN( XE3,YE3)
c CALL XPENDN( XE4,YE4)
c CALL XPENDN( XE1,YE1)
C
call xcolor(kcolor)
endif
c
C write the label
CALL XQCHOR( ANGSYM )
CALL XCHORI( ANG)
CALL XQCHMG( CMAG )
CALL XCHMAG( HLABEL)
CALL XCHARC( XLB,YLB, CLABEL(1:LCLAB) )
CALL XCHORI( ANGSYM )
CALL XCHMAG( CMAG )
ENDIF
DL=MIN( WL -WLABEL , DLABEL)
WL=0.0
NBUF=0
CALL XPENUP( XLB2, YLB2)
CALL XPENDN( XP2,YP2 )
GOTO 9150
9111 WL=WL
C CALL XPENUP(XP2,YP2)
NBUF=NBUF+1
XBUF(NBUF)=XP2
YBUF(NBUF)=YP2
IF(NBUF.GE.30) THEN
DO 210 NN=0,NBUF,2
XBUF(NN/2)=XBUF(NN)
210 YBUF(NN/2)=YBUF(NN)
NBUF=NN/2
ENDIF
GOTO 9150
9101 CALL XPENDN(XP2,YP2)
9150 XP1=XP2
YP1=YP2
XPP1=XPP2
YPP1=YPP2
CONTINUE
RETURN
ENTRY XLABMASK(lbmsk)
labmask = lbmsk
RETURN
END
SUBROUTINE XLBINT( NCLI) 1
CHARACTER CLABEL*20 ,CLABL*(*), LABEL*20, LBFORM*(*)
COMMON /XLAB14/ DLABEL,WLABEL,HLABEL,SIZLB,KLBTYP,ICLI,ICLON
COMMON /XLAB15/CLABEL
COMMON /XLAB16/ LCLAB
COMMON /XLBA33/ LABROT
CALL XQRANG( XRG,YRG)
DLABEL=XRG/NCLI
ICLI=NCLI
RETURN
ENTRY XLBSIZ( H1 )
KLBTYP=1
SIZLB=abs(H1)
RETURN
ENTRY XLBMAG( H)
KLBTYP=0
HLABEL=abs(H)
WLABEL= HLABEL*LCLAB*0.77
RETURN
ENTRY XLBROT(KROT)
LABROT=KROT
RETURN
ENTRY XLBON
ICLON=1
RETURN
ENTRY XLBOFF
ICLON=0
RETURN
ENTRY XQLBON(KLBON)
KLBON=ICLON
RETURN
ENTRY XLABEL( CLABL )
CLABEL=CLABL
LCLAB= LEN ( CLABL )
WLABEL=HLABEL*LCLAB*0.77
RETURN
ENTRY XQLABL( LABEL , LCH)
LABEL= CLABEL
LCH=LCLAB
RETURN
ENTRY XLBFM ( LBFORM )
RETURN
END
SUBROUTINE XINUMB(X,Y,I, FORM ),2
CHARACTER CH*132 , FORM*(*)
IF( FORM.EQ. '*' ) THEN
CALL XICH(I,CH,LCH)
ELSE
WRITE( CH, FORM ) I
LCH= ICLENG ( CH )
ENDIF
CALL XCHARL(X,Y,CH(1:LCH) )
END
SUBROUTINE XRNUMB(X,Y,R, FORM ) 3,2
CHARACTER CH*132 , FORM*(*)
IF( FORM.EQ. '*' ) THEN
CALL XRCH(R,CH,LCH)
ELSE
WRITE( CH, FORM ) R
LCH= ICLENG ( CH )
ENDIF
CALL XCHARL(X,Y,CH(1:LCH) )
END
SUBROUTINE XICH( I,CH, LCH) 3,1
CHARACTER CH*20
WRITE(CH,'( I20 )') I
LCH=20
CALL XCHLJ( CH, LCH )
END
SUBROUTINE XRCH( R,CH,LCH) 13,1
C Return real number R as a character string in automatically set format
CHARACTER CH*20
ABSR=ABS(R)
IF(ABSR.GE.1.0E5.OR.(ABSR.GT.0.0.AND.ABSR.LT.1.0E-2))THEN
WRITE(CH,'(1P,E20.2)') R
ELSEIF( ABSR.LT.0.1.AND. ABSR.NE.0.0) THEN
WRITE(CH,'(F20.2)') R
ELSE
WRITE(CH,'(F20.1)') R
ENDIF
LCH=20
CALL XCHLJ( CH, LCH)
END
SUBROUTINE XCHLJ( CH,LCH) 17
C Left justify a character string.
CHARACTER CH*(*) , CH1*20
K=1
LCH=LEN( CH )
DO 1 L=1,LCH
IF( CH(L:L).NE.' ') THEN
K=L
GOTO 2
ENDIF
1 CONTINUE
2 CH1=CH
CH=' '
CH(1:LCH-K+1)=CH1(K:LCH)
LCH=LCH-K+1
RETURN
END
SUBROUTINE XLETER(XO,YO,STRING, IPOS ) 3,7
COMMON /XCHP21/ XCHPEN, YCHPEN ,XCHMO,YCHMO,XCHPO,YCHPO
COMMON /XPHY01/ PL,PR,PB,PT,XRANGE,YRANGE
COMMON /XMAP04/ XL,XR,YB,YT,XSCALE,YSCALE
COMMON /XFTR06/ XFACTR,YFACTR
COMMON /XCHA20/ HCTR,SCTR,CRATIO, KFONT,NUNDLN
COMMON /XASC12/ IASCII(300)
COMMON /XCHR30/ ICRAM(256)
COMMON /XCHR31/ CHDATA
COMMON /XCHR32/ ICDATA
INTEGER ICDATA (0:150, 32:127)
CHARACTER CTEMP*1, CH*5,CHDATA(127)*300
CHARACTER*(*) STRING
LOGICAL MODE
common /xoutch/ nch
CH=CHDATA(2)
READ(CH ,103)IXCHR,IYCHR
CXY=0.75
SY = HCTR /( YFACTR *IYCHR)
SX = HCTR /( XFACTR *IYCHR) *CRATIO/CXY
IF( KFONT.EQ.2) THEN
FACTOR=6.0/4.2
SX=SX*FACTOR
SY=SY*FACTOR
ENDIF
XCHMO=XO
YCHMO=YO
XCHPO=XLTRNX(XO)
YCHPO=XLTRNY(YO)
N = LEN (STRING)
IF( IPOS.LT.0) GOTO 600
ITX=0
DO 8 ICHR=1,N
CTEMP = STRING (ICHR:ICHR)
I = ICHAR(CTEMP)
c I = ICRAM(I)
c I = IASCII(I)
IF( I.EQ.0) I=32
IF( ICDATA(0,I).NE.KFONT) THEN
CALL XCHDEC(ICDATA,CHDATA,I)
ICDATA(0,I)=KFONT
ENDIF
NCD=ICDATA(1,I)
IX= ICDATA(NCD-1,I)
IF( IX.GE.50) IX=IX-50
ITX=ITX+IX
8 CONTINUE
XWIDTH= ITX* SX
600 IF( IPOS ) 601,602,603
602 XSPOS=XO-0.5*XWIDTH
GOTO 300
603 XSPOS=XO- XWIDTH
GOTO 300
601 XSPOS=XO
300 CONTINUE
YSPOS = YO
XSP = XSPOS
YSP = YSPOS
XTPOS = XSPOS
YTPOS = YSPOS
CALL XCPNUP(XSP, YSP)
DO 1 ICHR=1,N
CTEMP = STRING (ICHR:ICHR)
I = ICHAR(CTEMP)
c I = ICRAM(I)
c I = IASCII(I)
IF (I .EQ. 0) THEN
I=32
IF( CTEMP.NE.' ')
: WRITE(NCH,*)' Can not draw character ',CTEMP,' it was replaced'
: ,' by a blank by ZXPLOT.'
ENDIF
IF( ICDATA(0,I).NE.KFONT) THEN
CALL XCHDEC(ICDATA,CHDATA,I)
ICDATA(0,I)=KFONT
ENDIF
NCD=ICDATA(1,I)
DO 3 ICD=2,NCD,2
IX= ICDATA(ICD,I)
JY= ICDATA(ICD+1,I)
MODE=.TRUE.
IF( IX.GE.50) THEN
MODE=.FALSE.
IX=IX-50
ENDIF
XTPOS = XSP + FLOAT(IX)*SX
YTPOS = YSP + FLOAT(JY)*SY
C IF (XTPOS.GT.XR.OR.XTPOS.LT.XL) WRITE(NCH,*)'Out of bound in x-dir.'
C IF (YTPOS.GT.YT.OR.YTPOS.LT.YB) WRITE(NCH,*)'Out of bound in y-dir.'
IF (MODE) THEN
CALL XCPNDN(XTPOS, YTPOS )
ELSE
CALL XCPNUP(XTPOS, YTPOS )
ENDIF
3 CONTINUE
XSP=XTPOS
YSP=YTPOS
1 CONTINUE
DO 2 N=1,NUNDLN
XST = XSPOS - 5.0*SX
YST = YSPOS - 15.0*SY
XFI = XTPOS + 5.0*SX
YFI = YTPOS - 15.0*SY
CALL XCPNUP (XST,YST)
CALL XCPNDN (XFI,YFI)
2 CONTINUE
C XCHPEN=XTPOS
C YCHPEN=YTPOS
RETURN
103 FORMAT(I2,1X,I2)
END
FUNCTION XCHLEN(STRING),3
COMMON /XPHY01/ PL,PR,PB,PT,XRANGE,YRANGE
COMMON /XMAP04/ XL,XR,YB,YT,XSCALE,YSCALE
COMMON /XFTR06/ XFACTR,YFACTR
COMMON /XCHA20/ HCTR,SCTR,CRATIO, KFONT,NUNDLN
COMMON /XASC12/ IASCII(300)
COMMON /XCHR30/ ICRAM(256)
COMMON /XCHR31/ CHDATA
COMMON /XCHR32/ ICDATA
INTEGER ICDATA (0:150, 32:127)
CHARACTER CTEMP*1, CH*5,CHDATA(127)*300
CHARACTER*(*) STRING
CH=CHDATA(2)
READ(CH ,103)IXCHR,IYCHR
CXY=0.75
CALL XQPSCL( XSC, YSC )
SY = 1.0/ ( IYCHR* YFACTR)*YSC
SX = 1.0/ ( IYCHR* XFACTR)*XSC *CRATIO/CXY
IF( KFONT.EQ.2) THEN
FACTOR=6.0/4.2
SX=SX*FACTOR
SY=SY*FACTOR
ENDIF
N = LEN (STRING)
ITX=0
DO 8 ICHR=1,N
CTEMP = STRING (ICHR:ICHR)
I = ICHAR(CTEMP)
c I = ICRAM(I)
c I = IASCII(I)
IF( I.EQ.0) I=32
IF( ICDATA(0,I).NE.KFONT) THEN
CALL XCHDEC(ICDATA,CHDATA,I)
ICDATA(0,I)=KFONT
ENDIF
NCD=ICDATA(1,I)
IX= ICDATA(NCD-1,I)
IF( IX.GE.50) IX=IX-50
ITX=ITX+IX
8 CONTINUE
XWIDTH= ITX* SX
XP1= 0.0
YP1= 0.0
XP2= XWIDTH
YP2= 0.0
CALL XCTRAN(XP1,YP1)
CALL XCTRAN(XP2,YP2)
XCHLEN=SQRT( (XP2-XP1)*(XP2-XP1)+ (YP2-YP1)*(YP2-YP1))
RETURN
103 FORMAT(I2,1X,I2)
END
FUNCTION ICLENG( CH )
CHARACTER*(*) CH
ICLENG=0
IC=LEN( CH )
DO 5 L=1,IC
5 IF( CH(L:L).NE.' ') ICLENG=L
RETURN
END
SUBROUTINE XCHOBL( CTROBL )
COMMON /XCHA20/ HCTR,SCTR,CRATIO, KFONT,NUNDLN
CRATIO= CTROBL
RETURN
ENTRY XQCHOB( COBL )
COBL=CRATIO
RETURN
END
SUBROUTINE XCHLIN( N )
COMMON /XCHA20/ HCTR,SCTR,CRATIO, KFONT,NUNDLN
NUNDLN=N
RETURN
ENTRY XQCHLN ( NN )
NN=NUNDLN
RETURN
END
SUBROUTINE XSTRLNTH( string, length ) 11
c Return the length of the non-blank part of a character string.
c INPUT:
c string A character string
c length The declared length of the character string 'string'.
c OUTPUT:
c length The length of the non-blank part of the string.
c
implicit none
character string*(*)
integer length
integer i
DO 100 i = length,1,-1
IF(string(i:i) .ne. ' '.and.string(i:i).ne.' ') GOTO 200
100 continue
200 CONTINUE
length = max(1,i)
RETURN
END
SUBROUTINE XCHRST(X2,Y2) 4
C Perform rotation around picture reference point (XMREF,YMREF)
COMMON /XCHP21/ XCHPEN, YCHPEN ,XCHMO,YCHMO,XCHPO,YCHPO
COMMON /XAGS09/ DRANG,CRANG,XANGLE,XSYMAN,SRANG,KSR,XA,YA
COMMON /XSCS10/ SINDRA,COSDRA,SINMRA,COSMRA,SINSRA,COSSRA
: ,SINXA,COSXA,SINYA,COSYA ,CHSIN,CHCOS
IF( XSYMAN.EQ.0.0) RETURN
X1=X2-XCHPO
Y1=Y2-YCHPO
X2=X1*CHCOS-Y1*CHSIN +XCHPO
Y2=X1*CHSIN+Y1*CHCOS +YCHPO
RETURN
ENTRY XCHORI(CHANG)
XSYMAN=CHANG
IF( CHANG.EQ.0) GOTO 3
RADANG= ATAN(1.)/45.0*XSYMAN
CHSIN= SIN( RADANG)
CHCOS= COS( RADANG)
XANGLE=CRANG+DRANG+(90-SRANG)*KSR+XA
RETURN
3 CHSIN= 0.0
CHCOS= 1.0
RETURN
ENTRY XQCHOR(SYMANG)
SYMANG=XSYMAN
RETURN
END
SUBROUTINE XCPNUP(X,Y) 3,4
COMMON /XCHP21/ XCHPEN, YCHPEN ,XCHMO,YCHMO,XCHPO,YCHPO
COMMON /XPEN11/ XPEN,YPEN,FLEN,BLEN,NPD,XMPEN,YMPEN
common /xcwndw/ icwndw, xcpen, ycpen
common /xmask1/ xm1(99),xm2(99),ym1(99),ym2(99),rmangl(99),
: cosmsa(99),sinmsa(99),lvlmsk
XCHPEN=X
YCHPEN=Y
X1=X
Y1=Y
CALL XCTRAN( X1,Y1)
xpen=x1
ypen=y1
CALL PPENUP( X1,Y1)
if(icwndw.eq.1.or.lvlmsk.ge.1)then
xcpen=xchpen
ycpen=ychpen
Xcpen=XLTRNX(Xcpen)
Ycpen=XLTRNY(Ycpen)
CALL XCHRST(Xcpen,ycpen)
call xlinvt(xcpen,ycpen)
XmPEN=xcpen
YmPEN=ycpen
endif
RETURN
END
subroutine xcpndn(x,y) 2,18
common /xchp21/ xchpen, ychpen ,xchmo,ychmo,xchpo,ychpo
COMMON /XPEN11/ XPEN,YPEN,FLEN,BLEN,NPD,XMPEN,YMPEN
common /xcwndw/ icwndw, xcpen, ycpen
common /xmask1/ xm1(99),xm2(99),ym1(99),ym2(99),rmangl(99),
: cosmsa(99),sinmsa(99),lvlmsk
real xa(199),ya(199),xb(199),yb(199)
xchpen=x
ychpen=y
if(icwndw.eq.0.and.lvlmsk.eq.0)then
x2=x
y2=y
call xctran(x2,y2)
xpen=x2
ypen=y2
call ppendn(x2,y2)
xcpen=x
ycpen=y
Xcpen=XLTRNX(Xcpen)
Ycpen=XLTRNY(Ycpen)
CALL XCHRST(Xcpen,ycpen)
call xlinvt(xcpen,ycpen)
XmPEN=xcpen
YmPEN=ycpen
goto 999
endif
xcpen0=xcpen
ycpen0=ycpen
x1=xcpen0
y1=ycpen0
X2=X
Y2=Y
X2=XLTRNX(X2)
Y2=XLTRNY(Y2)
CALL XCHRST(X2,Y2)
call xlinvt(x2,y2)
xcpen=x2
ycpen=y2
xmpen=xcpen
ympen=ycpen
if(icwndw.eq.1)then
call xtstwd(x1,y1,x2,y2,idispl)
x2a=x2
y2a=y2
if(idispl.ne.1)then
call xtrans(x2,y2)
xpen=x2
ypen=y2
call ppenup(x2,y2)
goto 999
endif
endif
lnsegs=1
xa(1)=x1
ya(1)=y1
xb(1)=x2
yb(1)=y2
if(lvlmsk.gt.0)then
call xtsmsk(xa,ya,xb,yb,lnsegs)
if(lnsegs.eq.0)then
call xtrans(x2 ,y2 )
xpen=x2
ypen=y2
call ppenup(x2 ,y2 )
goto 999
endif
endif
do 100 lin=1,lnsegs
x1=xa(lin)
y1=ya(lin)
x2=xb(lin)
y2=yb(lin)
x2a=x2
y2a=y2
if(x1.ne.xcpen0.or.y1.ne.ycpen0.or.lin.ne.1)then
call xtrans(x1 ,y1 )
xpen=x1
ypen=y1
call ppenup(x1 ,y1 )
endif
call xtrans(x2,y2)
xpen=x2
ypen=y2
call ppendn(x2,y2)
100 continue
if(x2a.ne.xcpen.or.y2a.ne.ycpen)then
x2=xcpen
y2=ycpen
call xtrans(x2,y2)
xpen=x2
ypen=y2
call ppenup(x2,y2)
endif
999 continue
RETURN
ENTRY XQCPEN( XCHP, YCHP )
XCHP=XCHPEN
YCHP=YCHPEN
RETURN
END
SUBROUTINE XCTRAN(X,Y) 4,5
COMMON /XPHO03/ DXPO,DYPO
COMMON /XMAO05/ DXMOP,DYMOP
COMMON /XPRJ26/ KPROJC
EXTERNAL XLTRNX,XLTRNY
X1=X
Y1=Y
IF(KPROJC.NE.0) CALL XPROJC(X1,Y1)
X1=XLTRNX(X1)
Y1=XLTRNY(Y1)
CALL XCHRST(X1,Y1)
C CALL XSRSET(X1,Y1)
CALL XOBSET(X1,Y1)
CALL XMRSET(X1,Y1)
X1=X1+DXMOP
Y1=Y1+DYMOP
CALL XDRSET(X1,Y1)
X=X1+DXPO
Y=Y1+DYPO
RETURN
END
C UTILITY ROUTINES:
SUBROUTINE XPOINT(X,Y) 1,5
C Plot a point at position (X,Y) of mathematical space with predefined
C size. ( The size can be defined by XRPONT).
COMMON /XCIR25/ XCIR(9) ,YCIR(9) , RPOINT
X1=X
Y1=Y
CALL XTRANS(X1,Y1)
CALL PPENUP(X1+RPOINT*XCIR(1), Y1+RPOINT*YCIR(1) )
DO 6 I=1,9
6 CALL PPENDN(X1+RPOINT*XCIR(I), Y1+RPOINT*YCIR(I) )
RETURN
ENTRY XPPONT(XP,YP)
CALL PPENUP(XP+RPOINT*XCIR(1), YP+RPOINT*YCIR(1) )
DO 5 I=3,9,2
5 CALL PPENDN(XP+RPOINT*XCIR(I), YP+RPOINT*YCIR(I) )
RETURN
ENTRY XPNTSZ(R)
C Define the size of points to be plotted by XPOINT by their radius
C in ND-space. By default R=0.0005
RPOINT=R
RETURN
END
SUBROUTINE XINTMKR 1
c
c This subroutine will define (initialize) some additional marker
c shapes for zxplot Library.
c
parameter (mxmrkty=10, mxmrkp=10)
COMMON /XPSD01/ XSIDE, YSIDE
integer imkrfil
COMMON /XMRK25/imkrfil,
: XMRK(mxmrkp,mxmrkty),YMRK(mxmrkp,mxmrkty),
: MDX(mxmrkty),RMARKER
imkrfil = 0
PI = 4.0*ATAN(1.0)
DO 71 J=1,mxmrkty
DO 71 I=1,mxmrkp
XMRK(I,J)=0.0
YMRK(I,J)=0.0
MDX(J)=0
71 CONTINUE
DO 70 I=1,9
XMRK(I,1)=COS((I-1)*0.25*PI)
YMRK(I,1)=SIN((I-1)*0.25*PI)
70 CONTINUE
mdx(1)=9
XMRK(1,2) = 1.0
YMRK(1,2) = 1.0
XMRK(2,2) = 0.
YMRK(2,2) = -1.0
XMRK(3,2) = -1.0
YMRK(3,2) = 1.0
XMRK(4,2) = 1.0
YMRK(4,2) = 1.0
MDX(2)=4
XMRK(1,3) = 0.0
YMRK(1,3) = 2.0
XMRK(2,3) = 1.0
YMRK(2,3) = 0.0
XMRK(3,3) = -1.0
YMRK(3,3) = 0.0
XMRK(4,3) = 0.0
YMRK(4,3) = 2.0
MDX(3)=4
XMRK(1,4) = 1.0
YMRK(1,4) = 1.0
XMRK(2,4) = 1.0
YMRK(2,4) = -1.0
XMRK(3,4) = -1.0
YMRK(3,4) = -1.0
XMRK(4,4) = -1.0
YMRK(4,4) = 1.0
XMRK(5,4) = 1.0
YMRK(5,4) = 1.0
MDX(4)=5
XMRK(1,5) = 1.0
YMRK(1,5) = 0.0
XMRK(2,5) = 0.0
YMRK(2,5) = -1.0
XMRK(3,5) = -1.0
YMRK(3,5) = 0.0
XMRK(4,5) = 0.0
YMRK(4,5) = 1.0
XMRK(5,5) = 1.0
YMRK(5,5) = 0.0
MDX(5)=5
RMARKER=0.0010*YSIDE
RETURN
END
SUBROUTINE XMARKER(X,Y,ITY) 14,5
c
c This subroutine will draw markers
c
c x,y marker's coordination
c ity Marker number
c
parameter (mxmrkty=10, mxmrkp=10)
integer imkrfil
COMMON /XMRK25/imkrfil,
: XMRK(mxmrkp,mxmrkty),YMRK(mxmrkp,mxmrkty),
: MDX(mxmrkty),RMARKER
common /xwndw1/ xw1,xw2,yw1,yw2, iwndon
real Xw(mxmrkp), Yw(mxmrkp)
IF(iwndon.ne.0) THEN
IF((x-xw1)*(x-xw2).gt.0.0 .or.((y-yw1)*(y-yw2).gt.0.0))
: return
ENDIF
X1=X
Y1=Y
CALL XTRANS(X1,Y1)
IF( imkrfil.eq.0 ) THEN
CALL PPENUP(X1+RMARKER*XMRK(1,ITY),Y1+RMARKER*YMRK(1,ITY) )
DO 7 I=1,MDX(ITY)
7 CALL PPENDN(X1+RMARKER*XMRK(I,ITY), Y1+RMARKER*YMRK(I,ITY))
ELSE
DO 9 I=1,MDX(ITY)
Xw(I) = X1+RMARKER*XMRK(I,ITY)
Yw(I) = Y1+RMARKER*YMRK(I,ITY)
CALL XLINVT (Xw(I),Yw(I))
9 CONTINUE
CALL XFILAREA(Xw,Yw,MDX(ITY))
ENDIF
RETURN
ENTRY XMRKSZ(R)
RMARKER=R
RETURN
ENTRY XMKRFIL( imkfil )
imkrfil = imkfil
RETURN
ENTRY XQMKRFIL( imkfil0 )
imkfil0 = imkrfil
RETURN
END
SUBROUTINE XBOX(X1,X2,Y1,Y2) 7,5
CALL XPENUP( X1,Y1)
CALL XPENDN ( X2,Y1)
CALL XPENDN ( X2,Y2)
CALL XPENDN ( X1,Y2)
CALL XPENDN ( X1,Y1)
RETURN
END
SUBROUTINE XBORDR 14,1
C DRAW A BORDER AROUND MAPPED AERA
COMMON /XMAP04/ X1,X2,Y1,Y2,XSCALE,YSCALE
CALL XBOX(X1,X2,Y1,Y2)
RETURN
END
SUBROUTINE XAXES(XO,XSTEP,YO,YSTEP) 14,2
C Draw X and Y axis through (XO,YO) with tick interval XSTEP and YSTEP
C If XSTEP or YSTEP=0.0,the intervals are set automatically
CALL XAXISX1(XO,YO,XSTEP, 0.0)
CALL XAXISY1(XO,YO,YSTEP, 0.0)
RETURN
END
SUBROUTINE XAXISX(XO,YO,XSTEP) 2,1
CALL XAXISX1(XO,YO,XSTEP, 0.0)
RETURN
END
SUBROUTINE XAXISY(XO,YO,YSTEP) 4,1
CALL XAXISY1(XO,YO,YSTEP, 0.0)
RETURN
END
SUBROUTINE XAXISX1(XO,YO,XSTEP_in,XMJSTEP) 2,9
C To draw X-AXIS through (XO,YO) with tick interval of XSTEP.
C If XSTEP=0.0,the interval is set automatically
c 2/17/1999 (M.Xue) Wrote this XAXISX and added YMJSTEP.
PARAMETER( JUMP =2 )
COMMON /XMAP04/ XL,XR,YB,YT,XSCALE,YSCALE
COMMON /XPHY01/ PL,PR,PB,PT,XRANGE,YRANGE
COMMON /XFTR06/ XFACTR,YFACTR
COMMON /XFMT33/ LBFMT, AXFMT
COMMON /XFMT34/ LLBFMT,LAXFMT
COMMON /XAXS18/ KANX,KANY, KTKX,KTKY
CHARACTER LBFMT*50, AXFMT*10
CHARACTER CH*20
EXTERNAL XAXINC
COMMON /XAXM35/ NTMAG, ANMAG, ANSIZ
real xmjstep
integer ijump, passed, ifold
IF( KTKX.EQ.0 .and.kanx.eq.0) RETURN
IF( xr.eq.xl ) return
UNITH=SQRT( ABS(XRANGE*YRANGE))*0.01
UH= MIN( ABS(XRANGE), ABS(YRANGE) )*0.03
IF( NTMAG.EQ.0) ANMAG=UH
IF( NTMAG.EQ.2) ANMAG=ANSIZ*YFACTR
HX= ANMAG/XFACTR
HY= ANMAG/YFACTR
CALL XQCHMG( HOLD )
CALL XCHMAG( ANMAG )
CALL XPENUP( XL, YO)
CALL XPENDN( XR, YO)
xstep = xstep_in
IF( XSTEP.EQ.0.0) THEN
XSTEPJ=XAXINC(XR-XL)
xstep = xstepj
ELSEIF(xmjstep.eq.0.0) THEN
XSTEPJ=XSTEP
5 IF( abs(NINT((XR-XL)/XSTEPJ)).GT.6 ) THEN
XSTEPJ=XSTEPJ*2
GOTO 5
ENDIF
ELSE
ijump=nint( xmjstep/xstep)
XSTEPJ=XSTEP*ijump
ENDIF
IF( KTKX.EQ.0) GOTO 110
HTICK=UNITH /YFACTR*KTKX
AXL=XO+ NINT((XL-XO)/XSTEP)*XSTEP
AXL=XO+ NINT((XL-XO)/XSTEPJ)*XSTEPJ - XSTEPJ
tem=XSTEPJ/XSTEP
IFOLD=NINT(XSTEPJ/XSTEP)
IFOLD=NINT( tem )
ifold = max(1, ifold)
epsx = (xr-xl)*0.001
passed =0
DO 150 i=0,5000
X=AXL+I*XSTEP
IF ((X-(XL-epsx))*(X-(XR+epsx)).le.0.0) then
passed=1
IF( KTKX.NE.0) THEN
XHT=HTICK
IF( MOD(I, IFOLD).EQ.0) XHT=HTICK+HTICK
CALL XPENUP(X,YO)
CALL XPENDN(X,YO+XHT)
ENDIF
IF( KANX.NE.0 .and. MOD(I, IFOLD).EQ.0) THEN
IF( AXFMT(1:LAXFMT).EQ.'*') THEN
CALL XRCH(X, CH, LCH)
ELSE
DO 503 KCH=1,LAXFMT
IF((AXFMT(KCH:KCH).EQ.'I')
: .or.(AXFMT(KCH:KCH).EQ.'i'))THEN
WRITE(CH,AXFMT(1:LAXFMT)) NINT(X)
GOTO 504
ENDIF
503 CONTINUE
WRITE(CH,AXFMT(1:LAXFMT)) X
504 LCH=ICLENG( CH )
CALL XCHLJ( CH(1:LCH), LCH)
ENDIF
YSHIFT=HY*1.5*KANX
CALL XCHARC(X, YO+YSHIFT, CH(1:LCH) )
ENDIF
ELSE
IF( passed.eq.1) GOTO 110
ENDIF
150 CONTINUE
110 CONTINUE
CALL XCHMAG( HOLD )
RETURN
END
SUBROUTINE XAXISY1(XO,YO,YSTEP_in,YMJSTEP) 2,10
C To draw Y-AXIS through (XO,YO) with tick interval of YSTEP.
C If YSTEP=0.0,the interval is set automatically
c 2/17/1999 (M.Xue) Wrote this XAXISY and added XMJSTEP.
implicit none
real xo,yo,ystep_in,ymjstep
real XL,XR,YB,YT,XSCALE,YSCALE
COMMON /XMAP04/ XL,XR,YB,YT,XSCALE,YSCALE
real PL,PR,PB,PT,XRANGE,YRANGE
COMMON /XPHY01/ PL,PR,PB,PT,XRANGE,YRANGE
real XFACTR,YFACTR
COMMON /XFTR06/ XFACTR,YFACTR
CHARACTER LBFMT*50, AXFMT*10
COMMON /XFMT33/ LBFMT, AXFMT
integer LLBFMT,LAXFMT
COMMON /XFMT34/ LLBFMT,LAXFMT
integer KANX,KANY, KTKX,KTKY
COMMON /XAXS18/ KANX,KANY, KTKX,KTKY
CHARACTER CH*20
real xaxinc, ystep
EXTERNAL XAXINC
real anmag,ansiz
integer ntmag,jfold,lch,kch,icleng
COMMON /XAXM35/ NTMAG, ANMAG, ANSIZ
real y,eps,unith,uh,hx,hy,hold,ystepj,AYB,yht,htick
integer j,jjump, passed
IF( KTKY.EQ.0 .and.kanY.eq.0) RETURN
IF( yt.eq.yb ) return
UNITH=SQRT( ABS(XRANGE*YRANGE))*0.01
UH= MIN( ABS(XRANGE), ABS(YRANGE) )*0.03
IF( NTMAG.EQ.0) ANMAG=UH
IF( NTMAG.EQ.2) ANMAG=ANSIZ*YFACTR
HX= ANMAG/XFACTR
HY= ANMAG/YFACTR
CALL XQCHMG( HOLD )
CALL XCHMAG( ANMAG )
CALL XPENUP( XO, YB)
CALL XPENDN( XO, YT)
ystep = ystep_in
IF( YSTEP.EQ.0.0) THEN
YSTEPJ=XAXINC(YT-YB)
ystep = ystepj
ELSEIF(ymjstep.eq.0.0) THEN
YSTEPJ=YSTEP
5 IF( abs( NINT((YT-YB)/YSTEPJ)).GT.6 ) THEN
YSTEPJ=YSTEPJ*2
GOTO 5
ENDIF
ELSE
jjump=nint( ymjstep/YSTEP)
YSTEPJ=YSTEP*jjump
ENDIF
IF( KTKY.EQ.0) GOTO 110
HTICK=UNITH/XFACTR*KTKY
AYB=YO+ NINT((YB-YO)/YSTEP)*YSTEP
AYB=YO+ NINT((YB-YO)/YSTEPJ)*YSTEPJ - YSTEPJ
JFOLD=NINT(YSTEPJ/YSTEP)
eps = (YT-YB)*0.001
passed =0
DO 150 j=0,5000
Y=AYB+j*YSTEP
IF ((Y-(YB-eps))*(Y-(YT+eps)).le.0.0) then
passed = 1
IF( KTKX.NE.0) THEN
YHT=HTICK
IF( MOD(j, JFOLD).EQ.0) YHT=HTICK+HTICK
CALL XPENUP(XO,Y)
CALL XPENDN(XO+YHT,Y)
ENDIF
IF( KANY.NE.0 .and. MOD(J, JFOLD).EQ.0) THEN
IF( AXFMT(1:LAXFMT).EQ.'*') THEN
CALL XRCH(Y, CH, LCH)
ELSE
DO 503 KCH=1,LAXFMT
IF((AXFMT(KCH:KCH).EQ.'I')
: .or.(AXFMT(KCH:KCH).EQ.'i'))THEN
WRITE(CH,AXFMT(1:LAXFMT)) NINT(Y)
GOTO 504
ENDIF
503 CONTINUE
WRITE(CH,AXFMT(1:LAXFMT)) Y
504 LCH=ICLENG( CH )
CALL XCHLJ( CH(1:LCH), LCH)
ENDIF
IF(KANY.EQ.-1)
: CALL XCHARR(XO-HX*0.7, Y-0.4*HY, CH(1:LCH) )
IF(KANY.EQ. 1)
: CALL XCHARL(XO+HX*0.7, Y-0.4*HY, CH(1:LCH) )
ENDIF
ELSE
IF(passed.eq.1) GOTO 110
ENDIF
150 CONTINUE
110 CONTINUE
CALL XCHMAG( HOLD )
RETURN
END
SUBROUTINE XAXANT(KANTX,KANTY) 10
COMMON /XAXS18/ KANX,KANY, KTKX,KTKY
COMMON /XFMT33/ LBFMT, AXFMT
COMMON /XFMT34/ LLBFMT,LAXFMT
CHARACTER LBFMT*50, AXFMT*10,AXFM*(*)
COMMON /XAXM35/ NTMAG, ANMAG, ANSIZ
C KANTX KANTY-- Axis annotation parameters.
C KANTX=1 annotation lacated above x-axis
C KANTX=-1 annotation lacated below x-axis
C KANTX=0 annotation on x-axis is suppressed
C KANTY=1 annotation lacated to the right of y-axis
C KANTY=-1 annotation lacated to the left of y-axis
C KANTY=0 annotation on y-axis is suppressed
C Default: KANTX=-1, KANTY=-1
KANX=KANTX
KANY=KANTY
RETURN
ENTRY XAXTIK(KTIKX,KTIKY)
C KTIKX KTIKY-- Axis ticking parameters.
C KTIKX=1 ticking lacated above x-axis
C KTIKX=-1 ticking lacated below x-axis
C KTIKX=0 ticking on x-axis is suppressed
C KTIKY=1 ticking lacated to the right of y-axis
C KTIKY=-1 ticking lacated to the left of y-axis
C KTIKY=0 ticking on y-axis is suppressed
C Default: KTIKX= 1, KTIKY= 1
KTKX=KTIKX
KTKY=KTIKY
RETURN
ENTRY XAXDEF
C* ZXPLOTI *
C To restore the default values of parameters for axis annotation
C and ticking.
KTKX=1
KTKY=1
KANX=-1
KANY=-1
RETURN
ENTRY XAXFMT( AXFM )
C* MODIFIED IN ZXPLOTI, INTEGER FORMAT ALLOWED. *
LAXFMT=LEN(AXFM)
AXFMT=AXFM
RETURN
END
SUBROUTINE XXAXIS(XCOOR,XVALUE,N,YO) 1,10
C To draw an X-AXIS through (XCOOR(1),YO) and tickmark the axis
C at x=xcoor(i) with value xvalue(i) for i=1,n.
real xcoor(n), xvalue(n)
COMMON /XMAP04/ XL,XR,YB,YT,XSCALE,YSCALE
COMMON /XPHY01/ PL,PR,PB,PT,XRANGE,YRANGE
COMMON /XFTR06/ XFACTR,YFACTR
COMMON /XFMT33/ LBFMT, AXFMT
COMMON /XFMT34/ LLBFMT,LAXFMT
COMMON /XAXS18/ KANX,KANY, KTKX,KTKY
CHARACTER LBFMT*50, AXFMT*10
CHARACTER CH*20
COMMON /XAXM35/ NTMAG, ANMAG, ANSIZ
UNITH=SQRT( ABS(XRANGE*YRANGE))*0.01
UH= MIN( ABS(XRANGE), ABS(YRANGE) )*0.03
IF( NTMAG.EQ.0) ANMAG=UH
IF( NTMAG.EQ.2) ANMAG=ANSIZ*YFACTR
HX= ANMAG/XFACTR
HY= ANMAG/YFACTR
CALL XQCHMG( HOLD )
CALL XCHMAG( ANMAG )
CALL XPENUP( Xcoor(1), YO)
CALL XPENDN( Xcoor(n), YO)
YSHIFT=HY*1.0*KANX
HTICK=UNITH*1.5/YFACTR*KTKX
DO 150 I=1,n
X=xcoor(i)
IF( AXFMT(1:LAXFMT).EQ.'*') THEN
CALL XRCH(Xvalue(i), CH, LCH)
ELSE
DO 503 KCH=1,LAXFMT
IF((AXFMT(KCH:KCH).EQ.'I')
: .or.(AXFMT(KCH:KCH).EQ.'i'))THEN
WRITE(CH,AXFMT(1:LAXFMT)) NINT(Xvalue(i))
GOTO 504
ENDIF
503 CONTINUE
WRITE(CH,AXFMT(1:LAXFMT)) Xvalue(i)
504 LCH=ICLENG( CH )
CALL XCHLJ( CH(1:LCH), LCH)
ENDIF
IF(KANX.EQ. 1) CALL XCHARC(X, YO+0.5*HY, CH(1:LCH))
IF(KANX.EQ.-1) CALL XCHARC(X, YO-1.0*HY, CH(1:LCH))
IF(KTKX.NE.0)THEN
CALL XPENUP(X,YO)
CALL XPENDN(X,YO+HTICK)
ENDIF
150 CONTINUE
CALL XCHMAG( HOLD )
RETURN
END
SUBROUTINE XYAXIS(XO,YCOOR,YVALUE,N) 3,10
C To draw Y-axis through (XO,YCOOR(1)) and tickmark at y=ycoord(j)
C with value yvalue(j) for j=1,n.
REAL YCOOR(N),YVALUE(N)
COMMON /XMAP04/ XL,XR,YB,YT,XSCALE,YSCALE
COMMON /XPHY01/PL,PR,PB,PT,XRANGE,YRANGE
COMMON /XFTR06/ XFACTR,YFACTR
COMMON /XAXS18/ KANX,KANY, KTKX,KTKY
COMMON /XFMT33/ LBFMT, AXFMT
COMMON /XFMT34/ LLBFMT,LAXFMT
CHARACTER LBFMT*50, AXFMT*10
CHARACTER CH*20
COMMON /XAXM35/ NTMAG, ANMAG, ANSIZ
UNITH=SQRT( ABS(XRANGE*YRANGE))*0.01
UH= MIN( ABS(XRANGE), ABS(YRANGE) )*0.03
IF( NTMAG.EQ.0) ANMAG=UH
IF( NTMAG.EQ.2) ANMAG=ANSIZ*YFACTR
HX= ANMAG/XFACTR
HY= ANMAG/YFACTR
CALL XQCHMG( HOLD )
CALL XCHMAG( ANMAG )
CALL XPENUP( XO, Ycoor(1))
CALL XPENDN( XO, Ycoor(n))
HTICK=UNITH*1.5/XFACTR*KTKY
DO 250 J=1,n
Y=ycoor(j)
IF( AXFMT(1:LAXFMT).EQ.'*') THEN
CALL XRCH(Yvalue(j), CH, LCH)
ELSE
DO 503 KCH=1,LAXFMT
IF((AXFMT(KCH:KCH).EQ.'I')
: .or.(axfmt(kch:kch).eq.'i')) THEN
WRITE(CH,AXFMT(1:LAXFMT)) NINT(Yvalue(j))
GOTO 504
ENDIF
503 CONTINUE
WRITE(CH,AXFMT(1:LAXFMT)) Yvalue(j)
504 LCH=ICLENG( CH )
CALL XCHLJ(CH(1:LCH), LCH)
ENDIF
IF( KANY ) 301,300,302
301 CALL XCHARR(XO-HX*0.3,Y-0.2*HY, CH(1:LCH) )
GOTO 300
302 CALL XCHARL(XO+HX*0.3,Y-0.2*HY, CH(1:LCH) )
300 IF(KTKY.NE.0)THEN
CALL XPENUP(XO,Y)
CALL XPENDN (XO+HTICK,Y)
ENDIF
250 CONTINUE
CALL XCHMAG( HOLD )
RETURN
END
REAL FUNCTION XAXINC(X)
c
C TO SET ANNOTATION INCREMENT (ANNOTATIONS >=4 AND =<16 FOR FOLD=1.0)
c
c Corrected version. 4/20/1994 Ming Xue.
c
integer D
real xlog
IF(x.eq.0.0) THEN
xaxinc = 1.0
return
ENDIF
xlog = log10(x)
IPOWER=INT(xlog )
if( xlog.lt.0.0 ) ipower = ipower-1
D= INT(X/10.0**IPOWER)
FOLD=1.0
IF(D.GE.1.AND.D.LT.3) THEN
XAXINC=2.0*10.0**(IPOWER-1)*FOLD
ELSEIF(D.GE.3.AND.D.LT.7) THEN
XAXINC=5.0*10.0**(IPOWER-1)*FOLD
ELSEIF(D.GE.7.AND.D.LT.10) THEN
XAXINC=1.0*10.0** IPOWER*FOLD
ELSEIF( d.eq.0) then
XAXINC=1.0*10.0** IPOWER*FOLD
ENDIF
IF(XAXINC .EQ.0.0) XAXINC=X*0.1
RETURN
END
SUBROUTINE XAXSCA(XL,XR,XSTEP, YB,YT,YSTEP) 15,1
C To draw ticks on border defined by (xl,xr,yb,yt) and annotate the
C ticks. Modifications: Options for annotation and ticking included
C just as those in axis plotting routines.
CALL XAXSCA1(XL,XR,XSTEP,0.0,YB,YT,YSTEP,0.0)
RETURN
END
SUBROUTINE XAXSCA1(XL,XR,XSTEP,XMJSTEP,YB,YT,YSTEP,YMJSTEP) 2,19
c
c add new variable XJUMP, YJUMP by Min , others almost like XAXSCA
C To draw ticks on border defined by (xl,xr,yb,yt) and annotate the
C ticks. Modifications: Options for annotation and ticking included
C just as those in axis plotting routines.
c
c Changed made by Ming Xue, 2/16/1998
c
c MX: 2/5/1999.
c XMJSTEP and YMJSTEP are now used to define major tick mark steps.
c 2/17/1999 (M.Xue) Rewrote this subroutine based on origin XAXSCA.
c
PARAMETER( JUMP=2 )
COMMON /XPHY01/PL,PR,PB,PT,XRANGE,YRANGE
COMMON /XFTR06/ XFACTR,YFACTR
COMMON /XFMT33/ LBFMT, AXFMT
COMMON /XFMT34/ LLBFMT,LAXFMT
COMMON /XAXS18/ KANX,KANY, KTKX,KTKY
CHARACTER LBFMT*50, AXFMT*10
CHARACTER CH*20
integer xjump, yjump, passed
real xmjstep, ymjstep
COMMON /XAXM35/ NTMAG, ANMAG, ANSIZ
SAVE KOR, X0, Y0
DATA KOR /0/
real eps
IF( XSTEP.EQ.0.0.OR. YSTEP.EQ.0.0) RETURN
UNITH=SQRT(ABS( XRANGE*YRANGE))*0.01
UH= MIN( ABS(XRANGE), ABS(YRANGE) )*0.03
IF( NTMAG.EQ.0) ANMAG=UH
IF( NTMAG.EQ.2) ANMAG=ANSIZ*YFACTR
HX= ANMAG/XFACTR
HY= ANMAG/YFACTR
CALL XQCHMG( HOLD )
CALL XCHMAG( ANMAG )
IF(xmjstep.eq.0.0) THEN
XSTEPJ=XSTEP*JUMP
5 IF( NINT((XR-XL)/XSTEPJ).GT.6 ) THEN
XSTEPJ=XSTEPJ*2
GOTO 5
ENDIF
ELSE
xjump=nint( xmjstep/xstep)
XSTEPJ=XSTEP*xjump
ENDIF
IF(ymjstep.eq.0.0) THEN
YSTEPJ=YSTEP*JUMP
6 IF( NINT((YT-YB)/YSTEPJ).GT.6 ) THEN
YSTEPJ=YSTEPJ*2
GOTO 6
ENDIF
ELSE
yjump=nint( ymjstep/ystep)
YSTEPJ=YSTEP*yjump
ENDIF
IF( KOR.EQ.1) THEN
XO=X0
YO=Y0
ELSE
XO=XL
YO=YB
ENDIF
CALL XBOX(XL,XR,YB,YT)
IF( KANX.EQ.0 .AND. KTKX.EQ.0 ) GOTO 160
HTICK=UNITH/YFACTR*KTKX
AXL=XO+NINT((XL-XO)/XSTEP)*XSTEP
AXL=XO+NINT((XL-XO)/XSTEPJ)*XSTEPJ - XSTEPJ
IFOLD=NINT(XSTEPJ/XSTEP)
eps = 0.001*(xr-xl)
passed =0
DO 100 i=0,5000
X=AXL+I*XSTEP
IF ((x-(xl-eps))*(x-(xr+eps)).le.0.0) then
passed =1
IF( KTKX.NE.0) THEN
XHT = HTICK
IF( MOD(I, IFOLD).EQ.0) XHT=HTICK+HTICK
CALL XPENUP(X,YB)
CALL XPENDN(X,YB+XHT)
CALL XPENUP(X,YT)
CALL XPENDN(X,YT-XHT)
endif
IF( KANX.NE.0 .and. MOD(I,IFOLD).EQ.0) THEN
IF( AXFMT(1:LAXFMT).EQ.'*') THEN
CALL XRCH(X, CH, LCH)
ELSE
DO 501 KCH=1,LAXFMT
IF((AXFMT(KCH:KCH).EQ.'I')
: .or.(axfmt(kch:kch).eq.'i')) THEN
WRITE(CH,AXFMT(1:LAXFMT)) NINT(X)
GOTO 502
ENDIF
501 CONTINUE
WRITE(CH,AXFMT(1:LAXFMT)) X
502 LCH=ICLENG( CH )
CALL XCHLJ(CH(1:LCH), LCH)
ENDIF
IF(KANX.EQ. 1)CALL XCHARC(X,YT+1.5*HY,CH(1:LCH))
IF(KANX.EQ.-1)CALL XCHARC(X,YB-1.5*HY,CH(1:LCH))
ENDIF
ELSE
IF(passed.eq.1) GOTO 160
ENDIF
100 CONTINUE
160 CONTINUE
IF( KANY.EQ.0 .AND. KTKY.EQ.0 ) GOTO 260
HTICK=UNITH/XFACTR*KTKY
AYB=YO+NINT((YB-YO)/YSTEP)*YSTEP
AYB=YO+NINT((YB-YO)/YSTEPJ)*YSTEPJ - YSTEPJ
JFOLD = NINT(YSTEPJ/YSTEP)
eps = 0.001*(YT-YB)
passed=0
DO 200 j=0,5000
Y=AYB+J*YSTEP
IF ((y-(yb-eps))*(y-(yt+eps)).le.0.0)then
passed =1
IF(KTKY.NE.0)THEN
YHT = HTICK
IF( MOD(J, JFOLD).EQ.0) YHT=HTICK+HTICK
CALL XPENUP(XL,Y)
CALL XPENDN(XL+YHT,Y)
CALL XPENUP(XR,Y)
CALL XPENDN(XR-YHT,Y)
endif
IF( KANY.NE.0 .and. MOD(J, JFOLD).EQ.0) THEN
IF( AXFMT(1:LAXFMT).EQ.'*') THEN
CALL XRCH(Y, CH, LCH)
ELSE
DO 503 KCH=1,LAXFMT
IF((AXFMT(KCH:KCH).EQ.'I')
: .or.(axfmt(kch:kch).eq.'i')) THEN
WRITE(CH,AXFMT(1:LAXFMT)) NINT(Y)
GOTO 504
ENDIF
503 CONTINUE
WRITE(CH,AXFMT(1:LAXFMT)) Y
504 LCH=ICLENG( CH )
CALL XCHLJ(CH(1:LCH), LCH)
ENDIF
IF(KANY.EQ.-1)
: CALL XCHARR(XL-HX*0.7, Y-0.4*HY, CH(1:LCH) )
IF(KANY.EQ. 1)
: CALL XCHARL(XR+HX*0.7, Y-0.4*HY, CH(1:LCH) )
ENDIF
ELSE
IF( passed.eq.1) GOTO 260
ENDIF
200 CONTINUE
260 CONTINUE
CALL XCHMAG( HOLD )
RETURN
ENTRY XAXSOR(X1, Y1)
KOR=1
X0=X1
Y0=Y1
RETURN
END
SUBROUTINE XAXNMG(A) 5
COMMON /XAXM35/ NTMAG, ANMAG, ANSIZ
ANMAG = abs(A)
NTMAG=1
RETURN
ENTRY XAXNSZ(B)
NTMAG=2
ANSIZ=abs(B)
END
SUBROUTINE XCLEVL(Z,MD, M,N,ZZMAX,ZZMIN,ZZINC,CL,NCNT) 6
C TO DETERMINE CONTOUR INCRMENT AND CONTOUR VALUES FOR Z(M,N)
C REAL Z(MD,1 ),CL(*) ! original
REAL Z(MD,N ),CL(*)
COMMON /XCLM19/ NMIN, NMAX
COMMON /XCRF17/CLREF,LCPTN,LABTYP,ICLF,LHILIT,IHLF,KCT0
COMMON /ZCHOLE/ NHOLE,SPECIA,nvtrbadv
common /xoutch/ nch
integer mxset
NCMIN=NMIN
NCMAX=NMAX
ZINC=ZZINC
mxset = 0
DO 20 J=1,N
DO 20 I=1,M
IF(NHOLE.EQ.1.AND.abs(Z(I,J)-SPECIA).lt.1.0e-6)GOTO 20
IF( mxset.eq.0) THEN
ZMAX1= Z(I,J)
ZMIN1= Z(I,J)
mxset = 1
ELSE
ZMAX1= MAX (ZMAX1,Z(I,J))
ZMIN1= MIN (ZMIN1,Z(I,J))
ENDIF
20 CONTINUE
DIFF=ZMAX1-ZMIN1
IF(DIFF.le.ABS( ZINC)*1.0E-6) THEN
WRITE(NCH,'(1x,a,/1x,a)')
: 'Bad first guess of contour increment or field is constant',
: 'number of contours is one.'
NCNT=1
CL(1)= ZMIN1
ZZMIN= ZMIN1
ZZMAX= ZMAX1
ZZINC= 0.0
RETURN
ENDIF
4 KCOUNT=0
1 CONTINUE
EPS=0.001*ZINC
KCOUNT=KCOUNT+1
IF( KCOUNT.GT.20) GOTO 998
KZINC=(ZMIN1-CLREF)/ZINC
ZMIN=KZINC*ZINC+CLREF
KZINC=(ZMAX1-CLREF)/ZINC
ZMAX=KZINC*ZINC+CLREF
IF(ZMIN1-CLREF.GT.0.0) ZMIN=ZMIN+ZINC
IF(ZMAX1-CLREF.LT.0.0) ZMAX=ZMAX-ZINC
C
CLV=ZMIN-ZINC
NCNT=0
6 CLV=CLV+ZINC
IF(CLV-ZMAX-EPS.gt.0.0) GOTO 8
NCNT=NCNT+1
IF(NCNT.GT.NCMAX) THEN
ZINC=ZINC*2
WRITE(nch,1000) NCMAX, ZINC
1000 FORMAT(' Number of contours > ',I3,' ,Zinc is doubled. Zinc='
: ,E10.3)
GO TO 1
ENDIF
IF( ABS( CLV-CLREF ).LT.EPS ) CLV=CLREF
CL(NCNT)=CLV
GOTO 6
8 CONTINUE
IF( NCNT.LT.NCMIN) THEN
ZINC=ZINC/2
WRITE(nch,2000) NCMIN,ZINC
2000 FORMAT(' Number of contours < ',I3,' ,Zinc is halved. Zinc='
: ,E10.3)
GO TO 1
ENDIF
WRITE(nch,'('' * Number of contours= '',I5,'' MIN='',E12.4,
: '' MAX='', E12.4,'' INC='',E12.5 )')
; NCNT,ZMIN1,ZMAX1,ZINC
ZZMAX=ZMAX
ZZMIN=ZMIN
ZZINC=ZINC
RETURN
998 WRITE(NCH,*)' Contour levels can not be selected by XCNTLV.'
WRITE(NCH,*)
:' Plz alter input contour interval or limits of contour number'
RETURN
ENTRY XCTREF( CREF)
C Set reference contour level. Default is 0.0 .
CLREF=CREF
RETURN
ENTRY XNCTRS(NMIN1, NMAX1)
C Set upper and lower limit of the number of contours
NMAX=NMAX1
NMIN=NMIN1
RETURN
END
SUBROUTINE XCTRHL(Z,X,Y,MD,M,N) 1,8
c
c This routine put H,L labels at the maximum and minium
c centers of a contour field.
c Written Oct 13, 1998 by Ming Xue
c
implicit none
integer hllabel,hllabel0
integer llbfmt,laxfmt
integer NHOLE,nvtrbadv
real SPECIA
COMMON /XFMT33/ LBFMT, AXFMT
COMMON /XFMT34/ LLBFMT,LAXFMT
COMMON /XHLL36/ hllabel
COMMON /ZCHOLE/ NHOLE,SPECIA,nvtrbadv
CHARACTER LBFMT*50, AXFMT*10
CHARACTER CH*20
integer lch,i,j,kch,icleng
real hch,zmin,zmax
c
c Input through argument list
c
integer md,m,n
REAL X(MD,*),Y(MD,*), Z(MD,*)
if(hllabel.eq.0) return
do j=1,n
do i=1,m
IF(.not.(NHOLE.EQ.1.AND.abs(Z(I,J)-SPECIA).lt.1.0e-6))then
if(hllabel.eq.1) then
zmax=max(z(max(1,i-1),j),z(i,min(n,j+1)),
: z(min(m,i+1),j),z(i,max(1,j-1)))
zmin=min(z(max(1,i-1),j),z(i,min(n,j+1)),
: z(min(m,i+1),j),z(i,max(1,j-1)))
else
zmax=max(z(max(1,i-1),j),z(i,min(n,j+1)),
: z(max(1,i-2),j),z(i,min(n,j+2)),
: z(min(m,i+1),j),z(i,max(1,j-1)),
: z(min(m,i+2),j),z(i,max(1,j-2)),
: z(max(1,i-1),max(1,j-1)),z(max(1,i-1),min(n,j+1)),
: z(min(m,i+1),min(n,j+1)),z(min(m,i+1),max(1,j-1)))
zmin=min(z(max(1,i-1),j),z(i,min(n,j+1)),
: z(max(1,i-2),j),z(i,min(n,j+2)),
: z(min(m,i+1),j),z(i,max(1,j-1)),
: z(min(m,i+2),j),z(i,max(1,j-2)),
: z(max(1,i-1),max(1,j-1)),z(max(1,i-1),min(n,j+1)),
: z(min(m,i+1),min(n,j+1)),z(min(m,i+1),max(1,j-1)))
endif
if(z(i,j).gt.zmax) then
call xqchsz(hch)
call xchsiz(2*hch)
call xcharc(x(i,j),y(i,j),'H')
call xchsiz(hch)
IF( LBFMT(1:LLBFMT).eq.'*') THEN
CALL XRCH( z(i,j), CH, LCH)
ELSE
DO 507 KCH=1,LLBFMT
IF((LBFMT(KCH:KCH).EQ.'I')
: .or.(lbfmt(kch:kch).eq.'i')) THEN
WRITE(CH,LBFMT(1:LLBFMT)) NINT(z(i,j))
GOTO 508
ENDIF
507 CONTINUE
WRITE( CH, LBFMT(1:LLBFMT) ) z(i,j)
508 LCH=ICLENG( CH )
CALL XCHLJ( CH(1:LCH), LCH)
ENDIF
call xqchsz(hch)
CALL Xcharc(x(i,j),y(i,j)-hch,ch(1:lch))
endif
if(z(i,j).lt.zmin) then
call xqchsz(hch)
call xchsiz(2*hch)
call xcharc(x(i,j),y(i,j),'L')
call xchsiz(hch)
IF( LBFMT(1:LLBFMT).eq.'*') THEN
CALL XRCH( z(i,j), CH, LCH)
ELSE
DO 503 KCH=1,LLBFMT
IF((LBFMT(KCH:KCH).EQ.'I')
: .or.(lbfmt(kch:kch).eq.'i')) THEN
WRITE(CH,LBFMT(1:LLBFMT)) NINT(z(i,j))
GOTO 504
ENDIF
503 CONTINUE
WRITE( CH, LBFMT(1:LLBFMT) ) z(i,j)
504 LCH=ICLENG( CH )
CALL XCHLJ( CH(1:LCH), LCH)
ENDIF
call xqchsz(hch)
CALL Xcharc(x(i,j),y(i,j)-hch,ch(1:lch))
endif
endif
enddo
enddo
RETURN
ENTRY XHLLABL(hllabel0)
hllabel=hllabel0
RETURN
END
SUBROUTINE XCOLFIL(a,x,y,iwrk,xw,yw,md,m,n, cl0,ncl, mode) 10,8
c
c#######################################################################
c
c Generate color filled contour plots of 2-d field A given its
c coordinates x and y.
c
c#######################################################################
c
c INPUT:
c
c a 2-dimensional slice of data to contour
c x x coordinate of grid points in plot space (over on page)
c y y coordinate of grid points in plot space (up on page)
c md first dimension of a
c iwrk,xw,yw Work arrays
c m number of points in the first dimension of a to be plotted
c n second dimension of a
c cl0 contour levels
c ncl Number of contour levels
c mode =1,2,3,4. As in XCONTA.
c
c#######################################################################
c
implicit none
integer md,m,n
real a(md,n)
real x(md,n)
real y(md,n)
integer iwrk(*)
real xw(*),yw(*) ! dimension for color routine zcontc at least 8*m
real cl0(*), cl(0:500)
integer ncl, mode
c
real zinc ! contour interval
real zmax, zmin ! The real max and min for the field
real ctrmin, ctrmax
integer iclrbgn, iclrend
integer nmin, nmax
COMMON /XCLM19/ NMIN, NMAX
integer NHOLE,nvtrbadv
real SPECIA
COMMON /ZCHOLE/ NHOLE,SPECIA,nvtrbadv
integer nch
common /xoutch/ nch
integer LCPTN,LABTYP,ICLF,LHILIT,IHLF,KCT0
real CLREF
COMMON /XCRF17/ CLREF,LCPTN,LABTYP,ICLF,LHILIT,IHLF,KCT0
c
c Parameters for color pallete plotting.
c
integer nctrlvls_max
parameter(nctrlvls_max=1000) ! Max. number of contour values
real ctrlvls(nctrlvls_max) ! contour values dividing the filled areas
integer clrindx(nctrlvls_max) ! plot color index bar color index
integer nctrlvls ! Number of contour levels
common /xcflvls/nctrlvls,ctrlvls,clrindx
integer icontcopt
common /xcontc_opt/ icontcopt
c
c Local variables
c
integer icol, kolor
integer mxset,nn
integer i,j,nclmin,nclmax,kcl, ncl0,ncl1, kcl0
integer ctrmin_set,ctrmax_set
real eps,clv,clv1,clv2
real tem,zmin1,zmax1
c print*,'inside xcolfil '
call xqcolor(kolor)
IF( MODE.LT.1.OR.MODE.GT.4) THEN
WRITE(NCH,*)
: ' Input MODE for XCOLFIL not between 1 and 4, job stoped.'
STOP 999
ENDIF
mxset = 0
DO 2 J=1,N
DO 2 I=1,M
IF(NHOLE.EQ.1.AND.abs(a(I,J)-SPECIA).lt.1.0e-6)GOTO 2
IF( mxset.eq.0) THEN
ZMAX= a(I,J)
ZMIN= a(I,J)
mxset = 1
ELSE
ZMAX= MAX (ZMAX,a(I,J))
ZMIN= MIN (ZMIN,a(I,J))
ENDIF
2 CONTINUE
IF( mxset.eq.0) RETURN
IF( mode.eq.1) then
ZINC=CL0(2)-CL0(1)
CALL XCLEVL(a,MD, M,N,ZMAX1,ZMIN1,ZINC,CL0,NCL)
IF( NCL.EQ.1 ) RETURN
ELSEIF( mode.eq.2) then
NCLMAX=NMAX
NCLMIN=NMIN
ZINC=CL0(2)-CL0(1)
CALL XNCTRS( 0, 500 )
CALL XCLEVL(a,MD, M,N,ZMAX1,ZMIN1,ZINC,CL0,NCL)
CALL XNCTRS( NCLMIN, NCLMAX )
IF( NCL.EQ.1 ) RETURN
ELSEIF( mode.eq.3) then
IF( ncl.le.0) return
ZINC=CL0(2)-CL0(1)
EPS=0.001*ZINC
CLV=CL0(1)-ZINC
kcl = 0
50 continue
CLV=CLV+ZINC
IF(CLV-ZMAX.gt.0.0) goto 150
IF( ABS( CLV-CLREF ).LT. EPS ) CLV=CLREF
kcl = kcl + 1
CL0(KCL)=CLV
GOTO 50
150 CONTINUE
c ncl = kcl
ELSEIF( mode.eq.4) then
ZINC=0.0 ! Undetermined - unequal intervals
ENDIF
CALL xqctrlim(ctrmin, ctrmax)
ctrmax_set = 1
ctrmin_set = 1
IF(ctrmax.eq.-9999.0 ) ctrmax_set = 0
IF(ctrmin.eq.-9999.0 ) ctrmin_set = 0
IF( ctrmax.eq.0.0.and.ctrmin.eq.0.0 ) THEN
ctrmin_set = 0
ctrmax_set = 0
ENDIF
c print*,'inside xcolfil 1'
c print*,'mode=',mode
IF( MODE.ne.4) THEN
IF(ctrmin_set.eq.1.and.ctrmax_set.eq.1) then
ncl0=1
ncl1=1
cl(1)=ctrmin
45 clv=cl(ncl1)+zinc
if(clv.gt.ctrmax+1.0e-5*zinc) goto 450
ncl1=ncl1+1
cl(ncl1)=clv
goto 45
450 continue
ELSEIF(ctrmin_set.eq.1.and.ctrmax_set.eq.0) then
ncl0=1
ncl1=1
if( ctrmin.gt.zmax) then
ncl1=1
goto 550
endif
cl(1)=ctrmin
65 clv=cl(ncl1)+zinc
if(clv.gt.zmax) goto 250
ncl1=ncl1+1
cl(ncl1)=clv
goto 65
250 continue
if(cl(ncl1).lt.zmax-1.0e-5*zinc)then
ncl1 = ncl1+1
cl(ncl1) = zmax
endif
ELSEIF(ctrmin_set.eq.0.and.ctrmax_set.eq.1) then
ncl0=1
ncl1=1
if( ctrmax.lt.zmin) then
ncl1=1
goto 550
endif
nn = int((ctrmax-zmin)/zinc)
cl(1)=ctrmax-nn*zinc
75 clv=cl(ncl1)+zinc
if(clv.gt.ctrmax+1.0e-5*zinc) goto 350
ncl1=ncl1+1
cl(ncl1)=clv
goto 75
350 continue
if(cl(1).gt.zmin+1.0e-5*zinc)then
ncl0 = 0
cl(ncl0) = zmin
endif
ELSE
ncl0 = 1
ncl1 = ncl
do i = 1,ncl
cl(i)=cl0(i)
enddo
if(cl(1).gt.zmin)then
ncl0 = 0
cl(ncl0) = zmin
endif
if(cl(ncl1).lt.zmax)then
ncl1 = ncl1+1
cl(ncl1) = zmax
endif
ENDIF
ELSE ! mode =4
ncl0 = 1
ncl1 = ncl
do i = 1,ncl
cl(i)=cl0(i)
enddo
ENDIF
550 continue
CALL XQCTRCLR(iclrbgn, iclrend)
kcl0 = 0
DO 100 KCL=ncl0, ncl1-1
c
CLV1=CL(KCL)
CLV2=CL(kcl+1)
if(clv2.lt.clv1) then
tem = clv2
clv2 = clv1
clv1 = tem
endif
c print*,'ncl0,ncl1,kcl,clv1,clv2=',ncl0,ncl1,kcl,clv1,clv2
kcl0 = kcl0+1
IF(iclrbgn.eq.iclrend) THEN
icol = iclrbgn
ELSEIF(iclrbgn.le.iclrend) THEN
icol= iclrbgn + mod(KCL0-1, iclrend-iclrbgn+1)
ELSE IF(iclrbgn.gt.iclrend) THEN
icol= iclrbgn - mod(KCL0-1, iclrbgn-iclrend+1)
END IF
call xcolor(icol)
IF( clv1.lt.zmax+1.0e-10*(clv2-clv1).and.
: clv2.gt.zmin-1.0e-10*(clv2-clv1)) then
if( icontcopt.eq.1) then
CALL XCONTC(a,x,y,iwrk,xw,yw,md,m,n,clv1,clv2)
else if( icontcopt.eq.2) then
CALL XCONTC1(a,x,y,md,m,n,clv1,clv2)
else if( icontcopt.eq.3) then
CALL XPIXELFIL(a,x,y,md,m,n,clv1,clv2)
else
Print*,'Wrong option for color fill.'
endif
endif
c
c Save values for plotting color palette
c
clrindx(min(kcl0,nctrlvls_max-1))=icol
ctrlvls(min(kcl0,nctrlvls_max-1))=CL(KCL)
ctrlvls(min(kcl0+1,nctrlvls_max))=CL(kcl+1)
100 CONTINUE
nctrlvls = kcl0+1
call xcolor(kolor)
RETURN
END
subroutine xpixelfil(z,x,y,md,m,n,c1,c2) 1,1
!
! This routine fills pixels with values between c1 and c2
! with one predefined color.
!
! To do: add missing value skipping capability
!
dimension z(md,*),x(md,*),y(md,*)
real xcell(4), ycell(4)
DO j=1,n-1
DO i=1,m-1
xcell(1) = x(i,j)
xcell(2) = x(i+1,j)
xcell(3) = x(i+1,j+1)
xcell(4) = x(i,j+1)
ycell(1) = y(i,j)
ycell(2) = y(i+1,j)
ycell(3) = y(i+1,j+1)
ycell(4) = y(i,j+1)
zmean = 0.25*(z(i,j)+z(i+1,j)+z(i,j+1)+z(i+1,j+1))
IF( zmean <= c2 .and. zmean >= c1 ) then
CALL XFILAREA(Xcell,Ycell,4)
ENDIF
ENDDO
ENDDO
RETURN
END
SUBROUTINE XCTRLIM(ctrmin1, ctrmax1) 8
c-----------------------------------------------------------------------
c Set lower and upper limits (the range) of the values beyond which no
c contour is plotted. Used by XCONTA and XCOLFIL.
c IF set to -9999.0, then the min or max in the field is used.
c e.g., CALL XCTRLIM(0.0, -9999.0) will plot all positive contours.
c-----------------------------------------------------------------------
real ctrmin1, ctrmax1,ctrmin2, ctrmax2
real ctrmin, ctrmax
common /xctrmx/ ctrmin, ctrmax
ctrmin = ctrmin1
ctrmax = ctrmax1
RETURN
ENTRY XQCTRLIM(ctrmin2, ctrmax2)
ctrmin2 = ctrmin
ctrmax2 = ctrmax
RETURN
END
SUBROUTINE XCONTA(Z,X,Y,IWRK,MD, M,N, CL, NCL, MODE ) 22,20
REAL X(MD,*),Y(MD,*),Z(MD,*), CL(*)
INTEGER IWRK(*)
COMMON /XCRF17/ CLREF,LCPTN,LABTYP,ICLF,LHILIT,IHLF,KCT0
COMMON /XCLM19/ NMIN, NMAX
COMMON /XFMT33/ LBFMT, AXFMT
COMMON /XFMT34/ LLBFMT,LAXFMT
COMMON /ZCHOLE/ NHOLE,SPECIA,nvtrbadv
CHARACTER LBFMT*50, AXFMT*10, LBFM*(*)
common /xoutch/ nch
CHARACTER CH*20
real ctrmin, ctrmax
common /xctrmx/ ctrmin, ctrmax
real rmin, rmax
integer ictr_thick_thin_ratio
common /ctr_thick_thin_ratio/ ictr_thick_thin_ratio
integer icol
integer mxset
IF( MODE.LT.1.OR.MODE.GT.4) THEN
WRITE(NCH,*)
: ' Input MODE for XCONTA not between 1 and 3, job stoped.'
STOP 999
ENDIF
IF( mode.eq.1) then
ZINC=CL(2)-CL(1)
CALL XCLEVL(Z,MD, M,N,ZMAX,ZMIN,ZINC,CL,NCL)
IF( NCL.EQ.1 ) RETURN
ELSEIF( mode.eq.2) then
NCLMAX=NMAX
NCLMIN=NMIN
ZINC=CL(2)-CL(1)
CALL XNCTRS( 0, 500 )
CALL XCLEVL(Z,MD, M,N,ZMAX,ZMIN,ZINC,CL,NCL)
CALL XNCTRS( NCLMIN, NCLMAX )
IF( NCL.EQ.1 ) RETURN
ELSEIF( mode.eq.3) then
IF( ncl.le.0) return
ZINC=CL(2)-CL(1)
ELSEIF( mode.eq.4) then
ZINC=1.0 ! Undetermined - unequal intervals
ENDIF
mxset = 0
DO 2 J=1,N
DO 2 I=1,M
IF(NHOLE.EQ.1.AND.abs(Z(I,J)-SPECIA).lt.1.0e-6)GOTO 2
IF( mxset.eq.0) THEN
ZMAX1= Z(I,J)
ZMIN1= Z(I,J)
mxset = 1
ELSE
ZMAX1= MAX (ZMAX1,Z(I,J))
ZMIN1= MIN (ZMIN1,Z(I,J))
ENDIF
2 CONTINUE
IF( mxset.eq.0) RETURN ! All values missing
rmax=zmax1
rmin=zmin1
IF( ctrmax.eq.0.0.and.ctrmin.eq.0.0 ) THEN
rmax=zmax1
rmin=zmin1
ELSE
rmax=ctrmax
rmin=ctrmin
IF(ctrmax.eq.-9999.0 ) rmax=zmax1
IF(ctrmin.eq.-9999.0 ) rmin=zmin1
END IF
CALL XQRANG( XRAG, YRAG )
XU= SQRT( ABS(XRAG*YRAG) )
IF0= 12*XU
IB0= 7*XU
ID1= 3*XU
ID0= 3*XU
CALL XQLBON( KLBON)
CALL XQFULL( KFULL )
IF( KFULL.EQ.0 ) CALL XQBRKN( KF1,KB1,KF2,KB2)
CALL XQTHIK( KTHICK )
EPS=0.001*ZINC
CLV=CL(1)-ZINC
c if( mode.eq.4) then
c print*,'mode=4', mode
c print*,'ncl,cl=',ncl,(cl(i),i=1,ncl)
c print*,'IHLF=',IHLF
c print*,'iclf=',iclf
c print*,'ncl =',ncl
c iclf = 1
c endif
kcl0 = 0
DO 100 KCL=1,NCL
IF( MODE.EQ.3) THEN
CLV=CLV+ZINC
IF(CLV-rmax.gt.0.0) goto 100
IF( ABS( CLV-CLREF ).LT. EPS ) CLV=CLREF
CL(KCL )=CLV
ENDIF
CLV=CL(KCL)
IF(mode.ne.4)then
IF(clv.lt.rmin .or. clv.gt.rmax) GOTO 100
ENDIF
kcl0 = kcl0+1
c
c Set labeling option for each contour
c
IDREF=NINT((CL(KCL)-CLREF)/ZINC)
IF( mode.eq.4) IDREF = KCL-1
IF((MOD(IDREF,ICLF).EQ.0.OR.NCL.EQ.1).AND. LABTYP.NE.0) THEN
IF( LABTYP.LT.0) THEN
CALL XLBON
ELSEIF( LABTYP.eq.1) THEN
IF( NCL.EQ. 1) THEN
NOCL=1
ELSE
NOCL=IDREF
ENDIF
CALL XICH( NOCL , CH, LCH)
CALL XLABEL( CH(1:LCH) )
CALL XLBON
ELSEIF( LABTYP.eq.2) THEN
IF( LBFMT(1:LLBFMT).NE.'*') THEN
DO 503 KCH=1,LLBFMT
IF((LBFMT(KCH:KCH).EQ.'I')
: .or.(lbfmt(kch:kch).eq.'i')) THEN
WRITE(CH,LBFMT(1:LLBFMT)) NINT(CL(KCL))
GOTO 504
ENDIF
503 CONTINUE
WRITE( CH, LBFMT(1:LLBFMT) ) CL(KCL)
504 LCH=ICLENG( CH )
CALL XCHLJ( CH(1:LCH), LCH)
ELSE
CALL XRCH( CL(KCL) , CH, LCH)
ENDIF
CALL XLABEL( CH(1:LCH) )
CALL XLBON
ENDIF
ELSE
CALL XLBOFF
ENDIF
c
c Set highlighting option for each contour
c
IF((MOD(IDREF,IHLF).EQ.0.OR.NCL.EQ.1).AND. LHILIT.NE.0 )THEN
CALL XTHICK(ictr_thick_thin_ratio)
ELSE
CALL XTHICK(1)
ENDIF
IF( LCPTN.eq.0 ) THEN
IF( CL(KCL).lt.0.0 ) THEN
CALL XBROKN(IF0,IB0,IF0,IB0)
ELSEIF( abs(CL(KCL)).lt.eps ) THEN
IF(KCT0.EQ.1) CALL XBROKN(ID1, ID0,ID1,ID0 )
IF(KCT0.EQ.2) CALL XBROKN(ID1,ID0,IF0,ID0)
IF(KCT0.EQ.3) THEN
CALL XFULL
CALL XTHICK(ictr_thick_thin_ratio)
ENDIF
ELSEIF( CL(KCL).gt.0.0 ) THEN
CALL XFULL
ENDIF
ELSEIF( LCPTN.eq.1 ) THEN
CALL XFULL
ELSEIF( LCPTN.eq.2 ) THEN
CALL XBROKN(IF0,IB0,IF0,IB0)
ELSEIF( LCPTN.eq.4 ) THEN
CALL XBROKN(ID1, ID0,ID1,ID0 )
ENDIF
IF( KCT0.EQ.0.AND.ABS(CLV).LT.1.0e-10*ZINC) GOTO 100
CALL XQCTRCLR(iclrbgn, iclrend)
IF(iclrbgn.eq.iclrend) THEN
icol = iclrbgn
ELSEIF(iclrbgn.le.iclrend) THEN
icol= iclrbgn + mod(KCL0-1, iclrend-iclrbgn+1)
ELSE IF(iclrbgn.gt.iclrend) THEN
icol= iclrbgn - mod(KCL0-1, iclrbgn-iclrend+1)
END IF
call xcolor(icol)
IF(clv.lt.zmin1.or. clv.gt.zmax1) GOTO 100
IF( NHOLE.EQ.1 ) THEN
CALL XCONTJ(Z,X,Y,IWRK,MD,M,N,CLV,SPECIA)
ELSE
CALL XCONTR(Z,X,Y,IWRK,MD, M,N,CLV )
ENDIF
100 CONTINUE
call XCTRHL(Z,X,Y,MD,M,N)
IF( KFULL.EQ.1) CALL XFULL
IF( KFULL.NE.1) CALL XBROKN( KF1,KB1,KF2,KB2)
IF( KLBON.EQ.1) CALL XLBON
IF( KLBON.NE.1) CALL XLBOFF
CALL XTHICK( KTHICK )
RETURN
ENTRY XCLFMT( LBFM )
LLBFMT=LEN(LBFM)
LBFMT=LBFM
RETURN
ENTRY XQCZRO(KZERO)
KZERO=KCT0
RETURN
ENTRY XCTR_THICK_THIN_RATIO(nctr_thick_thin_ratio)
ictr_thick_thin_ratio = nctr_thick_thin_ratio
RETURN
END
SUBROUTINE XCTRBADV(MHOLE) 7
COMMON /ZCHOLE/ NHOLE,SPECIA,nvtrbadv
NHOLE=MHOLE
RETURN
ENTRY XBADVAL(SPECM)
SPECIA=SPECM
RETURN
ENTRY XVTRBADV(MHOLE)
nvtrbadv = MHOLE
RETURN
END
SUBROUTINE XCTRCLR(klrbgn, klrend) 18
implicit none
integer klrbgn,klrend ! Beginning and ending colors of contours
integer iclrbgn,iclrend ! Beginning and ending colors of contours
common /xctrclor/iclrbgn,iclrend
iclrbgn = klrbgn
iclrend = klrend
RETURN
END
SUBROUTINE XQCTRCLR(klrbgn, klrend) 2
implicit none
integer klrbgn,klrend ! Beginning and ending colors of contours
integer iclrbgn,iclrend ! Beginning and ending colors of contours
common /xctrclor/iclrbgn,iclrend
klrbgn = iclrbgn
klrend = iclrend
RETURN
END
SUBROUTINE ZCONTA(Z,ZG,IWRK,MD,M ,N ,CL,NCL, MODE),14
DIMENSION ZG(MD ,*),Z(MD ,*),IWRK(M ,*),CL(*)
COMMON /XCRF17/ CLREF,LCPTN,LABTYP,ICLF,LHILIT,IHLF,KCT0
COMMON /XCLM19/ NMIN, NMAX
COMMON /XFMT33/ LBFMT, AXFMT
COMMON /XFMT34/ LLBFMT,LAXFMT
COMMON /ZCHOLE/ NHOLE,SPECIA,nvtrbadv
CHARACTER LBFMT*50, AXFMT*10
CHARACTER CH*20
COMPLEX ZG
IF( MODE.LT.1.OR.MODE.GT.3) THEN
PRINT*,' Input MODE for XCONTB not between 1 and 3, job stoped.'
STOP 999
ENDIF
GOTO ( 50,51,52 ) MODE
50 ZINC=CL(2)-CL(1)
CALL XCLEVL(Z,MD, M,N,ZMAX,ZMIN,ZINC,CL,NCL)
IF( NCL.EQ.1 ) RETURN
GOTO 55
51 NCLMAX=NMAX
NCLMIN=NMIN
ZINC=CL(2)-CL(1)
CALL XNCTRS( 0, 500 )
CALL XCLEVL(Z,MD, M,N,ZMAX,ZMIN,ZINC,CL,NCL)
IF( NCL.EQ.1 ) RETURN
CALL XNCTRS( NCLMIN, NCLMAX )
GOTO 55
52 IF( NCL-1 ) 101, 102, 103
101 RETURN
102 ZINC=1.0
GOTO 104
103 ZINC=CL(2)-CL(1)
104 CONTINUE
55 CONTINUE
mxset = 0
DO 2 J=1,N
DO 2 I=1,M
IF(NHOLE.EQ.1.AND.abs(Z(I,J)-SPECIA).lt.1.0e-6)GOTO 2
IF( mxset.eq.0) THEN
ZMAX1= Z(I,J)
ZMIN1= Z(I,J)
mxset = 1
ELSE
ZMAX1= MAX (ZMAX1,Z(I,J))
ZMIN1= MIN (ZMIN1,Z(I,J))
ENDIF
2 CONTINUE
CALL XQRANG( XRAG, YRAG )
XU= MIN( XRAG, YRAG)
IF0= 20*XU
IB0= 7*XU
ID1= 7*XU
ID0= 15*XU
CALL XQLBON( KLBON)
CALL XQFULL( KFULL )
IF( KFULL.EQ.0 ) CALL XQBRKN( KF1,KB1,KF2,KB2)
CALL XQTHIK( KTHICK )
EPS=0.001*ZINC
CLV=CL(1)-ZINC
DO 10 KCL=1,NCL
IF( MODE.EQ.3) THEN
CLV=CLV+ZINC
IF(CLV-ZMAX1 ) 4,4,10
4 IF( ABS( CLV-CLREF ).LT. EPS ) CLV=CLREF
CL(KCL )=CLV
ENDIF
IDREF=NINT((CL(KCL)-CLREF)/ZINC)
IF((MOD(IDREF,ICLF).EQ.0.OR.NCL.EQ.1).AND. LABTYP.NE.0) THEN
IF( LABTYP.LT.0) GOTO 46
GOTO (41,42) LABTYP
41 IF( NCL.EQ. 1) THEN
NOCL=1
ELSE
NOCL=IDREF
ENDIF
CALL XICH( NOCL,CH,LCH)
GOTO 43
42 CONTINUE
C IF( FLOAT( INT( ZINC ) ).EQ. ZINC .AND. FLOAT( INT(CLREF))
C : .EQ. CLREF) THEN
C CALL XICH( INT(CL(KCL)), CH, LCH )
IF( LBFMT(1:LLBFMT).NE.'*') THEN
WRITE( CH, LBFMT(1:LLBFMT) ) CL(KCL)
LCH=ICLENG( CH )
ELSE
CALL XRCH( CL(KCL),CH,LCH)
ENDIF
43 CONTINUE
CALL XLABEL( CH(1:LCH) )
46 CALL XLBON
ELSE
CALL XLBOFF
ENDIF
IF((MOD(IDREF,IHLF).EQ.0.OR.NCL.EQ.1).AND. LHILIT.NE.0 )THEN
CALL XTHICK(2)
ELSE
CALL XTHICK(1)
ENDIF
GOTO ( 30,31,32,33 ) LCPTN+1
30 IF( ABS( CL(KCL) ).LT. EPS ) GOTO 22
IF( CL(KCL)) 21,22,23
21 CALL XBROKN(IF0,IB0,IF0,IB0)
GOTO 24
22 CALL XBROKN(ID1,ID0,ID1,ID0 )
GOTO 24
23 CALL XFULL
24 CONTINUE
GOTO 35
31 CALL XFULL
GOTO 35
32 CALL XBROKN(IF0,IB0,IF0,IB0)
GOTO 35
33 CALL XBROKN(ID1,ID0,ID1,ID0 )
35 CONTINUE
CLV=CL(KCL)
IF( KCT0.EQ.0.AND.ABS(CLV).LT.0.1*ZINC) GOTO 10
IF( NHOLE.EQ.1 ) THEN
CALL ZCONTJ(Z,ZG,IWRK,MD,M,N,CLV,SPECIA)
ELSE
CALL ZCONTR(Z,ZG ,IWRK,MD, M,N,CLV )
ENDIF
10 CONTINUE
IF( KFULL.EQ.1) CALL XFULL
IF( KFULL.NE.1) CALL XBROKN( KF1,KB1,KF2,KB2)
IF( KLBON.EQ.1) CALL XLBON
IF( KLBON.NE.1) CALL XLBOFF
CALL XTHICK( KTHICK )
RETURN
END
SUBROUTINE XCMIXL 2
COMMON/XCRF17/CLREF,LCPTN,LABTYP,ICLF,LHILIT,IHLF,KCT0
C Contour plotting pattern is set so that lines are dash,dotted,solid
C for negative ,zero, positve values respectively. This is default.
LCPTN=0
RETURN
ENTRY XCFULL
LCPTN=1
RETURN
ENTRY XCDASH
C Set contour plotting pattern as dash lines.
LCPTN=2
RETURN
ENTRY XCDOT
LCPTN=3
RETURN
ENTRY XCLTYP( LTYPE)
C Define type of labels on contours.
C LTYPE-- parameter controling contour labeling.
C LTYPE <0, label is specified by user through XLABEL,
C =0, no labeling is done.
C =1, label the contour number, number=0 for zero contour.
C =2, label the contour values.
C By default LTYPE=2.
C Note setting LTYPE=0 is the only way to suppress labels outside
C routine XCONTA as XLBON and XLBOFF are called inside XCONTA.
LABTYP=LTYPE
RETURN
ENTRY XCLFRQ( NCLF)
C Set contour labeling frequency so that every NCLFth contour relative
C to reference contour is labeled. Default NCLF=2.
ICLF=NCLF
RETURN
ENTRY XHILIT( KHILIT )
LHILIT=KHILIT
RETURN
ENTRY XHLFRQ( NHLF )
IHLF=NHLF
RETURN
ENTRY XCZERO( KCZERO )
C Option of zero contour plotting.
C KCZERO=0, zero line is suppressed, by default KCZERO=1.
KCT0=KCZERO
RETURN
END
SUBROUTINE XCONTR(ZG,X,Y,IWRK,MD,MG,JG,CV) 2,3
DIMENSION ZG(MD ,*),X(MD ,*),Y(MD,*),IWRK(MG ,*)
C* The final edition of the contouring package 2nd ed
C* Zhang Zuojun, Jan. 1988
DOUBLE PRECISION CVn, normscl
DOUBLE PRECISION H5n
INTEGER normexp
C IFUN1(K)=K+MG*((MGP-K)/MGP-K/MGP)
D(P1,P2,B1,B2 )=B1+(CV-P1)*(B2-B1)/(P2-P1)
C Normalize CV and H5
IF (CV == 0) THEN
normexp = 0
ELSE
normexp = ANINT(LOG10(ABS(CV)))
END IF
normscl = 10**(-1.*normexp)
cvn = dble(cv)*normscl
c write(0,*) cv,normexp, normscl, cvn
MGP=MG+1
JGP=JG+1
DO 4 J=1,JG
DO 4 I=1,MG
4 IWRK(I,J)=0
DO 1 JJ=1,2*(MG+JG-2)
IF(JJ.LT.MG) THEN
I4=JJ
J4=1
ISW=1
ELSEIF(JJ.LT.MG+JG-1) THEN
I4=MG
J4=JJ-MG+1
ISW=4
ELSEIF(JJ.LT.MG+MG+JG-2) THEN
I4=MG+MG+JG-JJ-1
J4=JG
ISW=3
ELSEIF(JJ.LT.MG+MG+JG+JG-3) THEN
I4=1
J4=MG+MG+JG+JG-2-JJ
ISW=2
ENDIF
INI=MOD(ISW ,2)*(1-2*(MOD(ISW,4)/2))
INJ=MOD(ISW+1,2)*(1-2*(MOD(ISW,4)/2))
I1=I4+INI
J1=J4+INJ
IF(I1.EQ.0.OR.I1.EQ.MGP.OR.J1.EQ.0.OR.J1.EQ.JGP)GOTO 1
H1=ZG(I1,J1)
H4=ZG(I4,J4)
IF(H1.GE.CV.OR.H4.LT.CV ) GOTO 1
X1= X(I1,J1)
X4= X(I4,J4)
Y1= Y(I1,J1)
Y4= Y(I4,J4)
XA=D(H4,H1,X4,X1)
YA=D(H4,H1,Y4,Y1)
CALL XCURUP( XA, YA )
I2=I1+MOD(ISW-1,2)*(1-2*((ISW-1)/2))
J2=J1+MOD(ISW ,2)*(1-2*((ISW-1)/2))
I3=I4+MOD(ISW-1,2)*(1-2*((ISW-1)/2))
J3=J4+MOD(ISW ,2)*(1-2*((ISW-1)/2))
201 H1=ZG(I1,J1)
H2=ZG(I2,J2)
H3=ZG(I3,J3)
H4=ZG(I4,J4)
H5n=0.25*(dble(H1)+dble(H2)+dble(H3)+dble(H4))
H5 = H5n
H5n= normscl*H5n
X1= X(I1,J1)
X2= X(I2,J2)
X3= X(I3,J3)
X4= X(I4,J4)
Y1= Y(I1,J1)
Y2= Y(I2,J2)
Y3= Y(I3,J3)
Y4= Y(I4,J4)
IF(H2-CV) 52,53,53
52 IF(H3-CV) 63,62,62
53 IF(H3-CV) 54,61,61
c 54 IF(H5-CV) 63,61,61
54 if ( (H5n-CVn) > -1.0E-5) then
go to 61
else
go to 63
end if
61 ISA=1
XB=D(H1,H2,X1,X2)
YB=D(H1,H2,Y1,Y2)
I4=I2
J4=J2
GOTO 60
62 ISA=2
XB=D(H2,H3,X2,X3)
YB=D(H2,H3,Y2,Y3)
I1=I2
J1=J2
I4=I3
J4=J3
GOTO 60
63 ISA=3
XB=D(H3,H4,X3,X4)
YB=D(H3,H4,Y3,Y4)
I1=I3
J1=J3
60 ISW=MOD(ISW-ISA+5,4)+1
I2=I1+MOD(ISW-1,2)*(1-2*((ISW-1)/2))
J2=J1+MOD(ISW ,2)*(1-2*((ISW-1)/2))
I3=I4+MOD(ISW-1,2)*(1-2*((ISW-1)/2))
J3=J4+MOD(ISW ,2)*(1-2*((ISW-1)/2))
IF( I2.EQ.0.OR.I3.EQ.0.OR.I2.EQ.MGP.OR.I3.EQ.MGP .OR.
: J2.EQ.0.OR.J3.EQ.0.OR.J2.EQ.JGP.OR.J3.EQ.JGP) THEN
CALL XCURDN( XB, YB,0 , 1 )
ELSE
IF(XB.NE.XA. OR.YB.NE.YA) CALL XCURDN( XB , YB, 0 ,0)
XA=XB
YA=YB
IWRK(I1,J1)=1
IWRK(I4,J4)=1
GOTO 201
ENDIF
1 CONTINUE
DO 2 J=2,JG-1
DO 2 I=1,MG-1
ISW=1
I10=I+1
J10=J
I40=I
J40=J
IF(IWRK(I10,J10).EQ.1.AND.IWRK(I40,J40).EQ.1) GOTO 2
H1=ZG(I10,J10)
H4=ZG(I40,J40)
IF(H1.GE.CV.OR.H4.LT.CV ) GOTO 2
I1=I10
J1=J10
I4=I40
J4=J40
X1= X(I1,J1)
X4= X(I4,J4)
Y1= Y(I1,J1)
Y4= Y(I4,J4)
XA=D(H4,H1,X4,X1)
YA=D(H4,H1,Y4,Y1)
CALL XCURUP( XA, YA )
101 I2=I1+MOD(ISW-1,2)*(1-2*((ISW-1)/2))
J2=J1+MOD(ISW ,2)*(1-2*((ISW-1)/2))
I3=I4+MOD(ISW-1,2)*(1-2*((ISW-1)/2))
J3=J4+MOD(ISW ,2)*(1-2*((ISW-1)/2))
H1=ZG(I1,J1)
H2=ZG(I2,J2)
H3=ZG(I3,J3)
H4=ZG(I4,J4)
H5n=0.25*(dble(H1)+dble(H2)+dble(H3)+dble(H4))
H5 = H5n
H5n= normscl*H5n
X1= X(I1,J1)
X2= X(I2,J2)
X3= X(I3,J3)
X4= X(I4,J4)
Y1= Y(I1,J1)
Y2= Y(I2,J2)
Y3= Y(I3,J3)
Y4= Y(I4,J4)
IF(H2-CV) 12,13,13
12 IF(H3-CV) 23,22,22
13 IF(H3-CV) 14,21,21
c 14 IF(H5-CV) 23,21,21
14 if ( (H5n-CVn) > -1.0E-5) then
go to 21
else
go to 23
end if
21 ISA=1
XB=D(H1,H2,X1,X2)
YB=D(H1,H2,Y1,Y2)
I4=I2
J4=J2
GOTO 30
22 ISA=2
XB=D(H2,H3,X2,X3)
YB=D(H2,H3,Y2,Y3)
I1=I2
J1=J2
I4=I3
J4=J3
GOTO 30
23 ISA=3
XB=D(H3,H4,X3,X4)
YB=D(H3,H4,Y3,Y4)
I1=I3
J1=J3
30 IF( I1.EQ.I10.AND.J1.EQ.J10.AND.I4.EQ.I40.AND.J4.EQ.J40) THEN
CALL XCURDN(XB,YB,1,1)
ELSE
IF(XB.NE.XA. OR.YB.NE.YA) CALL XCURDN( XB , YB, 1 ,0)
XA=XB
YA=YB
IWRK(I1,J1)=1
IWRK(I4,J4)=1
ISW=MOD(ISW-ISA+5,4)+1
GOTO 101
ENDIF
2 CONTINUE
CALL XLPNUP( X(1,1) ,Y(1,1) )
RETURN
END
SUBROUTINE XCONTJ(ZG,X,Y,IWRK,MD,MG,JG,CV,SPEC) 1,9
DIMENSION ZG(MD ,*),X(MD ,*),Y(MD,*),IWRK(MG ,*)
C* New update for contouring allowing special value holes (SPEC)
C* The second edition of the contour tracing
C* Zhang Zuojun, Jan. 1988
C* New update including contouring on triagle grids
C* When MODE=0 contouring perform on retangular grids (default)
C* When MODE=1 contouring perform on triangular grids .
C IFUN1(K)=K+MG*((MGP-K)/MGP-K/MGP)
c
c Converted by Ming Xue, Oct. 1993 to use real arrays for
c grid coordinates.
c
DOUBLE PRECISION CVn, normscl
DOUBLE PRECISION H5n
INTEGER normexp
D(P1,P2,B1,B2 )=B1+(CV-P1)*(B2-B1)/(P2-P1)
C Normalize CV and H5
IF (CV == 0) THEN
normexp = 0
ELSE
normexp = ANINT(LOG10(ABS(CV)))
END IF
normscl = 10**(-1.*normexp)
cvn = dble(cv)*normscl
c write(0,*) cv,normexp, normscl, cvn
CALL ZQCONM(MODE)
DUM=SPEC
MGP=MG+1
JGP=JG+1
DO 4 J=1,JG
DO 4 I=1,MG
4 IWRK(I,J)=0
DO 1 JJ=1,2*(MG+JG-2)
IF(JJ.LT.MG) THEN
I4=JJ
J4=1
ISW=1
ELSEIF(JJ.LT.MG+JG-1) THEN
I4=MG
J4=JJ-MG+1
ISW=4
ELSEIF(JJ.LT.MG+MG+JG-2) THEN
I4=MG+MG+JG-JJ-1
J4=JG
ISW=3
ELSEIF(JJ.LT.MG+MG+JG+JG-3) THEN
I4=1
J4=MG+MG+JG+JG-2-JJ
ISW=2
ENDIF
INI=MOD(ISW ,2)*(1-2*(MOD(ISW,4)/2))
INJ=MOD(ISW+1,2)*(1-2*(MOD(ISW,4)/2))
I1=I4+INI
J1=J4+INJ
IF(I1.EQ.0.OR.I1.EQ.MGP.OR.J1.EQ.0.OR.J1.EQ.JGP)GOTO 1
H1=ZG(I1,J1)
H4=ZG(I4,J4)
IF(H1.GE.CV.OR.H4.LT.CV ) GOTO 1
X1= X(I1,J1)
X4= X(I4,J4)
Y1= Y(I1,J1)
Y4= Y(I4,J4)
XA=D(H4,H1,X4,X1)
YA=D(H4,H1,Y4,Y1)
CALL XCURUP( XA, YA )
I2=I1+MOD(ISW-1,2)*(1-2*((ISW-1)/2))
J2=J1+MOD(ISW ,2)*(1-2*((ISW-1)/2))
I3=I4+MOD(ISW-1,2)*(1-2*((ISW-1)/2))
J3=J4+MOD(ISW ,2)*(1-2*((ISW-1)/2))
201 H1=ZG(I1,J1)
H2=ZG(I2,J2)
H3=ZG(I3,J3)
H4=ZG(I4,J4)
H5n=0.25*(dble(H1)+dble(H2)+dble(H3)+dble(H4))
H5 = H5n
H5n= normscl*H5n
IF(H1.EQ.DUM.OR.H2.EQ.DUM.OR.H3.EQ.DUM.OR.H4.EQ.DUM)THEN
ISWTCH=0
ELSE
ISWTCH=1
ENDIF
X1= X(I1,J1)
X2= X(I2,J2)
X3= X(I3,J3)
X4= X(I4,J4)
Y1= Y(I1,J1)
Y2= Y(I2,J2)
Y3= Y(I3,J3)
Y4= Y(I4,J4)
IF(MODE.EQ.1) THEN
X5=0.25*(X1+X2+X3+X4)
Y5=0.25*(Y1+Y2+Y3+Y4)
ENDIF
IF(H2-CV) 52,53,53
52 IF(H3-CV) 63,62,62
53 IF(H3-CV) 54,61,61
c* 54 IF(H5-CV) 63,61,61
54 if ( (H5n-CVn) > -1.0E-5) then
go to 61
else
go to 63
end if
61 ISA=1
IF(MODE.EQ.1.AND.ISWTCH.EQ.1) THEN
IF(H5.LT.CV.AND.H3.GE.CV) THEN
XC=D(H4,H5,X4,X5)
YC=D(H4,H5,Y4,Y5)
IF(XC.NE.XA.or.YC.NE.YA)
: CALL XCURDN(XC,YC,0,0)
XA=XC
YA=YC
XC=D(H3,H5,X3,X5)
YC=D(H3,H5,Y3,Y5)
IF(XC.NE.XA.or.YC.NE.YA)
: CALL XCURDN(XC,YC,0,0)
XA=XC
YA=YC
XC=D(H2,H5,X2,X5)
YC=D(H2,H5,Y2,Y5)
IF(XC.NE.XA.or.YC.NE.YA)
: CALL XCURDN(XC,YC,0,0)
XA=XC
YA=YC
ELSE
XC=D(H1,H5,X1,X5)
YC=D(H1,H5,Y1,Y5)
IF(XC.NE.XA.or.YC.NE.YA) CALL XCURDN(XC,YC,0,0)
XA=XC
YA=YC
ENDIF
ENDIF
XB=D(H1,H2,X1,X2)
YB=D(H1,H2,Y1,Y2)
I4=I2
J4=J2
GOTO 60
62 ISA=2
IF(MODE.EQ.1.AND.ISWTCH.EQ.1) THEN
IF(H5.LT.CV) THEN
XC=D(H4,H5,X4,X5)
YC=D(H4,H5,Y4,Y5)
IF(XC.NE.XA.or.YC.NE.YA) CALL XCURDN(XC,YC,0,0)
XA=XC
YA=YC
XC=D(H3,H5,X3,X5)
YC=D(H3,H5,Y3,Y5)
IF(XC.NE.XA.or.YC.NE.YA) CALL XCURDN(XC,YC,0,0)
XA=XC
YA=YC
ELSE
XC=D(H1,H5,X1,X5)
YC=D(H1,H5,Y1,Y5)
IF(XC.NE.XA.or.YC.NE.YA) CALL XCURDN(XC,YC,0,0)
XA=XC
YA=YC
XC=D(H2,H5,X2,X5)
YC=D(H2,H5,Y2,Y5)
IF(XC.NE.XA.or.YC.NE.YA) CALL XCURDN(XC,YC,0,0)
XA=XC
YA=YC
ENDIF
ENDIF
XB=D(H2,H3,X2,X3)
YB=D(H2,H3,Y2,Y3)
I1=I2
J1=J2
I4=I3
J4=J3
GOTO 60
63 ISA=3
IF(MODE.EQ.1.AND.ISWTCH.EQ.1) THEN
IF(H5.GE.CV.AND.H2.LT.CV) THEN
XC=D(H1,H5,X1,X5)
YC=D(H1,H5,Y1,Y5)
IF(XC.NE.XA.or.YC.NE.YA) CALL XCURDN(XC,YC,0,0)
XA=XC
YA=YC
XC=D(H2,H5,X2,X5)
YC=D(H2,H5,Y2,Y5)
IF(XC.NE.XA.or.YC.NE.YA) CALL XCURDN(XC,YC,0,0)
XA=XC
YA=YC
XC=D(H3,H5,X3,X5)
YC=D(H3,H5,Y3,Y5)
IF(XC.NE.XA.or.YC.NE.YA) CALL XCURDN(XC,YC,0,0)
XA=XC
YA=YC
ELSE
XC=D(H4,H5,X4,X5)
YC=D(H4,H5,Y4,Y5)
IF(XC.NE.XA.or.YC.NE.YA) CALL XCURDN(XC,YC,0,0)
XA=XC
YA=YC
ENDIF
ENDIF
XB=D(H3,H4,X3,X4)
YB=D(H3,H4,Y3,Y4)
I1=I3
J1=J3
60 ISW=MOD(ISW-ISA+5,4)+1
I2=I1+MOD(ISW-1,2)*(1-2*((ISW-1)/2))
J2=J1+MOD(ISW ,2)*(1-2*((ISW-1)/2))
I3=I4+MOD(ISW-1,2)*(1-2*((ISW-1)/2))
J3=J4+MOD(ISW ,2)*(1-2*((ISW-1)/2))
IF( I2.EQ.0.OR.I3.EQ.0.OR.I2.EQ.MGP.OR.I3.EQ.MGP .OR.
: J2.EQ.0.OR.J3.EQ.0.OR.J2.EQ.JGP.OR.J3.EQ.JGP )THEN
IF(ISWTCH.EQ.1) THEN
CALL XCURDN(XB,YB,0,1)
ELSE
CALL XCURUP(XB,YB)
ENDIF
ELSE
IF(ISWTCH.EQ.1.AND.(XB.NE.XA.or.YB.NE.YA))THEN
IF(ZG(I2,J2).EQ.DUM.OR.ZG(I3,J3).EQ.DUM)THEN
CALL XCURDN(XB,YB,0,0)
ELSE
CALL XCURDN(XB,YB,0,1)
ENDIF
ELSE
CALL XCURUP(XB,YB)
ENDIF
XA=XB
YA=YB
IWRK(I1,J1)=1
IWRK(I4,J4)=1
GOTO 201
ENDIF
1 CONTINUE
DO 2 J=2,JG-1
DO 2 I=1,MG-1
ISW=1
I10=I+1
J10=J
I40=I
J40=J
IF(IWRK(I10,J10).EQ.1.AND.IWRK(I40,J40).EQ.1) GOTO 2
H1=ZG(I10,J10)
H4=ZG(I40,J40)
IF(H1.GE.CV.OR.H4.LT.CV ) GOTO 2
I1=I10
J1=J10
I4=I40
J4=J40
X1= X(I1,J1)
Y1= Y(I1,J1)
X4= X(I4,J4)
Y4= Y(I4,J4)
XA=D(H4,H1,X4,X1)
YA=D(H4,H1,Y4,Y1)
CALL XCURUP(XA,YA)
I2=I1+MOD(ISW-1,2)*(1-2*((ISW-1)/2))
J2=J1+MOD(ISW ,2)*(1-2*((ISW-1)/2))
I3=I4+MOD(ISW-1,2)*(1-2*((ISW-1)/2))
J3=J4+MOD(ISW ,2)*(1-2*((ISW-1)/2))
101 H1=ZG(I1,J1)
H2=ZG(I2,J2)
H3=ZG(I3,J3)
H4=ZG(I4,J4)
H5n=0.25*(dble(H1)+dble(H2)+dble(H3)+dble(H4))
H5=H5n
H5n = normscl*H5n
IF(H1.EQ.DUM.OR.H2.EQ.DUM.OR.H3.EQ.DUM.OR.H4.EQ.DUM)THEN
ISWTCH=0
ELSE
ISWTCH=1
ENDIF
X1= X(I1,J1)
X2= X(I2,J2)
X3= X(I3,J3)
X4= X(I4,J4)
Y1= Y(I1,J1)
Y2= Y(I2,J2)
Y3= Y(I3,J3)
Y4= Y(I4,J4)
IF(MODE.EQ.1) THEN
X5=0.25*(X1+X2+X3+X4)
Y5=0.25*(Y1+Y2+Y3+Y4)
ENDIF
IF(H2-CV) 12,13,13
12 IF(H3-CV) 23,22,22
13 IF(H3-CV) 14,21,21
c 14 IF(H5-CV) 23,21,21
14 IF ( (H5n-CVn) > -1.0E-5) THEN
GO TO 21
ELSE
GO TO 23
END IF
21 ISA=1
IF(MODE.EQ.1.AND.ISWTCH.EQ.1) THEN
IF(H5.LT.CV.AND.H3.GE.CV) THEN
XC=D(H4,H5,X4,X5)
YC=D(H4,H5,Y4,Y5)
IF(XC.NE.XA.or.YC.NE.YA) CALL XCURDN(XC,YC,1,0)
XA=XC
YA=YC
XC=D(H3,H5,X3,X5)
YC=D(H3,H5,Y3,Y5)
IF(XC.NE.XA.or.YC.NE.YA) CALL XCURDN(XC,YC,1,0)
XA=XC
YA=YC
XC=D(H2,H5,X2,X5)
YC=D(H2,H5,Y2,Y5)
IF(XC.NE.XA.or.YC.NE.YA) CALL XCURDN(XC,YC,1,0)
XA=XC
YA=YC
ELSE
XC=D(H1,H5,X1,X5)
YC=D(H1,H5,Y1,Y5)
IF(XC.NE.XA.or.YC.NE.YA) CALL XCURDN(XC,YC,1,0)
XA=XC
YA=YC
ENDIF
ENDIF
XB=D(H1,H2,X1,X2)
YB=D(H1,H2,Y1,Y2)
I4=I2
J4=J2
GOTO 30
22 ISA=2
IF(MODE.EQ.1.AND.ISWTCH.EQ.1) THEN
IF(H5.LT.CV) THEN
XC=D(H4,H5,X4,X5)
YC=D(H4,H5,Y4,Y5)
IF(XC.NE.XA.or.YC.NE.YA) CALL XCURDN(XC,YC,1,0)
XA=XC
YA=YC
XC=D(H3,H5,X3,X5)
YC=D(H3,H5,Y3,Y5)
IF(XC.NE.XA.or.YC.NE.YA) CALL XCURDN(XC,YC,1,0)
XA=XC
YA=YC
ELSE
XC=D(H1,H5,X1,X5)
YC=D(H1,H5,Y1,Y5)
IF(XC.NE.XA.or.YC.NE.YA) CALL XCURDN(XC,YC,1,0)
XA=XC
YA=YC
XC=D(H2,H5,X2,X5)
YC=D(H2,H5,Y2,Y5)
IF(XC.NE.XA.or.YC.NE.YA) CALL XCURDN(XC,YC,1,0)
XA=XC
YA=YC
ENDIF
ENDIF
XB=D(H2,H3,X2,X3)
YB=D(H2,H3,Y2,Y3)
I1=I2
J1=J2
I4=I3
J4=J3
GOTO 30
23 ISA=3
IF(MODE.EQ.1.AND.ISWTCH.EQ.1) THEN
IF(H5.GE.CV.AND.H2.LT.CV) THEN
XC=D(H1,H5,X1,X5)
YC=D(H1,H5,Y1,Y5)
IF(XC.NE.XA.or.YC.NE.YA) CALL XCURDN(XC,YC,1,0)
XA=XC
YA=YC
XC=D(H2,H5,X2,X5)
YC=D(H2,H5,Y2,Y5)
IF(XC.NE.XA.or.YC.NE.YA) CALL XCURDN(XC,YC,1,0)
XA=XC
YA=YC
XC=D(H3,H5,X3,X5)
YC=D(H3,H5,Y3,Y5)
IF(XC.NE.XA.or.YC.NE.YA) CALL XCURDN(XC,YC,1,0)
XA=XC
YA=YC
ELSE
XC=D(H4,H5,X4,X5)
YC=D(H4,H5,Y4,Y5)
IF(XC.NE.XA.or.YC.NE.YA) CALL XCURDN(XC,YC,1,0)
XA=XC
YA=YC
ENDIF
ENDIF
XB=D(H3,H4,X3,X4)
YB=D(H3,H4,Y3,Y4)
I1=I3
J1=J3
30 IF (I1.EQ.I10.AND.J1.EQ.J10.AND.I4.EQ.I40.AND.J4.EQ.J40) THEN
IF(ISWTCH.EQ.1)THEN
CALL XCURDN(XB,YB,0,1)
ELSE
CALL XCURUP(XB,YB)
ENDIF
ELSE
IWRK(I1,J1)=1
IWRK(I4,J4)=1
ISW=MOD(ISW-ISA+5,4)+1
I2=I1+MOD(ISW-1,2)*(1-2*((ISW-1)/2))
J2=J1+MOD(ISW ,2)*(1-2*((ISW-1)/2))
I3=I4+MOD(ISW-1,2)*(1-2*((ISW-1)/2))
J3=J4+MOD(ISW ,2)*(1-2*((ISW-1)/2))
IF (I2.EQ.0.OR.I3.EQ.0.OR.I2.EQ.MGP.OR.I3.EQ.MGP .OR.
: J2.EQ.0.OR.J3.EQ.0.OR.J2.EQ.JGP.OR.J3.EQ.JGP ) THEN
IF(ISWTCH.EQ.1)THEN
CALL XCURDN(XB,YB,0,1)
ELSE
CALL XCURUP(XB,YB)
ENDIF
ELSE
IF(ZG(I2,J2).EQ.DUM.OR.ZG(I3,J3).EQ.DUM)THEN
IF(ISWTCH.EQ.1) THEN
CALL XCURDN(XB,YB,0,1)
ELSE
CALL XCURUP(XB,YB)
ENDIF
ELSE
IF(ISWTCH.EQ.1) THEN
IF(XB.NE.XA.or.YB.NE.YA) CALL XCURDN(XB,YB,0,1)
ELSE
CALL XCURUP(XB,YB)
ENDIF
ENDIF
XA=XB
YA=YB
GOTO 101
END IF
ENDIF
2 CONTINUE
CALL XLPNUP( X(1,1), Y(1,1) )
RETURN
END
SUBROUTINE ZCONTR(ZG,Z,IWRK,MD,MG,JG,CV) 1,3
DIMENSION ZG(MD ,*),Z(MD ,*),IWRK(MG ,*)
C* The second edition of the contour tracing
C* Zhang Zuojun, Jan. 1988
C* New update including contouring on triagle grids
C* When MODE=0 contouring perform on retangular grids (default)
C* When MODE=1 contouring perform on triangular grids .
COMPLEX Z,B1,B2,ZA,ZB,ZC,Z1,Z2,Z3,Z4,Z5,D
C IFUN1(K)=K+MG*((MGP-K)/MGP-K/MGP)
D(P1,P2,B1,B2 )=B1+(CV-P1)*(B2-B1)/(P2-P1)
CALL ZQCONM(MODE)
MGP=MG+1
JGP=JG+1
DO 4 J=1,JG
DO 4 I=1,MG
4 IWRK(I,J)=0
DO 1 JJ=1,2*(MG+JG-2)
IF(JJ.LT.MG) THEN
I4=JJ
J4=1
ISW=1
ELSEIF(JJ.LT.MG+JG-1) THEN
I4=MG
J4=JJ-MG+1
ISW=4
ELSEIF(JJ.LT.MG+MG+JG-2) THEN
I4=MG+MG+JG-JJ-1
J4=JG
ISW=3
ELSEIF(JJ.LT.MG+MG+JG+JG-3) THEN
I4=1
J4=MG+MG+JG+JG-2-JJ
ISW=2
ENDIF
INI=MOD(ISW ,2)*(1-2*(MOD(ISW,4)/2))
INJ=MOD(ISW+1,2)*(1-2*(MOD(ISW,4)/2))
I1=I4+INI
J1=J4+INJ
IF(I1.EQ.0.OR.I1.EQ.MGP.OR.J1.EQ.0.OR.J1.EQ.JGP)GOTO 1
H1=ZG(I1,J1)
H4=ZG(I4,J4)
IF(H1.GE.CV.OR.H4.LT.CV ) GOTO 1
Z1= Z(I1,J1)
Z4= Z(I4,J4)
ZA=D(H4,H1,Z4,Z1)
CALL XCURUP(REAL(ZA),AIMAG(ZA))
I2=I1+MOD(ISW-1,2)*(1-2*((ISW-1)/2))
J2=J1+MOD(ISW ,2)*(1-2*((ISW-1)/2))
I3=I4+MOD(ISW-1,2)*(1-2*((ISW-1)/2))
J3=J4+MOD(ISW ,2)*(1-2*((ISW-1)/2))
201 H1=ZG(I1,J1)
H2=ZG(I2,J2)
H3=ZG(I3,J3)
H4=ZG(I4,J4)
H5=0.25*(H1+H2+H3+H4)
Z1= Z(I1,J1)
Z2= Z(I2,J2)
Z3= Z(I3,J3)
Z4= Z(I4,J4)
IF(MODE.EQ.1) Z5=0.25*(Z1+Z2+Z3+Z4)
IF(H2-CV) 52,53,53
52 IF(H3-CV) 63,62,62
53 IF(H3-CV) 54,61,61
54 IF(H5-CV) 63,61,61
61 ISA=1
IF(MODE.EQ.1) THEN
IF(H5.LT.CV.AND.H3.GE.CV) THEN
ZC=D(H4,H5,Z4,Z5)
IF(ZC.NE.ZA) CALL XCURDN(REAL(ZC),AIMAG(ZC),0,0)
ZA=ZC
ZC=D(H3,H5,Z3,Z5)
IF(ZC.NE.ZA) CALL XCURDN(REAL(ZC),AIMAG(ZC),0,0)
ZA=ZC
ZC=D(H2,H5,Z2,Z5)
IF(ZC.NE.ZA) CALL XCURDN(REAL(ZC),AIMAG(ZC),0,0)
ZA=ZC
ELSE
ZC=D(H1,H5,Z1,Z5)
IF(ZC.NE.ZA) CALL XCURDN(REAL(ZC),AIMAG(ZC),0,0)
ZA=ZC
ENDIF
ENDIF
ZB=D(H1,H2,Z1,Z2)
I4=I2
J4=J2
GOTO 60
62 ISA=2
IF(MODE.EQ.1) THEN
IF(H5.LT.CV) THEN
ZC=D(H4,H5,Z4,Z5)
IF(ZC.NE.ZA) CALL XCURDN(REAL(ZC),AIMAG(ZC),0,0)
ZA=ZC
ZC=D(H3,H5,Z3,Z5)
IF(ZC.NE.ZA) CALL XCURDN(REAL(ZC),AIMAG(ZC),0,0)
ZA=ZC
ELSE
ZC=D(H1,H5,Z1,Z5)
IF(ZC.NE.ZA) CALL XCURDN(REAL(ZC),AIMAG(ZC),0,0)
ZA=ZC
ZC=D(H2,H5,Z2,Z5)
IF(ZC.NE.ZA) CALL XCURDN(REAL(ZC),AIMAG(ZC),0,0)
ZA=ZC
ENDIF
ENDIF
ZB=D(H2,H3,Z2,Z3)
I1=I2
J1=J2
I4=I3
J4=J3
GOTO 60
63 ISA=3
IF(MODE.EQ.1) THEN
IF(H5.GE.CV.AND.H2.LT.CV) THEN
ZC=D(H1,H5,Z1,Z5)
IF(ZC.NE.ZA) CALL XCURDN(REAL(ZC),AIMAG(ZC),0,0)
ZA=ZC
ZC=D(H2,H5,Z2,Z5)
IF(ZC.NE.ZA) CALL XCURDN(REAL(ZC),AIMAG(ZC),0,0)
ZA=ZC
ZC=D(H3,H5,Z3,Z5)
IF(ZC.NE.ZA) CALL XCURDN(REAL(ZC),AIMAG(ZC),0,0)
ZA=ZC
ELSE
ZC=D(H4,H5,Z4,Z5)
IF(ZC.NE.ZA) CALL XCURDN(REAL(ZC),AIMAG(ZC),0,0)
ZA=ZC
ENDIF
ENDIF
ZB=D(H3,H4,Z3,Z4)
I1=I3
J1=J3
60 ISW=MOD(ISW-ISA+5,4)+1
I2=I1+MOD(ISW-1,2)*(1-2*((ISW-1)/2))
J2=J1+MOD(ISW ,2)*(1-2*((ISW-1)/2))
I3=I4+MOD(ISW-1,2)*(1-2*((ISW-1)/2))
J3=J4+MOD(ISW ,2)*(1-2*((ISW-1)/2))
IF( I2.EQ.0.OR.I3.EQ.0.OR.I2.EQ.MGP.OR.I3.EQ.MGP .OR.
: J2.EQ.0.OR.J3.EQ.0.OR.J2.EQ.JGP.OR.J3.EQ.JGP) THEN
CALL XCURDN(REAL(ZB),AIMAG(ZB),0,1)
ELSE
IF(ZB.NE.ZA) CALL XCURDN(REAL(ZB),AIMAG(ZB),0,0)
ZA=ZB
IWRK(I1,J1)=1
IWRK(I4,J4)=1
GOTO 201
ENDIF
1 CONTINUE
DO 2 J=2,JG-1
DO 2 I=1,MG-1
ISW=1
I10=I+1
J10=J
I40=I
J40=J
IF(IWRK(I10,J10).EQ.1.AND.IWRK(I40,J40).EQ.1) GOTO 2
H1=ZG(I10,J10)
H4=ZG(I40,J40)
IF(H1.GE.CV.OR.H4.LT.CV ) GOTO 2
I1=I10
J1=J10
I4=I40
J4=J40
Z1= Z(I1,J1)
Z4= Z(I4,J4)
ZA=D(H4,H1,Z4,Z1)
CALL XCURUP(REAL(ZA),AIMAG(ZA))
101 I2=I1+MOD(ISW-1,2)*(1-2*((ISW-1)/2))
J2=J1+MOD(ISW ,2)*(1-2*((ISW-1)/2))
I3=I4+MOD(ISW-1,2)*(1-2*((ISW-1)/2))
J3=J4+MOD(ISW ,2)*(1-2*((ISW-1)/2))
H1=ZG(I1,J1)
H2=ZG(I2,J2)
H3=ZG(I3,J3)
H4=ZG(I4,J4)
H5=0.25*(H1+H2+H3+H4)
Z1= Z(I1,J1)
Z2= Z(I2,J2)
Z3= Z(I3,J3)
Z4= Z(I4,J4)
IF(MODE.EQ.1) Z5=0.25*(Z1+Z2+Z3+Z4)
IF(H2-CV) 12,13,13
12 IF(H3-CV) 23,22,22
13 IF(H3-CV) 14,21,21
14 IF(H5-CV) 23,21,21
21 ISA=1
IF(MODE.EQ.1) THEN
IF(H5.LT.CV.AND.H3.GE.CV) THEN
ZC=D(H4,H5,Z4,Z5)
IF(ZC.NE.ZA) CALL XCURDN(REAL(ZC),AIMAG(ZC),1,0)
ZA=ZC
ZC=D(H3,H5,Z3,Z5)
IF(ZC.NE.ZA) CALL XCURDN(REAL(ZC),AIMAG(ZC),1,0)
ZA=ZC
ZC=D(H2,H5,Z2,Z5)
IF(ZC.NE.ZA) CALL XCURDN(REAL(ZC),AIMAG(ZC),1,0)
ZA=ZC
ELSE
ZC=D(H1,H5,Z1,Z5)
IF(ZC.NE.ZA) CALL XCURDN(REAL(ZC),AIMAG(ZC),1,0)
ZA=ZC
ENDIF
ENDIF
ZB=D(H1,H2,Z1,Z2)
I4=I2
J4=J2
GOTO 30
22 ISA=2
IF(MODE.EQ.1) THEN
IF(H5.LT.CV) THEN
ZC=D(H4,H5,Z4,Z5)
IF(ZC.NE.ZA) CALL XCURDN(REAL(ZC),AIMAG(ZC),1,0)
ZA=ZC
ZC=D(H3,H5,Z3,Z5)
IF(ZC.NE.ZA) CALL XCURDN(REAL(ZC),AIMAG(ZC),1,0)
ZA=ZC
ELSE
ZC=D(H1,H5,Z1,Z5)
IF(ZC.NE.ZA) CALL XCURDN(REAL(ZC),AIMAG(ZC),1,0)
ZA=ZC
ZC=D(H2,H5,Z2,Z5)
IF(ZC.NE.ZA) CALL XCURDN(REAL(ZC),AIMAG(ZC),1,0)
ZA=ZC
ENDIF
ENDIF
ZB=D(H2,H3,Z2,Z3)
I1=I2
J1=J2
I4=I3
J4=J3
GOTO 30
23 ISA=3
IF(MODE.EQ.1) THEN
IF(H5.GE.CV.AND.H2.LT.CV) THEN
ZC=D(H1,H5,Z1,Z5)
IF(ZC.NE.ZA) CALL XCURDN(REAL(ZC),AIMAG(ZC),1,0)
ZA=ZC
ZC=D(H2,H5,Z2,Z5)
IF(ZC.NE.ZA) CALL XCURDN(REAL(ZC),AIMAG(ZC),1,0)
ZA=ZC
ZC=D(H3,H5,Z3,Z5)
IF(ZC.NE.ZA) CALL XCURDN(REAL(ZC),AIMAG(ZC),1,0)
ZA=ZC
ELSE
ZC=D(H4,H5,Z4,Z5)
IF(ZC.NE.ZA) CALL XCURDN(REAL(ZC),AIMAG(ZC),1,0)
ZA=ZC
ENDIF
ENDIF
ZB=D(H3,H4,Z3,Z4)
I1=I3
J1=J3
30 IF( I1.EQ.I10.AND.J1.EQ.J10.AND.I4.EQ.I40.AND.J4.EQ.J40) THEN
CALL XCURDN(REAL(ZB),AIMAG(ZB),1,1)
ELSE
IF(ZB.NE.ZA) CALL XCURDN(REAL(ZB),AIMAG(ZB),1,0)
ZA=ZB
IWRK(I1,J1)=1
IWRK(I4,J4)=1
ISW=MOD(ISW-ISA+5,4)+1
GOTO 101
ENDIF
2 CONTINUE
CALL XLPNUP( REAL(Z(1,1)), AIMAG(Z(1,1)) )
RETURN
END
SUBROUTINE ZCONTJ(ZG,Z,IWRK,MD,MG,JG,CV,SPEC) 1,8
DIMENSION ZG(MD ,*),Z(MD ,*),IWRK(MG ,*)
C* New update for contouring allowing special value holes (SPEC)
C* The second edition of the contour tracing
C* Zhang Zuojun, Jan. 1988
C* New update including contouring on triagle grids
C* When MODE=0 contouring perform on retangular grids (default)
C* When MODE=1 contouring perform on triangular grids .
COMPLEX Z,B1,B2,ZA,ZB,ZC,Z1,Z2,Z3,Z4,Z5,D
C IFUN1(K)=K+MG*((MGP-K)/MGP-K/MGP)
D(P1,P2,B1,B2 )=B1+(CV-P1)*(B2-B1)/(P2-P1)
CALL ZQCONM(MODE)
DUM=SPEC
MGP=MG+1
JGP=JG+1
DO 4 J=1,JG
DO 4 I=1,MG
4 IWRK(I,J)=0
DO 1 JJ=1,2*(MG+JG-2)
IF(JJ.LT.MG) THEN
I4=JJ
J4=1
ISW=1
ELSEIF(JJ.LT.MG+JG-1) THEN
I4=MG
J4=JJ-MG+1
ISW=4
ELSEIF(JJ.LT.MG+MG+JG-2) THEN
I4=MG+MG+JG-JJ-1
J4=JG
ISW=3
ELSEIF(JJ.LT.MG+MG+JG+JG-3) THEN
I4=1
J4=MG+MG+JG+JG-2-JJ
ISW=2
ENDIF
INI=MOD(ISW ,2)*(1-2*(MOD(ISW,4)/2))
INJ=MOD(ISW+1,2)*(1-2*(MOD(ISW,4)/2))
I1=I4+INI
J1=J4+INJ
IF(I1.EQ.0.OR.I1.EQ.MGP.OR.J1.EQ.0.OR.J1.EQ.JGP)GOTO 1
H1=ZG(I1,J1)
H4=ZG(I4,J4)
IF(H1.GE.CV.OR.H4.LT.CV ) GOTO 1
Z1= Z(I1,J1)
Z4= Z(I4,J4)
ZA=D(H4,H1,Z4,Z1)
CALL XCURUP(REAL(ZA),AIMAG(ZA))
I2=I1+MOD(ISW-1,2)*(1-2*((ISW-1)/2))
J2=J1+MOD(ISW ,2)*(1-2*((ISW-1)/2))
I3=I4+MOD(ISW-1,2)*(1-2*((ISW-1)/2))
J3=J4+MOD(ISW ,2)*(1-2*((ISW-1)/2))
201 H1=ZG(I1,J1)
H2=ZG(I2,J2)
H3=ZG(I3,J3)
H4=ZG(I4,J4)
H5=0.25*(H1+H2+H3+H4)
IF(H1.EQ.DUM.OR.H2.EQ.DUM.OR.H3.EQ.DUM.OR.H4.EQ.DUM)THEN
ISWTCH=0
ELSE
ISWTCH=1
ENDIF
Z1= Z(I1,J1)
Z2= Z(I2,J2)
Z3= Z(I3,J3)
Z4= Z(I4,J4)
IF(MODE.EQ.1) Z5=0.25*(Z1+Z2+Z3+Z4)
IF(H2-CV) 52,53,53
52 IF(H3-CV) 63,62,62
53 IF(H3-CV) 54,61,61
54 IF(H5-CV) 63,61,61
61 ISA=1
IF(MODE.EQ.1.AND.ISWTCH.EQ.1) THEN
IF(H5.LT.CV.AND.H3.GE.CV) THEN
ZC=D(H4,H5,Z4,Z5)
IF(ZC.NE.ZA) CALL XCURDN(REAL(ZC),AIMAG(ZC),0,0)
ZA=ZC
ZC=D(H3,H5,Z3,Z5)
IF(ZC.NE.ZA) CALL XCURDN(REAL(ZC),AIMAG(ZC),0,0)
ZA=ZC
ZC=D(H2,H5,Z2,Z5)
IF(ZC.NE.ZA) CALL XCURDN(REAL(ZC),AIMAG(ZC),0,0)
ZA=ZC
ELSE
ZC=D(H1,H5,Z1,Z5)
IF(ZC.NE.ZA) CALL XCURDN(REAL(ZC),AIMAG(ZC),0,0)
ZA=ZC
ENDIF
ENDIF
ZB=D(H1,H2,Z1,Z2)
I4=I2
J4=J2
GOTO 60
62 ISA=2
IF(MODE.EQ.1.AND.ISWTCH.EQ.1) THEN
IF(H5.LT.CV) THEN
ZC=D(H4,H5,Z4,Z5)
IF(ZC.NE.ZA) CALL XCURDN(REAL(ZC),AIMAG(ZC),0,0)
ZA=ZC
ZC=D(H3,H5,Z3,Z5)
IF(ZC.NE.ZA) CALL XCURDN(REAL(ZC),AIMAG(ZC),0,0)
ZA=ZC
ELSE
ZC=D(H1,H5,Z1,Z5)
IF(ZC.NE.ZA) CALL XCURDN(REAL(ZC),AIMAG(ZC),0,0)
ZA=ZC
ZC=D(H2,H5,Z2,Z5)
IF(ZC.NE.ZA) CALL XCURDN(REAL(ZC),AIMAG(ZC),0,0)
ZA=ZC
ENDIF
ENDIF
ZB=D(H2,H3,Z2,Z3)
I1=I2
J1=J2
I4=I3
J4=J3
GOTO 60
63 ISA=3
IF(MODE.EQ.1.AND.ISWTCH.EQ.1) THEN
IF(H5.GE.CV.AND.H2.LT.CV) THEN
ZC=D(H1,H5,Z1,Z5)
IF(ZC.NE.ZA) CALL XCURDN(REAL(ZC),AIMAG(ZC),0,0)
ZA=ZC
ZC=D(H2,H5,Z2,Z5)
IF(ZC.NE.ZA) CALL XCURDN(REAL(ZC),AIMAG(ZC),0,0)
ZA=ZC
ZC=D(H3,H5,Z3,Z5)
IF(ZC.NE.ZA) CALL XCURDN(REAL(ZC),AIMAG(ZC),0,0)
ZA=ZC
ELSE
ZC=D(H4,H5,Z4,Z5)
IF(ZC.NE.ZA) CALL XCURDN(REAL(ZC),AIMAG(ZC),0,0)
ZA=ZC
ENDIF
ENDIF
ZB=D(H3,H4,Z3,Z4)
I1=I3
J1=J3
60 ISW=MOD(ISW-ISA+5,4)+1
I2=I1+MOD(ISW-1,2)*(1-2*((ISW-1)/2))
J2=J1+MOD(ISW ,2)*(1-2*((ISW-1)/2))
I3=I4+MOD(ISW-1,2)*(1-2*((ISW-1)/2))
J3=J4+MOD(ISW ,2)*(1-2*((ISW-1)/2))
IF( I2.EQ.0.OR.I3.EQ.0.OR.I2.EQ.MGP.OR.I3.EQ.MGP .OR.
: J2.EQ.0.OR.J3.EQ.0.OR.J2.EQ.JGP.OR.J3.EQ.JGP )THEN
IF(ISWTCH.EQ.1) THEN
CALL XCURDN(REAL(ZB),AIMAG(ZB),0,1)
ELSE
CALL XCURUP(REAL(ZB),AIMAG(ZB))
ENDIF
ELSE
IF(ISWTCH.EQ.1.AND.ZB.NE.ZA)THEN
IF(ZG(I2,J2).EQ.DUM.OR.ZG(I3,J3).EQ.DUM)THEN
CALL XCURDN(REAL(ZB),AIMAG(ZB),0,0)
ELSE
CALL XCURDN(REAL(ZB),AIMAG(ZB),0,1)
ENDIF
ELSE
CALL XCURUP(REAL(ZB),AIMAG(ZB))
ENDIF
ZA=ZB
IWRK(I1,J1)=1
IWRK(I4,J4)=1
GOTO 201
ENDIF
1 CONTINUE
DO 2 J=2,JG-1
DO 2 I=1,MG-1
ISW=1
I10=I+1
J10=J
I40=I
J40=J
IF(IWRK(I10,J10).EQ.1.AND.IWRK(I40,J40).EQ.1) GOTO 2
H1=ZG(I10,J10)
H4=ZG(I40,J40)
IF(H1.GE.CV.OR.H4.LT.CV ) GOTO 2
I1=I10
J1=J10
I4=I40
J4=J40
Z1= Z(I1,J1)
Z4= Z(I4,J4)
ZA=D(H4,H1,Z4,Z1)
CALL XCURUP(REAL(ZA),AIMAG(ZA))
I2=I1+MOD(ISW-1,2)*(1-2*((ISW-1)/2))
J2=J1+MOD(ISW ,2)*(1-2*((ISW-1)/2))
I3=I4+MOD(ISW-1,2)*(1-2*((ISW-1)/2))
J3=J4+MOD(ISW ,2)*(1-2*((ISW-1)/2))
101 H1=ZG(I1,J1)
H2=ZG(I2,J2)
H3=ZG(I3,J3)
H4=ZG(I4,J4)
H5=0.25*(H1+H2+H3+H4)
IF(H1.EQ.DUM.OR.H2.EQ.DUM.OR.H3.EQ.DUM.OR.H4.EQ.DUM)THEN
ISWTCH=0
ELSE
ISWTCH=1
ENDIF
Z1= Z(I1,J1)
Z2= Z(I2,J2)
Z3= Z(I3,J3)
Z4= Z(I4,J4)
IF(MODE.EQ.1) Z5=0.25*(Z1+Z2+Z3+Z4)
IF(H2-CV) 12,13,13
12 IF(H3-CV) 23,22,22
13 IF(H3-CV) 14,21,21
14 IF(H5-CV) 23,21,21
21 ISA=1
IF(MODE.EQ.1.AND.ISWTCH.EQ.1) THEN
IF(H5.LT.CV.AND.H3.GE.CV) THEN
ZC=D(H4,H5,Z4,Z5)
IF(ZC.NE.ZA) CALL XCURDN(REAL(ZC),AIMAG(ZC),1,0)
ZA=ZC
ZC=D(H3,H5,Z3,Z5)
IF(ZC.NE.ZA) CALL XCURDN(REAL(ZC),AIMAG(ZC),1,0)
ZA=ZC
ZC=D(H2,H5,Z2,Z5)
IF(ZC.NE.ZA) CALL XCURDN(REAL(ZC),AIMAG(ZC),1,0)
ZA=ZC
ELSE
ZC=D(H1,H5,Z1,Z5)
IF(ZC.NE.ZA) CALL XCURDN(REAL(ZC),AIMAG(ZC),1,0)
ZA=ZC
ENDIF
ENDIF
ZB=D(H1,H2,Z1,Z2)
I4=I2
J4=J2
GOTO 30
22 ISA=2
IF(MODE.EQ.1.AND.ISWTCH.EQ.1) THEN
IF(H5.LT.CV) THEN
ZC=D(H4,H5,Z4,Z5)
IF(ZC.NE.ZA) CALL XCURDN(REAL(ZC),AIMAG(ZC),1,0)
ZA=ZC
ZC=D(H3,H5,Z3,Z5)
IF(ZC.NE.ZA) CALL XCURDN(REAL(ZC),AIMAG(ZC),1,0)
ZA=ZC
ELSE
ZC=D(H1,H5,Z1,Z5)
IF(ZC.NE.ZA) CALL XCURDN(REAL(ZC),AIMAG(ZC),1,0)
ZA=ZC
ZC=D(H2,H5,Z2,Z5)
IF(ZC.NE.ZA) CALL XCURDN(REAL(ZC),AIMAG(ZC),1,0)
ZA=ZC
ENDIF
ENDIF
ZB=D(H2,H3,Z2,Z3)
I1=I2
J1=J2
I4=I3
J4=J3
GOTO 30
23 ISA=3
IF(MODE.EQ.1.AND.ISWTCH.EQ.1) THEN
IF(H5.GE.CV.AND.H2.LT.CV) THEN
ZC=D(H1,H5,Z1,Z5)
IF(ZC.NE.ZA) CALL XCURDN(REAL(ZC),AIMAG(ZC),1,0)
ZA=ZC
ZC=D(H2,H5,Z2,Z5)
IF(ZC.NE.ZA) CALL XCURDN(REAL(ZC),AIMAG(ZC),1,0)
ZA=ZC
ZC=D(H3,H5,Z3,Z5)
IF(ZC.NE.ZA) CALL XCURDN(REAL(ZC),AIMAG(ZC),1,0)
ZA=ZC
ELSE
ZC=D(H4,H5,Z4,Z5)
IF(ZC.NE.ZA) CALL XCURDN(REAL(ZC),AIMAG(ZC),1,0)
ZA=ZC
ENDIF
ENDIF
ZB=D(H3,H4,Z3,Z4)
I1=I3
J1=J3
30 IF( I1.EQ.I10.AND.J1.EQ.J10.AND.I4.EQ.I40.AND.J4.EQ.J40) THEN
IF(ISWTCH.EQ.1)THEN
CALL XCURDN(REAL(ZB),AIMAG(ZB),0,1)
ELSE
CALL XCURUP(REAL(ZB),AIMAG(ZB))
ENDIF
ELSE
IWRK(I1,J1)=1
IWRK(I4,J4)=1
ISW=MOD(ISW-ISA+5,4)+1
I2=I1+MOD(ISW-1,2)*(1-2*((ISW-1)/2))
J2=J1+MOD(ISW ,2)*(1-2*((ISW-1)/2))
I3=I4+MOD(ISW-1,2)*(1-2*((ISW-1)/2))
J3=J4+MOD(ISW ,2)*(1-2*((ISW-1)/2))
IF(ZG(I2,J2).EQ.DUM.OR.ZG(I3,J3).EQ.DUM)THEN
IF(ISWTCH.EQ.1) THEN
CALL XCURDN(REAL(ZB),AIMAG(ZB),0,1)
ELSE
CALL XCURUP(REAL(ZB),AIMAG(ZB))
ENDIF
ELSE
IF(ISWTCH.EQ.1) THEN
IF(ZB.NE.ZA) CALL XCURDN(REAL(ZB),AIMAG(ZB),0,1)
ELSE
CALL XCURUP(REAL(ZB),AIMAG(ZB))
ENDIF
ENDIF
ZA=ZB
GOTO 101
ENDIF
2 CONTINUE
CALL XLPNUP( REAL(Z(1,1)), AIMAG(Z(1,1)) )
RETURN
END
SUBROUTINE ZCONTM(MODES)
SAVE MODE
MODE=MODES
RETURN
C***************
ENTRY ZQCONM(MODET)
MODET=MODE
RETURN
DATA MODE/0/
END
SUBROUTINE ZRCNTR(ZG,Z,MD,MG,NG,CV) 1,4
C* The final edition of the contouring routine
C* 12.6.1987
DIMENSION ZG(MD,*),Z(MD,*)
COMPLEX Z,B1,B2,ZA,ZB,Z1,Z2,Z3,Z4,D
D(P1,P2,B1,B2 )=B1+(CV-P1)*(B2-B1)/(P2-P1)
JG=ABS(NG)
IDUB=0
DO 1 J=1,MG-1
DO 2 I=1,JG-1
H1=ZG(J ,I )
H2=ZG(J+1,I )
Z1= Z(J ,I )
Z2= Z(J+1,I )
H3=ZG(J+1,I+1)
H4=ZG( J,I+1)
Z3= Z(J+1,I+1)
Z4= Z( J,I+1)
IF(H1-CV)11,20,20
11 IF(H2-CV)12,14,14
12 IF(H3-CV)13,15,15
13 IF(H4-CV) 2,30,30
14 IF(H3-CV)16,17,17
15 IF(H4-CV)31,32,32
16 IF(H4-CV)33,34,34
17 IF(H4-CV)35,36,36
20 IF(H2-CV)21,23,23
21 IF(H3-CV)22,24,24
22 IF(H4-CV)36,35,35
23 IF(H3-CV)25,26,26
24 IF(H4-CV)37,33,33
25 IF(H4-CV)32,31,31
26 IF(H4-CV)30, 2, 2
30 ZA=D(H1,H4,Z1,Z4)
ZB=D(H4,H3,Z4,Z3)
GOTO 40
31 ZA=D(H2,H3,Z2,Z3)
ZB=D(H4,H3,Z4,Z3)
GOTO 40
32 ZA=D(H1,H4,Z1,Z4)
ZB=D(H2,H3,Z2,Z3)
GOTO 40
33 ZA=D(H1,H2,Z1,Z2)
ZB=D(H2,H3,Z2,Z3)
IDUB=0
GOTO 40
34 IDUB=1
H5=0.25*(H1+H2+H3+H4)
IF(H5.GT.CV) IDUB=-1
GOTO (30,31) 2-(1+IDUB)/2
35 ZA=D(H1,H2,Z1,Z2)
ZB=D(H4,H3,Z4,Z3)
GOTO 40
36 ZA=D(H1,H2,Z1,Z2)
ZB=D(H1,H4,Z1,Z4)
IDUB=0
GOTO 40
37 IDUB=-1
H5=0.25*(H1+H2+H3+H4)
IF(H5.GT.CV) IDUB=1
GOTO (30,31) 2-(1+IDUB)/2
GOTO 31
40 CONTINUE
IF(NG.GT.0) THEN
CALL XPENUP(REAL(ZA),AIMAG(ZA))
CALL XPENDN(REAL(ZB),AIMAG(ZB))
ELSE
ZB=ZA+0.7*(ZB-ZA)
CALL XPENUP(REAL(ZA),AIMAG(ZA))
CALL XPENDN(REAL(ZB),AIMAG(ZB))
ENDIF
IF(IDUB)36,2,33
2 CONTINUE
1 CONTINUE
RETURN
END
SUBROUTINE ZRCNTA(ZG,Z,MD,MG,JG,CVL,NC),1
DIMENSION ZG(MD,*),Z(MD,*),CVL(*)
COMPLEX Z
DO 100 K=1,NC
CV=CVL(K)
100 CALL ZRCNTR(ZG,Z,MD,MG,JG,CV)
RETURN
END
SUBROUTINE ZRCNTB(ZG,Z,MD,MG,NG,CVL,NC),4
C Contouring on triangular grid
DIMENSION ZG(MD,*),Z(MD,*),CVL(*)
COMPLEX Z,B1,B2,ZA,ZB,Z1,Z2,Z3,D
D(P1,P2,B1,B2 )=B1+(CV-P1)*(B2-B1)/(P2-P1)
JG=ABS(NG)
DO 50 I=1,MG-1
DO 50 J=1,JG-1
H3=0.25*(ZG(I,J)+ZG(I,J+1)+ZG(I+1,J+1)+ZG(I+1,J))
Z3=0.25*( Z(I,J)+ Z(I,J+1)+ Z(I+1,J+1)+ Z(I+1,J))
DO 50 M=1,4
H1=ZG(I+MOD(M ,4)/2,J+MOD(M-1,4)/2)
Z1=Z (I+MOD(M ,4)/2,J+MOD(M-1,4)/2)
H2=ZG(I+MOD(M+1,4)/2,J+MOD(M ,4)/2)
Z2=Z (I+MOD(M+1,4)/2,J+MOD(M ,4)/2)
DO 50 K=1,NC
CV=CVL(K)
IF(H1-CV) 1, 2, 2
1 IF(H2-CV) 3, 4, 4
3 IF(H3-CV)50,30,30
4 IF(H3-CV)20,10,10
2 IF(H2-CV) 5, 6, 6
5 IF(H3-CV)10,20,20
6 IF(H3-CV)30,50,50
10 ZA=D(H3,H1,Z3,Z1)
ZB=D(H1,H2,Z1,Z2)
GOTO 40
20 ZA=D(H1,H2,Z1,Z2)
ZB=D(H2,H3,Z2,Z3)
GOTO 40
30 ZA=D(H2,H3,Z2,Z3)
ZB=D(H3,H1,Z3,Z1)
40 IF(ZA.EQ.ZB) GOTO 50
IF(NG.GT.0) THEN
CALL XPENUP(REAL(ZA),AIMAG(ZA))
CALL XPENDN(REAL(ZB),AIMAG(ZB))
ELSE
ZB=ZA+0.7*(ZB-ZA)
CALL XPENUP(REAL(ZA),AIMAG(ZA))
CALL XPENDN(REAL(ZB),AIMAG(ZB))
ENDIF
50 CONTINUE
RETURN
END
SUBROUTINE XHATCH(Z,X,Y,MD,M,N,CL1,CL2, MODE),4
REAL X(MD,*),Y(MD,*),Z(MD,*)
IF( MODE.EQ.0) THEN
CALL XHATCX(Z,X,Y,MD,M,N,CL1,CL2)
CALL XHATCY(Z,X,Y,MD,M,N,CL1,CL2)
RETURN
ENDIF
IF( MODE.EQ.1) CALL XHATCX(Z,X,Y,MD,M,N,CL1,CL2)
IF( MODE.EQ.-1) CALL XHATCY(Z,X,Y,MD,M,N,CL1,CL2)
RETURN
END
SUBROUTINE XHATCX(Z,X,Y,MD,M,N,CL1,CL2) 2,5
REAL X(MD,*),Y(MD,*), Z(MD,*) ,XP(10),YP(10)
COMMON /XFTR06/ XFACTR,YFACTR
COMMON /XHCH35/ DH
D(P1,P2,B1,B2)=B1+(CV-P1)*(B2-B1)/(P2-P1)
IF( CL1.EQ.CL2)RETURN
C
MM=M-1
NM=N-1
XSIGN=SIGN( 1.0, X(M,1)-X(1,1) )
DXP = DH*XSIGN
DX=DXP/XFACTR
XS= X(1,1)
IS=1
1 CONTINUE
XS=XS+DX
IF((XS-X(M,1))*XSIGN. GT. 0.0) RETURN
2 IF((XS-X(IS+1,1))*XSIGN.GT.0.0) THEN
IS=IS+1
IF(IS.GT.M-1)RETURN
GOTO 2
ENDIF
HS=Z(IS,1)+(Z(IS+1,1)-Z(IS,1))/(X(IS+1,1)-X(IS,1))*(XS-X(IS,1))
IF( HS.GE.CL1.AND.HS.LE.CL2) THEN
YPP= Y(IS,1)+(Y(IS+1,1)-Y(IS,1))
: /(X(IS+1,1)-X(IS,1))*(XS-X(IS,1))
CALL XPENUP(XS,YPP)
MODEP =1
ELSE
MODEP =0
ENDIF
IP=IS
DO 540 J=1,NM
X1=X(IP,J)
Y1=Y(IP,J)
H1=Z(IP,J)
X4=X(IP+1,J)
Y4=Y(IP+1,J)
H4=Z(IP+1,J)
X2=X(IP,J+1)
Y2=Y(IP,J+1)
H2=Z(IP,J+1)
X3=X(IP+1,J+1)
Y3=Y(IP+1,J+1)
H3=Z(IP+1,J+1)
CV=CL1
NP=0
DO 300 IK=1,2
IDUB=0
IF(H1-CV)11,20,20
11 IF(H2-CV)12,14,14
12 IF(H3-CV)13,15,15
13 IF(H4-CV)250,250,30
14 IF(H3-CV)16,17,17
15 IF(H4-CV)31,32,32
16 IF(H4-CV)33,39,39
17 IF(H4-CV)35,36,36
20 IF(H2-CV)21,23,23
21 IF(H3-CV)22,24,24
22 IF(H4-CV)36,35,35
23 IF(H3-CV)25,26,26
24 IF(H4-CV)38,33,33
25 IF(H4-CV)32,31,31
26 IF(H4-CV)30,250,250
38 IF((H1+H2+H3+H4)*0.25-CV) 34,34,37
39 IF((H1+H2+H3+H4)*0.25-CV) 37,37,34
30 XA=D(H1,H4,X1,X4)
YA=D(H1,H4,Y1,Y4)
XB=D(H4,H3,X4,X3)
YB=D(H4,H3,Y4,Y3)
GOTO 40
31 XA=D(H2,H3,X2,X3)
YA=D(H2,H3,Y2,Y3)
XB=D(H4,H3,X4,X3)
YB=D(H4,H3,Y4,Y3)
GOTO 40
32 XA=D(H1,H4,X1,X4)
YA=D(H1,H4,Y1,Y4)
XB=D(H2,H3,X2,X3)
YB=D(H2,H3,Y2,Y3)
GOTO 40
33 XA=D(H1,H2,X1,X2)
YA=D(H1,H2,Y1,Y2)
XB=D(H2,H3,X2,X3)
YB=D(H2,H3,Y2,Y3)
IDUB=0
GOTO 40
34 IDUB=1
GOTO 31
35 XA=D(H1,H2,X1,X2)
YA=D(H1,H2,Y1,Y2)
XB=D(H4,H3,X4,X3)
YB=D(H4,H3,Y4,Y3)
GOTO 40
36 XA=D(H1,H2,X1,X2)
YA=D(H1,H2,Y1,Y2)
XB=D(H1,H4,X1,X4)
YB=D(H1,H4,Y1,Y4)
IDUB=0
GOTO 40
37 IDUB=-1
GOTO 30
40 CONTINUE
IF(XA.EQ.XB) GOTO 245
XC=MIN(XA,XB)
XD=MAX(XA,XB)
IF( XS.GT.XC.AND.XS.LE.XD) THEN
NP=NP+1
XP(NP)=XS
YP(NP)=YA+(YB-YA)/(XB-XA)*(XS-XA)
ENDIF
245 IF(IDUB)33,250,36
250 CV=CL2
300 CONTINUE
IF( NP.GT.2) CALL XHAT01(YP,XP,NP)
DO 350 NPL=1,NP
IF( MODEP.EQ.0) THEN
CALL XPENUP(XP(NPL),YP(NPL))
MODEP=1
ELSE
CALL XPENDN(XP(NPL),YP(NPL))
MODEP=0
ENDIF
350 CONTINUE
540 CONTINUE
IF( MODEP.EQ.1) THEN
YPP=Y(IS,N)+(Y(IS+1,N)-Y(IS,N))/(X(IS+1,N)-X(IS,N))*(XS-X(IS,N))
CALL XPENDN(XS,YPP)
MODP=0
ENDIF
IF( IS.LE.M-1)GOTO 1
RETURN
END
SUBROUTINE XHATCY(Z,X,Y,MD,M,N,CL1,CL2) 2,5
REAL X(MD,*),Y(MD,*), Z(MD,*) ,XP(10),YP(10)
COMMON /XFTR06/ XFACTR,YFACTR
COMMON /XHCH35/ DH
D(P1,P2,B1,B2)=B1+(CV-P1)*(B2-B1)/(P2-P1)
IF( CL1.EQ.CL2)RETURN
C
MM=M-1
NM=N-1
YSIGN=SIGN( 1.0, Y(1,N)-Y(1,1))
DYP = DH*YSIGN
DY=DYP/YFACTR
YS= Y(1,1)
JS=1
1 CONTINUE
YS=YS+DY
IF((YS-Y(1,N))*YSIGN. GT. 0.0) RETURN
2 IF((YS-Y(1,JS+1 ))*YSIGN.GT.0.0) THEN
JS=JS+1
IF( JS.GT. N-1 ) RETURN
GOTO 2
ENDIF
HS=Z(1,JS)+(Z(1,JS+1)-Z(1,JS))/(Y(1,JS+1)-Y(1,JS))*(YS-Y(1,JS))
IF( HS.GE.CL1.AND.HS.LE.CL2) THEN
XPP=X(1,JS)+(X(1,JS+1)-X(1,JS))/(Y(1,JS+1)-Y(1,JS))*(YS-Y(1,JS))
CALL XPENUP(XPP,YS)
MODEP =1
ELSE
MODEP =0
ENDIF
DO 540 I=1,M-1
JP=JS
X1=X(I,JP)
Y1=Y(I,JP)
H1=Z(I,JP)
X4=X(I+1,JP)
Y4=Y(I+1,JP)
H4=Z(I+1,JP)
X2=X(I,JP+1)
Y2=Y(I,JP+1)
H2=Z(I,JP+1)
X3=X(I+1,JP+1)
Y3=Y(I+1,JP+1)
H3=Z(I+1,JP+1)
CV=CL1
NP=0
DO 300 IK=1,2
IDUB=0
10 IF(H1-CV)11,20,20
11 IF(H2-CV)12,14,14
12 IF(H3-CV)13,15,15
13 IF(H4-CV)250,250,30
14 IF(H3-CV)16,17,17
15 IF(H4-CV)31,32,32
16 IF(H4-CV)33,39,39
17 IF(H4-CV)35,36,36
20 IF(H2-CV)21,23,23
21 IF(H3-CV)22,24,24
22 IF(H4-CV)36,35,35
23 IF(H3-CV)25,26,26
24 IF(H4-CV)38,33,33
25 IF(H4-CV)32,31,31
26 IF(H4-CV)30,250,250
38 IF((H1+H2+H3+H4)*0.25-CV) 34,34,37
39 IF((H1+H2+H3+H4)*0.25-CV) 37,37,34
30 XA=D(H1,H4,X1,X4)
YA=D(H1,H4,Y1,Y4)
XB=D(H4,H3,X4,X3)
YB=D(H4,H3,Y4,Y3)
GOTO 40
31 XA=D(H2,H3,X2,X3)
YA=D(H2,H3,Y2,Y3)
XB=D(H4,H3,X4,X3)
YB=D(H4,H3,Y4,Y3)
GOTO 40
32 XA=D(H1,H4,X1,X4)
YA=D(H1,H4,Y1,Y4)
XB=D(H2,H3,X2,X3)
YB=D(H2,H3,Y2,Y3)
GOTO 40
33 XA=D(H1,H2,X1,X2)
YA=D(H1,H2,Y1,Y2)
XB=D(H2,H3,X2,X3)
YB=D(H2,H3,Y2,Y3)
IDUB=0
GOTO 40
34 IDUB=1
GOTO 31
35 XA=D(H1,H2,X1,X2)
YA=D(H1,H2,Y1,Y2)
XB=D(H4,H3,X4,X3)
YB=D(H4,H3,Y4,Y3)
GOTO 40
36 XA=D(H1,H2,X1,X2)
YA=D(H1,H2,Y1,Y2)
XB=D(H1,H4,X1,X4)
YB=D(H1,H4,Y1,Y4)
IDUB=0
GOTO 40
37 IDUB=-1
GOTO 30
40 CONTINUE
50 IF(YA.EQ.YB) GOTO 245
YC=MIN(YA,YB)
YD=MAX(YA,YB)
IF( YS.GT.YC.AND.YS.LE.YD) THEN
NP=NP+1
YP(NP)=YS
XP(NP)=XA+(XB-XA)/(YB-YA)*(YS-YA)
ENDIF
245 IF(IDUB)33,250,36
250 CV=CL2
300 CONTINUE
IF( NP.GT.2) CALL XHAT01(XP,YP,NP)
DO 350 NPL=1,NP
IF( MODEP.EQ.0) THEN
CALL XPENUP(XP(NPL),YP(NPL))
MODEP=1
ELSE
CALL XPENDN(XP(NPL),YP(NPL))
MODEP=0
ENDIF
350 CONTINUE
540 CONTINUE
IF( MODEP.EQ.1) THEN
XPP=X(M,JS)+(X(M,1+JS)-X(M,JS))/(Y(M,1+JS)-Y(M,JS))*(YS-Y(M,JS))
CALL XPENDN(XPP,YS)
MODEP=0
ENDIF
IF( JS.LE.(N-1)) GOTO 1
RETURN
END
SUBROUTINE XDHTCH( DD ) 3
COMMON /XHCH35/ DH
DH=DD
RETURN
END
SUBROUTINE XHAT01(XP,YP,N) 2
C arrange data sequence in xp and yp in ascending order of XP element
REAL XP(N), YP(N), XPT(20),YPT(20)
INTEGER IN(20)
IF( n.gt. 20 ) then
print*,'work arrray defined in XHAT01 not big enough.'
print*,'plotting job stopped'
stop
endif
XPT(1)=XP(1)
YPT(1)=YP(1)
DO 4 I=1,N
4 IN(I)=0
K=1
KK=1
3 DO 1 I=1,N
IF( XP(I).LT.XPT(K).AND.IN(I).EQ.0) THEN
KK=I
XPT(K)=XP(I)
YPT(K)=YP(I)
ENDIF
1 CONTINUE
IN(KK)=1
K=K+1
IF(K.GT.N) GOTO 6
DO 5 I=1,N
IF( IN(I).EQ.0) THEN
YPT(K)=YP(I)
XPT(K)=XP(I)
KK=I
GOTO 3
ENDIF
5 CONTINUE
GOTO 3
6 DO 2 I=1,N
XP(I)=XPT(I)
2 YP(I)=YPT(I)
END
SUBROUTINE XHATCHA(Z,X,Y,xwk,ywk,MD,M,N,CL1a,CL2a, 2,4
: hatch_angle)
c
c This routine does hatching of arbitary orientation
c between two contour values
c Written Oct 13, 1998 by Ming Xue
c
implicit none
c
c Input through argument list
c
integer md,m,n
REAL X(MD,*),Y(MD,*), Z(MD,*)
real cl1a,cl2a,cl1,cl2
REAL Xwk(MD,*),Ywk(MD,*)
c
c Input through common blocks
c
real XFACTR,YFACTR,DH
COMMON /XFTR06/ XFACTR,YFACTR
COMMON /XHCH35/ DH
real hatch_angle,sinhagl,coshagl
c common /xhatch_angle/ hatch_angle,sinhagl,coshagl
real sinhagla,coshagla
c
c Miselaneous local variables
c
integer i,j,np,idub,npl,ik,i1,j1,i2,j2
integer ledgefound,uedgefound
real XP(20),YP(20) ! Work arrays
real d,p1,p2,b1,b2,cv
real dxp,dx,hs,xs,xc,xd,tem
real x1,y1,h1,x2,y2,h2,x3,y3,h3,x4,y4,h4,xa,xb,ya,yb
real xwkmin,xwkmax,ywkmin,ywkmax,xmin,xmax
real ys1,ys2
integer iedge1,jedge1,iedge2,jedge2
integer iedge3,jedge3,iedge4,jedge4
real fxtrns,fytrns,fxorig,fyorig
real xtrns,ytrns,xorig,yorig
integer i3,j3,i4,j4
real ys1_new,ys2_new,yxratio
c
c Inline functions
c
D(P1,P2,B1,B2)=B1+(CV-P1)*(B2-B1)/(P2-P1)
fxtrns(xorig,yorig)= xorig*coshagl+yorig*sinhagl
fytrns(xorig,yorig)=-xorig*sinhagl+yorig*coshagl
fxorig(xtrns,ytrns)= xtrns*coshagl-ytrns*sinhagl
fyorig(xtrns,ytrns)= xtrns*sinhagl+ytrns*coshagl
c
c Start of executable statements
c
IF(CL1a.EQ.CL2a) RETURN ! Then there is nothing to do.
cl1=min(cl1a,cl2a)
cl2=max(cl1a,cl2a)
tem = (hatch_angle-90.0)*atan(1.0)/45.0
sinhagla= sin( tem )
coshagla = cos( tem )
yxratio = yfactr/xfactr
tem=1.0/sqrt(coshagla**2+(yxratio*sinhagla)**2)
sinhagl = yxratio*sinhagla*tem
coshagl = coshagla*tem
c
c Transform into a rotated coordinate. Which angle between
c the new y axis and the old x axis is hatch_angle
C
DO i=1,m
DO j=1,n
xwk(i,j)=fxtrns(x(i,j),y(i,j))
ywk(i,j)=fytrns(x(i,j),y(i,j))
ENDDO
ENDDO
xwkmin = xwk(1,1)
xwkmax = xwk(1,1)
ywkmin = ywk(1,1)
ywkmax = ywk(1,1)
DO i=1,m
DO j=1,n
xwkmin=min(xwk(i,j),xwkmin)
xwkmax=max(xwk(i,j),xwkmax)
ywkmin=min(ywk(i,j),ywkmin)
ywkmax=max(ywk(i,j),ywkmax)
ENDDO
ENDDO
DXP = DH
DX=DXP/XFACTR
XS= Xwkmin+dx
100 CONTINUE ! Come back for another hatching line
c call xpenup(fxorig(xs,ywkmin),fyorig(xs,ywkmin))
c call xpendn(fxorig(xs,ywkmax),fyorig(xs,ywkmax))
C Scan boxes on the edges, and found the edge of the box with the
c smallest intercepting y with the hatch line.
c
ledgefound = 0
ys1=ywkmax
uedgefound = 0
ys2=ywkmin
DO i=1,m-1
DO j=1,n-1
IF(i.eq.1.or.i.eq.m-1.or.j.eq.1.or.j.eq.n-1)then
xmin=min(xwk(i,j),xwk(i+1,j),xwk(i,j+1),xwk(i+1,j+1))
xmax=max(xwk(i,j),xwk(i+1,j),xwk(i,j+1),xwk(i+1,j+1))
if(xs.ge.xmin.and.xs.lt.xmax) then
call getlnsgmnt(xwk,ywk,md,i,j,xs,ys1_new,i1,j1,i2,j2,
: ys2_new,i3,j3,i4,j4)
if(ledgefound.eq.0.or.
: (ledgefound.ne.0.and.ys1_new.lt.ys1))then
iedge1=i1
jedge1=j1
iedge2=i2
jedge2=j2
ys1=ys1_new
ledgefound=1
endif
if(uedgefound.eq.0.or.
: (uedgefound.ne.0.and.ys2_new.gt.ys2))then
iedge3=i3
jedge3=j3
iedge4=i4
jedge4=j4
ys2=ys2_new
uedgefound=1
endif
endif
endif
ENDDO
ENDDO
c starting or ending box not found. No very likely, just in case
IF(ledgefound.eq.0.or.uedgefound.eq.0) RETURN
HS=Z(iedge1,jedge1)+(Z(iedge2,jedge2)-Z(iedge1,jedge1))/
: (Xwk(iedge2,jedge2)-Xwk(iedge1,jedge1))
: *(XS-Xwk(iedge1,jedge1))
NP=0
IF( HS.GE.CL1.AND.HS.LE.CL2) THEN
np=np+1
xp(np)=XS
yp(np)=ys1
ENDIF
HS=Z(iedge3,jedge3)+(Z(iedge4,jedge4)-Z(iedge3,jedge3))/
: (Xwk(iedge4,jedge4)-Xwk(iedge3,jedge3))
: *(XS-Xwk(iedge3,jedge3))
IF( HS.GE.CL1.AND.HS.LE.CL2) THEN
np=np+1
xp(np)=XS
yp(np)=ys2
ENDIF
DO 540 I=1,m-1
DO 540 J=1,N-1
X1=Xwk(I,J) ! low-left
Y1=Ywk(I,J)
H1=Z(I,J)
X4=Xwk(I+1,J) ! low-right
Y4=Ywk(I+1,J)
H4=Z(I+1,J)
X2=Xwk(I,J+1) ! upper-left
Y2=Ywk(I,J+1)
H2=Z(I,J+1)
X3=Xwk(I+1,J+1) ! upper-right
Y3=Ywk(I+1,J+1)
H3=Z(I+1,J+1)
xmin=min(x1,x2,x3,x4)
xmax=max(x1,x2,x3,x4)
if(.not.(xs.ge.xmin.and.xs.lt.xmax)) goto 540
CV=CL1
DO 300 IK=1,2 ! Test CL1 and CL2, hence 2 here
IDUB=0
10 IF(H1-CV)11,20,20
11 IF(H2-CV)12,14,14
12 IF(H3-CV)13,15,15
13 IF(H4-CV)250,250,30
14 IF(H3-CV)16,17,17
15 IF(H4-CV)31,32,32
16 IF(H4-CV)33,39,39
17 IF(H4-CV)35,36,36
20 IF(H2-CV)21,23,23
21 IF(H3-CV)22,24,24
22 IF(H4-CV)36,35,35
23 IF(H3-CV)25,26,26
24 IF(H4-CV)38,33,33
25 IF(H4-CV)32,31,31
26 IF(H4-CV)30,250,250
38 IF((H1+H2+H3+H4)*0.25-CV) 34,34,37
39 IF((H1+H2+H3+H4)*0.25-CV) 37,37,34
30 XA=D(H1,H4,X1,X4)
YA=D(H1,H4,Y1,Y4)
XB=D(H4,H3,X4,X3)
YB=D(H4,H3,Y4,Y3)
GOTO 40
31 XA=D(H2,H3,X2,X3)
YA=D(H2,H3,Y2,Y3)
XB=D(H4,H3,X4,X3)
YB=D(H4,H3,Y4,Y3)
GOTO 40
32 XA=D(H1,H4,X1,X4)
YA=D(H1,H4,Y1,Y4)
XB=D(H2,H3,X2,X3)
YB=D(H2,H3,Y2,Y3)
GOTO 40
33 XA=D(H1,H2,X1,X2)
YA=D(H1,H2,Y1,Y2)
XB=D(H2,H3,X2,X3)
YB=D(H2,H3,Y2,Y3)
IDUB=0
GOTO 40
34 IDUB=1
GOTO 31
35 XA=D(H1,H2,X1,X2)
YA=D(H1,H2,Y1,Y2)
XB=D(H4,H3,X4,X3)
YB=D(H4,H3,Y4,Y3)
GOTO 40
36 XA=D(H1,H2,X1,X2)
YA=D(H1,H2,Y1,Y2)
XB=D(H1,H4,X1,X4)
YB=D(H1,H4,Y1,Y4)
IDUB=0
GOTO 40
37 IDUB=-1
GOTO 30
40 CONTINUE
50 IF(XA.EQ.XB) GOTO 245
XC=MIN(XA,XB)
XD=MAX(XA,XB)
IF( XS.GT.XC.AND.XS.LE.XD) THEN
NP=NP+1
XP(NP)=XS
YP(NP)=YA+(YB-YA)/(XB-XA)*(XS-XA)
ENDIF
245 IF(IDUB)33,250,36
250 CV=CL2
300 CONTINUE
540 CONTINUE
IF( NP.GE.2) then
CALL Xsortxyp(xp,yp,NP)
do npl=1,np,2
CALL XPENUP(fxorig(XP(npl),YP(npl))
: ,fyorig(XP(npl),YP(npl)))
CALL XPENDN(fxorig(XP(NPL+1),YP(NPL+1))
: ,fyorig(XP(NPL+1),YP(NPL+1)))
enddo
endif
XS=XS+DX
IF(XS.lt.Xwkmax) GOTO 100
RETURN
END
SUBROUTINE getlnsgmnt(xwk,ywk,md,i,j,xs, 1
: ys1,ie1,je1,ie2,je2,ys2,ie3,je3,ie4,je4)
c
c This version does hatching of arbitary orientation
c between two contour values
c
implicit none
c
c Input through argument list
c
integer md
REAL Xwk(MD,*),Ywk(MD,*)
integer i,j
integer iedge1(4),iedge2(4),jedge1(4),jedge2(4)
real xs,ys1,ys2
integer ie1,je1,ie2,je2,ie3,je3,ie4,je4
integer nch
common /xoutch/ nch
c
c Miselaneous local variables
c
integer i1,j1,i2,j2,icount
real tem,ys(4)
icount = 0
i1=i
j1=j
i2=i
j2=j+1
IF( (xwk(i1,j1)-xs)*(xwk(i2,j2)-xs).le.0.0 .and.
: (xwk(i1,j1).ne.xwk(i2,j2)) ) then
tem=1.0/(xwk(i2,j2)-xwk(i1,j1))*(xs-xwk(i1,j1))
icount = icount+1
ys(icount)=ywk(i1,j1)+(ywk(i2,j2)-ywk(i1,j1))*tem
iedge1(icount)=i1
jedge1(icount)=j1
iedge2(icount)=i2
jedge2(icount)=j2
endif
i1=i
j1=j+1
i2=i+1
j2=j+1
IF( (xwk(i1,j1)-xs)*(xwk(i2,j2)-xs).le.0.0 .and.
: (xwk(i1,j1).ne.xwk(i2,j2)) ) then
tem=1.0/(xwk(i2,j2)-xwk(i1,j1))*(xs-xwk(i1,j1))
icount = icount+1
ys(icount)=ywk(i1,j1)+(ywk(i2,j2)-ywk(i1,j1))*tem
iedge1(icount)=i1
jedge1(icount)=j1
iedge2(icount)=i2
jedge2(icount)=j2
endif
i1=i+1
j1=j+1
i2=i+1
j2=j
IF( (xwk(i1,j1)-xs)*(xwk(i2,j2)-xs).le.0.0 .and.
: (xwk(i1,j1).ne.xwk(i2,j2)) ) then
tem=1.0/(xwk(i2,j2)-xwk(i1,j1))*(xs-xwk(i1,j1))
icount = icount+1
ys(icount)=ywk(i1,j1)+(ywk(i2,j2)-ywk(i1,j1))*tem
iedge1(icount)=i1
jedge1(icount)=j1
iedge2(icount)=i2
jedge2(icount)=j2
endif
i1=i
j1=j
i2=i+1
j2=j
IF( (xwk(i1,j1)-xs)*(xwk(i2,j2)-xs).le.0.0 .and.
: (xwk(i1,j1).ne.xwk(i2,j2)) ) then
tem=1.0/(xwk(i2,j2)-xwk(i1,j1))*(xs-xwk(i1,j1))
icount = icount+1
ys(icount)=ywk(i1,j1)+(ywk(i2,j2)-ywk(i1,j1))*tem
iedge1(icount)=i1
jedge1(icount)=j1
iedge2(icount)=i2
jedge2(icount)=j2
endif
IF( icount.eq.0 .or. icount.gt.2 ) then
write(nch,'(3(1x,a/))')
: 'No or more than two intercepting side(s) found.',
: 'Something is wrong.',
: 'Program stopped in subroutine gtlnsgmnt.'
Stop
ENDIF
if( ys(2).ge.ys(1)) then
ie1=iedge1(1)
je1=jedge1(1)
ie2=iedge2(1)
je2=jedge2(1)
ie3=iedge1(2)
je3=jedge1(2)
ie4=iedge2(2)
je4=jedge2(2)
ys1=ys(1)
ys2=ys(2)
else
ie1=iedge1(2)
je1=jedge1(2)
ie2=iedge2(2)
je2=jedge2(2)
ie3=iedge1(1)
je3=jedge1(1)
ie4=iedge2(1)
je4=jedge2(1)
ys1=ys(2)
ys2=ys(1)
endif
RETURN
END
SUBROUTINE xsortxyp(xp,yp,n) 1
c sort xp and yp in ascending order in yp
real xp(n),yp(n)
do j=2,n
a=yp(j)
b=xp(j)
do i=j-1,1,-1
if(yp(i).le.a) goto 10
yp(i+1)=yp(i)
xp(i+1)=xp(i)
enddo
i=0
10 continue
yp(i+1)=a
xp(i+1)=b
enddo
return
end
SUBROUTINE XVECTU(U,V,MD,M,ISTEP,N,JSTEP,XLENG,UUNIT) 2,3
C
C Assess ranges if U,V values, and set length XLENG at which the unit
C vector UUNIT is plotted in x-direction.
C The length of vector in y-direction is scaled according to mapping.
C (Notice the non-isotropicity.)
C XLENG was set as XSCALE/(M-1)*ISTEP where XSCALE is the horizontal
C scale of mapped area.
C UUNIT was set that the longest vector falls between 0.75*XLENG
C and 1.5*XLENG in length.
c
c Fixed a problem with the first guess of umax,umin,vmax,vmin
c when the first value is missing.
c Jan. 24, 1995.
c
REAL U(MD,N),V(MD,N)
COMMON /XART36/ KARTYP,KVMODE,VSC
COMMON /ZCHOLE/ NHOLE,SPECIA,nvtrbadv
character*(*) sumax,sumin,svmax,svmin
CHARACTER CH1*80
SAVE UMAX, UMIN, VMAX, VMIN
common /xoutch/ nch
integer mxset
mxset = 0
DO 5 J=1,N,JSTEP
DO 5 I=1,M,ISTEP
IF(nvtrbadv.eq.1.and.(U(I,J).eq.SPECIA.or.V(I,J).eq.SPECIA))
: goto 5
IF(mxset.eq.0) THEN
UMAX=U(i,j)
VMAX=V(i,j)
UMIN=UMAX
VMIN=VMAX
mxset = 1
ELSE
UMAX=MAX(UMAX,U(I,J))
UMIN=MIN(UMIN,U(I,J))
VMAX=MAX(VMAX,V(I,J))
VMIN=MIN(VMIN,V(I,J))
ENDIF
5 CONTINUE
WRITE(nch,'('' Umax='',G10.4E2,'' Umin='',G10.4E2,
: '' Vmax='',G10.4E2,'' Vmin='',G10.4E2)')UMAX,UMIN,VMAX,VMIN
IF (UMAX.EQ.UMIN.AND.VMAX.EQ.VMIN ) GO TO 500
UNIT=UUNIT
IF( KVMODE.EQ.2) GOTO 105
25 IF( MAX( ABS(UMAX), ABS(UMIN),abs(vmax),abs(vmin))
: .LT. UNIT*0.75 ) THEN
UNIT=UNIT/2
WRITE(nch,100) UNIT
100 FORMAT(' Max vector < 0.75*UNIT , UNIT is halved. UNIT='
: ,3F9.4)
GO TO 25
ENDIF
30 IF( MAX( ABS(UMAX),ABS(UMIN),abs(vmax),abs(vmin))
: .GT.UNIT*1.5 ) THEN
UNIT=UNIT*2
WRITE(nch,200) UNIT
200 FORMAT(' Max vector > 1.5 *UNIT ,UNIT is doubled. UNIT='
: ,3F9.4)
GO TO 30
ENDIF
CONTINUE
105 UUNIT=UNIT
500 CALL XQMAP(XL,XR,YB,YT)
XLENG=(XR-XL)/(M-1)* ISTEP*VSC
RETURN
ENTRY XVSCAL( VSC0)
VSC=VSC0
RETURN
ENTRY XVMODE(KVM)
KVMODE=KVM
RETURN
ENTRY XVLMT( CSIZE)
C Call XVLIMT with UMAX,UMIN,VMAX,VMIN saved in XVECTU.
C CSIZE set the size of characters. Default is about 0.012.
C Default value is assumed if CSIZE is 0.0.
CALL XVLIMT(UMAX,UMIN,VMAX,VMIN, CSIZE)
RETURN
ENTRY XVLIMIT(x,y,sUMAX,sUMIN,sVMAX,sVMIN)
WRITE(CH1,'(a,a,G9.3E2,3(a,a,a,G9.3E2))')
: sumax,'=',UMAX,',',sumin,'=',UMIN,',',
: svmax,'=',VMAX,',',svmin,'=',VMIN
lch = 80
CALL xstrmin (CH1,LCH)
CALL XCHARC(x,y,ch1(1:lch))
RETURN
END
SUBROUTINE XVECTR(U,V,X,Y,MD,M,ISTEP,N,JSTEP,XLENG,UUNIT) 2,2
C Plot vector feilds ( U,V) . Unit X-component UUNIT is plotted with
C length XLENG in mapped maths coordinate. Length of vector in
C Y-direction is scaled according to the mapping.
REAL U(MD,N),V(MD,N),X(MD,N),Y(MD,N)
COMMON /ZCHOLE/ NHOLE,SPECIA,nvtrbadv
common /xwndw1/ xw1,xw2,yw1,yw2, iwndon
DO 15 J=1,N,JSTEP
DO 15 I=1,M,ISTEP
IF(iwndon.eq.0 .or. ((x(i,j)-xw1)*(x(i,j)-xw2).le.0.0 .and.
: (y(i,j)-yw1)*(y(i,j)-yw2).le.0.0) ) THEN
IF(nvtrbadv.eq.0) THEN
CALL XARROW( U(I,J),V(I,J),X(I,J),Y(I,J),XLENG,UUNIT)
ELSE
IF(u(i,j).ne.SPECIA.and.v(i,j).ne.SPECIA )
: CALL XARROW( U(I,J),V(I,J),X(I,J),Y(I,J),XLENG,UUNIT)
ENDIF
ENDIF
15 CONTINUE
RETURN
END
SUBROUTINE XBARBS(U,V,X,Y,MD,M,ISTEP,N,JSTEP,wunits,xleng,barbopt) 1,2
C Plot wind barbs for vector feilds ( U,V).
REAL U(MD,N),V(MD,N),X(MD,N),Y(MD,N)
COMMON /ZCHOLE/ NHOLE,SPECIA,nvtrbadv
common /xwndw1/ xw1,xw2,yw1,yw2, iwndon
integer wunits,barbopt
DO 15 J=1,N,JSTEP
DO 15 I=1,M,ISTEP
IF(iwndon.eq.0 .or. ((x(i,j)-xw1)*(x(i,j)-xw2).le.0.0 .and.
: (y(i,j)-yw1)*(y(i,j)-yw2).le.0.0) ) THEN
IF(nvtrbadv.eq.0) THEN
CALL XBARB(U(I,J),V(I,J),X(I,J),Y(I,J),wunits,XLENG,
: barbopt)
ELSE
IF(u(i,j).ne.SPECIA.and.v(i,j).ne.SPECIA )
: CALL XBARB(U(I,J),V(I,J),X(I,J),Y(I,J),wunits,XLENG,
: barbopt)
ENDIF
ENDIF
15 CONTINUE
RETURN
END
SUBROUTINE XBARB(U,V,X0,Y0,wunits,XLENG,barbopt) 3,11
c Plot a wind barb at (x0, y0) for wind vector (u,v).
C Its length is specified in terms of the length in
c the x-coordinate direction.
IMPLICIT NONE
real u,v,x0,y0
integer wunits ! Wind units. =1: m/s, =2: knots or miles/per hour
real xleng
integer barbopt ! Option for plotting the direction of wind barb
! =1, wind barb direction conforms to the streamlines if plotted,
! i.e., it depends on the grid aspect ration.
! =2, wind bard direction represents the absolute direction,
! regardless the grid aspect ratio.
real pi, angle1, sina1, cosa1
c PARAMETER(PI=3.14159,ANGLE1=(120./180+1)*PI)
PARAMETER(PI=3.14159,ANGLE1=(105./180+1)*PI)
real speed, sinta,costa,arrow
integer nhalf, nfull, nfifty,i
real dx,dy,px0,py0,px1,py1,dpx,dpy,px1a,py1a
real XPNTSD,XPLENG,DPXY,dx1,dy1
real xfactr,yfactr
COMMON /XFTR06/ XFACTR,YFACTR
c sina1=-0.866027355 ! sin( angle1 )
c cosa1= 0.499996603 ! cos( ANGLE1 )
c sina1=sin( angle1 )
c cosa1=cos( angle1 )
sina1= -0.965925826
cosa1= 0.258819045
speed = sqrt( u*u + v*v)
IF( speed .lt. 1.0e-10 ) RETURN
If (wunits.EQ.1) Then
nhalf = Nint (speed/2.5) !for m/s
ElseIf (wunits.EQ.2) Then
nhalf = Nint (speed/5.0) !for mph/knots
End If
nfifty = nhalf / 10
nhalf = nhalf - nfifty * 10
nfull = nhalf / 2
nhalf = nhalf - nfull * 2
XPLENG =XPNTSD( 0.0,0.0,XLENG,0.0)
PX0=X0
PY0=Y0
CALL XTRANS(PX0,PY0)
IF( barbopt.eq.1) then
DX=u/speed*xleng
DY=v/speed*xleng
PX1=X0-DX
PY1=Y0-DY
CALL XTRANS(PX1,PY1)
DPX=PX1-PX0
DPY=PY1-PY0
else
DPX=-u*XPLENG/speed
DPY=-v*XPLENG/speed
px1=px0+dpx
py1=py0+dpy
endif
DPXY=SQRT( DPX*DPX+DPY*DPY)
IF(DPXY.le.1.0E-30) RETURN
SINTA=DPY/DPXY
COSTA=DPX/DPXY
ARROW=0.50* XPLENG
DX1=ARROW*(COSTA*COSA1-SINTA*SINA1)
DY1=ARROW*(SINTA*COSA1+COSTA*SINA1)
CALL XTPNUP(PX0,PY0)
CALL XTPNDN(PX1,PY1)
px1a = px1
py1a = py1
DO i=1,nfifty ! Plot flags
CALL XTPNUP(PX1a , PY1a )
CALL XTPNDN(PX1a+DX1, PY1a+DY1)
px1a = px1a+0.30*(px0-px1)
py1a = py1a+0.30*(py0-py1)
CALL XTPNDN(PX1a,PY1a)
ENDDO
DO i=1,nfull ! Plot full-length barbs
CALL XTPNUP(PX1a , PY1a )
CALL XTPNDN(PX1a+DX1, PY1a+DY1)
px1a = px1a+0.15*(px0-px1)
py1a = py1a+0.15*(py0-py1)
ENDDO
if( nhalf.ge.1 .and. (nfifty.eq.0.and.nfull.eq.0)) then
px1a = px1a+0.20*(px0-px1)
py1a = py1a+0.20*(py0-py1)
endif
DO i=1,nhalf ! Plot half-length barbs
CALL XTPNUP(PX1a , PY1a )
CALL XTPNDN(PX1a+DX1*0.5, PY1a+DY1*0.5)
px1a = px1a+0.15*(px0-px1)
py1a = py1a+0.15*(py0-py1)
ENDDO
RETURN
END
SUBROUTINE XCONTS(Z,X,Y,MD,ND, ZINC),2
REAL Z(MD,ND),X(MD,ND),Y(MD,ND),CL(150)
INTEGER IWRK(10000)
CL(1)=0.0
CL(2)=ZINC
MODE=1
M =MD
N =ND
IST=1
JST=1
CALL XCONTA(Z(IST,JST),X(IST,JST),Y(IST,JST)
: ,IWRK,MD,M,N,CL,NCL,MODE)
IF( NCL.EQ.0) THEN
ZMAX= CL(1)
ZINC1= ZMAX
ELSE
ZMAX=CL(NCL)
ZINC1=CL(2)-CL(1)
ENDIF
CALL XCLIMT(ZMAX, CL(1),ZINC1, 0.0)
RETURN
END
SUBROUTINE XVECTS(U,V,X,Y,MD,ISTEP,ND,JSTEP,XLENG1,UUNIT1),3
REAL U(MD,ND),V(MD,ND),X(MD,ND),Y(MD,ND)
M =MD
N =ND
IST=1
JST=1
XLENG=XLENG1
UUNIT=UUNIT1
CALL XVECTU(U(IST,JST),V(IST,JST),MD,M,ISTEP,N,JSTEP,XLENG,UUNIT)
CALL XVECTR(U(IST,JST),V(IST,JST),X(IST,JST),Y(IST,JST),
: MD,M,ISTEP,N,JSTEP,XLENG,UUNIT)
CALL XQMAP(XL,XR,YB,YT)
X0=XL+(XR-XL)*0.75
Y0=YT+(YT-YB)*0.03
KEY=0
AM=1.0
IF( (M-1)/ISTEP.GT.30) AM=2.0
CALL XVECTK(X0,Y0,XLENG*AM,UUNIT*AM, KEY)
CALL XVLMT(0.0)
RETURN
END
SUBROUTINE XCAPTN(TITLES,NUM,CH, LC ),6
C PLOT CAPTIONS ALONG THE BORDER
common /xoutch/ nch
CHARACTER TITLES(NUM)*50, CH*100
CALL XQMAP(XL,XR,YB,YT)
CALL XQRANG( XRG, YRG )
CALL XQCHOR( ANG0 )
CALL XQCHMG( SIZ0 )
SIZ=0.05*MIN( XRG, YRG)
HX=SIZ*(XR-XL)/XRG
HY=SIZ*(YT-YB)/YRG
CALL XCHMAG( SIZ )
IF( NUM.GE.1) THEN
CALL XQOBAG( XANG, YANG )
CALL XCHORI( 90.0 +YANG-XANG )
CALL XCHARC( XL- 2.5*HX, 0.5*(YT+YB), TITLES(1)(1:10) )
CALL XCHORI(0.0)
CALL XCHARC( 0.5*(XR+XL), YB-2*HY , TITLES(1)(11:20))
ENDIF
IF( NUM.GE.2) THEN
CALL XCHARL(XL,YB-4*HY,TITLES(2)(1:20)//' '//ch(1:lc))
ENDIF
YCP=YB-4.5*HY
DO 10 K=3,NUM
YCP=YCP-HY
CALL XCHARL(XL,YCP,TITLES(K))
10 CONTINUE
CALL XCHORI( ANG0 )
CALL XCHMAG( SIZ0 )
WRITE(NCH,*) TITLES(2)(1:20) ,' is to be plotted..'
RETURN
END
SUBROUTINE XCLIMT(FMAX,FMIN,FINC ,CTRSIZ) 2,4
CHARACTER CH*150
CALL XQMAP(XL,XR,YB,YT)
CALL XQRANG( XRG, YRG )
CALL XQCHMG( SIZ0 )
IF(ctrsiz.eq.0) THEN
SIZ=0.03*MIN( XRG, YRG)
CALL XCHMAG(SIZ)
ELSE
CALL XCHSIZ(CTRSIZ)
ENDIF
WRITE(CH,'(''Min='',G9.3E2,'' Max='',G9.3E2,
: '' Contour interval='',G9.3E2)')FMIN,FMAX,FINC
lch = 54
CALL xstrmin ( CH, LCH)
CALL XCHARC( 0.5*(XL+XR), YT+0.02*(YT-YB),CH(1:lch) )
CALL XCHMAG( SIZ0)
RETURN
END
SUBROUTINE XVLIMT(UMAX,UMIN,VMAX,VMIN , ctrsiz) 1,6
CHARACTER CH1*80, ch2*80
CALL XQMAP(XL,XR,YB,YT)
CALL XQCHMG( SIZ0 )
CALL XQRANG( XRG, YRG )
CALL XQCHMG( SIZ0 )
IF( ctrsiz .eq. 0.0 ) THEN
SIZ=0.03*MIN( XRG, YRG)
CALL XCHMAG(SIZ)
ELSE
CALL XCHSIZ(CTRSIZ)
ENDIF
WRITE(CH1,'('' Umax='',G9.3E2,'' Umin='',G9.3E2)')UMAX,UMIN
WRITE(CH2,'('' Wmax='',G9.3E2,'' Wmin='',G9.3E2)')VMAX,VMIN
lch = 30
CALL xstrmin ( CH1, LCH)
CALL XCHARL(XL,YT+0.02*(YT-YB),CH1(1:lch))
lch = 30
CALL xstrmin ( CH2, LCH)
CALL XCHARL(XL,YT+0.06*(YT-YB),CH2(1:lch) )
CALL XCHMAG( SIZ0)
RETURN
END
SUBROUTINE XVECTK(x0,y0, xleng, uunit, key) 2,20
c
c#######################################################################
c PURPOSE:
c Plot unit vectors starting at (X0,Y0)
C KEY=-1, 0, 1, 2, for none,in both X and Y-direction,X only, Y only
c INPUT: x0 y0 xleng uunit key c
c#######################################################################
c
implicit none
c
real x0,y0
real xleng,uunit
integer key
c
c#######################################################################
c
c Misc. local Variables
c
c#######################################################################
c
real pi,angle1,angle2
parameter(pi=3.14159,angle1=(10./180+1)*pi,angle2=(-10./180+1)*pi)
real sina1,cosa1,sina2,cosa2
parameter(sina1=-.17365,cosa1=-.98481,sina2= -sina1,cosa2=cosa1)
real xrg,xl,xr,xscale
real yrg,yb,yt,yscale,yf
real dx,dx1,dx2
real dy,dy1,dy2
real px0,px1,px2
real py0,py1,py2
real dph,dpv
real costa,sinta
real vunit
real arrow
real asym
real xang
real yang
integer lch
character ch*20
c
CALL xqrang(xrg,yrg)
CALL xqmap(xl,xr,yb,yt)
xscale=xr-xl
yscale=yt-yb
yf=0.4+( min(xrg,yrg) -0.4)*0.5
vunit=uunit
dx=xleng
dy=xleng
px0=x0
py0=y0
px1=x0+dx
py1=y0
px2=x0
py2=y0+dy
CALL xtrans(px0,py0)
CALL xtrans(px1,py1)
CALL xtrans(px2,py2)
dph=sqrt( (px1-px0)**2+(py1-py0)**2 )
dpv=sqrt( (px2-px0)**2+(py2-py0)**2 )
5 IF( dpv.gt.(1.5*dph) ) THEN
dpv=dpv*0.5
dy=dy*0.5
vunit=vunit*0.5
GO TO 5
ENDIF
6 IF( dpv.lt.(0.75*dph) ) THEN
dpv=dpv*2
dy=dy*2
vunit=vunit*2
GO TO 6
ENDIF
px2=x0
py2=y0+dy
CALL xtrans(px2,py2)
IF( key.eq.0.or.key.eq.1) THEN
arrow=0.30*dph
costa=(px1-px0)/dph
sinta=(py1-py0)/dph
dx1=arrow*(costa*cosa1-sinta*sina1)
dy1=arrow*(sinta*cosa1+costa*sina1)
dx2=arrow*(costa*cosa2-sinta*sina2)
dy2=arrow*(sinta*cosa2+costa*sina2)
CALL xtpnup(px0,py0)
CALL xtpndn(px1 , py1)
CALL xtpndn(px1+dx1, py1+dy1)
CALL xtpnup(px1 , py1 )
CALL xtpndn(px1+dx2, py1+dy2)
write(ch,'(f6.1)') uunit
lch=6
CALL xchlj (ch,lch)
call XSTRLNTH(ch,lch)
CALL xcharl(x0+dx +0.01*xscale,y0,ch(1:lch) )
ENDIF
c
IF( key.eq.0.or.key.eq.2 ) THEN
arrow=0.30*dph
costa=(px2-px0)/dpv
sinta=(py2-py0)/dpv
dx1=arrow*(costa*cosa1-sinta*sina1)
dy1=arrow*(sinta*cosa1+costa*sina1)
dx2=arrow*(costa*cosa2-sinta*sina2)
dy2=arrow*(sinta*cosa2+costa*sina2)
CALL xtpnup(px0,py0)
CALL xtpndn(px2 , py2)
CALL xtpndn(px2+dx1, py2+dy1)
CALL xtpnup(px2 , py2 )
CALL xtpndn(px2+dx2, py2+dy2)
CALL xqobag( xang, yang )
CALL xqchor( asym )
CALL xchori(90.0+ yang- xang)
write(ch,'(f6.1)') vunit
lch=6
CALL xchlj (ch,lch)
call XSTRLNTH(ch,lch)
CALL xcharl(x0-.01*xscale ,y0 ,ch(1:lch) )
CALL xchori( asym )
ENDIF
RETURN
END
SUBROUTINE XGRAPH( X,Y,N ) 20,4
C Plot single valued curve y=y(x), where for each x,there is a unique y.
C METHOD-- parameter controling curve plotting pattern
C =0 ,points are joined up by straight lines
C =1 or 2, two points are joined up using seamed quadratics.
C when =1,slope at data points are calculated using monotonic method
C when =2, using Bessel methed.
REAL X(*), Y(*)
IF( N.LE.1) RETURN
IF( N.EQ.2) THEN
CALL XLPNUP( X(1),Y(1))
CALL XLPNDN( X(2),Y(2))
RETURN
ENDIF
CALL XQCVMD( MTD )
IF( MTD.EQ.0) THEN
CALL XLPNUP(X(1),Y(1))
ELSE
CALL XGRPUP(X(1),Y(1))
ENDIF
NEND=0
DO 10 I=2,N
IF( MTD.EQ.0) THEN
CALL XLPNDN(X(I),Y(I))
ELSE
IF( I.EQ.N) NEND=1
CALL XGRPDN(X(I),Y(I),NEND)
ENDIF
10 CONTINUE
CALL XLPNUP( X(N),Y(N) )
RETURN
END
SUBROUTINE XGRPUP(X,Y) 1,4
C Position pen at the starting point of a sigle valued curve y=y(x).
COMMON /SVCURV/ X1,Y1,X2,Y2,X3,Y3,NPTS, SL1,SL2
COMMON /XCDV23/ NSUBDV
COMMON /XCMD24/ MTD
common /xoutch/ nch
X2=X
Y2=Y
NPTS=1
CALL XLPNUP(X2,Y2)
RETURN
ENTRY XGRPDN(X,Y,NEND)
C Join (x,y(x)) with a smooth seamed quadratic curve, where y=y(x) is a
C single valued function.
KEND=NEND
IF( MTD.EQ.0.OR .NSUBDV.LE.1) THEN
CALL XLPNDN(X,Y)
RETURN
ENDIF
NEND1=NEND
IF( NPTS.LT.3)GOTO 8
IF( X.EQ.X2)THEN
IF(Y.NE.Y2)GOTO 999
IF( NEND1.EQ.1) GOTO 22
GOTO 5
ENDIF
NPTS=NPTS+1
X1=X2
Y1=Y2
X2=X3
Y2=Y3
X3=X
Y3=Y
GOTO 13
8 IF(NPTS.EQ.2) GOTO 10
IF( X.EQ.X2) THEN
IF(Y.NE.Y2)GOTO 999
GOTO 5
ENDIF
NPTS=NPTS+1
X3=X
Y3=Y
GOTO 5
10 IF( X.EQ.X3) THEN
IF(Y.NE.Y3)GOTO 999
GOTO 5
ENDIF
NPTS=NPTS+1
X4=X
Y4=Y
CALL XQUADR(X2,Y2,X3,Y3,X4,Y4,A,B,C)
X1=X2-(X4-X3)
Y1=C+(B+A*X1)*X1
13 IF( (X3-X2)*(X2-X1).LT.0.0) GOTO 997
KOUNT=1
IF( NPTS.EQ.3) KOUNT=2
21 DO 20 J=1,KOUNT
D21=(Y2-Y1)/(X2-X1)
D32=(Y3-Y2)/(X3-X2)
IF(MTD.EQ.2) THEN
DD31=(D32-D21)/(X3-X1)
SL2=( D21+D32-DD31*(X1-2*X2+X3))*0.5
GOTO 16
ELSEIF( MTD.EQ.1) THEN
IF( D21*D32.GT. 0.0) THEN
AA=(1.0+(X3-X2)/(X3-X1))/3.0
SLINV=AA/D21+(1-AA)/D32
SL2=1.0/SLINV
ELSE
SL2=0.0
ENDIF
GOTO 16
ENDIF
16 IF( KOUNT.EQ.2.AND.J.EQ.1) THEN
SL1=SL2
X1=X2
Y1=Y2
X2=X3
Y2=Y3
X3=X4
Y3=Y4
ENDIF
20 CONTINUE
CALL XSEAMQ( X1,Y1,SL1,X2,Y2,SL2,A1,A2,B,C)
XSUB=X1
XINC=(X2-X1)/NSUBDV
XC=(X2+X1)*0.5
KEND=0
DO 15 ISUB=2,NSUBDV
XSUB=XSUB+XINC
A12=A1
IF( ISUB.GT.NSUBDV/2 ) A12=A2
YSUB=C +(B +A12*(XSUB-XC))*(XSUB-XC)
15 CALL XLPNDN( XSUB,YSUB)
IF( NEND.EQ.1.AND.NEND1.EQ.0) KEND=1
CALL XLPNDN( X2,Y2)
SL1=SL2
22 IF(NEND1.EQ.0) THEN
RETURN
ELSE
CALL XQUADR(X1,Y1,X2,Y2,X3,Y3,A,B,C)
X4=X3-(X1-X2)
Y4=C+(B+A*X4)*X4
X1=X2
Y1=Y2
X2=X3
Y2=Y3
X3=X4
Y3=Y4
NEND1=0
KOUNT=1
GOTO 21
ENDIF
5 IF( NEND1.NE.1) RETURN
IF( NPTS.EQ.2) THEN
KEND=1
CALL XLPNDN( X2,Y2)
ELSE
RETURN
ENDIF
RETURN
999 WRITE(NCH,*)
: ' Input data are controdicting! Curve plotting aborted.'
RETURN
997 WRITE(NCH,*)' Input data not in correct order! Plotting aborted.'
RETURN
END
SUBROUTINE XCURVE( X,Y,N, KLOSE) 20,4
C Plot multiple-valued curve X(t), Y(t).
C METHOD-- parameter controling curve plotting pattern.
C =0 ,points are joined up by straight lines
C =1 or 2, two points are joined up using parametric seamed quadratics.
C when =1,slope at data points are calculated using monotonic method
C when =2, using Bessel methed.
REAL X(*), Y(*)
IF( N.LE.1) RETURN
IF( N.EQ.2) THEN
CALL XLPNUP( X(1),Y(1))
CALL XLPNDN( X(2),Y(2))
RETURN
ENDIF
CALL XQCVMD(MTD)
IF( MTD.EQ.0) THEN
CALL XLPNUP(X(1),Y(1))
ELSE
CALL XCURUP(X(1),Y(1))
ENDIF
NEND=0
DO 10 I=2,N
IF( MTD.EQ.0) THEN
CALL XLPNDN(X(I),Y(I))
ELSE
IF( I.EQ.N) NEND=1
CALL XCURDN(X(I),Y(I), KLOSE, NEND)
ENDIF
10 CONTINUE
IF( MTD.EQ.0.AND.KLOSE.EQ.1.AND.(X(1).NE.X(N).OR.Y(1).NE.Y(N)))
: CALL XLPNDN(X(1), Y(1))
CALL XLPNUP( X(1),Y(1) )
RETURN
END
SUBROUTINE XCURUP(X,Y) 20,8
COMMON /MVCURV/ X1,Y1,X2,Y2,X3,Y3,T2,NPTS ,SL1X,SL1Y,SL2X,SL2Y
SAVE X01,Y01,X02,Y02,X03,Y03,IEND
COMMON /XCDV23/ NSUBDV
COMMON /XCMD24/ MTD
X2=X
Y2=Y
NPTS=1
IEND=0
CALL XLPNUP(X2,Y2)
RETURN
ENTRY XCURDN(X,Y,KCLOSE,NEND)
IF( MTD.EQ.0.OR .NSUBDV.LE.1) THEN
CALL XLPNDN(X,Y )
RETURN
ENDIF
NEND1=NEND
KLOSE=KCLOSE
IF( NPTS.LT.3)GOTO 8
IF( X.EQ.X2.AND.Y.EQ.Y2) THEN
IF( NEND1.EQ.1) GOTO 22
GOTO 5
ENDIF
NPTS=NPTS+1
T2=T2+1.
X1=X2
Y1=Y2
X2=X3
Y2=Y3
X3=X
Y3=Y
GOTO 13
8 IF(NPTS.EQ.2) GOTO 10
IF( X.EQ.X2.AND.Y.EQ.Y2) GOTO 5
NPTS=NPTS+1
X3=X
Y3=Y
IF( KLOSE.EQ.1) CALL XLPNUP(X3,Y3)
GOTO 5
10 IF( X.EQ.X3.AND.Y.EQ.Y3) GOTO 5
NPTS=NPTS+1
X4=X
Y4=Y
T2=2.0
IF( KLOSE.EQ.1) THEN
X1=X2
Y1=Y2
X2=X3
Y2=Y3
X3=X4
Y3=Y4
X01=X1
X02=X2
X03=X3
Y01=Y1
Y02=Y2
Y03=Y3
KOUNT=1
GOTO 21
ENDIF
T1=0.0
CALL XQUADR(T2-1,X2,T2,X3,T2+1,X4,A,B,C)
X1=C
CALL XQUADR(T2-1,Y2,T2,Y3,T2+1,Y4,A,B,C)
Y1=C
13 KOUNT=1
IF( NPTS.EQ.3.AND.KLOSE.NE.1) KOUNT=2
21 DO 20 J=1,KOUNT
IF(MTD.EQ.2) THEN
SL2X=(X3-X1)*0.5
SL2Y=(Y3-Y1)*0.5
GOTO 16
ELSEIF( MTD.EQ.1) THEN
D21X= X2-X1
D32X= X3-X2
D21Y= Y2-Y1
D32Y= Y3-Y2
IF( D21X*D32X.GT. 0.0) THEN
SLINV=0.5/D21X+0.5/D32X
IF(SLINV.EQ.0.0) THEN
SL2X=0.0
ELSE
SL2X=1.0/SLINV
ENDIF
ELSE
SL2X=0.0
ENDIF
IF( D21Y*D32Y.GT. 0.0) THEN
SLINV=0.5/D21Y+0.5/D32Y
IF(SLINV.EQ.0.0) THEN
SL2Y=0.0
ELSE
SL2Y=1.0/SLINV
ENDIF
ELSE
SL2Y=0.0
ENDIF
GOTO 16
ENDIF
16 CONTINUE
IF(KLOSE.EQ.1.AND.NPTS.LE.3) THEN
SL1X=SL2X
SL1Y=SL2Y
RETURN
ENDIF
IF( KOUNT.EQ.2.AND.J.EQ.1) THEN
SL1X=SL2X
SL1Y=SL2Y
X1=X2
Y1=Y2
X2=X3
Y2=Y3
X3=X4
Y3=Y4
T2=2.0
ENDIF
20 CONTINUE
CALL XSEAMQ( T2-1.0,X1,SL1X,T2,X2,SL2X,A1X,A2X,BX,CX)
T=T2-1
TC=T2-0.5
XX=CX+(BX+A1X*(T-TC))*(T-TC)
CALL XSEAMQ( T2-1.0,Y1,SL1Y,T2,Y2,SL2Y,A1Y,A2Y,BY,CY)
TINC=1.0/NSUBDV
KEND=0
DO 15 ISUB=2,NSUBDV
T=(ISUB-1)*TINC-0.5
A12X=A1X
A12Y=A1Y
IF( ISUB.GT.NSUBDV/2 ) THEN
A12Y=A2Y
A12X=A2X
ENDIF
XSUB=CX+(BX+A12X*T)*T
YSUB=CY+(BY+A12Y*T)*T
15 CALL XLPNDN( XSUB,YSUB)
IF(KLOSE.EQ.1) THEN
IF( IEND.EQ.3) KEND=1
ELSE
IF( NEND .EQ.1.AND.NEND1.EQ.0 ) KEND=1
ENDIF
CALL XLPNDN( X2,Y2)
SL1X=SL2X
SL1Y=SL2Y
22 IF(NEND1.EQ.0) THEN
RETURN
ELSEIF(KLOSE.EQ.1) THEN
IF(IEND.GE.3) RETURN
X1=X2
X2=X3
Y1=Y2
Y2=Y3
27 IEND=IEND+1
IF( IEND.EQ.1) THEN
IF(X3.EQ.X01.AND.Y3.EQ.Y01) GOTO 27
X3=X01
Y3=Y01
ELSEIF( IEND.EQ.2) THEN
X3=X02
Y3=Y02
ELSEIF( IEND.EQ.3) THEN
X3=X03
Y3=Y03
ENDIF
NPTS=NPTS+1
T2=T2+1
KOUNT=1
GOTO 21
ELSE
T4=NPTS+1.0
CALL XQUADR(T2-1,X1,T2,X2,T2+1,X3,A,B,C)
X4=C+(B+A*T4)*T4
CALL XQUADR(T2-1,Y1,T2,Y2,T2+1,Y3,A,B,C)
Y4=C+(B+A*T4)*T4
X1=X2
Y1=Y2
X2=X3
Y2=Y3
X3=X4
Y3=Y4
T2=T2+1
NEND1=0
KOUNT=1
GOTO 21
ENDIF
5 IF( NEND1.EQ.1.AND. NPTS.EQ.2) THEN
KEND=1
CALL XLPNDN( X3,Y3)
ENDIF
RETURN
END
SUBROUTINE XCURDV(NDIV )
COMMON /XCDV23/ NSUBDV
NSUBDV= NDIV
RETURN
END
SUBROUTINE XCVMTD( METHOD )
C Set the method for curve plotting when using XGRPUP,XGRPDN,XGRAPH,
C XCURUP,XCURUP,XCURDN. By default METHOD=0
COMMON /XCMD24/ MTD
MTD= METHOD
RETURN
ENTRY XQCVMD( MTD1 )
MTD1=MTD
RETURN
END
SUBROUTINE XQUADR(X1,Y1,X2,Y2,X3,Y3,A,B,C) 6
C Return the coefficients A,B,C of a quadratic polynomial fitting
C points (X1,Y1),(X2,Y2),(X3,Y3)
D21=(Y2-Y1)/(X2-X1)
D32=(Y3-Y2)/(X3-X2)
A=(D32-D21)/(X3-X1)
B=(D21*(X3+X2)-D32*(X1+X2))/(X3-X1)
C=(X3*Y1-X1*Y3+X1*X3*(D32-D21))/(X3-X1)
RETURN
END
SUBROUTINE XSEAMQ(X1,Y1,SL1,X2,Y2,SL2,A1,A2,B,C) 3
C Fit points (X1,Y1) and(X2,Y2) with slopes SL1,SL2 at the corresponding
C seamed quadratics so that y=c+(b+a*(x-xc))*(x-xc) where xc=(x1+x2)/2
C and a=a1 for (x2-x1)*(x-xc)<0.0 ,a=a2 for (x2-x1)*(x-xc)>=0.0
H=(X2-X1)*0.5
HH=H*H
TL=Y1+0.5*H*SL1
TR=Y2-0.5*H*SL2
C =0.5*(TL+TR)
B =(TR-TL)/H
A1=(Y1-1.5*TL+0.5*TR)/HH
A2=(Y2-1.5*TR+0.5*TL)/HH
RETURN
END
C* COLOUR FILLING ROUTINES
SUBROUTINE ZCONTB(ZG,Z,MD,MG,JG,C1,C2),1
C Colour filling of triangular blocks
DIMENSION ZG(MD,*),Z(MD,*),X(5),Y(5)
COMPLEX Z,B1,B2,ZA,ZB,ZC,ZD,Z1,Z2,Z3,Z4,Z5,D
D(P1,P2,B1,B2 )=B1+(CV-P1)*(B2-B1)/(P2-P1)
CV1=MIN(C1,C2)
CV2=MAX(C1,C2)
DO 101 I=1,MG-1
DO 102 J=1,JG-1
H5=0.25*(ZG(I,J)+ZG(I,J+1)+ZG(I+1,J+1)+ZG(I+1,J))
Z5=0.25*( Z(I,J)+ Z(I,J+1)+ Z(I+1,J+1)+ Z(I+1,J))
DO 103 M=1,4
H1=ZG(I+MOD(M ,4)/2,J+MOD(M-1,4)/2)
Z1=Z (I+MOD(M ,4)/2,J+MOD(M-1,4)/2)
H2=ZG(I+MOD(M+1,4)/2,J+MOD(M ,4)/2)
Z2=Z (I+MOD(M+1,4)/2,J+MOD(M ,4)/2)
H3=H5
Z3=Z5
IF(H2.LT.H1) THEN
H4=H2
H2=H1
H1=H4
Z4=Z2
Z2=Z1
Z1=Z4
ENDIF
IF(H3.LT.H1) THEN
H4=H3
H3=H1
H1=H4
Z4=Z3
Z3=Z1
Z1=Z4
ENDIF
IF(H3.LT.H2) THEN
H4=H3
H3=H2
H2=H4
Z4=Z3
Z3=Z2
Z2=Z4
ENDIF
IWS=0
DO 104 K=1,2
CV=CV1*(2-K)+CV2*(K-1)
IF(H1-CV) 1, 3, 3
1 IF(H2-CV) 2,10,10
2 IF(H3-CV)30,20,20
3 IWA=0
GOTO 104
10 IWA=1
ZA=D(H3,H1,Z3,Z1)
ZB=D(H1,H2,Z1,Z2)
IF(K.EQ.1) GOTO 60
IF(IWS.EQ.0) THEN
X(1)= REAL(Z1)
X(2)= REAL(ZA)
X(3)= REAL(ZB)
Y(1)=AIMAG(Z1)
Y(2)=AIMAG(ZA)
Y(3)=AIMAG(ZB)
NP=3
ELSEIF(IWS.EQ.1) THEN
X(1)= REAL(ZA)
X(2)= REAL(ZB)
X(3)= REAL(ZD)
X(4)= REAL(ZC)
Y(1)=AIMAG(ZA)
Y(2)=AIMAG(ZB)
Y(3)=AIMAG(ZD)
Y(4)=AIMAG(ZC)
NP=4
ENDIF
GOTO 60
20 IWA=2
ZA=D(H2,H3,Z2,Z3)
ZB=D(H3,H1,Z3,Z1)
IF(K.EQ.1) GOTO 60
IF(IWS.EQ.0) THEN
X(1)= REAL(ZA)
X(2)= REAL(ZB)
X(3)= REAL(Z1)
X(4)= REAL(Z2)
Y(1)=AIMAG(ZA)
Y(2)=AIMAG(ZB)
Y(3)=AIMAG(Z1)
Y(4)=AIMAG(Z2)
NP=4
ELSEIF(IWS.EQ.1) THEN
X(1)= REAL(ZA)
X(2)= REAL(ZB)
X(3)= REAL(ZC)
X(4)= REAL(ZD)
X(5)= REAL(Z2)
Y(1)=AIMAG(ZA)
Y(2)=AIMAG(ZB)
Y(3)=AIMAG(ZC)
Y(4)=AIMAG(ZD)
Y(5)=AIMAG(Z2)
NP=5
ELSEIF(IWS.EQ.2) THEN
X(1)= REAL(ZA)
X(2)= REAL(ZB)
X(3)= REAL(ZD)
X(4)= REAL(ZC)
Y(1)=AIMAG(ZA)
Y(2)=AIMAG(ZB)
Y(3)=AIMAG(ZD)
Y(4)=AIMAG(ZC)
NP=4
ENDIF
GOTO 60
30 IWA=3
IF(K.EQ.1) GOTO 103
IF(IWS.EQ.0) THEN
X(1)= REAL(Z1)
X(2)= REAL(Z2)
X(3)= REAL(Z3)
Y(1)=AIMAG(Z1)
Y(2)=AIMAG(Z2)
Y(3)=AIMAG(Z3)
NP=3
ELSEIF(IWS.EQ.1) THEN
X(1)= REAL(ZC)
X(2)= REAL(ZD)
X(3)= REAL(Z2)
X(4)= REAL(Z3)
Y(1)=AIMAG(ZC)
Y(2)=AIMAG(ZD)
Y(3)=AIMAG(Z2)
Y(4)=AIMAG(Z3)
NP=4
ELSEIF(IWS.EQ.2) THEN
X(1)= REAL(ZC)
X(2)= REAL(ZD)
X(3)= REAL(Z3)
Y(1)=AIMAG(ZC)
Y(2)=AIMAG(ZD)
Y(3)=AIMAG(Z3)
NP=3
ENDIF
60 IF(K.NE.1) CALL XFILAREA(X,Y,NP)
IF(IWA.EQ.3) GOTO 103
ZC=ZA
ZD=ZB
IWS=IWA
104 CONTINUE
103 CONTINUE
102 CONTINUE
101 CONTINUE
RETURN
END
SUBROUTINE ZCONTC(ZG,Z,IWRK,X,Y,MD,MG,JG,C1,C2),2
C filling colour between two contour values
DIMENSION ZG(MD,*),Z(MD,*),IWRK(MG,*),X(*),Y(*)
COMPLEX Z,B1,B2,ZA,ZB,Z1,Z2,Z3,Z4,D
D(P1,P2,B1,B2 )=B1+(CV-P1)*(B2-B1)/(P2-P1)
MGP=MG+1
CV1=MIN(C1,C2)
CV2=MAX(C1,C2)
DO 3 J=1,JG-1
HMN=MIN(ZG(1,J),ZG(1,J+1))
HMX=MAX(ZG(1,J),ZG(1,J+1))
DO 50 I=2,MG
HMN=MIN(HMN,ZG(I,J),ZG(I,J+1))
50 HMX=MAX(HMX,ZG(I,J),ZG(I,J+1))
IF(HMN.GE.CV1.AND.HMX.LE.CV2) THEN
NP=1
ZA=Z(1,J)
X(NP)= REAL(ZA)
Y(NP)=AIMAG(ZA)
DO 51 I=2,MG
IF(Z(I,J).NE.ZA) THEN
NP=NP+1
ZA=Z(I,J)
X(NP)= REAL(ZA)
Y(NP)=AIMAG(ZA)
ENDIF
51 CONTINUE
DO 52 I=1,MG
IF(Z(MG-I+1,J+1).NE.ZA) THEN
NP=NP+1
ZA=Z(MG-I+1,J+1)
X(NP)= REAL(ZA)
Y(NP)=AIMAG(ZA)
ENDIF
52 CONTINUE
CALL XFILAREA(X,Y,NP)
ELSEIF(HMN.GT.CV2.OR.HMX.LT.CV1) THEN
GOTO 3
ENDIF
DO 4 JJ=1,4
DO 4 I=1,MG
4 IWRK(I,JJ)=0
DO 2 I=1,MG-1
I1=I
J1=J
I2=I+1
J2=J
I3=I+1
J3=J+1
I4=I
J4=J+1
ISIG= 1
29 CV=0.5*(1+ISIG)*CV1+0.5*(ISIG-1)*CV2
H1=ZG(I1,J1)*ISIG
H2=ZG(I2,J2)*ISIG
H3=ZG(I3,J3)*ISIG
H4=ZG(I4,J4)*ISIG
IF(H1-CV)31,36,36
31 IF(H2-CV)32,34,34
32 IF(H3-CV)33,35,35
33 IF(H4-CV)46,42,42
34 IF(H3-CV)44,35,35
35 IF(H4-CV)43,42,42
36 IF(H2-CV)41,37,37
37 IF(H3-CV)44,38,38
38 IF(H4-CV)43,46,46
41 ISW=1
I10=I2
J10=J2
I40=I1
J40=J1
GOTO 45
42 ISW=2
I10=I1
J10=J1
I40=I4
J40=J4
GOTO 45
43 ISW=3
I10=I4
J10=J4
I40=I3
J40=J3
GOTO 45
44 ISW=4
I10=I3
J10=J3
I40=I2
J40=J2
GOTO 45
46 IF(ISIG.EQ.1) THEN
IF(H1.LT.CV ) GOTO 2
ISIG=-1
GOTO 29
ENDIF
GOTO 2
45 J0=J+ISIG-2
IF(IWRK(I10,J10-J0).EQ.1.AND.IWRK(I40,J40-J0).EQ.1) GOTO 2
I1=I10
J1=J10
I4=I40
J4=J40
CV=0.5*(1+ISIG)*CV1+0.5*(ISIG-1)*CV2
H1=ZG(I1,J1)*ISIG
H4=ZG(I4,J4)*ISIG
Z1= Z(I1,J1)
Z4= Z(I4,J4)
ZA=D(H4,H1,Z4,Z1)
NP=1
X(NP)=REAL(ZA)
Y(NP)=AIMAG(ZA)
101 I2=I1+MOD(ISW-1,2)*(1-2*((ISW-1)/2))
J2=J1+MOD(ISW ,2)*(1-2*((ISW-1)/2))
I3=I4+MOD(ISW-1,2)*(1-2*((ISW-1)/2))
J3=J4+MOD(ISW ,2)*(1-2*((ISW-1)/2))
IF(I2.EQ.0.OR.I3.EQ.0.OR.I2.EQ.MGP.OR.I3.EQ.MGP)GOTO 103
IF(J2.EQ.J-1.OR.J3.EQ.J-1.OR.J2.EQ.J+2.OR.J3.EQ.J+2)GOTO 103
GOTO 104
103 ISW=MOD(ISW+1,4)+1
KORNER=0
112 INI=MOD(ISW ,2)*(1-2*(MOD(ISW,4)/2))
INJ=MOD(ISW+1,2)*(1-2*(MOD(ISW,4)/2))
CVC=0.5*(ISIG+1)*CV2+0.5*(ISIG-1)*CV1
H4=ZG(I4,J4)*ISIG
IF(KORNER.EQ.0.AND.H4.GT.CVC) THEN
ISIG=-ISIG
CV=0.5*(1+ISIG)*CV1+0.5*(ISIG-1)*CV2
I4=I1
J4=J1
I1=I4+INI
J1=J4+INJ
H1=ZG(I1,J1)*ISIG
H4=ZG(I4,J4)*ISIG
Z1= Z(I1,J1)
Z4= Z(I4,J4)
ZA=D(H4,H1,Z4,Z1)
IWRK(I1,J1-J-ISIG+2)=1
IWRK(I4,J4-J-ISIG+2)=1
NP=NP+1
X(NP)=REAL(ZA)
Y(NP)=AIMAG(ZA)
IF (I1.NE.I10.OR.J1.NE.J10.OR.I4.NE.I40.OR.J4.NE.J40) GOTO 101
GOTO 100
ELSE
I1=I4
J1=J4
NP=NP+1
X(NP)=REAL(Z(I1,J1))
Y(NP)=AIMAG(Z(I1,J1))
ENDIF
111 I4=I1
J4=J1
I1=I4+INI
J1=J4+INJ
IF(I1.EQ.0.OR.I1.EQ.MGP.OR.J1.EQ.J-1.OR.J1.EQ.J+2)GOTO 113
GOTO 114
113 ISW=MOD(ISW+2,4)+1
KORNER=1
GOTO 112
114 H1=ZG(I1,J1)*ISIG
IF(H1.GT.CV2*(1+ISIG)*0.5+CV1*(ISIG-1)*0.5) THEN
ISIG=-ISIG
H1=-H1
CV=0.5*(1+ISIG)*CV1+0.5*(ISIG-1)*CV2
ELSEIF(H1-CV.GE.0.) THEN
NP=NP+1
X(NP)=REAL(Z(I1,J1))
Y(NP)=AIMAG(Z(I1,J1))
GOTO 111
ENDIF
H4=ZG(I4,J4)*ISIG
Z1= Z(I1,J1)
Z4= Z(I4,J4)
ZA=D(H4,H1,Z4,Z1)
IWRK(I1,J1-J-ISIG+2)=1
IWRK(I4,J4-J-ISIG+2)=1
NP=NP+1
X(NP)=REAL(ZA)
Y(NP)=AIMAG(ZA)
IF (I1.NE.I10.OR.J1.NE.J10.OR.I4.NE.I40.OR.J4.NE.J40) GOTO 101
GOTO 100
104 H1=ZG(I1,J1)*ISIG
H2=ZG(I2,J2)*ISIG
H3=ZG(I3,J3)*ISIG
H4=ZG(I4,J4)*ISIG
H5=0.25*(H1+H2+H3+H4)
Z1= Z(I1,J1)
Z2= Z(I2,J2)
Z3= Z(I3,J3)
Z4= Z(I4,J4)
IF(H1-CV) 11, 2,15
11 IF(H2-CV) 12,13,13
12 IF(H3-CV) 23,22,22
13 IF(H3-CV) 14,21,21
14 IF(H5-CV) 23,21,21
15 IF(H2-CV) 16,16,18
16 IF(H3-CV) 21,21,17
17 IF(H5-CV) 21,21,23
18 IF(H3-CV) 22,22,23
21 ISA=1
ZB=D(H1,H2,Z1,Z2)
I4=I2
J4=J2
GOTO 30
22 ISA=2
ZB=D(H2,H3,Z2,Z3)
I1=I2
J1=J2
I4=I3
J4=J3
GOTO 30
23 ISA=3
ZB=D(H3,H4,Z3,Z4)
I1=I3
J1=J3
30 IF(ZB.NE.ZA) THEN
NP=NP+1
X(NP)=REAL(ZB)
Y(NP)=AIMAG(ZB)
ENDIF
IWRK(I1,J1-J-ISIG+2)=1
IWRK(I4,J4-J-ISIG+2)=1
ZA=ZB
ISW=MOD(ISW-ISA+5,4)+1
IF (I1.NE.I10.OR.J1.NE.J10.OR.I4.NE.I40.OR.J4.NE.J40) GOTO 101
100 CALL XFILAREA(X,Y,NP-1)
2 CONTINUE
3 CONTINUE
RETURN
END
subroutine xcfill(z,x,y,iw,xw,yw,md,m,n,cl,ncl,mode),6
C
c Produce a colour or gray filling map by calling Xcontc.
C Z : array defining the data surface.
C X,Y: 2-d arrays defining the coordintes of grid points.
C IW: integeter working space of size M*N.
C xw,yw: real working space of size 8*M.
C Md, M, N: dimension of arrays
C CL, NCl: input 1-d array containing the value of contours between
C shaded areas.
C Mode: =0, no shading.
C if mode>0, colour varies from white to black for lower to higher
C contour values.
C if mode<0, the order of gray filling is reveresed, i.e. black for
C minimum, white for maximum.
C ZFmin, ZFmax: Lower and upper limits of the contour values between
C which the shading is done.
C if zfmin=-999.0, zfmin=min(z), if zfmax=999.0, zfmax=max(z).
C
dimension z(md,*),x(md,*),y(md,*),iw(md,*),xw(*),yw(*),cl(1)
c data limzf,zfmin,zfmax /0,-999.0, 999.0/
c save limzf, zfmax, zfmin
common /xlimzf/ limzf, zfmax, zfmin
integer icontcopt
common /xcontc_opt/ icontcopt
if(mode.eq.0) return
zmax1=z(1,1)
zmin1=zmax1
do 1 j=1,n
do 1 i=1,m
zmax1=max(z(i,j),zmax1)
zmin1=min(z(i,j),zmin1)
1 continue
ncl1=ncl
if(limzf.ne.0) then
if(zfmin.ne.-999.0)then
if(zfmin.ge.cl(ncl1))then
ncl1=1
return
elseif(zfmin.lt.cl(1)) then
do 14 k=ncl1,1,-1
14 cl(k+1)=cl(k)
cl(1)=zmin1
ncl1=ncl1+1
goto 12
endif
do 10 k=1,ncl1-1
if(cl(k).le.zfmin.and.cl(k+1).gt.zfmin) then
cl(1)=zfmin
ncl1=ncl1-k+1
do 11 kk=2,ncl1
11 cl(kk)=cl(k+kk-1)
goto 12
endif
10 continue
endif
12 if(zfmax.ne.999.0)then
if(zfmax.le.cl(1))then
ncl1=1
return
elseif(zfmax.gt.cl(ncl1)) then
ncl1=ncl1+1
cl(ncl1)=zmax1
goto 22
endif
do 20 k=1,ncl1-1
if(cl(k).lt.zfmax.and.cl(k+1).ge.zfmax) then
cl(k+1)=zfmax
ncl1=k+1
goto 22
endif
20 continue
endif
22 continue
endif
if((limzf.eq.0.or.zfmin.eq.-999.0).and.(zmin1.lt.cl(1)))then
do 32 k=ncl1,1,-1
32 cl(k+1)=cl(k)
cl(1)=zmin1
ncl1=ncl1+1
endif
if((limzf.eq.0.or.zfmax.eq.999.0).and.(zmax1.gt.cl(ncl1)))then
ncl1=ncl1+1
cl(ncl1)=zmax1
endif
call xqthik(ithick)
call xthick(0)
do 50 k=1,ncl1-1
cl1=cl(k)
cl2=cl(k+1)
C
C set gray degree:
C
if(mode.gt.0) gray=(ncl1-k-0.5)/(ncl1-1)
if(mode.lt.0) gray=(k-0.5)/(ncl1-1)
call PSgray(gray)
if( icontcopt.eq.1) then
call xcontc(z,x,y,iw,xw,yw,md,m,n,cl1,cl2)
else
CALL XCONTC1(z,x,y,md,m,n,cl1,cl2)
endif
50 continue
call xthick(ithick)
call PSgray(0.0)
return
end
subroutine xcflim(zfmi_1, zfma_1)
common /xlimzf/ limzf, zfmax, zfmin
limzf=1
zfmax=zfma_1
zfmin=zfmi_1
return
end
subroutine xcontc(zg,zr,zi,iwrk,x,y,md,mg,jg,c1,c2) 2,2
c
C This is the 'real' version of ZCONTC.F
c Fill in colour between two contour values. developed by zunjun zhang
c at Reading university, england. jan, 1988.
c Modified by Shian-Jiann Lin at University of Oklahoma, Mar. 3,1990.
c external routine called: XFILAREA(x,y,np)
c Polygon is defined by (x(i),y(i),i=1,np)
c
dimension zg(md,*),Zr(md,*),Zi(md,*)
integer iwrk(mg,*)
real x(*),y(*) ! at least 8*m
c
c Single precision may cause the infinite loops noted above. It fixes one
c case on LEMIEUX.
c
C Change to double is one way to fix the problem. If we find it does not
C work later, it can be changed to normalied fix just as xcontj does.
C -- Commented by WYH
double precision h1,h2,h3,h4,h5,cv,cvc
double precision p1,p2
dr(p1,p2,b1r,b2r)=b1r+(cv-p1)*(b2r-b1r)/(p2-p1)
di(p1,p2,b1i,b2i)=b1i+(cv-p1)*(b2i-b1i)/(p2-p1)
mgp=mg+1
if(c1.gt.c2) then
cv1=c2
cv2=c1
else
cv1=c1
cv2=c2
endif
do 3 j=1,jg-1
hmx=zg(1,j)
hmn=zg(1,j+1)
if(hmn.gt.hmx) then
hmx=hmn
hmn=zg(1,j)
endif
C
do 50 i=2,mg
a=zg(i,j)
b=zg(i,j+1)
if(a.gt.b) then
if(a.gt.hmx) hmx=a
if(b.lt.hmn) hmn=b
else
if(b.gt.hmx) hmx=b
if(a.lt.hmn) hmn=a
endif
50 continue
if(hmn.ge.cv1.and.hmx.le.cv2) then
np=1
x(np)=Zr(1,j)
y(np)=Zi(1,j)
do 51 i=2,mg
if(Zr(i,j).ne.x(np).or.Zi(i,j).ne.y(np)) then
np=np+1
c if(np.gt.md*100) then
c print*,'np =', np, ' exceeding ', md*100
c stop
c endif
x(np)= Zr(i,j)
y(np)= Zi(i,j)
endif
51 continue
do 52 i=1,mg
img=mg-i+1
if(Zr(img,j+1).ne.x(np).or.Zi(img,j+1).ne.y(np)) then
np=np+1
c if(np.gt.md*100) then
c print*,'np =', np, ' exceeding ', md*100
c stop
c endif
x(np) = Zr(img,j+1)
y(np) = Zi(img,j+1)
endif
52 continue
c print*,'calling xfilarea 1'
call XFILAREA(x,y,np)
c print*,'done calling xfilarea'
elseif(hmn.gt.cv2.or.hmx.lt.cv1) then
goto 3
endif
do 4 jj=1,4
do 4 i=1,mg
4 iwrk(i,jj)=0
do 2 i=1,mg-1
i1=i
j1=j
i2=i+1
j2=j
i3=i+1
j3=j+1
i4=i
j4=j+1
isig= 1
29 cv=0.5*(1+isig)*cv1+0.5*(isig-1)*cv2
h1=zg(i1,j1)*isig
h2=zg(i2,j2)*isig
h3=zg(i3,j3)*isig
h4=zg(i4,j4)*isig
if(h1-cv)31,36,36
31 if(h2-cv)32,34,34
32 if(h3-cv)33,35,35
33 if(h4-cv)46,42,42
34 if(h3-cv)44,35,35
35 if(h4-cv)43,42,42
36 if(h2-cv)41,37,37
37 if(h3-cv)44,38,38
38 if(h4-cv)43,46,46
41 isw=1
i10=i2
j10=j2
i40=i1
j40=j1
goto 45
42 isw=2
i10=i1
j10=j1
i40=i4
j40=j4
goto 45
43 isw=3
i10=i4
j10=j4
i40=i3
j40=j3
goto 45
44 isw=4
i10=i3
j10=j3
i40=i2
j40=j2
goto 45
46 if(isig.eq.1) then
if(h1.lt.cv ) goto 2
isig=-1
goto 29
endif
goto 2
45 j0=j+isig-2
if(iwrk(i10,j10-j0).eq.1.and.iwrk(i40,j40-j0).eq.1) goto 2
i1=i10
j1=j10
i4=i40
j4=j40
cv=0.5*(1+isig)*cv1+0.5*(isig-1)*cv2
h1=zg(i1,j1)*isig
h4=zg(i4,j4)*isig
np=1
x(np)=dr(h4,h1,Zr(i4,j4),Zr(i1,j1))
y(np)=di(h4,h1,Zi(i4,j4),Zi(i1,j1))
C
101 i2=i1+mod(isw-1,2)*(1-2*((isw-1)/2))
j2=j1+mod(isw ,2)*(1-2*((isw-1)/2))
i3=i4+mod(isw-1,2)*(1-2*((isw-1)/2))
j3=j4+mod(isw ,2)*(1-2*((isw-1)/2))
if(i2.eq.0.or.i3.eq.0.or.i2.eq.mgp.or.i3.eq.mgp)goto 103
if(j2.eq.j-1.or.j3.eq.j-1.or.j2.eq.j+2.or.j3.eq.j+2)goto 103
goto 104
103 isw=mod(isw+1,4)+1
korner=0
112 ini=mod(isw ,2)*(1-2*(mod(isw,4)/2))
inj=mod(isw+1,2)*(1-2*(mod(isw,4)/2))
cvc=0.5*(isig+1)*cv2+0.5*(isig-1)*cv1
h4=zg(i4,j4)*isig
if(korner.eq.0.and.h4.gt.cvc) then
isig=-isig
cv=0.5*(1+isig)*cv1+0.5*(isig-1)*cv2
i4=i1
j4=j1
i1=i4+ini
j1=j4+inj
h1=zg(i1,j1)*isig
h4=zg(i4,j4)*isig
iwrk(i1,j1-j-isig+2)=1
iwrk(i4,j4-j-isig+2)=1
np=np+1
c if(np.gt.md*100) then
c print*,'np =', np, ' exceeding ', md*100
c stop
c endif
x(np)=dr(h4,h1,Zr(i4,j4),Zr(i1,j1))
y(np)=di(h4,h1,Zi(i4,j4),Zi(i1,j1))
if (i1.ne.i10.or.j1.ne.j10.or.i4.ne.i40.or.j4.ne.j40) goto 101
goto 100
else
i1=i4
j1=j4
np=np+1
c if(np.gt.md*100) then
c print*,'np =', np, ' exceeding ', md*100
c stop
c endif
x(np)=Zr(i1,j1)
y(np)=Zi(i1,j1)
endif
111 i4=i1
j4=j1
i1=i4+ini
j1=j4+inj
if(i1.eq.0.or.i1.eq.mgp.or.j1.eq.j-1.or.j1.eq.j+2)goto 113
goto 114
113 isw=mod(isw+2,4)+1
korner=1
goto 112
114 h1=zg(i1,j1)*isig
if(h1.gt.cv2*(1+isig)*0.5+cv1*(isig-1)*0.5) then
isig=-isig
h1=-h1
cv=0.5*(1+isig)*cv1+0.5*(isig-1)*cv2
elseif(h1-cv.ge.0.) then
np=np+1
c if(np.gt.md*100) then
c print*,'np =', np, ' exceeding ', md*100
c stop
c endif
x(np)=Zr(i1,j1)
y(np)=Zi(i1,j1)
goto 111
endif
h4=zg(i4,j4)*isig
iwrk(i1,j1-j-isig+2)=1
iwrk(i4,j4-j-isig+2)=1
np=np+1
c if(np.gt.md*100) then
c print*,'np =', np, ' exceeding ', md*100
c stop
c endif
x(np)=dr(h4,h1,Zr(i4,j4),Zr(i1,j1))
y(np)=di(h4,h1,Zi(i4,j4),Zi(i1,j1))
if (i1.ne.i10.or.j1.ne.j10.or.i4.ne.i40.or.j4.ne.j40) goto 101
goto 100
104 h1=zg(i1,j1)*isig
h2=zg(i2,j2)*isig
h3=zg(i3,j3)*isig
h4=zg(i4,j4)*isig
h5=0.25*(h1+h2+h3+h4)
if(h1-cv) 11, 2,15
11 if(h2-cv) 12,13,13
12 if(h3-cv) 23,22,22
13 if(h3-cv) 14,21,21
14 if(h5-cv) 23,21,21
15 if(h2-cv) 16,16,18
16 if(h3-cv) 21,21,17
17 if(h5-cv) 21,21,23
18 if(h3-cv) 22,22,23
21 isa=1
zbr=dr(h1,h2,Zr(i1,j1),Zr(i2,j2))
zbi=di(h1,h2,Zi(i1,j1),Zi(i2,j2))
c
i4=i2
j4=j2
goto 30
22 isa=2
zbr=dr(h2,h3,Zr(i2,j2),Zr(i3,j3))
zbi=di(h2,h3,Zi(i2,j2),Zi(i3,j3))
c
i1=i2
j1=j2
i4=i3
j4=j3
goto 30
23 isa=3
zbr=dr(h3,h4,Zr(i3,j3),Zr(i4,j4))
zbi=di(h3,h4,Zi(i3,j3),Zi(i4,j4))
C
i1=i3
j1=j3
30 if(zbr.ne.x(np).or.zbi.ne.y(np)) then
np=np+1
c if(np.gt.md*100) then
c print*,'np =', np, ' exceeding ', md*100
c stop
c endif
x(np)=zbr
y(np)=zbi
endif
iwrk(i1,j1-j-isig+2)=1
iwrk(i4,j4-j-isig+2)=1
isw=mod(isw-isa+5,4)+1
if (i1.ne.i10.or.j1.ne.j10.or.i4.ne.i40.or.j4.ne.j40) goto 101
100 continue
c print*,'calling xfilarea 2'
call XFILAREA(x,y,np-1)
c print*,'done calling xfilarea'
2 continue
3 continue
return
end
C* SURFACE VIEWING ROUTINES
SUBROUTINE ZSFPLT(SURFAS,MD,M,N,WORK),12
C isometric surface viewing
REAL SURFAS(MD,*),WORK(2,*)
SAVE IQ,ANGISM,SCALE,XRANGE,XX0,YY0,MODE
DATA IQ/1/,ANGISM/1.043862/,SCALE/1./,XX0,YY0,XRANGE/2*0.,2./
: ,MODE/0/
C MD: the first dimension of array to be viewed
C M: array dimension of x direction
C N: array dimension of y direction
C WORK: working space of total dimension at least 2*max(M,N)
C
IQUAD=IQ
EPS=1.E-4
M1=(MOD(IQUAD,4)/2)*(M-1)+1
N1=((IQUAD-1)/2)*(N-1) +1
DX=XRANGE/(M+N)
DY=DX/TAN(ANGISM)
IF( MOD(IQUAD,2).EQ.0) DX=-ABS(DX)
HS= SCALE
C plot parallel along x direction
C first line
C loop 101,102 draw line in x-direction
IF(MODE.EQ.2) GOTO 301
DO 101 I=1,M
X=(I-1)*DX+XX0
Y=(I-1)*DY+YY0
II=ABS(I-M1)+1
JJ=ABS(1-N1)+1
Y=Y+SURFAS(II,JJ)*HS
WORK(1,I)=Y
WORK(2,I)=Y
IF(I.EQ.1) THEN
CALL XPENUP(X,Y)
ELSE
CALL XPENDN(X,Y)
ENDIF
101 CONTINUE
DO 102 J=2,N
C loop 103 : upper surface
DO 103 I=M,2,-1
X= (I-1)*DX-(J-1)*DX +XX0
Y0= (I-1)*DY+(J-1)*DY+YY0
II=ABS(I-M1)+1
JJ=ABS(J-N1)+1
Y=Y0+SURFAS(II,JJ )*HS
PMAX1=WORK(1, I)
PMAX2=WORK(1, I-1)
IF(Y.GE.WORK(1,I-1)) THEN
IPLOT=1
WORK(1,I)=Y
IF(I.EQ.M) THEN
CALL ZSF002(X,Y,IPLOT)
ELSE
II1=ABS(I -M1)+1
JJ1=ABS(J-1-N1)+1
Y2=Y0+SURFAS(II1,JJ1)*HS-DY
IF(ABS(PMAX1-Y2).LT.EPS) Y1=Y2
CALL ZSF001(X,Y,IPLOT,PMAX2,PMAX1,Y1,DX)
ENDIF
ELSE
IPLOT=0
IF(I.EQ.M) THEN
CALL ZSF002(X,Y,0)
ELSE
CALL ZSF001(X,Y,IPLOT,PMAX2,PMAX1,Y1,DX)
ENDIF
WORK(1,I)=WORK(1,I-1)
ENDIF
Y1=Y
103 CONTINUE
X=-(J-1)*DX+XX0
Y=+(J-1)*DY+YY0
II=ABS(1-M1)+1
JJ=ABS(J-N1)+1
Y=Y+SURFAS(II,JJ)*HS
WORK(1,1)=Y
CALL ZSF003(X,Y)
C loop 104 : Lower surface
DO 104 I=M,2,-1
X= (I-1)*DX-(J-1)*DX+XX0
Y0=(I-1)*DY+(J-1)*DY+YY0
II=ABS(I-M1)+1
JJ=ABS(J-N1)+1
Y=Y0+SURFAS(II,JJ)*HS
PMIN1=WORK(2, I)
PMIN2=WORK(2, I-1)
IF(Y.LE.WORK(2,I-1)) THEN
IPLOT=1
WORK(2,I)=Y
IF(I.EQ.M) THEN
CALL ZSF002(X,Y,IPLOT)
ELSE
II1=ABS(I -M1)+1
JJ1=ABS(J-1-N1)+1
Y2=Y0+SURFAS(II1,JJ1)*HS-DY
IF(ABS(PMIN1-Y2).LT.EPS) Y1=Y2
CALL ZSF001(X,Y,IPLOT,PMIN2,PMIN1,Y1,DX)
ENDIF
ELSE
IPLOT=0
IF(I.EQ.M) THEN
CALL ZSF002(X,Y,IPLOT)
ELSE
CALL ZSF001(X,Y,IPLOT,PMIN2,PMIN1,Y1,DX)
ENDIF
WORK(2,I)=WORK(2,I-1)
ENDIF
Y1=Y
104 CONTINUE
X=-(J-1)*DX+XX0
Y=+(J-1)*DY+YY0
II=ABS(1-M1)+1
JJ=ABS(J-N1)+1
Y=Y+SURFAS(II,JJ)*HS
WORK(2,1)=Y
CALL ZSF003(X,Y)
102 CONTINUE
C loop 201,202 draw line in y-direction
301 IF(MODE.EQ.1) RETURN
DO 201 J=1,N
X=-(J-1)*DX+XX0
Y= (J-1)*DY+YY0
II=ABS(1-M1)+1
JJ=ABS(J-N1)+1
Y=Y+SURFAS(II,JJ)*HS
WORK(1,J)=Y
WORK(2,J)=Y
IF(J.EQ.1) THEN
CALL XPENUP(X,Y)
ELSE
CALL XPENDN(X,Y)
ENDIF
201 CONTINUE
DO 202 I=2,M
C loop 203 : upper surface
DO 203 J=N,2,-1
X= (I-1)*DX-(J-1)*DX +XX0
Y0= (I-1)*DY+(J-1)*DY +YY0
II=ABS(I-M1)+1
JJ=ABS(J-N1)+1
Y=Y0+SURFAS(II,JJ )*HS
PMAX1=WORK(1, J)
PMAX2=WORK(1, J-1)
IF(Y.GE.WORK(1,J-1)) THEN
IPLOT=1
WORK(1,J)=Y
IF(J.EQ.N) THEN
CALL ZSF002(X,Y,IPLOT)
ELSE
II1=ABS(I-1-M1)+1
JJ1=ABS(J -N1)+1
Y2=Y0+SURFAS(II1,JJ1)*HS-DY
IF(ABS(PMAX1-Y2).LT.EPS) Y1=Y2
CALL ZSF001(X,Y,IPLOT,PMAX2,PMAX1,Y1,-DX)
ENDIF
ELSE
IPLOT=0
IF(J.EQ.N) THEN
CALL ZSF002(X,Y,0)
ELSE
CALL ZSF001(X,Y,IPLOT,PMAX2,PMAX1,Y1,-DX)
ENDIF
WORK(1,J)=WORK(1,J-1)
ENDIF
Y1=Y
203 CONTINUE
X=(I-1)*DX+XX0
Y=(I-1)*DY+YY0
II=ABS(I-M1)+1
JJ=ABS(1-N1)+1
Y=Y+SURFAS(II,JJ )*HS
WORK(1,1)=Y
CALL ZSF003(X,Y)
C loop 204 : lower surface
DO 204 J=N,2,-1
X= (I-1)*DX-(J-1)*DX +XX0
Y0= (I-1)*DY+(J-1)*DY +YY0
II=ABS(I-M1)+1
JJ=ABS(J-N1)+1
Y=Y0+SURFAS(II,JJ )*HS
PMIN1=WORK(2, J)
PMIN2=WORK(2, J-1)
IF(Y.LE.WORK(2,J-1)) THEN
IPLOT=1
WORK(2,J)=Y
IF(J.EQ.N) THEN
CALL ZSF002(X,Y,IPLOT)
ELSE
II1=ABS(I-1-M1)+1
JJ1=ABS(J -N1)+1
Y2=Y0+SURFAS(II1,JJ1)*HS-DY
IF(ABS(PMIN1-Y2).LT.EPS) Y1=Y2
CALL ZSF001(X,Y,IPLOT,PMIN2,PMIN1,Y1,-DX)
ENDIF
ELSE
IPLOT=0
IF(J.EQ.N) THEN
CALL ZSF002(X,Y,IPLOT)
ELSE
CALL ZSF001(X,Y,IPLOT,PMIN2,PMIN1,Y1,-DX)
ENDIF
WORK(2,J)=WORK(2,J-1)
ENDIF
Y1=Y
204 CONTINUE
X=(I-1)*DX+XX0
Y=(I-1)*DY+YY0
II=ABS(I-M1)+1
JJ=ABS(1-N1)+1
Y=Y+SURFAS(II,JJ )*HS
WORK(2,1)=Y
CALL ZSF003(X,Y)
202 CONTINUE
RETURN
ENTRY ZSFSTL(MODES)
C MODE=0 draw surface lines along both axes directions (default).
C MODE=1 draw surface lines along the x-direction.
C MODE=2 draw surface lines along the y-direction.
MODE=MODES
RETURN
ENTRY ZSFVEW(IQS)
C Define the corner through which the surface is viewed
C IQ=1,2,3 & 4
IQ=IQS
RETURN
ENTRY ZSFSCL(SCALES)
C Set the scaler which scales the surplot data
C Decreasing SCALE results in decreasing in size of the plot
SCALE=SCALES
RETURN
ENTRY ZSFANG(ANGS)
C Set the isometric angle of the surface viewing
ANGISM=4.*ATAN(1.)*ANGS/180.
RETURN
ENTRY ZSFLOC(X0S,Y0S,RANGEX)
C left to right range in plotting space
C (X0S,Y0S) : the position of reference point
C i.e. the closest grid point to the viewer
XRANGE=RANGEX
XX0=X0S
YY0=Y0S
RETURN
END
SUBROUTINE ZSF001(X,Y,IPLOT,PY,PYP,YP,DX) 8,7
SAVE ILAST
IF(IPLOT.EQ.ILAST) THEN
IF(IPLOT.GT.0) THEN
CALL XPENDN(X,Y)
ENDIF
ELSE
XX=(PY-Y)/(YP-PYP + PY-Y)
YY=Y+(YP-Y)*XX
XX=X+XX*DX
IF(IPLOT.EQ.0) THEN
CALL XPENDN(XX,YY)
IPLOT=0
ELSE
CALL XPENUP(XX,YY)
CALL XPENDN(X, Y )
IPLOT=1
ENDIF
ENDIF
ILAST=IPLOT
RETURN
ENTRY ZSF002(X,Y,IPLOT)
C this entry is used to initialize the state of plotting line
CALL XPENUP(X,Y)
ILAST=IPLOT
RETURN
ENTRY ZSF003(X,Y)
IF(ILAST.GT.0) THEN
CALL XPENDN(X,Y)
ELSE
CALL XPENUP(X,Y)
ENDIF
RETURN
END
SUBROUTINE XCHDEC(ICDATA,CHDATA,I) 3
C To decode character set data for charactere No. I.
CHARACTER CHDATA(127)*300,XCH*2,YCH*2,STR2*4
INTEGER ICDATA (0:150, 32:127)
ILEN = ICLENG(CHDATA(I))
I0=0
J0=0
ICDATA(1,I)=ILEN/2+1
ICD=1
DO 5 INUM=1,ILEN,4
STR2 = CHDATA(I) (INUM:INUM+3)
READ(STR2,100)XCH,YCH
JX = XDECOD(XCH)
JY = XDECOD(YCH)
I00=0
IF (JX .GT. 127) THEN
JX = JX - 128
I00=1
ENDIF
I0=I0+JX-64
J0=J0+JY-64
IF( I00.EQ.1) THEN
ICDATA(ICD+1,I)=I0
ELSE
ICDATA(ICD+1,I)=I0+50
ENDIF
ICDATA(ICD+2,I)=J0
ICD=ICD+2
5 CONTINUE
100 FORMAT(2A,2A)
RETURN
END
FUNCTION XDECOD(CH)
CHARACTER CH*2 ,F*1
COMMON /XCHR30/ ICRAM(256)
100 FORMAT(1A)
101 FORMAT(1X,1A)
READ(CH,100) F
J = ICHAR(F)
J= ICRAM( J )
IF (J .GT. 200) THEN
J=J-240
ELSE
J=J-183
END IF
READ(CH,101) F
K = ICHAR(F)
K= ICRAM( K )
IF (K .GT. 200) THEN
K = K - 240
ELSE
K=K-183
ENDIF
XDECOD = 16*J+K
END
C
SUBROUTINE XCSETA(C) 2
CHARACTER*300 C(127)
C(1) =' ROMAN CHARACTER SET.'
C(2) ='20 30 Size of characters in x and y direction.'
C(32)='5540'
C(33)='4155BF3EC134C14CBF42403EC03A4035BF3FC13FC141BF414A3E'
C(34)='4258BF3FBF41C141C13FC03EBF3EBF3F4845BF3FBF41C141C13FC0
+3EBF3EBF3F492D'
C(35)='4855B9244D5CB9243A51CE40313ACE40453C'
C(36) ='4559C023445DC0234456BF3FC13FC141C041BE42BD41BC40BD3F
+BE3EC03EC13EC13FC23FC63EC23FC23E3249C23EC23FC63EC23FC13FC13EC03CBE
+3EBD3FBC40BD41BE42C041C141C13FBF3F533D'
C(37) ='D2553340C23EC03EBF3EBE3FBE40BE42C042C142C241C240C23F
+C33FC340C341C2413C32BE3FBF3EC03EC23EC240C241C142C042BE42BE404839'
C(38) ='524DBF3FC13FC141C041BF41BF40BF3FBF3EBE3BBE3DBE3EBE3F
+BD40BD41BF42C043C142C644C242C142C042BF42BE41BE3FBF3EC03EC13DC23DC5
+39C23EC33FC140C141C041313EBE41BF42C043C142C2424046C13EC835C23EC23F
+4640'
C(39) ='4258BF3FBF41C141C13FC03EBF3EBF3F492D'
C(40) ='4759BE3EBE3DBE3CBF3BC03CC13BC23CC23DC23E3E5EBE3CBF3D
+BF3BC03CC13BC13DC23C4945'
C(41) ='4059C23EC23DC23CC13BC03CBF3BBE3CBE3DBE3E425EC23CC13D
+C13BC03CBF3BBF3DBE3C4C45'
C(42) ='4555C0343B49CA3A4046B63A5034'
C(43) ='4952C02E3749D2404837'
C(44) ='4241BF3FBF41C141C13FC03EBF3EBF3F4944'
C(45) ='4049D2404837'
C(46) ='4140BF41C141C13F493F'
C(47) ='5259AE205647'
C(48) ='4655BD3FBE3DBF3BC03DC13BC23DC33FC240C341C243C145C043
+BF45BE43BD41BE40BE3FBF3FBF3EBF3BC03DC13BC13EC13FC23F4240C241C141C1
+42C145C043BF45BF42BF414A2C'
C(49) ='4051C241C343C02B3F54C02C3C40C9404640'
C(50) ='4151C13FBF3FBF41C041C142C141C341C440C33FC13FC13EC03E
+BF3EBD3EBB3EBE3FBE3EBF3DC03D4955C23FC13FC13EC03EBF3EBD3EBC3E3B39C1
+41C240C53EC340C241C1413540C53DC440C141C142463D'
C(51) ='4151C13FBF3FBF41C041C142C141C341C440C33FC13EC03DBF3E
+BD3FBD404349C23FC13EC03DBF3EBE3FC23FC23EC13EC03DBF3EBF3FBD3FBC40BD
+41BF41BF42C041C141C13FBF3F4B46C13DC03DBF3EBF3F483F'
C(52) ='4A53C02D4140C055B531D040453A'
C(53) ='4255BE36C242C341C340C33FC23EC13DC03EBF3DBE3EBD3FBD40
+BD41BF41BF42C041C141C13FBF3F474AC23FC23EC13DC03EBF3DBE3EBE3F3A55CA
+40363FC540C541482B'
C(54) ='4C52BF3FC13FC141C041BF42BE41BD40BD3FBE3EBF3EBF3CC03A
+C13DC23EC33FC240C341C242C143C041BF43BE42BD41BF40BD3FBE3EBF3D464EBE
+3FBE3EBF3EBF3CC03AC13DC23EC23F4240C241C242C143C041BF43BE424A34'
C(55 )='4055C03A4042C142C242C240C53DC240C141C142333EC241C240
+C53E4443C03DBF3DBC3BBF3EBF3DC03B464FBB3BBF3EBF3DC03B4E40'
C(56 )='4555BD3FBF3EC03DC13EC33FC440C341C142C043BF42BD41BC40
+BE3FBF3EC03DC13EC23F4440C241C142C043BF42BE413C37BD3FBF3FBF3EC03CC1
+3EC13FC33FC440C341C141C142C044BF42BF41BD413C40BE3FBF3FBF3EC03CC13E
+C13FC23F4440C241C141C142C044BF42BF414935'
C(57 )='4D4EBF3DBE3EBD3FBF40BD41BE42BF43C041C143C242C341C240
+C33FC23EC13DC03ABF3CBF3EBE3EBD3FBD40BE41BF42C041C141C13FBF3F4445BE
+41BE42BF43C041C143C242C2414240C23FC23EC13DC03ABF3CBF3EBE3E4B3F'
C(58 )='414EBF3FC13FC141BF414034BF3FC13FC141BF414E3E'
C(59 )='414EBF3FC13FC141BF414032BF41C141C13FC03EBF3EBF3F4E44
+'
C(60 )='5052B037D0374440'
C(61 )='404CD2402E3AD240483A'
C(62 )='4052D037B0375440'
C(63 )='4151C13FBF3FBF41C041C142C141C241C340C33FC13FC13EC03E
+BF3EBF3FBC3EC03D414EC23FC13FC13EC03EBF3EBE3E3E37BF3FC13FC141BF414D
+3E'
C(64 )='4F4DBF42BE41BD40BE3FBF3FBF3DC03DC13EC23FC340C241C142
+3B48BE3EBF3DC03DC13EC13F474BBF38C03EC23FC240C242C143C042BF43BF42BE
+42BE41BD41BD40BD3FBE3FBE3EBF3EBF3DC03DC13DC13EC23EC23FC33FC340C341
+C241C1413E4DBF38C03EC13F483B'
C(65 )='4955B92B4755C72B3952C62E3546C940333AC6404640C6404340
+'
C(66 )='4340C0554140C02B3C55CC40C33FC13FC13EC03EBF3EBF3FBD3F
+404AC23FC13FC13EC03EBF3EBF3FBE3F3840C840C33FC13FC13EC03DBF3EBF3FBD
+3FB4404C4BC23FC13FC13EC03DBF3EBF3FBE3F4A40'
C(67 )='4E52C13DC046BF3DBE42BD41BE40BD3FBE3EBF3EBF3DC03BC13D
+C13EC23EC33FC240C341C242C1423850BE3FBE3EBF3EBF3DC03BC13DC13EC23EC2
+3F4E40'
C(68 )='4340C0554140C02B3C55CA40C33FC23EC13EC13DC03BBF3DBF3E
+BE3EBD3FB6404A55C23FC23EC13EC13DC03BBF3DBF3EBE3EBE3F4C40'
C(69 )='4340C0554140C02B464FC038364ED040C03ABF463536C6403635
+D040C046BF3A4640'
C(70 )='4340C0554140C02B464FC038364ED040C03ABF463536C6403635
+C7404D40'
C(71 )='4E52C13DC046BF3DBE42BD41BE40BD3FBE3EBF3EBF3DC03BC13D
+C13EC23EC33FC240C341C2423952BE3FBE3EBF3EBF3DC03BC13DC13EC23EC23F47
+48C0384148C0383C48C7404538'
C(72 )='4340C0554140C02B4C40C0554140C02B2F55C7404640C7403036
+CC403035C7404640C7404440'
C(73 )='4340C0554140C02B3C55C740392BC7404440'
C(74 )='4855C02FBF3DBE3FBE40BE41BF42C042C141C13FBF3F4651C02F
+BF3DBF3F3F55C740442B'
C(75 )='4340C0554140C02B4D55B3334544C834374CC8343055C7404640
+C6402D2BC7404640C6404340'
C(76 )='4340C0554140C02B3C55C740392BCF40C046BF3A4440'
C(77 )='4340C0554140C62E3952C72BC755C02B4140C0552E40C4404D40
+C4402B2BC6404840C7404440'
C(78 )='4340C0554140CC2D3451CC2DC0553040C4404940C6402D2BC640
+5140'
C(79 )='4755BD3FBE3EBF3EBF3CC03DC13CC13EC23EC33FC240C341C242
+C142C144C043BF44BF42BE42BD41BE40BE3FBE3EBF3EBF3CC03DC13CC13EC23EC2
+3F4240C241C242C142C144C043BF44BF42BE42BE414D2B'
C(80 )='4340C0554140C02B3C55CC40C33FC13FC13EC03DBF3EBF3FBD3F
+B840484BC23FC13FC13EC03DBF3EBF3FBE3F3436C7404F40'
C(81 )='4755BD3FBE3EBF3EBF3CC03DC13CC13EC23EC33FC240C341C242
+C142C144C043BF44BF42BE42BD41BE40BE3FBE3EBF3EBF3CC03DC13CC13EC23EC2
+3F4240C241C242C142C144C043BF44BF42BE42BE413B2DC041C142C241C140C23F
+C13EC139C13FC240C142C0413B45C13CC13EC13FC140C1414643'
C(82 )='4340C0554140C02B3C55CC40C33FC13FC13EC03EBF3EBF3FBD3F
+B840484AC23FC13FC13EC03EBF3EBF3FBE3F3435C740424BC23FC13FC339C13FC1
+40C1413948C13EC239C13FC240C142C041443D'
C(83 )='4D52C143C03ABF43BE42BD41BD40BD3FBE3EC03EC13EC13FC23F
+C63EC23FC23E3249C23EC23FC63EC23FC13FC13EC03CBE3EBD3FBD40BD41BE42BF
+43C03AC143533D'
C(84 )='4740C0554140C02B3955BF3AC046CF40C03ABF46362BC7404840
+'
C(85 )='4355C031C13DC23EC33FC240C341C242C143C04F3340C031C13D
+C23EC23F3755C7404740C640442B'
C(86 )='4255C72B3A55C62E4752B92B3755C6404640C640422B'
C(87 )='4355C42B3D55C3304450BC2B4455C42B3D55C3304450BC2B3155
+C7404940C640422B'
C(88 )='4255CD2B3455CD2B4055B22B3E55C6404640C6402E2BC6404640
+C6404240'
C(89 )='4255C735C0363A55C735C0364755B935364BC6404740C640332B
+C7404840'
C(90 )='CD554140B32B4055BF3AC046CE40322BCE40C046BF3A4740'
C(91 )='4059C0204140C0603F40C7403920C7404847'
C(92 )='4059D2204447'
C(93 )='4659C0204140C0603940C7403920C7404947'
C(94 )='4052C747C739462E'
C(95 )='403ED4404442'
C(96 )='4058C13FC141BF41BF3FC03EC13EC13F472D'
C(97 )='424CC03FBF40C041C141C241C440C23FC13FC13EC039C13EC13F
+3D4CC037C13EC23FC1403C4ABF3FBA3FBD3FBF3EC03EC13EC33FC340C241C24239
+45BE3FBF3EC03EC13EC23F5040'
C(98 )='4340C0554140C02B404BC242C241C240C33FC23EC13DC03EBF3D
+BE3EBD3FBE40BE41BE42464BC23FC23EC13DC03EBF3DBE3EBE3F3655C440512B'
C(99 )='4C4BBF3FC13FC141C041BE42BE41BD40BD3FBE3EBF3DC03EC13D
+C23EC33FC240C341C242394BBE3FBE3EBF3DC03EC13DC23EC23F4D40'
C(100 )='4C55C02B4155C02B3F4BBE42BE41BE40BD3FBE3EBF3DC03EC13D
+C23EC33FC240C241C2423A4BBE3FBE3EBF3DC03EC13DC23EC23F4355C4403F2BC4
+404540'
C(101 )='4148CC40C042BF42BF41BE41BD40BD3FBE3EBF3DC03EC13DC23E
+C33FC240C341C2423F45C043BF423B41BE3FBE3EBF3DC03EC13DC23EC23F4D40'
C(102 )='4854BF3FC13FC141C041BF41BE40BE3FBF3EC02E4355BF3FBF3E
+C02E3C4EC8403832C7404640'
C(103 )='464EBE3FBF3FBF3EC03EC13EC13FC23FC240C241C141C142C042
+BF42BF41BE41BE403E3FBF3EC03CC13E4640C142C044BF42413FC141C241C03FBE
+403739BF3FBF3EC03FC13EC33FC540C33FC13F3345C13FC33FC540C33FC13EC03F
+BF3EBD3FBA40BD41BF42C041C142C3414F40'
C(104 )='4340C0554140C02B404BC242C341C240C33FC13EC0353C4EC23F
+C13EC0353255C4403C2BC7404440C7404440'
C(105 )='4355BF3FC13FC141BF414039C032414EC0323C4EC4403C32C740
+4440'
C(106 )='4555BF3FC13FC141BF414139C02EBF3EBE3FBE40BF41C041C141
+C13FBF3F4454C02EBF3EBF3F3F55C4404532'
C(107 )='4340C0554140C02B4A4EB6364544C6383948C6383255C4404739
+C6402F32C7404440C6404440'
C(108 )='4340C0554140C02B3C55C4403C2BC7404440'
C(109 )='434EC032414EC032404BC242C341C240C33FC13EC0353C4EC23F
+C13EC035414BC242C341C240C33FC13EC0353C4EC23FC13EC035274EC4403C32C7
+404440C7404440C7404440'
C(110 )='434EC032414EC032404BC242C341C240C33FC13EC0353C4EC23F
+C13EC035324EC4403C32C7404440C7404440'
C(111 )='464EBD3FBE3EBF3DC03EC13DC23EC33FC240C341C242C143C042
+BF43BE42BD41BE40BE3FBE3EBF3DC03EC13DC23EC23F4240C241C242C143C042BF
+43BE42BE414B32'
C(112 )='4339C0554140C02B4052C242C241C240C33FC23EC13DC03EBF3D
+BE3EBD3FBE40BE41BE42464BC23FC23EC13DC03EBF3DBE3EBE3F364EC4403C2BC7
+404E47'
C(113 )='4C39C0554140C02B3F52BE42BE41BE40BD3FBE3EBF3DC03EC13D
+C23EC33FC240C241C2423A4BBE3FBE3EBF3DC03EC13DC23EC23F4339C7404447'
C(114 )='434EC032414EC0324048C143C242C241C340C13FC03FBF3FBF41
+C1413441C4403C32C7404A40'
C(115 )='4A4CC142C03CBF42BF41BE41BC40BE3FBF3FC03EC13FC23FC53E
+C23FC13F3547C13FC23FC53EC23FC13FC03DBF3FBE3FBC40BE41BF41BF42C03CC1
+42503E'
C(116 )='4355C02FC13DC23FC240C241C1423952C02FC13DC13F3A4EC840
+4732'
C(117 )='434EC035C13EC33FC240C341C242364BC035C13EC23F474EC032
+414EC032314EC4404740C4403F32C4404440'
C(118 )='424EC6323B4EC534464CBA32384EC6404440C6404232'
C(119 )='434EC4323D4EC335444BBC32444EC4323D4EC335444BBC32314E
+C7404940C6404232'
C(120 )='424ECB32364ECB32404EB4323E4EC6404440C6403032C6404440
+C6404440'
C(121 )='424EC6323B4EC534464CBA32BE3CBE3EBE3FBF40BF41C141C13F
+3E54C6404440C6404332'
C(122 )='4B4EB5324C4EB532404EBF3CC044CC403432CC40C044BF3C4740
+'
C(123 )='4559BE3FBF3FBF3EC03EC13EC13FC13EC03EBE3E414EBF3EC03E
+C13EC13FC13EC03EBF3EBC3EC43EC13EC03EBF3EBF3FBF3EC03EC13E3F4EC23EC0
+3EBF3EBF3FBF3EC03EC13EC13FC23F4747'
C(124 )='4059C0204747'
C(125 )='4059C23FC13FC13EC03EBF3EBF3FBF3EC03EC23E3F4EC13EC03E
+BF3EBF3FBF3EC03EC13EC43EBC3EBF3EC03EC13EC13FC13EC03EBF3E414EBE3EC0
+3EC13EC13FC13EC03EBF3EBF3FBE3F4B47'
C(126 )='4046C042C143C241C240C23FC43DC23FC240C241C1422E3EC142
+C241C240C23FC43DC23FC240C241C143C0424834'
C(127 )='5540'
RETURN
END
SUBROUTINE XCSETB(C) 2
CHARACTER*300 C(127)
C(1) =' Small and Simple.'
C(2) =' 6 8 '
C(32 )='4640'
C(33 )='C0414041C0444240403A'
C(34 )='4044C1424140BF3E403C4340'
C(35 )='4042C4404042BC404142C03A4240C046433A'
C(36 )='4041C340C141BF41BE40BF41C141C3403E41C03A4440'
C(37 )='4046C03FC140C041BF404440BC3A4440BF40C041C140C03F4240'
+
C(38 )='4442BE3EBF40BF41C041C242C041BF41BF3FC03FC43C4240'
C(39 )='4044C142403A4240'
C(40 )='40464240BE3EC03EC23E4240'
C(41 )='4046C23EC03EBE3E4440'
C(42 )='4241C044423EBC404442BC3C4044C43C423F'
C(43 )='4241C044423EBC40463D'
C(44 )='4041C03FBF3F41414240'
C(45 )='4043C4404240403D'
C(46 )='C041423F'
C(47 )='C4464240403A'
C(48 )='4140BF41C044C141C140C13FC03CBF3FBF404440'
C(49 )='4045C141C03A3F40C2404240'
C(50 )='4045C141C240C13FC03FBF3FBE40BF3FC03EC4404240'
C(51 )='4045C141C240C13FC03FBF3FBF404140C13FC03FBF3FBE40BF414
+03F4640'
C(52 )='4442BC40C344C03A4340'
C(53 )='4041C13FC240C141C042BF41BD40C042C4404240403A'
C(54 )='4043C340C13FC03FBF3FBE40BF41C043C242C1404340403A'
C(55 )='4046C440BD3A4540'
C(56 )='4140BF41C041C141C240C141C041BF41BE40BF3FC03FC13F4240C
+13FC03FBF3FBE404540'
C(57 )='4140C140C242C043BF41BE40BF3FC03FC13FC3404240403D'
C(58 )='4044C03F403FC03F423F'
C(59 )='4044C03F403FC03EBF3F41414240'
C(60 )='40464240BD3DC33D4240'
C(61 )='4044C440403EBC404640403E'
C(62 )='4046C33DBD3D4540'
C(63 )='4045C141C140C13FC03FBF3FC03F403FC03F4340'
C(64 )='4343BF3FBF40C041C141C140C03EC141C042BF41BE40BF3FC03CC
+13FC3404240'
C(65 )='C042C244C23CC03E3C42C440423E'
C(66 )='C340C141C041BF41BE404240C141C041BF41BD404140C03A4540'
+
C(67 )='44404041BF3FBE40BF41C044C141C240C13F423E403D'
C(68 )='C340C141C044BF41BD404140C03A4540'
C(69 )='C046C4403C40403DC2403E40403DC4404240'
C(70 )='C046C4403C40403DC240403D4440'
C(71 )='4343C140C03DBD40BF41C044C141C3404240403A'
C(72 )='C046403DC4404043C03A4240'
C(73 )='4046C2403F40C03A3F40C2404240'
C(74 )='4041C13FC240C141C0454240403A'
C(75 )='C0464440BD3DBF404140C33D4240'
C(76 )='4046C03AC4404240'
C(77 )='C046C23CC244C03A4240'
C(78 )='C046C43AC046403A4240'
C(79 )='C046C440C03ABC404640'
C(80 )='C046C340C13FC03FBF3FBD40463D'
C(81 )='4242C13FBF3FBF40BF41C044C141C240C13FC03DBF3FC13F4240'
+
C(82 )='C046C340C13FC03FBF3FBD404140C33D4240'
C(83 )='4041C13FC240C141BC44C141C240C13F4240403B'
C(84 )='4046C4403E40C03A4440'
C(85 )='4046C03BC13FC240C141C0454240403A'
C(86 )='4046C33AC3464240403A'
C(87 )='4046C23AC143C13DC2464240403A'
C(88 )='C4463C40C43A4240'
C(89 )='4046C23DC03D4043C2434240403A'
C(90 )='4046C440BC3AC4404240'
C(91 )='C046C240403ABE404440'
C(92 )='4046C43A4240'
C(93 )='4046C240C03ABE404440'
C(94 )='4044C242C23E423C'
C(95 )='403FC4404241'
C(96 )='4046C13E423C'
C(97 )='4240BF40BF41C042C141C140C13FC03EBF3F4141C13F4240'
C(98 )='C046403CC242C140C13FC03EBF3FBF40BE42403E4640'
C(99 )='4444BD40BF3FC03EC13FC3404240'
C(100)='4442BE3EBF40BF41C042C141C140C23E4044C03A4240'
C(101)='4042C340C141BF41BE40BF3FC03EC13FC2404340'
C(102)='4043C3404142BF41BF40BF3FC03B4540'
C(103)='403FC13FC240C141C044BF41BE40BF3FC03EC13FC3404240'
C(104)='C046403CC242C140C13FC03D4240'
C(105)='C0434041C0414240403B'
C(106)='403FC13FC140C141C0444041C0414240403B'
C(107)='C046403CC240C2423E3EC23E4240'
C(108)='4046C03BC13F4240'
C(109)='C044403FC141C13FC03F4041C141C13FC03D4240'
C(110)='C044403FC141C140C13FC03D4240'
C(111)='4340BE40BF41C042C141C240C13FC03EBF3F4340'
C(112)='403EC046403FC141C240C13FC03EBF3FBD404640'
C(113)='443EC046403FBF41BE40BF3FC03EC13FC3404240'
C(114)='C044403EC242C140C13F4240403D'
C(115)='C340C141BF41BE40BF41C141C340423C'
C(116)='4044C4403E42C03BC13FC141423F'
C(117)='4044C03DC13FC140C2424042C03C4240'
C(118)='4044C23CC244423C'
C(119)='4044C13CC144C13CC144423C'
C(120)='C4443C40C43C4240'
C(121)='4044C23C4244BD3ABF4040424640'
C(122)='4044C440BC3CC4404240'
C(123)='40464240BF3FC03FBF3FC13FC03FC13F4240'
C(124)='C046403A4240'
C(125)='C141C041C141BF41C041BF41403A4440'
C(126)='4041C141C240C141423E403F'
C(127)='4640'
RETURN
END
SUBROUTINE XCSETC(C) 2
CHARACTER*300 C(127)
C(1) =' A Simple Large Character Set. '
C(2) ='30 40 '
C(32 )='5340'
C(33 )='4155BF3EC134C14CBF42403EC03A4035BF3FC13FC141BF414C3E'
+
C(34 )='4258BF3FBF41C141C13FC03EBF3EBF3F4845BF3FBF41C141C13FC
+03EBF3EBF3F492D'
C(35 )='4855B9244D5CB9243A51CE40313ACE40453C'
C(36 )='4559C023445DC0234556BE42BD41BC40BD3FBE3EC03EC13EC13FC
+23FC63EC23FC13FC13EC03DBE3EBD3FBC40BD41BE42543D'
C(37 )='D2553340C23EC03EBF3EBE3FBE40BE42C042C142C241C240C23FC
+33FC340C341C2413C32BE3FBF3EC03EC23EC240C241C142C042BE42BE404839'
C(38 )='524DBF3FC13FC141C041BF41BF40BF3FBF3EBE3BBE3DBE3EBE3FB
+D40BD41BF42C043C142C644C242C142C042BF42BE41BE3FBF3EC03EC13DC23DC53
+9C23EC33FC140C141C041313EBE41BF42C043C142C2424046C13EC835C23EC23F4
+640'
C(39 )='4258BF3FBF41C141C13FC03EBF3EBF3F492D'
C(40 )='4759BE3EBE3DBE3CBF3BC03CC13BC23CC23DC23E4747'
C(41 )='4059C23EC23DC23CC13BC03CBF3BBE3CBE3DBE3E4E47'
C(42 )='454FC0343B49CA3A4046B63A503A'
C(43 )='4952C02E3749D2404837'
C(44 )='4241BF3FBF41C141C13FC03EBF3EBF3F4A44'
C(45 )='4049D2404837'
C(46 )='4142BF3FC13FC141483F'
C(47 )='5259AE205647'
C(48 )='4655BD3FBE3DBF3BC03DC13BC23DC33FC240C341C243C145C043B
+F45BE43BD41BE404E2B'
C(49 )='4051C241C343C02B4B40'
C(50 )='4150C041C142C141C241C440C23FC13FC13EC03EBF3EBE3DB636C
+E404640'
C(51 )='4255CB40BA38C340C23FC13FC13DC03EBF3DBE3EBD3FBD40BD41B
+F41BF42543C'
C(52 )='4A55B632CF403B4EC02B4A40'
C(53 )='4C55B640BF37C141C341C340C33FC23EC13DC03EBF3DBE3EBD3FB
+D40BD41BF41BF42543C'
C(54 )='4C52BF42BD41BE40BD3FBE3DBF3BC03BC13CC23EC33FC140C341C
+242C143C041BF43BE42BD41BF40BD3FBE3EBF3D5439'
C(55 )='4055CE40B62B5040'
C(56 )='4555BD3FBF3EC03EC13EC23FC43FC33FC23EC13EC03DBF3EBF3FB
+D3FBC40BD41BF41BF42C043C142C242C341C441C241C142C042BF42BD41BC404F2
+B'
C(57 )='4D4EBF3DBE3EBD3FBF40BD41BE42BF43C041C143C242C341C140C
+33FC23EC13CC03BBF3BBE3DBD3FBE40BD41BF42533D'
C(58 )='414EBF3FC13FC141BF414034BF3FC13FC141BF414E3E'
C(59 )='414EBF3FC13FC141BF414032BF41C141C13FC03EBF3EBF3F4E44'
+
C(60 )='5052B037D0374440'
C(61 )='404CD2402E3AD240483A'
C(62 )='4052D037B0375440'
C(63 )='4151C13FBF3FBF41C041C142C141C241C340C33FC13EC03EBF3EB
+F3FBC3EC03D414E423F413F413E403E3F3E3E3E3E37BF3FC13FC141BF414D3E'
C(64 )='4F4DBF42BE41BD40BE3FBF3FBF3DC03DC13EC23FC340C241C1423
+B48BE3EBF3DC03DC13EC13F474BBF38C03EC23FC240C242C143C042BF43BF42BE4
+2BE41BD41BD40BD3FBE3FBE3EBF3EBF3DC03DC13DC13EC23EC23FC33FC340C341C
+241C1413E4DBF38C03EC13F483B'
C(65 )='C855C82B3347CA404939'
C(66 )='C055C940C33FC13FC13EC03EBF3EBF3FBD3F3740C940C33FC13FC
+13EC03DBF3EBF3FBD3FB7405540'
C(67 )='4F50BF42BE42BE41BC40BE3FBE3EBF3EBF3DC03BC13DC13EC23EC
+23FC440C241C242C142463B'
C(68 )='C055C740C33FC23EC13EC13DC03BBF3DBF3EBE3EBD3FB9405540'
+
C(69 )='C055CD403336C8403835CD404640'
C(70 )='C055CD403336C8404A35'
C(71 )='4F50BF42BE42BE41BC40BE3FBE3EBF3EBF3DC03BC13DC13EC23EC
+23FC440C241C242C142C043BB404B38'
C(72 )='C0554E40C02B324BCE404835'
C(73 )='C055482B'
C(74 )='4A55C030BF3DBF3FBE3FBE40BE41BF41BF43C0425039'
C(75 )='C0554E40B2324545C9344740'
C(76 )='4055C02BCC404540'
C(77 )='C055C82BC855C02B4840'
C(78 )='C055CE2BC055482B'
C(79 )='4655BE3FBE3EBF3EBF3DC03BC13DC13EC23EC23FC440C241C242C
+142C143C045BF43BF42BE42BE41BC40502B'
C(80 )='C055C940C33FC13FC13EC03DBF3EBF3FBD3FB7405536'
C(81 )='4655BE3FBE3EBF3EBF3DC03BC13DC13EC23EC23FC440C241C242C
+142C143C045BF43BF42BE42BE41BC40432FC63A4742'
C(82 )='C055C940C33FC13FC13EC03EBF3EBF3FBD3FB7404740C7354740'
+
C(83 )='4E52BE42BD41BC40BD3FBE3EC03EC13EC13FC23FC63EC23FC13FC
+13EC03DBE3EBD3FBC40BD41BE42543D'
C(84 )='4755C02B3955CE40442B'
C(85 )='4055C031C13DC23EC33FC240C341C242C143C04F482B'
C(86 )='4055C82BC855442B'
C(87 )='4055C52BC555C52BC555442B'
C(88 )='CE553240CE2B4640'
C(89 )='4055C836C84A3836C0354C40'
C(90 )='4055CE40B22BCE404640'
C(91 )='4759B940C020C7404847'
C(92 )='4059D2204447'
C(93 )='4059C740C020B9404C47'
C(94 )='4052C747C739462E'
C(95 )='403ED4404442'
C(96 )='4058C13FC141BF41BF3FC03EC13EC13F472D'
C(97 )='4C4EC032404BBE42BE41BD40BE3FBE3EBF3DC03EC13DC23EC23FC
+340C241C242473D'
C(98 )='C0554036C242C241C340C23FC23EC13DC03EBF3DBE3EBE3FBD40B
+E41BE42533D'
C(99 )='4C4BBE42BE41BD40BE3FBE3EBF3DC03EC13DC23EC23FC340C241C
+242463D'
C(100)='4C55C02B404BBE42BE41BD40BE3FBE3EBF3DC03EC13DC23EC23FC
+340C241C242473D'
C(101)='4048CC40C042BF42BF41BE41BD40BE3FBE3EBF3DC03EC13DC23EC
+23FC340C241C242463D'
C(102)='4855BE40BE3FBF3DC02F3D4EC7404532'
C(103)='4C4EC030BF3DBF3FBE3FBD40BE414951BE42BE41BD40BE3FBE3EB
+F3DC03EC13DC23EC23FC340C241C242473D'
C(104)='C0554035C343C241C340C23FC13DC0364840'
C(105)='4054C13FC141BF41BF3F413AC0324740'
C(106)='4454C13FC141BF41BF3F413AC02FBF3DBE3FBE404A47'
C(107)='C0554A39B6364444C7384640'
C(108)='C055482B'
C(109)='C04E403CC343C241C340C23FC13DC036404AC343C241C340C23FC
+13DC0364840'
C(110)='C04E403CC343C241C340C23FC13DC0364840'
C(111)='454EBE3FBE3EBF3DC03EC13DC23EC23FC340C241C242C143C042B
+F43BE42BE41BD404E32'
C(112)='404EC02B4052C242C241C340C23FC23EC13DC03EBF3DBE3EBE3FB
+D40BE41BE42533D'
C(113)='4C4EC02B4052BE42BE41BD40BE3FBE3EBF3DC03EC13DC23EC23FC
+340C241C242473D'
C(114)='C04E403AC143C242C241C3404532'
C(115)='4B4BBF42BD41BD40BD3FBF3EC13EC23FC53FC23FC13EC03FBF3EB
+D3FBD40BD41BF42513D'
C(116)='4355C02FC13DC23FC240384EC7404732'
C(117)='404EC036C13DC23FC340C241C343404AC0324840'
C(118)='404EC632C64E4432'
C(119)='404EC432C44EC432C44E4632'
C(120)='CB4E4032B54E5132'
C(121)='414EC632464EBA32BE3CBE3EBE3FBF405047'
C(122)='404ECB40B532CB404640'
C(123)='4559BE3FBF3FBF3EC03EC13EC13FC13EC03EBE3EBE3FC23FC23EC
+03EBF3EBF3FBF3EC03EC13EC13FC23F4747'
C(124)='4059C0204747'
C(125)='4059C23FC13FC13EC03EBF3EBF3FBF3EC03EC23EC23FBE3FBE3EC
+03EC13EC13FC13EC03EBF3EBF3FBE3F4B47'
C(126)='4046C042C143C241C240C23FC43DC23FC240C241C1422E3EC142C
+241C240C23FC43DC23FC240C241C143C0424834'
C(127)='5340'
RETURN
END
SUBROUTINE XCSETD(C) 2
CHARACTER*300 C(127)
C(1) =' Italic Character set.'
C(2) ='20 30 '
C(32 )='5540'
C(33 )='4655BF3FBE34434CBD34434DC13FBC343E3ABF3FC13FC141BF414
+E3E'
C(34 )='4857BD40C242C13EBF3EBE3E4B44BD40C242C13EBF3EBE3E4A2D'
+
C(35 )='4855B9244D5CB9243A51CE40313ACE40453C'
C(36 )='4A59B8234D5DB8234955BF3FC13FC141C041BF42BF41BD41BC40B
+D3FBE3EC03EC13EC13FC73CC23E3549C23EC73CC13FC13EC03DBF3EBF3FBD3FBC4
+0BD41BF41BF42C041553B'
C(37 )='D2553340C23EC03EBF3EBE3FBE40BE42C042C142C241C240C23FC
+33FC340C341C2413C32BE3FBF3EC03EC23EC240C241C142C042BE42BE404839'
C(38 )='524DBF3FC13FC141C041BF41BF40BF3FBF3EBE3BBE3DBE3EBE3FB
+D40BD41BF42C043C142C644C242C142C042BF42BE41BE3FBF3EC03EC13DC23DC53
+9C23EC33FC140C141C041313EBE41BF42C043C142C2424046C13EC835C23EC23F4
+640'
C(39 )='4857BD40C242C13EBF3EBE3E4A2D'
C(40 )='4C59BC3DBD3DBE3DBE3CBF3BC03CC13BC13DC13E455DBD3CBE3CB
+F3DBF3BC03B4E3F'
C(41 )='4959C13EC13DC13BC03CBF3BBE3CBE3DBD3DBC3D4960C13DC13BC
+03BBF3BBF3D473C'
C(42 )='4655C0343B49CA3A3640CA46462E'
C(43 )='4D52BB2E3A49D2404637'
C(44 )='4340BD40C242C13EBF3EBE3E4C44'
C(45 )='4049D2404837'
C(46 )='4140BF41C141C13F493F'
C(47 )='5A59A6205847'
C(48 )='4955BD3FBE3EBE3DBF3DBF3CC03DC13DC13FC23FC240C341C242C
+243C143C144C043BF43BF41BE41BE40BE3FBE3EBE3DBF3DBF3CC03DC13DC23E424
+0C241C242C243C143C144C043BF43482D'
C(49 )='4140C8553E3CBB2F4140C655BD3DBD3EBE3F4743BC3E4A30'
C(50 )='454F4142C13FBF3FBF41C041C142C141C341C340C33FC13EC03EB
+F3EBE3EBD3EBC3EBD3EBE3EBE3C4D55C23FC13EC03EBF3EBE3EBA3C3A3AC141C24
+0C53EC340C241C142353FC53DC340C241C143463C'
C(51 )='4551C13FBF3FBF41C041C142C141C341C340C33FC13EC03EBF3EB
+D3EBD3F434AC23FC13EC03EBF3EBE3E3B3FC240C33FC13FC13EC03DBF3EBF3FBD3
+FBC40BD41BF41BF42C041C141C13FBF3F4847C23FC13FC13EC03DBF3EBF3FBE3F4
+C40'
C(52 )='4E54BA2C4755BA2B4655B131CC40493A'
C(53 )='5046374FBB36454ACA40363FC540C5413136C141C341C340C33FC
+13FC13EC03DBF3DBE3EBD3FBD40BD41BF41BF42C041C141C13FBF3F4849C23FC13
+FC13EC03DBF3DBE3EBE3F4D40'
C(54 )='4E52BF3FC13FC141C041BF42BE41BD40BD3FBE3EBE3DBF3DBF3CC
+03CC13EC13FC23FC340C341C242C142C043BF42BF41BE41BD40BE3FBE3EBF3E484
+EBE3FBE3EBE3DBF3DBF3CC03BC13E453FC241C242C142C0444937'
C(55 )='4355BE3A4F46BF3DBE3DBB3ABE3DBF3EBF3C494FBA3ABE3DBF3EB
+F3C3F52C343C240C53D3741C241C240C53EC240C141452D'
C(56)='51553840BD3FBF3FBF3EC03DC13EC23FC340C441C141C142C043BF
+42BD41BD40BE3FBF3FBF3EC03DC13EC13F4340C341C141C142C043BF42BE413B36
+BC3FBE3EBF3EC03DC13EC33FC440C441C141C142C043BF42BF41BE413D40BD3FBE
+3EBF3EC03DC13EC23F4440C341C141C142C0444838'
C(57 )='4B4A4344BF3EBE3EBE3FBD40BE41BF41BF42C043C142C242C341C
+340C23FC13FC13EC03CBF3CBF3DBE3DBE3EBD3FBD40BE41BF42C041C141C13FBF3
+F4347BF42C044C142C242C241453FC13EC03BBF3CBF3DBE3DBE3E4D3F'
C(58 )='444EBF3FC13FC141BF413D34BF3FC13FC141BF414D3F'
C(59 )='454EBF3FC13FC141BF413D32BF41C141C13FC03FBF3EBE3E4D44'
+
C(60 )='5352AD37D0374640'
C(61 )='434CD2402B3AD240483A'
C(62 )='4252CE37AE375540'
C(63 )='4151C13FBF3FBF41C041C142C141C341C440C33FC13EC03EBF3EB
+F3FBA3EBE3FC03EC13FC240434EC23FC13EC03EBF3EBF3FBE3F3A36BF3FC13FC14
+1BF41553E'
C(64 )='4F4DBF42BE41BD40BE3FBF3FBF3DC03DC13EC23FC340C241C1423
+B48BE3EBF3DC03DC13EC13F474BBF38C03EC23FC240C242C143C042BF43BF42BE4
+2BE41BD41BD40BD3FBE3FBE3EBF3EBF3DC03DC13DC13EC23EC23FC33FC340C341C
+241C1413E4DBF38C03EC13F483B'
C(65 )='4F55B32B4D55C12B3E53C12D3746C940313AC6404640C6404540'
+
C(66 )='4955BA2B4755BA2B4255CB40C33FC13EC03EBF3DBF3FBD3F414AC
+23FC13EC03EBF3DBF3FBE3F3740C940C23FC13EC03EBF3DBE3EBC3FB440504BC13
+FC13EC03EBF3DBE3EBD3F4C40'
C(67 )='4F53C140C142BF3AC042BF42BF41BE41BD40BD3FBE3EBE3DBF3DB
+F3CC03DC13DC13FC33FC340C241C242C1423C50BE3FBE3EBE3DBF3DBF3CC03DC13
+DC13FC23F4E40'
C(68 )='4955BA2B4755BA2B4255C940C33FC13FC13DC03CBF3CBE3CBE3EB
+E3FBC3FB7404F55C23FC13FC13DC03CBF3CBE3CBE3EBE3FBD3F4E40'
C(69 )='4955BA2B4755BA2B4A4FBE383A4ECF40BF3AC0463336C6403335C
+F40C245BD3B4940'
C(70 )='4955BA2B4755BA2B4A4FBE383A4ECF40BF3AC0463336C6403335C
+7405040'
C(71 )='4F53C140C142BF3AC042BF42BF41BE41BD40BD3FBE3EBE3DBF3DB
+F3CC03DC13DC13FC33FC240C341C242C2443B4EBE3FBE3EBE3DBF3DBF3CC03DC13
+DC13FC23F4240C241C242C2443D40C7404439'
C(72 )='4955BA2B4755BA2B5255BA2B4755BA2B3555C7404640C7402D36C
+C402D35C7404640C7404640'
C(73 )='4955BA2B4755BA2B4255C740332BC7404840'
C(74 )='4E55BB2FBF3EBF3FBE3FBE40BE41BF42C042C141C13FBF3F4C51B
+B2FBF3EBE3E4555C740412B'
C(75 )='4955BA2B4755BA2B5355AF334744C4343B4CC4343655C7404640C
+640272BC7404640C6404440'
C(76 )='4955BA2B4755BA2B4255C740332BCF40C246BD3A4640'
C(77 )='4955BA2B4655C12B4055C12D4C53B32B4D55BA2B4755BA2B3455C
+4404D40C440252BC6404840C7404640'
C(78 )='4955BA2B4655C72E394FC72E4655BA2B3655C3404A40C640272BC
+6405340'
C(79 )='4A55BD3FBE3EBE3DBF3DBF3CC03DC13DC13FC23FC340C341C242C
+243C143C144C043BF43BF41BE41BD40BE3FBE3EBE3DBF3DBF3CC03DC13DC23E434
+0C241C242C243C143C144C043BF43BE42482B'
C(80 )='4955BA2B4755BA2B4255CC40C33FC13EC03EBF3DBE3EBC3FB8404
+B4BC23FC13EC03EBF3DBE3EBD3F3136C7405040'
C(81)='4A55BD3FBE3EBE3DBF3DBF3CC03DC13DC13FC23FC340C341C242C24
+3C143C144C043BF43BF41BE41BD40BE3FBE3EBE3DBF3DBF3CC03DC13DC23E4340C
+241C242C243C143C144C043BF43BE42362DC041C142C241C140C23FC13EC039C13
+FC240C142C0413C45C13AC13FC140C1414743'
C(82 )='4955BA2B4755BA2B4255CB40C33FC13EC03EBF3DBF3FBD3FB7404
+A4AC23FC13EC03EBF3DBF3FBE3F3C40C23FC13FC138C13FC240C142C0413B46C23
+9C13FC140C1412C3EC7405140'
C(83 )='5153C140C142BF3AC042BF42BF41BD41BC40BD3FBE3EC03EC13EC
+13FC73CC23E3549C23EC73CC13FC13EC03DBF3EBF3FBD3FBC40BD41BF41BF42C04
+2BF3AC142C140553E'
C(84 )='4B55BA2B4755BA2B3F55BD3AC246CF40BF3AC046302BC7404C40'
+
C(85 )='4555BD35BF3CC03DC13EC33FC440C341C242C143C44F3340BD35B
+F3CC03DC13EC23F3D55C7404740C640442B'
C(86 )='4555C12B4055C12D4C53B32B3D55C6404640C640432B'
C(87 )='4555BE2B4355BE2D4953B62B4A55BE2B4355BE2D4953B62B3755C
+7404940C640422B'
C(88 )='4855C72B3A55C72B4655AC2B4455C6404640C640282BC6404640C
+6404740'
C(89 )='4555C436BD354055C436BD354D55B636394AC6404740C6402D2BC
+7404C40'
C(90 )='5355AD2B5455AD2B4655BD3AC246CE402C2BCE40C246BD3A4940'
+
C(91 )='4859B8204960B8204760C7403120C7404C47'
C(92 )='4959CC204447'
C(93 )='4E59B8204960B8204160C7403120C7404C47'
C(94 )='4552C747C739452E'
C(95 )='403ED4404442'
C(96 )='4058C13FC141BF41BF3FC03EC13EC13F472D'
C(97 )='4D4EBE39BF3CC03EC13FC340C242C1423D4ABE39BF3CC03EC13F3
+F47C043BF43BE41BE40BD3FBE3DBF3DC03DC13EC13FC23FC240C241C243C1433B4
+7BE3FBE3DBF3DC03CC13E533F'
C(98 )='4455BC33C03DC13DC13F4354BC33C143C242C241C240C23FC13FC
+13EC03DBF3DBE3DBD3FBE40BE41BF43C0444945C13EC03CBF3DBE3DBE3F3B55C44
+04E2B'
C(99 )='4B4BC03FC140C041BF42BE41BD40BD3FBE3DBF3DC03DC13EC13FC
+23FC240C341C2433B4ABE3FBE3DBF3DC03CC13E4F3F'
C(100)='4F55BC32BF3CC03EC13FC340C242C1423F51BC32BF3CC03EC13F3
+F47C043BF43BE41BE40BD3FBE3DBF3DC03DC13EC13FC23FC240C241C243C1433B4
+7BE3FBE3DBF3DC03CC13E4A54C440452B'
C(101)='4145C441C341C342C142BF42BE41BD40BD3FBE3DBF3DC03DC13EC
+13FC23FC240C341C2423B4BBE3FBE3DBF3DC03CC13E4F3F'
C(102)='5054BF3FC13FC141C041BF41BE40BE3FBF3FBF3EBF3DBD32BF3CB
+F3E4A5BBE3EBF3EBF3CBE37BF3CBF3DBF3EBF3FBE3FBE40BF41C041C141C13FBF3
+F4554CA404032'
C(103)='504EBC32BF3DBE3DBD3FBD40BE41BF41C041C141C13FBF3F4E53B
+C32BF3DBE3DBE3F474EC043BF43BE41BE40BD3FBE3DBF3DC03DC13EC13FC23FC24
+0C241C243C1433B47BE3FBE3DBF3DC03CC13E503F'
C(104)='4655BA2B4755BA2B4247C244C242C241C240C23FC13FC03EBE3AC
+03DC13F3E4EC23EC03EBE3AC03DC13FC340C242C1423151C4404E2B'
C(105)='4955BF3FC13FC141BF413835C142C242C340C13FC03DBE3AC03DC
+13F3F4EC13FC03DBE3AC03DC13FC340C242C142443C'
C(106)='4B55BF3FC13FC141BF413835C142C242C340C13FC03DBD36BF3DB
+F3EBF3FBE3FBE40BF41C041C141C13FBF3F4854C13FC03DBD36BF3DBF3EBE3E4B4
+7'
C(107)='4755BA2B4755BA2B4D4DBF3FC13FC141C041BF41BF40BE3FBC3CB
+E3FBE404240C23FC23AC13F3B48C13FC23AC13FC240C241C2433451C4404D2B'
C(108)='4555BC32BF3CC03EC13FC340C242C1423F51BC32BF3CC03EC13F4
+055C440462B'
C(109)='404AC142C242C340C13FC03EBF3CBE39414EC13FC03EBF3CBE394
+347C244C242C241C240C23FC13FC03EBD36404EC23EC03EBD364347C244C242C24
+1C240C23FC13FC03EBE3AC03DC13F3E4EC23EC03EBE3AC03DC13FC340C242C1424
+33C'
C(110)='404AC142C242C340C13FC03EBF3CBE39414EC13FC03EBF3CBE394
+347C244C242C241C240C23FC13FC03EBE3AC03DC13F3E4EC23EC03EBE3AC03DC13
+FC340C242C142433C'
C(111)='464EBD3FBE3DBF3DC03DC13EC13FC23FC240C341C243C143C043B
+F42BF41BE41BE40BE3FBE3DBF3DC03CC13E443FC241C243C143C044BF424733'
C(112)='424AC142C242C340C13FC03EBF3CBC324355C13FC03EBF3CBC324
+54EC143C243C241C240C23FC13FC13EC03DBF3DBE3DBD3FBE40BE41BF43C043494
+6C13EC03CBF3DBE3DBE3F3339C7404F47'
C(113)='4D4EBA2B4755BA2B434EC043BF43BE41BE40BD3FBE3DBF3DC03DC
+13EC13FC23FC240C241C243C1433B47BE3FBE3DBF3DC03CC13E4238C7404847'
C(114)='404AC142C242C340C13FC03EBF3CBE39414EC13FC03EBF3CBE394
+347C244C242C241C240C13FC03FBF3FBF41C1414333'
C(115)='4C4CC03FC140C041BF41BD41BD40BD3FBF3FC03EC13FC73CC13F3
+747C13FC73CC13FC03DBF3FBD3FBD40BD41BF41C041C140C03F503E'
C(116)='4655BC32BF3CC03EC13FC340C242C1423F51BC32BF3CC03EC13F3
+D4EC9404532'
C(117)='404AC142C242C340C13FC03DBE3AC03EC23E3E4EC13FC03DBE3AC
+03EC13FC23FC240C241C242C2444247BE39BF3CC03EC13FC340C242C1423D4ABE3
+9BF3CC03EC13F4740'
C(118)='404AC142C242C340C13FC03DBE3AC03EC23E3E4EC13FC03DBE3AC
+03EC13FC23FC140C341C242C243C144C044BF40C13E4434'
C(119)='404AC142C242C340C13FC03DBE3AC03EC23E3E4EC13FC03DBE3AC
+03EC13FC23FC240C241C242C1424249BE37C03DC13FC23FC240C241C242C142C14
+4C045BF40C13E3842BE37C03DC23E4C40'
C(120)='414AC243C241C340C13EC03D3E45C13EC03DBF3CBF3EBE3EBE3FB
+F40BF41C041C141C13FBF3F4644C03DC13EC340C241C2434049BF3FC13FC141C04
+1BF41BF40BE3FBE3EBF3EBF3CC03DC13E4B40'
C(121)='404AC142C242C340C13FC03DBE3AC03EC23E3E4EC13FC03DBE3AC
+03EC13FC23FC240C241C242C2444347BC32BF3DBE3DBD3FBD40BE41BF41C041C14
+1C13FBF3F4E53BC32BF3DBE3DBE3F4D47'
C(122)='4E4EBF3EBE3EB83ABE3EBF3E414AC142C242C340C43E3740C241C
+340C43FC2403436C240C43FC340C2413740C43EC340C242C142473C'
C(123)='4C59BD3FBF3FBF3EC03DC13DC03FBF3EBE3E444EBF3DC03EC13DC
+03EBF3EBF3FBB3EC43EC13FC03EBF3DBD3EBF3FBF3EC03E434EC13FC13EC03FBF3
+EBE3FBF3FBE3DC03FC13EC23F40474940'
C(124)='4859B8204C47'
C(125)='4659C23FC13FC03EBF3DBD3DBF3EC03FC23E414EC13EBF3DBD3DB
+F3EC03EC13FC43EBB3EBE3DC03EC13DC03D444CBD3EBF3EC03FC13EC03DBF3EBE3
+E4B47'
C(126)='4046C042C143C241C240C23FC43DC23FC240C241C1422E3EC142C
+241C240C23FC43DC23FC240C241C143C0424834'
C(127)='5540'
RETURN
END
SUBROUTINE XCPALET(mode) 8,24
c
c#######################################################################
c
c PURPOSE:
c
c Generate color label plots of 2-d field A given its
c coordinate using ZXPLOT and ncar package..
c
c#######################################################################
c
c AUTHOR: Min Zou
c 15/08/92
C
c#######################################################################
c
c INPUT:
c
c ctrlvls(nctrlvls) Contour values dividing the filled areas
c clrindx(nctrlvls-1) Plot color index bar color index
c nctrlvls Number of contour levels
c
c mode Option for positioning the color palette
c = 1, color bar is located below the plotting space
c = 2, color bar is located to the right of plotting space
c
c#######################################################################
c
c Variable Declarations.
c
c#######################################################################
c
implicit none
c
integer mode
integer nctrlvls_max
parameter(nctrlvls_max=1000) ! Max. number of contour values
real ctrlvls(nctrlvls_max) ! contour values dividing the filled areas
integer clrindx(nctrlvls_max) ! plot color index bar color index
integer nctrlvls, nctrlvls_lim ! Number of contour levels
common /xcflvls/nctrlvls,ctrlvls,clrindx
character cpalnfmt*15, xtem*15
common /xcplnfmt/ cpalnfmt
integer icplswitch
common /xcplswitch/ icplswitch
real xl,xr,yb,yt
character*20 ch
integer lch
real xra(5),yra(5) ! array for single color box
real dtx,dty,x,y,xs,ys
real byt,byb,bxl,bxr
integer k,kwndon,iskip
real xwd1,xwd2,ywd1,ywd2,hch
c
C@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
C
C Beginning of executable code...
C
C@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
c
c print*,'cpalnfmt=',cpalnfmt
c print*,'mode, icplswitch=', mode, icplswitch
IF( mode .eq. 2 .and. icplswitch .eq. 0 ) return
IF(nctrlvls .gt.nctrlvls_max) THEN
write(6,'(a,/a,i5,a)')
: 'The number of contours exceeded maximum allowed.',
: 'Only ',nctrlvls_max,' contours will be plotted'
ENDIF
nctrlvls_lim =min(nctrlvls,nctrlvls_max)
call xqmap(xl,xr,yb,yt)
byt=yb-0.13*(yt-yb)
byb=byt-0.06*(yt-yb)
c
c Find out old window setting
c
call xqwdwon(kwndon)
if( kwndon.eq.1) then
call xqwndw(xwd1,xwd2,ywd1,ywd2)
call xwdwof
endif
IF(nctrlvls_lim.lt.15)then
iskip=1
ELSEIF(nctrlvls_lim.lt.30) then
iskip=2
else
iskip=3
endif
call xqchsz(hch)
if(mode.eq.1) then ! Place color bar below plotting window.
byt= yb-0.07*(yt-yb)
byb=byt-0.03*(yt-yb)
xs= xr-xl
ys= byt-byb
dtx=xs/(nctrlvls_lim-1)
DO 10 k=1,nctrlvls_lim-1
xra(1)=xl+dtx*(k-1)
xra(2)=xl+dtx*k
xra(3)=xra(2)
xra(4)=xra(1)
yra(1)=byt
yra(2)=byt
yra(3)=byb
yra(4)=byb
CALL XCOLOR(clrindx(k))
CALL XFILAREA(xra,yra,4)
CALL xcolor(1)
call xbox(xra(1),xra(2),yra(3),yra(1))
IF(mod(k-1,iskip).eq.0) then
if( cpalnfmt(1:1).eq.'*') then
CALL XRCH_new(ctrlvls(k),ch,lch)
else
if( index(cpalnfmt,'I').eq.0 .and.
: index(cpalnfmt,'i').eq.0 ) then
write(ch,cpalnfmt) ctrlvls(k)
else
write(ch,cpalnfmt) nint(ctrlvls(k))
endif
lch = 15
call xstrlnth(ch,lch)
endif
CALL xcharc(xra(1),byb-1.3*hch,ch(1:lch))
END IF
10 CONTINUE
CALL xcolor(1)
CALL XRCH_new(ctrlvls(nctrlvls_lim),ch,lch)
CALL xcharc(xr,byb-1.3*hch,ch(1:lch))
else if(mode.eq.2) then ! Place color bar to the right of plotting window.
bxr = xr+0.07*(xr-xl)
bxl = xr+0.03*(xr-xl)
xs = bxr-bxl
ys = 0.94*(yt-yb)
dty=ys/(nctrlvls_lim-1)
x=bxr+0.20*xs
DO 20 k=1,nctrlvls_lim-1
yra(1)=0.030*(yt-yb)+yb+dty*(k-1)
yra(2)=0.030*(yt-yb)+yb+dty*k
yra(3)=yra(2)
yra(4)=yra(1)
xra(1)=bxl
xra(2)=bxl
xra(3)=bxr
xra(4)=bxr
CALL XCOLOR(clrindx(k))
CALL XFILAREA(xra,yra,4)
CALL xcolor(1)
call xbox(xra(1),xra(3),yra(1),yra(2))
IF(mod(k-1,iskip).eq.0) then
if( cpalnfmt(1:1).eq.'*') then
CALL XRCH_new(ctrlvls(k),ch,lch)
else
if( index(cpalnfmt,'I').eq.0 .and.
: index(cpalnfmt,'i').eq.0 ) then
write(ch,cpalnfmt) ctrlvls(k)
else
write(ch,cpalnfmt) nint(ctrlvls(k))
endif
lch = 15
call xstrlnth(ch,lch)
endif
CALL xcharl(x,yra(1)-0.3*hch,ch(1:lch))
END IF
20 CONTINUE
CALL xcolor(1)
y=0.025*(yt-yb)+yb+ys
CALL XRCH_new(ctrlvls(nctrlvls_lim),ch,lch)
CALL xcharl(x,y-0.3*hch,ch(1:lch))
end if
c
c Restore old windin setting
c
if( kwndon.eq.1) call xwindw(xwd1,xwd2,ywd1,ywd2)
RETURN
ENTRY XCPALNFMT( xtem )
cpalnfmt = xtem
RETURN
END
SUBROUTINE XRCH_new( R,CH,LCH) 4,3
C Return real number R as a character string in automatically set format
REAL R
CHARACTER CH*20, STR*20
CALL XGETFMT(R,STR)
IF(ABS(R).LT. 1.E-20) THEN
WRITE(CH,'(F3.1)') R
ELSE
WRITE(CH,STR) R
ENDIF
LCH=20
CALL xstrlnth( CH, LCH)
CALL xstrmin ( CH, LCH)
RETURN
END
SUBROUTINE xgetfmt(R,CH) 1
INTEGER NPOZ
CHARACTER CH*20,FORM,NDROB
WRITE(CH,10)R
10 FORMAT(G11.4)
DO I=20,1,-1
IF(CH(I:I).EQ.'0'.OR.CH(I:I).EQ.' ') THEN
CH(I:I)=' '
ELSE
GOTO 1
END IF
END DO
1 CONTINUE
NPOZ=0
NDOT=0
NMANT=0
NDROB=' '
FORM='F'
DO I = 1,20
IF(CH(I:I).NE.' ' ) NPOZ=NPOZ+1
IF(CH(I:I).EQ.'E') FORM='E'
IF(NDROB.EQ.'.'.AND.CH(I:I).NE.' ') NDOT=NDOT+1
IF(CH(I:I).EQ.'.') NDROB='.'
IF(FORM.NE.'E') NMANT=NPOZ
END DO
NPOZ=NPOZ
IF(FORM.EQ.'F') THEN
IF(NDOT.NE.0) THEN
write(CH,20) '(',FORM,NPOZ,'.',NDOT,')'
ELSE
write(CH,20) '(',FORM,NPOZ,'.',NDOT,')'
END IF
elseif(FORM.EQ.'E') then
CH = '(1PE20.2)'
ELSE
write(CH,20) '(',FORM,NPOZ,'.',NMANT,')'
END IF
20 FORMAT(A1,A1,I1,A1,I1,A1)
RETURN
END
SUBROUTINE XSTRMIN( string, length ) 5
c
c#######################################################################
c
c PURPOSE:
c
c Minimize a string length by removing consecutive blank spaces.
c
c#######################################################################
c
c AUTHOR: Ming Xue
c 1/15/93
c
c#######################################################################
c
c INPUT:
c string A character string
c length The declared length of the character string 'string'.
c OUTPUT:
c length The length of string with consecutive blank spaces
c removed.
c
c#######################################################################
implicit none
character string*(*)
integer length
character str*256, str_1
integer i,len_old
c
IF( length.gt.256) THEN
print*,'Work string defined in XSTRMIN was too small.'
print*,'The output from this subroutine may not be correct.'
length=256
ENDIF
len_old = length
length = 1
str = string
DO 100 i = 2,len_old
str_1 = str(i-1:i-1)
IF(.not.(str(i:i).eq.' '.and.
: (str_1.eq.' '.or.str_1.eq.'('.or.str_1.eq.'='))) THEN
length=length+1
string(length:length)=str(i:i)
ENDIF
100 CONTINUE
DO 200 i = 1,length
if( string(i:i).ne.' ') goto 300
200 CONTINUE
300 CONTINUE
IF( i.ne.1) then
str=string
string(1:length-i+1)=str(i:length)
length = length-i+1
ENDIF
RETURN
END
SUBROUTINE XSTPJGRD(mapproj,trulat1,trulat2,trulon, 7,3
: ctrlat,ctrlon,xl,yl,xorig,yorig)
c
c Set up map projection grid
c
implicit none
integer mapproj
real trulat1,trulat2,trulon
real ctrlat,ctrlon,xl,yl,xorig,yorig
real swx,swy,ctrx,ctry
call XSTMPRJ(mapproj,trulat1,trulat2,trulon)
CALL xlltoxy( 1,1, ctrlat,ctrlon, ctrx, ctry )
swx = ctrx - (xl*0.5+xorig)*1000.0
swy = ctry - (yl*0.5+yorig)*1000.0
CALL xsetorig( 1, swx, swy)
RETURN
END
c
c ##################################################################
c ##################################################################
c ###### ######
c ###### ARPS Map Projection Subsystem. ######
c ###### ######
c ###### Developed by ######
c ###### Center for Analysis and Prediction of Storms ######
c ###### University of Oklahoma ######
c ###### ######
c ##################################################################
c ##################################################################
c
c General Information
c
c This set of subroutines allows for transformation between
c lat-lon coordinates and any one of three map projections: Polar
c Stereographic, Lambert Conformal or Mercator.
c
c In order for the transformation subroutines to work, the
c map projection must first be set up by calling setmapr. The
c user may wish to call setorig immediately after setmapr to
c established an origin (given a lat-long or x-y in the default
c system) other than the default origin (e.g., the north pole).
c
c All lat-lons are in degrees (positive north, negative south,
c positive east and negative west). Note carefully the dimensions
c of x,y -- it differs among the subroutines to conform to ARPS usage.
c x,y coordinates are meters on earth but may be changed using the scale
c parameter in setmapr to change to km (scale=0.001) or to a different
c sphere (e.g., scale=mars_radius/earth_radius).
c
c
c ##################################################################
c ##################################################################
c ###### ######
c ###### SUBROUTINE XSTMPRJ ######
c ###### ######
c ###### Developed by ######
c ###### Center for Analysis and Prediction of Storms ######
c ###### University of Oklahoma ######
c ###### ######
c ##################################################################
c ##################################################################
c
SUBROUTINE XSTMPRJ(iproj,trulat1,trulat2,trulon) 1
c
c#######################################################################
c
c PURPOSE:
c
c Set constants for map projections, which are stored in
c the common block named /xprojcst/.
c
c
c#######################################################################
c
c AUTHOR: Keith Brewster
c 11/13/93.
c
c MODIFICATION HISTORY:
c 03/30/1995 (K. Brewster)
c Corrected error in Lambert Conformal scaling and added code to
c allow Lambert Tangent projection (lat1=lat2 in Lambert Conformal).
c Resulted in redefinition of projc1 for option 2.
c
c#######################################################################
c
c INPUT:
c
c iproj Map projection number
c 1=North Polar Stereographic (-1 South Pole)
c 2=Northern Lambert Conformal (-2 Southern)
c 3=Mercator
c 4=Lat,Lon
c
c scale Map scale factor, at latitude=latnot
c Distance on map = (Distance on earth) * scale
c For ARPS model runs, generally this is 1.0
c For ARPS plotting this will depend on window
c size and the area to be plotted.
c
c latnot(2) Real "True" latitude(s) of map projection
c (degrees, positive north)
c Except for iproj=1, only latnot(1) is used
c
c orient Longitude line that runs vertically on the map.
c (degrees, negative west, positive east)
c
c#######################################################################
c
c Variable Declarations.
c
c#######################################################################
c
implicit none
integer iproj
real trulat1, trulat2, trulon
real scale ! map scale factor
real latnot(2) ! true latitude (degrees N)
real orient ! orientation longitude (degrees E)
real d2rad,eradius
parameter (d2rad=3.141592654/180.,
: eradius = 6371000. ) ! mean earth radius in m
integer jproj,jpole
real trulat(2),rota,scmap,xorig,yorig,
: projc1,projc2,projc3,projc4,projc5
common /xprojcst/ jproj,jpole,trulat,rota,scmap,xorig,yorig,
: projc1,projc2,projc3,projc4,projc5
c
c#######################################################################
c
c Misc. local variables:
c
c#######################################################################
c
real denom1,denom2,denom3
c#######################################################################
c
c
C@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
C
C Beginning of executable code...
C
C@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
c
scale = 1.0
latnot(1) = trulat1
latnot(2) = trulat2
orient = trulon
xorig=0.
yorig=0.
jproj=iabs(iproj)
jpole=isign(1,iproj)
c
c#######################################################################
c
c No map projection
c
c#######################################################################
c
IF ( jproj.eq.0 ) THEN
c write(6,'(a)')
c : ' No map projection will be used.'
c
c#######################################################################
c
c Polar Stereographic projection
c For this projection:
c projc1 is the scaled earth's radius, scale times eradius
c projc2 is the numerator of emfact, the map image scale factor.
c projc3 is projc2 times the scaled earth's radius.
c
c#######################################################################
c
ELSEIF( jproj.eq.1 ) THEN
trulat(1)=latnot(1)
rota=orient
scmap=scale
projc1=scale*eradius
projc2=(1. + sin(d2rad*jpole*trulat(1)) )
projc3=projc1*projc2
IF(jpole.gt.0) THEN
c write(6,'(a/,a)')
c : ' Map projection set to Polar Stereographic',
c : ' X origin, Y origin set to 0.,0. at the North Pole.'
ELSE
c write(6,'(a/,a)')
c : ' Map projection set to Polar Stereographic',
c : ' X origin, Y origin set to 0.,0. at the South Pole.'
END IF
c
c#######################################################################
c
c Lambert Conformal Conic Projection.
c For this projection:
c projc1 is the scaled earth's radius, scale times eradius/n
c projc2 is cos of trulat(1)
c projc3 is tan (45. - trulat/2) a const for local map scale
c projc4 is the cone constant, n
c
c#######################################################################
c
ELSE IF( jproj.eq.2 ) THEN
trulat(1)=latnot(1)
trulat(2)=latnot(2)
rota=orient
scmap=scale
projc2=cos(d2rad*trulat(1))
projc3=tan(d2rad*(45.-0.5*jpole*trulat(1)))
denom1=cos(d2rad*trulat(2))
denom2=tan(d2rad*(45.-0.5*jpole*trulat(2)))
IF(denom2.ne.0.) THEN
denom3=alog( projc3/denom2 )
ELSE
denom3=0.
END IF
IF(denom1.ne.0. and. denom3.ne.0.) THEN
projc4=alog( projc2/denom1 ) / denom3
c print *, ' The cone constant is : ',projc4
IF( projc4.lt.0.) THEN
write(6,'(a/,a,f9.2,a,f9.2,/a)')
: ' Warning in SETMAPR for Lambert Projection',
: ' For the true latitudes provided, ',
: trulat(1),' and ',trulat(2),
: ' projection must be from opposite pole...changing pole.'
jpole=-jpole
projc3=tan(d2rad*(45.-0.5*jpole*trulat(1)) )
denom2=tan(d2rad*(45.-0.5*jpole*trulat(2)))
IF(denom2.ne.0.) THEN
denom3=alog( projc3/denom2 )
ELSE
denom3=0.
END IF
IF(denom1.ne.0. and. denom3.ne.0.) THEN
projc4=alog( projc2/denom1 ) / denom3
c print *, ' The revised cone constant is : ',projc4
ELSE
write(6,'(a/,a,f9.2,a,f9.2)')
: ' Error (1) in SETMAPR for Lambert Projection',
: ' Illegal combination of trulats one: ',
: trulat(1),' and two: ',trulat(2)
STOP
END IF
END IF
projc1=scale*eradius/projc4
ELSE IF(denom3.eq.0. .and. denom2.ne.0.) THEN ! tangent
write(6,'(a/,a,f9.2,a,f9.2)')
: ' Using Tangent Lambert Projection',
: ' Based on input combination of trulats one: ',
: trulat(1),' and two: ',trulat(2)
projc4=sin(d2rad*jpole*trulat(1))
c print *, ' The cone constant is : ',projc4
IF( projc4.lt.0.) THEN
write(6,'(a/,a,f9.2,a,f9.2,/a)')
: ' Warning in SETMAPR for Lambert Projection',
: ' For the true latitudes provided, ',
: trulat(1),' and ',trulat(2),
: ' projection must be from opposite pole...changing pole.'
jpole=-jpole
projc4=sin(d2rad*jpole*trulat(1))
END IF
projc1=scale*eradius/projc4
ELSE
write(6,'(a/,a,f9.2,a,f9.2)')
: ' Error (1) in SETMAPR for Lambert Projection',
: ' Illegal combination of trulats one: ',
: trulat(1),' and two: ',trulat(2)
STOP
END IF
IF(jpole.gt.0) THEN
c write(6,'(a/,a)')
c : ' Map projection set to Lambert Conformal',
c : ' X origin, Y origin set to 0.,0. at the North Pole.'
ELSE
c write(6,'(a/,a)')
c : ' Map projection set to Lambert Conformal',
c : ' X origin, Y origin set to 0.,0. at the South Pole.'
END IF
c
c#######################################################################
c
c Mercator Projection.
c For this projection:
c projc1 is the scaled earth's radius, scale times eradius
c projc2 is cos of trulat(1)
c projc3 is projc1 times projc2
c
c#######################################################################
c
ELSE IF( jproj.eq.3 ) THEN
trulat(1)=latnot(1)
rota=orient
scmap=scale
projc1=scale*eradius
projc2=cos(d2rad*trulat(1))
projc3=projc1*projc2
IF(projc2.le.0.) THEN
write(6,'(a/,a,f9.2,a,f9.2)')
: ' Error (1) in SETMAPR for Mercator Projection',
: ' Illegal true latitude provided: ',trulat(1)
STOP
END IF
write(6,'(a/,a,f6.1/,a)')
: ' Map projection set to Mercator',
: ' X origin, Y origin set to 0.,0. at the equator,',rota,
: ' Y positive toward the North Pole.'
c
c#######################################################################
c
c Lat, Lon Projection.
c For this projection:
c projc1 is the scaled earth's radius, scale times eradius
c projc2 is cos of trulat(1)
c projc3 is projc1 times projc2 times 180/pi
c
c#######################################################################
c
ELSE IF( jproj.eq.4 ) THEN
trulat(1)=latnot(1)
rota=orient
scmap=scale
projc1=scale*eradius
projc2=cos(d2rad*trulat(1))
IF(projc2.le.0.) THEN
write(6,'(a/,a,f9.2,a,f9.2)')
: ' Error (1) in SETMAPR for Lat,Lon Projection',
: ' Illegal true latitude provided: ',trulat(1)
STOP
END IF
projc3=projc1*projc2/d2rad
write(6,'(a/,a,/a)')
: ' Map projection set to Lat, Lon',
: ' X origin, Y origin set to 0.,0. at the equator, 0. long',
: ' Y positive toward the North Pole.'
ELSE
write(6,'(i4,a)') iproj,' projection is not supported'
STOP
END IF
RETURN
END
c
c ##################################################################
c ##################################################################
c ###### ######
c ###### SUBROUTINE GETMAPR ######
c ###### ######
c ###### Developed by ######
c ###### Center for Analysis and Prediction of Storms ######
c ###### University of Oklahoma ######
c ###### ######
c ##################################################################
c ##################################################################
c
SUBROUTINE XGETMAPR(iproj,scale,latnot,orient,x0,y0)
c
c#######################################################################
c
c PURPOSE:
c
c Get the constants for the current map projection, which are stored
c in the common block named /xprojcst/.
c
c
c#######################################################################
c
c AUTHOR: Keith Brewster
c 9/17/94.
c
c MODIFICATION HISTORY:
c 1/17/96 Corrected retrieval of iproj to assign sign from jpole.
c
c#######################################################################
c
c OUTPUT:
c
c iproj Map projection number
c 1=North Polar Stereographic (-1 South Pole)
c 2=Northern Lambert Conformal (-2 Southern)
c 3=Mercator
c 4=Lat,Lon
c
c scale Map scale factor, at latitude=latnot
c Distance on map = (Distance on earth) * scale
c For ARPS model runs, generally this is 1.0
c For ARPS plotting this will depend on window
c size and the area to be plotted.
c
c latnot(2) Real "True" latitude(s) of map projection
c (degrees, positive north)
c Except for iproj=2, only latnot(1) is used
c
c orient Longitude line that runs vertically on the map.
c (degrees, negative west, positive east)
c
c x0 x coordinate of origin
c y0 y coordinate of origin
c
c#######################################################################
c
c Variable Declarations.
c
c#######################################################################
c
implicit none
integer iproj ! map projection number
real scale ! map scale factor
real latnot(2) ! true latitude (degrees N)
real orient ! orientation longitude (degrees E)
real x0 ! x coordinate of origin
real y0 ! y coordinate of origin
integer jproj,jpole
real trulat(2),rota,scmap,xorig,yorig,
: projc1,projc2,projc3,projc4,projc5
common /xprojcst/ jproj,jpole,trulat,rota,scmap,xorig,yorig,
: projc1,projc2,projc3,projc4,projc5
c#######################################################################
c
c
C@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
C
C Beginning of executable code...
C
C@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
c
iproj=jproj*jpole
scale=scmap
latnot(1)=trulat(1)
latnot(2)=trulat(2)
orient=rota
x0=xorig
y0=yorig
RETURN
END
c
c ##################################################################
c ##################################################################
c ###### ######
c ###### SUBROUTINE XSETORIG ######
c ###### ######
c ###### Developed by ######
c ###### Center for Analysis and Prediction of Storms ######
c ###### University of Oklahoma ######
c ###### ######
c ##################################################################
c ##################################################################
c
SUBROUTINE XSETORIG(iopt,x0,y0) 1,3
c
c#######################################################################
c
c PURPOSE:
c
c Set the origin for the map projection.
c This is call after subroutine mapproj if the origin
c must be moved from the original position, which is the
c pole for the polar stereographic projection and the
c Lambert conformal, and the equator for Mercator.
c
c#######################################################################
c
c AUTHOR: Keith Brewster
c 11/20/93.
c
c MODIFICATION HISTORY:
c
c#######################################################################
c
c INPUT:
c
c iopt origin setting option
c 1: origin given in corrdinate x,y
c 2: origin given in lat,lon on earth
c
c x0 first coordinate of origin
c y0 second coordinate of origin
c
c
c#######################################################################
c
c Variable Declarations.
c
c#######################################################################
c
implicit none
integer iopt ! origin setting option
real x0 ! first coordinate of origin
real y0 ! second coordinate of origin
integer jproj,jpole
real trulat(2),rota,scmap,xorig,yorig,
: projc1,projc2,projc3,projc4,projc5
common /xprojcst/ jproj,jpole,trulat,rota,scmap,xorig,yorig,
: projc1,projc2,projc3,projc4,projc5
c
c#######################################################################
c
c Misc. local variables:
c
c#######################################################################
c
real xnew,ynew,rlat,rlon
c#######################################################################
c
c
C@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
C
C Beginning of executable code...
C
C@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
c
c
c#######################################################################
c
c iopt=1 origin is given in x,y in absolute coordinates.
c
c#######################################################################
c
IF( iopt.eq.1 ) THEN
xorig=x0
yorig=y0
CALL xxytoll(1,1,0.,0.,rlat,rlon)
c write(6,'(/a,f18.2,f18.2,/a,f16.2,f16.2/)')
c : ' Coordinate origin set to absolute x,y =',xorig,yorig,
c : ' Latitude, longitude= ',rlat,rlon
c
c#######################################################################
c
c iopt=2 origin is given in lat,lon on earth
c
c#######################################################################
c
c
ELSE IF( iopt.eq.2 ) THEN
xorig=0.
yorig=0.
CALL xlltoxy(1,1,x0,y0,xnew,ynew)
xorig=xnew
yorig=ynew
c write(6,'(/a,f16.2,f16.2,/a,f16.2,f16.2/)')
c : ' Coordinate origin set to absolute x,y =',xorig,yorig,
c : ' Latitude, longitude= ',x0,y0
ELSE
CALL xxytoll(1,1,0.,0.,rlat,rlon)
c write(6,'(/a,i4,a,/a,f16.2,f16.2,/a,f16.2,f16.2)')
c : ' Setorig option ',iopt,' not supported.',
c : ' Coordinate origin unchanged at x,y =',xorig,yorig,
c : ' Latitude, longitude= ',rlat,rlon
END IF
RETURN
END
c
c
c ##################################################################
c ##################################################################
c ###### ######
c ###### SUBROUTINE XXYTOLL ######
c ###### ######
c ###### Developed by ######
c ###### Center for Analysis and Prediction of Storms ######
c ###### University of Oklahoma ######
c ###### ######
c ##################################################################
c ##################################################################
c
c
SUBROUTINE XXYTOLL(idim,jdim,x,y,rlat,rlon) 10
c
c#######################################################################
c
c PURPOSE:
c
c Determine latitude and longitude given X,Y coordinates on
c map projection. SETMAPR must be called before this routine
c to set-up the map projection constants.
c
c#######################################################################
c
c AUTHOR: Keith Brewster
c 11/13/93.
c
c MODIFICATION HISTORY:
c 01/17/96 Bug in southern hemisphere for Polar Stereo and
c Mercator projections fixed.
c
c#######################################################################
c
c INPUT:
c
c idim Number of points in x direction.
c jdim Number of points in y direction.
c
c rlat Array of latitude.
c (degrees, negative south, positive north)
c
c rlon Array of longitude.
c (degrees, negative west, positive east)
c
c OUTPUT:
c
c x Vector of x in map coordinates
c y Vector of y in map coordinates
c Units are meters unless the scale parameter is
c not equal to 1.0
c
c#######################################################################
c
c Variable Declarations.
c
c#######################################################################
c
implicit none
integer idim,jdim
real x(idim),y(jdim),rlat(idim,jdim),rlon(idim,jdim)
real r2deg,eradius
parameter (r2deg=180./3.141592654,
: eradius = 6371000. ) ! mean earth radius in m
c
integer jproj,jpole
real trulat(2),rota,scmap,xorig,yorig,
: projc1,projc2,projc3,projc4,projc5
common /xprojcst/ jproj,jpole,trulat,rota,scmap,xorig,yorig,
: projc1,projc2,projc3,projc4,projc5
c
c#######################################################################
c
c Misc. local variables:
c
c#######################################################################
c
integer i,j
real xabs,yabs,yjp
real radius,ratio,dlon
c#######################################################################
c
c
C@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
C
C Beginning of executable code...
C
C@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
c
c#######################################################################
c
c No map projection
c
c#######################################################################
c
IF ( jproj.eq.0 ) THEN
ratio=r2deg/eradius
DO 10 j = 1, jdim
DO 10 i = 1, idim
rlat(i,j) = ratio*(y(j)+yorig)
rlon(i,j) = ratio*(x(i)+xorig)
10 CONTINUE
c
c#######################################################################
c
c Polar Stereographic projection
c For this projection:
c projc1 is the scaled earth's radius, scale times eradius
c projc2 is the numerator of emfact, the map image scale factor.
c projc3 is projc2 times the scaled earth's radius.
c
c#######################################################################
c
ELSEIF( jproj.eq.1 ) THEN
DO 100 j=1,jdim
DO 100 i=1,idim
yabs=y(j)+yorig
xabs=x(i)+xorig
radius=sqrt( xabs*xabs + yabs*yabs )/projc3
rlat(i,j) = jpole*(90. - 2.*r2deg*atan(radius))
rlat(i,j)=amin1(rlat(i,j), 90.)
rlat(i,j)=amax1(rlat(i,j),-90.)
IF((jpole*yabs).gt.0.) THEN
dlon=180. + r2deg*atan(-xabs/yabs)
ELSE IF((jpole*yabs).lt.0.) THEN
dlon=r2deg*atan(-xabs/yabs)
ELSE IF (xabs.gt.0.) THEN ! y=0.
dlon=90.
ELSE
dlon=-90.
END IF
rlon(i,j)= rota + jpole*dlon
IF(rlon(i,j).gt. 180) rlon(i,j)=rlon(i,j)-360.
IF(rlon(i,j).lt.-180) rlon(i,j)=rlon(i,j)+360.
rlon(i,j)=amin1(rlon(i,j), 180.)
rlon(i,j)=amax1(rlon(i,j),-180.)
c
100 CONTINUE
c
c#######################################################################
c
c Lambert Conformal Conic Projection.
c For this projection:
c projc1 is the scaled earth's radius, scale times eradius/n
c projc2 is cos of trulat(1)
c projc3 is tan (45. - trulat/2) a const for local map scale
c projc4 is the cone constant, n
c
c#######################################################################
c
ELSE IF ( jproj.eq.2 ) THEN
DO 200 j=1,jdim
DO 200 i=1,idim
yabs=y(j)+yorig
xabs=x(i)+xorig
radius=sqrt( xabs*xabs+ yabs*yabs )
ratio=projc3*((radius/(projc1*projc2))**(1./projc4))
rlat(i,j)=jpole*(90. -2.*r2deg*(atan(ratio)))
rlat(i,j)=amin1(rlat(i,j), 90.)
rlat(i,j)=amax1(rlat(i,j),-90.)
yjp=jpole*yabs
IF(yjp.gt.0.) THEN
dlon=180. + r2deg*atan(-xabs/yabs)/projc4
ELSE IF(yjp.lt.0.) THEN
dlon=r2deg*atan(-xabs/yabs)/projc4
ELSE IF (xabs.gt.0.) THEN ! y=0.
dlon=90./projc4
ELSE
dlon=-90./projc4
END IF
rlon(i,j)= rota + jpole*dlon
IF(rlon(i,j).gt. 180) rlon(i,j)=rlon(i,j)-360.
IF(rlon(i,j).lt.-180) rlon(i,j)=rlon(i,j)+360.
rlon(i,j)=amin1(rlon(i,j), 180.)
rlon(i,j)=amax1(rlon(i,j),-180.)
200 CONTINUE
c
c#######################################################################
c
c Mercator Projection.
c For this projection:
c projc1 is the scaled earth's radius, scale times eradius
c projc2 is cos of trulat(1)
c projc3 is projc1 times projc2
c
c#######################################################################
c
ELSE IF( jproj.eq.3 ) THEN
DO 300 j=1,jdim
DO 300 i=1,idim
yabs=y(j)+yorig
xabs=x(i)+xorig
rlat(i,j)=(90. - 2.*r2deg*atan(exp(-yabs/projc3)))
rlat(i,j)=amin1(rlat(i,j), 90.)
rlat(i,j)=amax1(rlat(i,j),-90.)
dlon=r2deg*(xabs/projc3)
rlon(i,j)=rota + dlon
IF(rlon(i,j).gt. 180) rlon(i,j)=rlon(i,j)-360.
IF(rlon(i,j).lt.-180) rlon(i,j)=rlon(i,j)+360.
300 CONTINUE
c
c#######################################################################
c
c Lat, Lon Projection.
c For this projection:
c projc1 is the scaled earth's radius, scale times eradius
c projc2 is cos of trulat(1)
c projc3 is projc1 times projc2 times 180/pi
c
c#######################################################################
c
ELSE IF( jproj.eq.4 ) THEN
DO 400 j=1,jdim
DO 400 i=1,idim
rlon(i,j)=x(j)-xorig
rlat(i,j)=y(j)-yorig
400 CONTINUE
ELSE
write(6,'(i4,a)') jproj,' projection is not supported'
STOP
END IF
RETURN
END
c
c ##################################################################
c ##################################################################
c ###### ######
c ###### SUBROUTINE XLLTOXY ######
c ###### ######
c ###### Developed by ######
c ###### Center for Analysis and Prediction of Storms ######
c ###### University of Oklahoma ######
c ###### ######
c ##################################################################
c ##################################################################
c
SUBROUTINE XLLTOXY(idim,jdim,rlat,rlon,xloc,yloc) 14
c
c#######################################################################
c
c PURPOSE:
c
c Determine x, y coordinates on map projection from the given latitude
c and longitude. SETMAPR must be called before this routine to set-up
c the map projection constants.
c
c#######################################################################
c
c AUTHOR: Keith Brewster
c 11/11/93.
c
c MODIFICATION HISTORY:
c
c#######################################################################
c
c INPUT:
c
c idim Array dimension in x direction
c jdim Array dimension in y direction
c
c rlat Real vector of latitude.
c (degrees, negative south, positive north)
c
c rlon Real vector of longitude.
c (degrees, negative west, positive east)
c
c OUTPUT:
c
c xloc Real vector of x in map coordinates
c yloc Real vector of y in map coordinates
c
c#######################################################################
c
c Variable Declarations.
c
c#######################################################################
c
implicit none
integer idim,jdim
real rlat(idim,jdim),rlon(idim,jdim)
real xloc(idim,jdim),yloc(idim,jdim)
real d2rad,eradius
parameter (d2rad=3.141592654/180.,
: eradius = 6371000. ) ! mean earth radius in m
integer jproj,jpole
real trulat(2),rota,scmap,xorig,yorig,
: projc1,projc2,projc3,projc4,projc5
common /xprojcst/ jproj,jpole,trulat,rota,scmap,xorig,yorig,
: projc1,projc2,projc3,projc4,projc5
c
c#######################################################################
c
c Misc. local variables:
c
c#######################################################################
c
integer i,j
real radius,denom,dlon,ratio
real tem
c#######################################################################
c
c
C@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
C
C Beginning of executable code...
C
C@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
c
c#######################################################################
c
c No map projection
c
c#######################################################################
c
IF( jproj.eq.0 ) THEN
ratio=d2rad*eradius
DO 10 j = 1, jdim
DO 10 i = 1, idim
tem = rlon(i,j)
if( tem.lt.-180.0) tem = 360.0+tem
if( tem.gt. 180.0) tem = tem-360.0
xloc(i,j) = ratio*tem - xorig
yloc(i,j) = ratio*rlat(i,j) - yorig
10 CONTINUE
c
c#######################################################################
c
c Polar Stereographic projection
c For this projection:
c projc1 is the scaled earth's radius, scale times eradius
c projc2 is the numerator of emfact, the map image scale factor.
c projc3 is projc2 times the scaled earth's radius.
c
c#######################################################################
c
ELSE IF( jproj.eq.1 ) THEN
DO 100 j=1,jdim
DO 100 i=1,idim
denom=(1. + sin(d2rad*jpole*rlat(i,j)))
IF(denom.eq.0.) denom=1.0E-10
radius=jpole*projc3*cos(d2rad*rlat(i,j))/denom
tem = rlon(i,j)-rota
if( tem.lt.-180.0) tem = 360.0+tem
if( tem.gt. 180.0) tem = tem-360.0
dlon=jpole*d2rad*tem
xloc(i,j)= radius*sin(dlon) - xorig
yloc(i,j)=-radius*cos(dlon) - yorig
100 CONTINUE
c
c#######################################################################
c
c Lambert Conformal Conic Projection.
c For this projection:
c projc1 is the scaled earth's radius, scale times eradius/n
c projc2 is cos of trulat(1)
c projc3 is tan (45. - trulat/2) a const for local map scale
c projc4 is the cone constant, n
c
c#######################################################################
c
ELSE IF( jproj.eq.2 ) THEN
DO 200 j=1,jdim
DO 200 i=1,idim
radius=projc1*projc2
: *(tan(d2rad*(45.-0.5*jpole*rlat(i,j)))/projc3)**projc4
c dlon=projc4*d2rad*(rlon(i,j)-rota)
cmx
tem = rlon(i,j)-rota
if( tem.lt.-180.0) tem = 360.0+tem
if( tem.gt. 180.0) tem = tem-360.0
dlon=projc4*d2rad*tem
xloc(i,j)= radius*sin(dlon) - xorig
yloc(i,j)=-jpole*radius*cos(dlon) - yorig
200 CONTINUE
c
c#######################################################################
c
c Mercator Projection.
c For this projection:
c projc1 is the scaled earth's radius, scale times eradius
c projc2 is cos of trulat(1)
c projc3 is projc1 times projc2
c
c#######################################################################
c
ELSE IF(jproj.eq.3) THEN
DO 300 j=1,jdim
DO 300 i=1,idim
dlon=rlon(i,j)-rota
IF(dlon.lt.-180.) dlon=dlon+360.
IF(dlon.gt. 180.) dlon=dlon-360.
xloc(i,j)=projc3*d2rad*dlon - xorig
denom=tan(d2rad*(45. - 0.5*rlat(i,j)))
IF( denom.le.0. ) denom=1.0E-10
yloc(i,j)=-projc3*alog(denom) - yorig
300 CONTINUE
c
c#######################################################################
c
c Lat, Lon Projection.
c For this projection:
c projc1 is the scaled earth's radius, scale times eradius
c projc2 is cos of trulat(1)
c projc3 is projc1 times projc2 times 180/pi
c
c#######################################################################
c
ELSE IF(jproj.eq.4) THEN
DO 400 j=1,jdim
DO 400 i=1,idim
tem = rlon(i,j)
if( tem.lt.-180.0) tem = 360.0+tem
if( tem.gt. 180.0) tem = tem-360.0
xloc(i,j)=tem -xorig
yloc(i,j)=rlat(i,j)-yorig
400 CONTINUE
ELSE
write(6,'(i4,a)') jproj,' projection is not supported'
STOP
END IF
RETURN
END
c
c ##################################################################
c ##################################################################
c ###### ######
c ###### SUBROUTINE XLATTOMF ######
c ###### ######
c ###### Developed by ######
c ###### Center for Analysis and Prediction of Storms ######
c ###### University of Oklahoma ######
c ###### ######
c ##################################################################
c ##################################################################
c
SUBROUTINE XLATTOMF(idim,jdim,rlat,emfact)
c
c#######################################################################
c
c PURPOSE:
c
c Determine the map scale factor, emfact, at a given latitude.
c
c#######################################################################
c
c AUTHOR: Keith Brewster
c 11/11/93.
c
c MODIFICATION HISTORY:
c
c#######################################################################
c
c INPUT:
c
c idim Array dimension in x direction
c jdim Array dimension in y direction
c
c rlat Real vector of latitudes.
c (degrees, negative south, positive north)
c
c OUTPUT:
c
c emfact Vector of map scale factors corresponding to the
c input latitudes (map scale includes the projection
c image scale times the overall scale of the map).
c
c#######################################################################
c
c Variable Declarations.
c
c#######################################################################
c
implicit none
integer idim,jdim ! dimensions of arrays
real rlat(idim,jdim) ! latitude (degrees)
real emfact(idim,jdim) ! local map scale factor
real d2rad
parameter (d2rad=3.141592654/180.)
integer jproj,jpole
real trulat(2),rota,scmap,xorig,yorig,
: projc1,projc2,projc3,projc4,projc5
common /xprojcst/ jproj,jpole,trulat,rota,scmap,xorig,yorig,
: projc1,projc2,projc3,projc4,projc5
c
c#######################################################################
c
c Misc. local variables:
c
c#######################################################################
c
integer i,j
real denom
c#######################################################################
c
c
C@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
C
C Beginning of executable code...
C
C@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
c
c#######################################################################
c
c No map projection
c
c#######################################################################
c
IF( jproj.eq.0 ) THEN
DO 10 j=1,jdim
DO 10 i=1,idim
emfact(i,j)=1.0
10 CONTINUE
c
c#######################################################################
c
c Polar Stereographic projection
c For this projection:
c projc1 is the scaled earth's radius, scale times eradius
c projc2 is the numerator of emfact, the map image scale factor.
c projc3 is projc2 times the scaled earth's radius.
c
c#######################################################################
c
ELSE IF( jproj.eq.1 ) THEN
DO 100 j=1,jdim
DO 100 i=1,idim
denom=(1. + sin(d2rad*jpole*rlat(i,j)))
IF(denom.eq.0.) denom=1.0E-10
emfact(i,j)=scmap*projc2/denom
100 CONTINUE
c
c#######################################################################
c
c Lambert Conformal Conic Projection.
c For this projection:
c projc1 is the scaled earth's radius, scale times eradius/n
c projc2 is cos of trulat(1)
c projc3 is tan (45. - trulat/2) a const for local map scale
c projc4 is the cone constant, n
c
c#######################################################################
c
ELSE IF( jproj.eq.2 ) THEN
DO 200 j=1,jdim
DO 200 i=1,idim
denom=cos( d2rad*rlat(i,j) )
IF(denom.lt.1.0E-06) THEN
emfact(i,j)=1.0e+10
ELSE
emfact(i,j)=scmap*(projc2/denom)
: *(tan(d2rad*(45.-0.5*jpole*rlat(i,j)))
: /projc3)**projc4
END IF
emfact(i,j)=amax1(emfact(i,j),1.0e-10)
emfact(i,j)=amin1(emfact(i,j),1.0e+10)
200 CONTINUE
c
c#######################################################################
c
c Mercator Projection.
c For this projection:
c projc1 is the scaled earth's radius, scale times eradius
c projc2 is cos of trulat(1)
c
c#######################################################################
c
ELSE IF(jproj.eq.3) THEN
DO 300 j=1,jdim
DO 300 i=1,idim
denom=cos( d2rad*rlat(i,j) )
IF(denom.eq.0.) denom=1.0E-10
emfact(i,j)=projc2/denom
300 CONTINUE
c
c#######################################################################
c
c Lat, Lon Projection.
c For this projection:
c projc1 is the scaled earth's radius, scale times eradius
c projc2 is cos of trulat(1)
c projc3 is projc1 times projc2 times 180/pi
c
c#######################################################################
c
ELSE IF(jproj.eq.4) THEN
DO 400 j=1,jdim
DO 400 i=1,idim
denom=cos( d2rad*rlat(i,j) )
IF(denom.eq.0.) denom=1.0E-10
emfact(i,j)=projc3/denom
400 CONTINUE
ELSE
write(6,'(i4,a)') jproj,' projection is not supported'
STOP
END IF
RETURN
END
c
c ##################################################################
c ##################################################################
c ###### ######
c ###### SUBROUTINE XXYTOMF ######
c ###### ######
c ###### Developed by ######
c ###### Center for Analysis and Prediction of Storms ######
c ###### University of Oklahoma ######
c ###### ######
c ##################################################################
c ##################################################################
c
SUBROUTINE XXYTOMF(idim,jdim,x,y,emfact)
c
c#######################################################################
c
c PURPOSE:
c
c Determine the map scale factor, emfact, given x,y in the projected
c space.
c
c#######################################################################
c
c AUTHOR: Keith Brewster
c 11/11/93.
c
c MODIFICATION HISTORY:
c
c#######################################################################
c
c INPUT:
c
c idim Array dimension in x direction.
c jdim Array dimension in y direction.
c
c x x coordinate values (meters if scmap=1.0)
c y y coordinate values (meters if scmap=1.0)
c
c OUTPUT:
c
c emfact Vector of map scale factors corresponding to the
c input x,y's.
c
c#######################################################################
c
c Variable Declarations.
c
c#######################################################################
c
implicit none
integer idim,jdim ! array dimensions
real x(idim) ! x map coordinate
real y(jdim) ! y map coordinate
real emfact(idim,jdim) ! local map scale factor
real d2rad,r2deg
parameter (d2rad=3.141592654/180.,
: r2deg=180./3.141592654)
integer jproj,jpole
real trulat(2),rota,scmap,xorig,yorig,
: projc1,projc2,projc3,projc4,projc5
common /xprojcst/ jproj,jpole,trulat,rota,scmap,xorig,yorig,
: projc1,projc2,projc3,projc4,projc5
c
c#######################################################################
c
c Misc. local variables:
c
c#######################################################################
c
integer i,j
real xabs,yabs,rlat,ratio,radius,denom
c
C@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
C
C Beginning of executable code...
C
C@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
c
c#######################################################################
c
c No map projection
c
c#######################################################################
IF( jproj.eq.0 ) THEN
DO 10 j=1,jdim
DO 10 i=1,idim
emfact(i,j)=1.0
10 CONTINUE
c
c#######################################################################
c
c Polar Stereographic projection
c For this projection:
c projc1 is the scaled earth's radius, scale times eradius
c projc2 is the numerator of emfact, the map image scale factor.
c projc3 is projc2 times the scaled earth's radius.
c
c#######################################################################
c
ELSE IF( jproj.eq.1 ) THEN
DO 100 j=1,jdim
DO 100 i=1,idim
xabs=x(i)+xorig
yabs=y(j)+yorig
radius=sqrt( xabs*xabs + yabs*yabs )/projc3
rlat = 90. - 2.*r2deg*atan(radius)
rlat=amin1(rlat, 90.)
rlat=amax1(rlat,-90.)
denom=(1. + sin(d2rad*rlat))
IF(denom.eq.0.) denom=1.0E-10
emfact(i,j)=scmap*projc2/denom
100 CONTINUE
c
c#######################################################################
c
c Lambert Conformal Conic Projection.
c For this projection:
c projc1 is the scaled earth's radius, scale times eradius/n
c projc2 is cos of trulat(1)
c projc3 is tan (45. - trulat/2) a const for local map scale
c projc4 is the cone constant, n
c
c#######################################################################
c
ELSE IF( jproj.eq.2 ) THEN
DO 200 j=1,jdim
DO 200 i=1,idim
xabs=x(i)+xorig
yabs=y(j)+yorig
radius=sqrt( xabs*xabs+ yabs*yabs )
ratio=projc3*((radius/(projc1*projc2))**(1./projc4))
rlat=90. -2.*r2deg*(atan(ratio))
rlat=amin1(rlat, 90.)
rlat=amax1(rlat,-90.)
denom=cos( d2rad*rlat )
IF(denom.eq.0.) denom=1.0E-10
emfact(i,j)=scmap*(projc2/denom)
: *(tan(d2rad*(45.-0.5*rlat))/projc3)**projc4
200 CONTINUE
c
c#######################################################################
c
c Mercator Projection.
c For this projection:
c projc1 is the scaled earth's radius, scale times eradius
c projc2 is cos of trulat(1)
c projc3 is projc1 times projc2
c
c#######################################################################
c
ELSE IF(jproj.eq.3) THEN
DO 300 j=1,jdim
yabs=y(j)+yorig
rlat=90. - 2.*r2deg*atan(exp(-yabs/projc3))
rlat=amin1(rlat, 90.)
rlat=amax1(rlat,-90.)
denom=cos( d2rad*rlat )
IF(denom.eq.0.) denom=1.0E-10
DO 300 i=1,idim
emfact(i,j)=projc2/denom
300 CONTINUE
c
c#######################################################################
c
c Lat, Lon Projection.
c For this projection:
c projc1 is the scaled earth's radius, scale times eradius
c projc2 is cos of trulat(1)
c projc3 is projc1 times projc2 times 180/pi
c
c#######################################################################
c
ELSE IF(jproj.eq.4) THEN
DO 400 j=1,jdim
yabs=y(j)+yorig
denom=cos( d2rad*yabs )
IF(denom.eq.0.) denom=1.0E-10
DO 400 i=1,idim
emfact(i,j)=projc3/denom
400 CONTINUE
ELSE
write(6,'(i4,a)') jproj,' projection is not supported'
STOP
END IF
RETURN
END
c
c ##################################################################
c ##################################################################
c ###### ######
c ###### SUBROUTINE XDDROTUV ######
c ###### ######
c ###### Developed by ######
c ###### Center for Analysis and Prediction of Storms ######
c ###### University of Oklahoma ######
c ###### ######
c ##################################################################
c ##################################################################
c
SUBROUTINE XDDROTUV(nsta,stalon,dd,ff,ddrot,umap,vmap)
c
c#######################################################################
c
c PURPOSE:
c
c Rotate wind from earth direction to map orientation.
c
c#######################################################################
c
c AUTHOR: Keith Brewster
c 11/20/93.
c
c MODIFICATION HISTORY:
c 03/30/95 (K. Brewster)
c Removed the map scale factor from the conversion of winds
c from u,v on the earth to projection u,v. Affected argument
c list of ddrotuv.
c
c#######################################################################
c
c INPUT:
c
c nsta array dimension
c
c stalon longitude (degrees E)
c
c dd wind direction (degrees from north)
c ff wind speed
c
c OUTPUT:
c
c ddrot wind direction rotated to map orientation
c
c umap u wind component on map (same units as ff)
c vmap v wind component on map (same units as ff)
c
c#######################################################################
c
c Variable Declarations.
c
c#######################################################################
c
implicit none
integer nsta ! array dimension
real stalon(nsta) ! longitude (degrees E)
real dd(nsta) ! wind direction
real ff(nsta) ! speed
real ddrot(nsta) ! wind direction rotated to map orientation
real umap(nsta) ! u wind component on map
real vmap(nsta) ! v wind component on map
real d2rad,r2deg
parameter (d2rad=3.141592654/180.,
: r2deg=180./3.141592654)
integer jproj,jpole
real trulat(2),rota,scmap,xorig,yorig,
: projc1,projc2,projc3,projc4,projc5
common /xprojcst/ jproj,jpole,trulat,rota,scmap,xorig,yorig,
: projc1,projc2,projc3,projc4,projc5
c
c#######################################################################
c
c Misc. local variables:
c
c#######################################################################
c
integer i
real arg
c#######################################################################
c
c
C@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
C
C Beginning of executable code...
C
C@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
c
c#######################################################################
c
c No map projection.
c Just do conversion from ddff to u,v.
c
c#######################################################################
c
IF( jproj.eq.0 ) THEN
DO 50 i=1,nsta
ddrot(i)=dd(i)
arg = (ddrot(i) * d2rad)
umap(i) = -ff(i) * sin(arg)
vmap(i) = -ff(i) * cos(arg)
50 CONTINUE
c
c#######################################################################
c
c Polar Stereographic projection
c For this projection:
c projc1 is the scaled earth's radius, scale times eradius
c projc2 is the numerator of emfact, the map image scale factor.
c projc3 is projc2 times the scaled earth's radius.
c
c#######################################################################
c
ELSE IF( jproj.eq.1 ) THEN
DO 100 i=1,nsta
ddrot(i)=dd(i) + rota - stalon(i)
arg = (ddrot(i) * d2rad)
umap(i) = -ff(i) * sin(arg)
vmap(i) = -ff(i) * cos(arg)
100 CONTINUE
c
c#######################################################################
c
c Lambert Conformal Conic Projection.
c For this projection:
c projc1 is the scaled earth's radius, scale times eradius/n
c projc2 is cos of trulat(1)
c projc3 is tan (45. - trulat/2) a const for local map scale
c projc4 is the cone constant, n
c
c#######################################################################
c
ELSE IF( jproj.eq.2 ) THEN
DO 200 i=1,nsta
ddrot(i)=dd(i) + projc4*(rota - stalon(i))
arg = (ddrot(i) * d2rad)
umap(i) = -ff(i) * sin(arg)
vmap(i) = -ff(i) * cos(arg)
200 CONTINUE
c
c#######################################################################
c
c Mercator Projection.
c For this projection:
c projc1 is the scaled earth's radius, scale times eradius
c projc2 is cos of trulat(1)
c projc3 is projc1 times projc2
c
c#######################################################################
c
ELSE IF(jproj.eq.3) THEN
DO 300 i=1,nsta
ddrot(i)=dd(i)
arg = (ddrot(i) * d2rad)
umap(i) = -ff(i) * sin(arg)
vmap(i) = -ff(i) * cos(arg)
300 CONTINUE
c
c#######################################################################
c
c Lat, Lon Projection.
c For this projection:
c projc1 is the scaled earth's radius, scale times eradius
c projc2 is cos of trulat(1)
c projc3 is projc1 times projc2 times 180/pi
c
c#######################################################################
c
ELSE IF(jproj.eq.4) THEN
DO 400 i=1,nsta
ddrot(i)=dd(i)
arg = (ddrot(i) * d2rad)
umap(i) = -ff(i) * sin(arg)
vmap(i) = -ff(i) * cos(arg)
400 CONTINUE
ELSE
write(6,'(i4,a)') jproj,' projection is not supported'
STOP
END IF
RETURN
END
c
c ##################################################################
c ##################################################################
c ###### ######
c ###### SUBROUTINE XUVROTDD ######
c ###### ######
c ###### Developed by ######
c ###### Center for Analysis and Prediction of Storms ######
c ###### University of Oklahoma ######
c ###### ######
c ##################################################################
c ##################################################################
c
SUBROUTINE XUVROTDD(idim,jdim,elon,umap,vmap,dd,ff)
c
c#######################################################################
c
c PURPOSE:
c Convert winds u, v in map coordinates to wind direction and speed
c in earth coordinates.
c
c#######################################################################
c
c AUTHOR: Keith Brewster
c 11/20/93.
c
c MODIFICATION HISTORY:
c 03/30/95 (K. Brewster)
c Removed the map scale factor from the conversion of winds
c from u,v on the earth to projection u,v. Affected argument
c list of uvrotdd.
c
c#######################################################################
c
c INPUT:
c idim Array dimension in the x direction
c jdim Array dimension in the y direction
c
c elon Earth longitude (degrees E)
c
c umap u wind component on map
c vmap v wind component on map
c
c OUTPUT:
c dd wind direction on earth
c ff wind speed on earth
c
c#######################################################################
c
c Variable Declarations.
c
c#######################################################################
c
implicit none
integer idim,jdim ! array dimensions
real elon(idim,jdim) ! longitude (degrees E)
real umap(idim,jdim) ! u wind component on map
real vmap(idim,jdim) ! v wind component on map
real dd(idim,jdim) ! direction
real ff(idim,jdim) ! wind speed
real d2rad,r2deg
parameter (d2rad=3.141592654/180.,
: r2deg=180./3.141592654)
integer jproj,jpole
real trulat(2),rota,scmap,xorig,yorig,
: projc1,projc2,projc3,projc4,projc5
common /xprojcst/ jproj,jpole,trulat,rota,scmap,xorig,yorig,
: projc1,projc2,projc3,projc4,projc5
c
c#######################################################################
c
c Misc. local variables:
c
c#######################################################################
c
integer i,j
real dlon
c#######################################################################
c
c
C@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
C
C Beginning of executable code...
C
C@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
c
c#######################################################################
c
c No map projection
c
c#######################################################################
c
IF( jproj.eq.0 ) THEN
DO 50 j=1,jdim
DO 50 i=1,idim
ff(i,j) = sqrt(umap(i,j)*umap(i,j) + vmap(i,j)*vmap(i,j))
IF(vmap(i,j).gt.0.) THEN
dlon=r2deg*atan(umap(i,j)/vmap(i,j))
ELSE IF(vmap(i,j).lt.0.) THEN
dlon=180. + r2deg*atan(umap(i,j)/vmap(i,j))
ELSE IF(umap(i,j).ge.0.) THEN
dlon=90.
ELSE
dlon=-90.
END IF
dd(i,j)= dlon + 180.
dd(i,j)= dd(i,j)-360.*(nint(dd(i,j))/360)
50 CONTINUE
c
c#######################################################################
c
c Polar Stereographic projection
c For this projection:
c projc1 is the scaled earth's radius, scale times eradius
c projc2 is the numerator of emfact, the map image scale factor.
c projc3 is projc2 times the scaled earth's radius.
c
c#######################################################################
c
ELSE IF( jproj.eq.1 ) THEN
DO 100 j=1,jdim
DO 100 i=1,idim
ff(i,j) = sqrt(umap(i,j)*umap(i,j) + vmap(i,j)*vmap(i,j))
IF(vmap(i,j).gt.0.) THEN
dlon=r2deg*atan(umap(i,j)/vmap(i,j))
ELSE IF(vmap(i,j).lt.0.) THEN
dlon=180. + r2deg*atan(umap(i,j)/vmap(i,j))
ELSE IF(umap(i,j).ge.0.) THEN
dlon=90.
ELSE
dlon=-90.
END IF
dd(i,j)= dlon + 180. + elon(i,j) - rota
dd(i,j)= dd(i,j)-360.*(nint(dd(i,j))/360)
100 CONTINUE
c
c#######################################################################
c
c Lambert Conformal Conic Projection.
c For this projection:
c projc1 is the scaled earth's radius, scale times eradius/n
c projc2 is cos of trulat(1)
c projc3 is tan (45. - trulat/2) a const for local map scale
c projc4 is the cone constant, n
c
c#######################################################################
c
ELSE IF( jproj.eq.2 ) THEN
DO 200 j=1,jdim
DO 200 i=1,idim
ff(i,j) = sqrt(umap(i,j)*umap(i,j) + vmap(i,j)*vmap(i,j))
IF(vmap(i,j).gt.0.) THEN
dlon=r2deg*atan(umap(i,j)/vmap(i,j))
ELSE IF(vmap(i,j).lt.0.) THEN
dlon=180. + r2deg*atan(umap(i,j)/vmap(i,j))
ELSE IF(umap(i,j).ge.0.) THEN
dlon=90.
ELSE
dlon=-90.
END IF
dd(i,j)= dlon + 180. + projc4*(elon(i,j) - rota)
dd(i,j)= dd(i,j)-360.*(nint(dd(i,j))/360)
200 CONTINUE
c
c#######################################################################
c
c Mercator Projection.
c For this projection:
c projc1 is the scaled earth's radius, scale times eradius
c projc2 is cos of trulat(1)
c projc3 is projc1 times projc2
c
c#######################################################################
c
ELSE IF(jproj.eq.3) THEN
DO 300 j=1,jdim
DO 300 i=1,idim
ff(i,j) = sqrt(umap(i,j)*umap(i,j) + vmap(i,j)*vmap(i,j))
IF(vmap(i,j).gt.0.) THEN
dlon=r2deg*atan(umap(i,j)/vmap(i,j))
ELSE IF(vmap(i,j).lt.0.) THEN
dlon=180. + r2deg*atan(umap(i,j)/vmap(i,j))
ELSE IF(umap(i,j).ge.0.) THEN
dlon=90.
ELSE
dlon=-90.
END IF
dd(i,j)= dlon + 180.
dd(i,j)= dd(i,j)-360.*(nint(dd(i,j))/360)
300 CONTINUE
c
c#######################################################################
c
c Lat, Lon Projection.
c For this projection:
c projc1 is the scaled earth's radius, scale times eradius
c projc2 is cos of trulat(1)
c projc3 is projc1 times projc2 times 180/pi
c
c#######################################################################
c
ELSE IF(jproj.eq.4) THEN
DO 400 j=1,jdim
DO 400 i=1,idim
ff(i,j) = sqrt(umap(i,j)*umap(i,j) + vmap(i,j)*vmap(i,j))
IF(vmap(i,j).gt.0.) THEN
dlon=r2deg*atan(umap(i,j)/vmap(i,j))
ELSE IF(vmap(i,j).lt.0.) THEN
dlon=180. + r2deg*atan(umap(i,j)/vmap(i,j))
ELSE IF(umap(i,j).ge.0.) THEN
dlon=90.
ELSE
dlon=-90.
END IF
dd(i,j)= dlon + 180.
dd(i,j)= dd(i,j)-360.*(nint(dd(i,j))/360)
400 CONTINUE
ELSE
write(6,'(i4,a)') jproj,' projection is not supported'
STOP
END IF
RETURN
END
c
c ##################################################################
c ##################################################################
c ###### ######
c ###### SUBROUTINE XUVETOMP ######
c ###### ######
c ###### Developed by ######
c ###### Center for Analysis and Prediction of Storms ######
c ###### University of Oklahoma ######
c ###### ######
c ##################################################################
c ##################################################################
c
SUBROUTINE XUVETOMP(idim,jdim,uear,vear,lon,umap,vmap)
c
c#######################################################################
c
c PURPOSE:
c
c Transform u, v wind from earth coordinates to map coordinates.
c
c#######################################################################
c
c AUTHOR: Keith Brewster
c 04/30/94.
c
c MODIFICATION HISTORY:
c 03/30/95 (K. Brewster)
c Removed the map scale factor from the conversion of winds
c from u,v on the earth to projection u,v. Affected argument
c list of uvetomp.
c 04/30/96 (KB)
c Streamlined the computation for iproj=1 and iproj=2.
c 12/11/96 (KB)
c Corrected a bug in the computation for iproj=1 and iproj=2.
c
c#######################################################################
c
c INPUT:
c
c idim Array dimension in the x direction
c jdim Array dimension in the y direction
c
c uear u (eastward) wind component on earth
c vear v (northwrd) wind component on earth
c
c lon earth longitude
c
c OUTPUT:
c
c umap u wind component on map
c vmap v wind component on map
c
c#######################################################################
c
c Variable Declarations.
c
c#######################################################################
c
implicit none
integer idim,jdim ! array dimensions
real uear(idim,jdim) ! u (eastward) wind component on earth
real vear(idim,jdim) ! v (northward) wind component on earth
real lon(idim,jdim) ! longitude (degrees east)
real umap(idim,jdim) ! u wind component on map
real vmap(idim,jdim) ! v wind component on map
real d2rad,r2deg
parameter (d2rad=3.141592654/180.,
: r2deg=180./3.141592654)
integer jproj,jpole
real trulat(2),rota,scmap,xorig,yorig,
: projc1,projc2,projc3,projc4,projc5
common /xprojcst/ jproj,jpole,trulat,rota,scmap,xorig,yorig,
: projc1,projc2,projc3,projc4,projc5
c
c#######################################################################
c
c Misc. local variables:
c
c#######################################################################
c
integer i,j
real dlon,arg,dxdlon,dydlon,utmp,vtmp
c
C@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
C
C Beginning of executable code...
C
C@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
c
c#######################################################################
c
c No map projection
c
c#######################################################################
c
IF( jproj.eq.0 ) THEN
DO 50 j=1,jdim
DO 50 i=1,idim
umap(i,j) = uear(i,j)
vmap(i,j) = vear(i,j)
50 CONTINUE
c
c#######################################################################
c
c Polar Stereographic projection
c For this projection:
c projc1 is the scaled earth's radius, scale times eradius
c projc2 is the numerator of emfact, the map image scale factor.
c projc3 is projc2 times the scaled earth's radius.
c
c#######################################################################
c
ELSE IF( jproj.eq.1 ) THEN
DO 100 j=1,jdim
DO 100 i=1,idim
dlon=(lon(i,j)-rota)
arg=d2rad*dlon
dxdlon=cos(arg)
dydlon=sin(arg)
utmp=uear(i,j)
vtmp=vear(i,j)
umap(i,j)=utmp*dxdlon - vtmp*dydlon
vmap(i,j)=vtmp*dxdlon + utmp*dydlon
100 CONTINUE
c
c#######################################################################
c
c Lambert Conformal Conic Projection.
c For this projection:
c projc1 is the scaled earth's radius, scale times eradius/n
c projc2 is cos of trulat(1)
c projc3 is tan (45. - trulat/2) a const for local map scale
c projc4 is the cone constant, n
c
c#######################################################################
c
ELSE IF( jproj.eq.2 ) THEN
DO 200 j=1,jdim
DO 200 i=1,idim
dlon=(lon(i,j)-rota)
arg=d2rad*projc4*(dlon - 360.*nint(dlon/360.))
dxdlon=cos(arg)
dydlon=sin(arg)
utmp=uear(i,j)
vtmp=vear(i,j)
umap(i,j)=utmp*dxdlon - vtmp*dydlon
vmap(i,j)=vtmp*dxdlon + utmp*dydlon
200 CONTINUE
c
c#######################################################################
c
c Mercator Projection.
c For this projection:
c projc1 is the scaled earth's radius, scale times eradius
c projc2 is cos of trulat(1)
c projc3 is projc1 times projc2
c
c#######################################################################
c
ELSE IF(jproj.eq.3) THEN
DO 300 j=1,jdim
DO 300 i=1,idim
umap(i,j) = uear(i,j)
vmap(i,j) = vear(i,j)
300 CONTINUE
c
c#######################################################################
c
c Lat, Lon Projection.
c For this projection:
c projc1 is the scaled earth's radius, scale times eradius
c projc2 is cos of trulat(1)
c projc3 is projc1 times projc2 times 180/pi
c
c#######################################################################
c
ELSE IF(jproj.eq.4) THEN
DO 400 j=1,jdim
DO 400 i=1,idim
umap(i,j) = uear(i,j)
vmap(i,j) = vear(i,j)
400 CONTINUE
ELSE
write(6,'(i4,a)') jproj,' projection is not supported'
STOP
END IF
RETURN
END
c
c ##################################################################
c ##################################################################
c ###### ######
c ###### SUBROUTINE XUVMPTOE ######
c ###### ######
c ###### Developed by ######
c ###### Center for Analysis and Prediction of Storms ######
c ###### University of Oklahoma ######
c ###### ######
c ##################################################################
c ##################################################################
c
SUBROUTINE XUVMPTOE(idim,jdim,umap,vmap,lon,uear,vear)
c
c#######################################################################
c
c PURPOSE:
c
c Transform u, v wind from map coordinates to earth coordinates.
c
c#######################################################################
c
c AUTHOR: Keith Brewster
c 04/30/94.
c
c MODIFICATION HISTORY:
c 03/30/95 (K. Brewster)
c Removed the map scale factor from the conversion of winds
c from u,v on the map to earth u,v. Affected argument
c list of uvmptoe.
c 04/30/96 (KB)
c Streamlined the computation for iproj=1 and iproj=2.
c 12/11/96 (KB)
c Corrected a bug in the computation for iproj=1 and iproj=2.
c
c#######################################################################
c
c INPUT:
c
c idim Array dimension in x direction
c jdim Array dimension in y direction
c
c umap u wind component on map
c vmap v wind component on map
c
c lon Longitude (degrees E)
c
c OUTPUT:
c
c uear u (eastward) wind component on earth
c vear v (northward) wind component on earth
c
c#######################################################################
c
c Variable Declarations.
c
c#######################################################################
c
implicit none
integer idim,jdim ! array dimensions
real lon(idim,jdim) ! longitude (degrees E)
real umap(idim,jdim) ! u wind component on map
real vmap(idim,jdim) ! v wind component on map
real uear(idim,jdim) ! u (eastward) wind component on earth
real vear(idim,jdim) ! v (northward) wind component on earth
real d2rad,r2deg
parameter (d2rad=3.141592654/180.,
: r2deg=180./3.141592654)
integer jproj,jpole
real trulat(2),rota,scmap,xorig,yorig,
: projc1,projc2,projc3,projc4,projc5
common /xprojcst/ jproj,jpole,trulat,rota,scmap,xorig,yorig,
: projc1,projc2,projc3,projc4,projc5
c
c#######################################################################
c
c Misc. local variables:
c
c#######################################################################
c
integer i,j
real dlon,arg,utmp,vtmp,dxdlon,dydlon
c
C@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
C
C Beginning of executable code...
C
C@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
c
c#######################################################################
c
c No map projection
c
c#######################################################################
c
IF( jproj.eq.0 ) THEN
DO 50 j=1,jdim
DO 50 i=1,idim
uear(i,j) = umap(i,j)
vear(i,j) = vmap(i,j)
50 CONTINUE
c
c#######################################################################
c
c Polar Stereographic projection
c For this projection:
c projc1 is the scaled earth's radius, scale times eradius
c projc2 is the numerator of emfact, the map image scale factor.
c projc3 is projc2 times the scaled earth's radius.
c
c#######################################################################
c
ELSE IF( jproj.eq.1 ) THEN
DO 100 j=1,jdim
DO 100 i=1,idim
dlon=(lon(i,j)-rota)
arg=d2rad*dlon
dxdlon=cos(arg)
dydlon=sin(arg)
utmp=umap(i,j)
vtmp=vmap(i,j)
uear(i,j)=utmp*dxdlon + vtmp*dydlon
vear(i,j)=vtmp*dxdlon - utmp*dydlon
100 CONTINUE
c
c#######################################################################
c
c Lambert Conformal Conic Projection.
c For this projection:
c projc1 is the scaled earth's radius, scale times eradius/n
c projc2 is cos of trulat(1)
c projc3 is tan (45. - trulat/2) a const for local map scale
c projc4 is the cone constant, n
c
c#######################################################################
c
ELSE IF( jproj.eq.2 ) THEN
DO 200 j=1,jdim
DO 200 i=1,idim
dlon=(lon(i,j)-rota)
arg=d2rad*projc4*(dlon - 360.*nint(dlon/360.))
dxdlon=cos(arg)
dydlon=sin(arg)
utmp=umap(i,j)
vtmp=vmap(i,j)
uear(i,j)=utmp*dxdlon + vtmp*dydlon
vear(i,j)=vtmp*dxdlon - utmp*dydlon
200 CONTINUE
c
c#######################################################################
c
c Mercator Projection.
c For this projection:
c projc1 is the scaled earth's radius, scale times eradius
c projc2 is cos of trulat(1)
c projc3 is projc1 times projc2
c
c#######################################################################
c
ELSE IF(jproj.eq.3) THEN
DO 300 j=1,jdim
DO 300 i=1,idim
uear(i,j) = umap(i,j)
vear(i,j) = vmap(i,j)
300 CONTINUE
c
c#######################################################################
c
c Lat, Lon Projection.
c For this projection:
c projc1 is the scaled earth's radius, scale times eradius
c projc2 is cos of trulat(1)
c projc3 is projc1 times projc2 times 180/pi
c
c#######################################################################
c
ELSE IF(jproj.eq.4) THEN
DO 400 j=1,jdim
DO 400 i=1,idim
uear(i,j) = umap(i,j)
vear(i,j) = vmap(i,j)
400 CONTINUE
ELSE
write(6,'(i4,a)') jproj,' projection is not supported'
STOP
END IF
RETURN
END
SUBROUTINE XDRAWMAP_old(nunit, mapfile, latgrid, longrid),16
c
c-----------------------------------------------------------------------
c This subroutine will draw a map within a rectagular box in
c a map projection space. The map projection and plotting space
c should have been properly set before calling this subroutine.
c-----------------------------------------------------------------------
c
c nunit the channel of the mapfile data
c mapfile character of map file name
c latgrid,longrid (degree): the intervals between lat and lon grid lines.
c < 0.0, no grid lines in the given direction,
c = 0.0, internally determined,
c = any real number, typically from 1.0 to 10.0 degrees.
c-----------------------------------------------------------------------
c Author: Ming Xue
c-----------------------------------------------------------------------
implicit none
integer nunit
character mapfile*(*)
real latgrid,longrid
integer nmax
parameter (nmax = 100)
real xloc(nmax),yloc(nmax),lat(nmax),long(nmax)
real lonmin,lonmax,latmin,latmax
real x1,x2,y1,y2,xw1,xw2,yw1,yw2
integer iseg,ilast,ndata,i,j
real pi2deg,x,y
integer jmax,imax,iwndwon
integer lsample
parameter ( lsample = 21)
real xlat(lsample),ylon(lsample)
: ,rlat(lsample,lsample),rlon(lsample,lsample)
real latgrid1,longrid1
real trulon
common /pass/trulon
CALL xqmap (x1,x2,y1,y2)
CALL xqwdwon( iwndwon )
CALL xqwndw(xw1,xw2,yw1,yw2)
CALL xwindw(x1,x2,y1,y2)
OPEN(nunit,file=mapfile,form='formatted',status='old')
ILAST=-999
ndata = 0
pi2deg = 180.0/3.1415926535
200 CONTINUE
READ (nunit,*,END=900) ISEG,X,Y
IF( iseg.ne.ilast ) GOTO 300
ndata = ndata+1
long(ndata) = x*pi2deg
lat (ndata) = y*pi2deg
IF(ndata.eq.nmax ) GOTO 300
GOTO 200
300 CONTINUE
IF( ndata.gt.1) THEN
CALL xlltoxy(ndata,1,lat,long,xloc,yloc)
CALL xpenup(xloc(1)*0.001 ,yloc(1)*0.001 )
DO 350 i=2,ndata
CALL xpendn(xloc(i)*0.001 ,yloc(i)*0.001 )
350 CONTINUE
ENDIF
ndata = 1
long(ndata) = x*pi2deg
lat (ndata) = y*pi2deg
ilast = iseg
IF( iseg.eq.-10) GOTO 900
GOTO 200
900 CONTINUE
REWIND nunit
c To draw grid lines
do i=1,lsample
do j=1,lsample
xlat(i)=(x1+(i-1)*(x2-x1)/(lsample-1))*1000.0
ylon(j)=(y1+(j-1)*(y2-y1)/(lsample-1))*1000.0
enddo
enddo
CALL xxytoll(lsample,lsample,xlat,ylon,rlat,rlon)
lonmin = rlon(1,1)
lonmax = rlon(1,1)
latmin = rlat(1,1)
latmax = rlat(1,1)
do i=1,lsample
do j=1,lsample
lonmin=min(lonmin, rlon(i,j))
lonmax=max(lonmax, rlon(i,j))
latmin=min(latmin, rlat(i,j))
latmax=max(latmax, rlat(i,j))
enddo
enddo
c print*,'lonmin, latmin, lonmax, latmax=',
c : lonmin, latmin, lonmax, latmax
latgrid1 = latgrid
longrid1 = longrid
IF( latgrid.eq.0.0 ) latgrid1=5.0
IF( longrid.eq.0.0 ) longrid1=5.0
if(lonmin.lt.0.0) lonmin = lonmin-longrid1
if(latmin.lt.0.0) latmin = latmin-latgrid1
if(lonmax.gt.0.0) lonmax = lonmax+longrid1
if(latmax.gt.0.0) latmax = latmax+latgrid1
lonmin=int(lonmin/longrid1)*longrid1
lonmax=int(lonmax/longrid1)*longrid1
latmin=int(latmin/latgrid1)*latgrid1
latmax=int(latmax/latgrid1)*latgrid1
c print*,'lonmin, latmin, lonmax, latmax=',
c : lonmin, latmin, lonmax, latmax
CALL xbrokn(6,3,6,3)
IF( latgrid .lt. 0.0) GOTO 650
jmax=nint((latmax-latmin)/latgrid1)
DO 600 j=1,jmax+1
DO 610 i=1,100
lat (i) = latmin + (j-1)*latgrid1
long(i) = lonmin + (i-1)/99.0*(lonmax-lonmin)
610 CONTINUE
CALL xlltoxy( 100,1, lat, long, xloc, yloc)
CALL xpenup(xloc(1)*0.001 ,yloc(1)*0.001 )
DO 620 i=2,100
xloc(i) = xloc(i)*0.001
yloc(i) = yloc(i)*0.001
CALL xpendn(xloc(i),yloc(i))
620 CONTINUE
600 CONTINUE
650 CONTINUE
IF( longrid .lt. 0.0) GOTO 750
imax=nint((lonmax-lonmin)/longrid1)
DO 700 i=1,imax+1
DO 710 j=1,11
lat (j) = latmin + (j-1)*(latmax-latmin)/10.0
long(j) = lonmin + (i-1)*longrid1
710 CONTINUE
CALL xlltoxy( 11,1, lat, long, xloc, yloc)
CALL xpenup(xloc(1)*0.001 ,yloc(1)*0.001 )
DO 720 j=2,11
xloc(j) = xloc(j)*0.001
yloc(j) = yloc(j)*0.001
CALL xpendn(xloc(j),yloc(j))
720 CONTINUE
700 CONTINUE
750 CONTINUE
CALL XFULL
IF( iwndwon.eq.1) then
CALL xwindw(xw1,xw2,yw1,yw2)
else
CALL xwdwof
endif
RETURN
END
SUBROUTINE XDRAWMAP(nunit, mapfile, latgrid, longrid) 7,14
c
c-----------------------------------------------------------------------
c This subroutine will draw a map within a rectagular box in
c a map projection space. The map projection and plotting space
c should have been properly set before calling this subroutine.
c-----------------------------------------------------------------------
c
c nunit the channel of the mapfile data
c mapfile character of map file name
c latgrid,longrid (degree): the intervals between lat and lon grid lines.
c < 0.0, no grid lines in the given direction,
c = 0.0, internally determined,
c = any real number, typically from 1.0 to 10.0 degrees.
c-----------------------------------------------------------------------
c Author: Ming Xue
c 1/18/199 (M. Xue)
c Changed to used new format of map data obtained from NCAR
c-----------------------------------------------------------------------
implicit none
integer nunit
character mapfile*(*)
real latgrid,longrid
integer nmax
parameter (nmax = 100)
real xloc(nmax),yloc(nmax),lat(nmax),long(nmax)
real lonmin,lonmax,latmin,latmax
real x1,x2,y1,y2,xw1,xw2,yw1,yw2
integer ndata,i,j
integer jmax,imax,iwndwon
integer lsample
parameter ( lsample = 21)
real xlat(lsample),ylon(lsample)
: ,rlat(lsample,lsample),rlon(lsample,lsample)
real latgrid1,longrid1
integer NPTS,IGID
real XLATMX,XLATMN,XLONMX,XLONMN
real trulon
common /pass/trulon
CALL xqmap (x1,x2,y1,y2)
CALL xqwdwon( iwndwon )
CALL xqwndw(xw1,xw2,yw1,yw2)
CALL xwindw(x1,x2,y1,y2)
do i=1,lsample
do j=1,lsample
xlat(i)=(x1+(i-1)*(x2-x1)/(lsample-1))*1000.0
ylon(j)=(y1+(j-1)*(y2-y1)/(lsample-1))*1000.0
enddo
enddo
CALL xxytoll(lsample,lsample,xlat,ylon,rlat,rlon)
lonmin = rlon(1,1)
lonmax = rlon(1,1)
latmin = rlat(1,1)
latmax = rlat(1,1)
do i=1,lsample
do j=1,lsample
lonmin=min(lonmin, rlon(i,j))
lonmax=max(lonmax, rlon(i,j))
latmin=min(latmin, rlat(i,j))
latmax=max(latmax, rlat(i,j))
enddo
enddo
OPEN(nunit,file=mapfile,form='formatted',status='old')
read (nunit,'(a)') ! Skip header line 1
read (nunit,'(a)') ! Skip header line 2
200 CONTINUE
10 READ (nunit,1001,END=900)
: NPTS,IGID,XLATMX,XLATMN,XLONMX,XLONMN
c
c igid=1: CONTINENTAL OUTLINES
C =2: US STATE BOUNDARIES (HIGHER RESOLUTION THAN 1)
C =3: INTERNATIONAL POLITICAL BOUNDARIES
1001 FORMAT(2I8,4F8.3)
IF( npts .lt.2 ) GOTO 200
ndata = (npts+1)/2
READ (nunit,1002,END=900)(lat(I),long(I),I=1,ndata)
1002 FORMAT(10F8.3)
if( (xlatmn-latmin)*(xlatmn-latmax).lt.0.0 .or.
: (xlatmx-latmin)*(xlatmx-latmax).lt.0.0 .or.
: (xlonmn-lonmin)*(xlonmn-lonmax).lt.0.0 .or.
: (xlonmx-lonmin)*(xlonmx-lonmax).lt.0.0 ) then
CALL xlltoxy(ndata,1,lat,long,xloc,yloc)
CALL xpenup(xloc(1)*0.001 ,yloc(1)*0.001 )
DO 350 i=2,ndata
CALL xpendn(xloc(i)*0.001 ,yloc(i)*0.001 )
350 CONTINUE
endif
GOTO 200
900 CONTINUE
CLOSE (nunit)
c To draw grid lines
latgrid1 = latgrid
longrid1 = longrid
IF( latgrid.eq.0.0 ) latgrid1=5.0
IF( longrid.eq.0.0 ) longrid1=5.0
if(lonmin.lt.0.0) lonmin = lonmin-longrid1
if(latmin.lt.0.0) latmin = latmin-latgrid1
if(lonmax.gt.0.0) lonmax = lonmax+longrid1
if(latmax.gt.0.0) latmax = latmax+latgrid1
lonmin=int(lonmin/longrid1)*longrid1
lonmax=int(lonmax/longrid1)*longrid1
latmin=int(latmin/latgrid1)*latgrid1
latmax=int(latmax/latgrid1)*latgrid1
CALL xbrokn(6,3,6,3)
IF( latgrid .lt. 0.0) GOTO 650
jmax=nint((latmax-latmin)/latgrid1)
DO 600 j=1,jmax+1
DO 610 i=1,100
lat (i) = latmin + (j-1)*latgrid1
long(i) = lonmin + (i-1)/99.0*(lonmax-lonmin)
610 CONTINUE
CALL xlltoxy( 100,1, lat, long, xloc, yloc)
CALL xpenup(xloc(1)*0.001 ,yloc(1)*0.001 )
DO 620 i=2,100
xloc(i) = xloc(i)*0.001
yloc(i) = yloc(i)*0.001
CALL xpendn(xloc(i),yloc(i))
620 CONTINUE
600 CONTINUE
650 CONTINUE
IF( longrid .lt. 0.0) GOTO 750
imax=nint((lonmax-lonmin)/longrid1)
DO 700 i=1,imax+1
DO 710 j=1,11
lat (j) = latmin + (j-1)*(latmax-latmin)/10.0
long(j) = lonmin + (i-1)*longrid1
710 CONTINUE
CALL xlltoxy( 11,1, lat, long, xloc, yloc)
CALL xpenup(xloc(1)*0.001 ,yloc(1)*0.001 )
DO 720 j=2,11
xloc(j) = xloc(j)*0.001
yloc(j) = yloc(j)*0.001
CALL xpendn(xloc(j),yloc(j))
720 CONTINUE
700 CONTINUE
750 CONTINUE
CALL XFULL
c IF( iwndwon.eq.1) then
c CALL xwindw(xw1,xw2,yw1,yw2)
c else
c CALL xwdwof
c endif
RETURN
END
subroutine xintsy(a)
return
end
subroutine xcontc1(z,x,y,md,m,n,c1,c2) 2,1
!
! This routine has the same functionality of xcontx, but
! use a simpler but less efficient algorithm
!
! To do: add missing value skipping capability
!
dimension z(md,*),x(md,*),y(md,*)
real xcell(4), ycell(4),zcell(4)
DO j=1,n-1
DO i=1,m-1
xcell(1) = x(i,j)
xcell(2) = x(i+1,j)
xcell(3) = x(i+1,j+1)
xcell(4) = x(i,j+1)
ycell(1) = y(i,j)
ycell(2) = y(i+1,j)
ycell(3) = y(i+1,j+1)
ycell(4) = y(i,j+1)
zcell(1) = z(i,j)
zcell(2) = z(i+1,j)
zcell(3) = z(i+1,j+1)
zcell(4) = z(i,j+1)
call fillcell(xcell, ycell, zcell, c1, c2)
ENDDO
ENDDO
RETURN
END
subroutine fillcell(xc,yc,zc, cl1, cl2) 1,3
!
! Fill areas between cl1 and cl2 with a specified color
! within a cell defined by four points
!
implicit none
real xc(4), yc(4), zc(4), cl1, cl2
REAL D,p1,p2,b1,b2,cv
REAL zmin,zmax,x1,x2,y1,y2,z1,z2,cl,z12min,z12max
REAL xp(20),yp(20)
INTEGER np,i,i1,i2,no_cl1_found,no_cl2_found
INTEGER cl1_already_found,cl2_already_found,first_cl,current_cl
D(P1,P2,B1,B2,CV)=B1+(CV-P1)*(B2-B1)/(P2-P1)
zmin = min(zc(1),zc(2),zc(3),zc(4))
zmax = max(zc(1),zc(2),zc(3),zc(4))
IF( cl1 .gt. zmax ) return
IF( cl2 .lt. zmin ) return
IF( zmax.le.cl2.and.zmin.ge.cl1) then
call xfilarea(xc,yc,4)
return
endif
np = 0
no_cl1_found = 0
no_cl2_found = 0
first_cl = 0
current_cl = 0
DO i=1,4
i1=i
i2=i+1
if(i2.gt.4)i2=i2-4
x1=xc(i1)
x2=xc(i2)
y1=yc(i1)
y2=yc(i2)
z1=zc(i1)
z2=zc(i2)
c write(6,'(a,2i3,6f7.3)')
c : 'i1,i2,x1,y1,x2,y2,z1,z2=',i1,i2,x1,y1, x2,y2,z1,z2
z12min = min(z1,z2)
z12max = max(z1,z2)
! IF( z12min.gt.cl2) CYCLE
! IF( z12max.lt.cl1) CYCLE
IF( z12min.gt.cl2) goto 121
IF( z12max.lt.cl1) goto 121
IF( i.eq.1.and.(z1.le.cl2.and.z1.ge.cl1)) then
np = np + 1
xp(np)=x1
yp(np)=y1
current_cl = 3 ! corner point
c print*,'np,xp,yp=',np,xp(np),yp(np),first_cl
endif
IF( z12max.le.cl2.and.z12min.ge.cl1) then
c np = np + 1
c xp(np)=x1
c yp(np)=y1
np = np + 1
xp(np)=x2
yp(np)=y2
current_cl = 3 ! corner point
! cycle
goto 121
ENDIF
IF( z2.gt.z1) THEN
cl = cl1 ! look for cl1 first
cl2_already_found = 0
c IF( (cl-z1)*(cl-z2).lt.0 ) then
IF( cl.ge.z1.and.cl.le.z2 ) then
np = np + 1
xp(np)=d(z1,z2,x1,x2,cl)
yp(np)=d(z1,z2,y1,y2,cl)
no_cl1_found = no_cl1_found + 1
if( first_cl.eq.0) first_cl = 1
current_cl = 1
cl = cl2 ! now look for cl2
c IF( (cl-z1)*(cl-z2).lt.0 ) then
IF( cl.ge.z1.and.cl.le.z2 ) then
np = np + 1
xp(np)=d(z1,z2,x1,x2,cl)
yp(np)=d(z1,z2,y1,y2,cl)
no_cl2_found = no_cl2_found + 1
cl2_already_found = 1
if( first_cl.eq.0) first_cl = 2
current_cl = 2
else
np = np + 1
xp(np)=x2
yp(np)=y2
current_cl = 3 ! corner point
endif
endif
cl = cl2 ! now look for cl2
c IF( cl2_already_found.eq.0.and.(cl-z1)*(cl-z2).lt.0) then
IF(cl2_already_found.eq.0.and.(cl.ge.z1.and.cl.le.z2))then
np = np + 1
xp(np)=d(z1,z2,x1,x2,cl)
yp(np)=d(z1,z2,y1,y2,cl)
no_cl2_found = no_cl2_found + 1
if( first_cl.eq.0) first_cl = 2
current_cl = 2
endif
else ! z2.le.z1 case
cl = cl2 ! look for cl2 first
cl1_already_found = 0
c IF( (cl-z1)*(cl-z2).lt.0 ) then
IF( cl.ge.z2.and.cl.le.z1 ) then
np = np + 1
xp(np)=d(z1,z2,x1,x2,cl)
yp(np)=d(z1,z2,y1,y2,cl)
no_cl2_found = no_cl2_found + 1
if( first_cl.eq.0) first_cl = 2
current_cl = 2
cl = cl1 ! now look for cl1
c IF( (cl-z1)*(cl-z2).lt.0 ) then
IF( cl.ge.z2.and.cl.le.z1 ) then
np = np + 1
xp(np)=d(z1,z2,x1,x2,cl)
yp(np)=d(z1,z2,y1,y2,cl)
cl1_already_found = 1
no_cl1_found = no_cl1_found + 1
if( first_cl.eq.0) first_cl = 1
current_cl = 1
else
np = np + 1
xp(np)=x2
yp(np)=y2
current_cl = 3 ! corner point
endif
endif
cl = cl1 ! now look for cl1
c IF(cl1_already_found.eq.0.and.(cl-z1)*(cl-z2).lt.0) then
IF(cl1_already_found.eq.0.and.(cl.ge.z2.and.cl.le.z1))then
np = np + 1
xp(np)=d(z1,z2,x1,x2,cl)
yp(np)=d(z1,z2,y1,y2,cl)
no_cl1_found = no_cl1_found + 1
if( first_cl.eq.0) first_cl = 1
current_cl = 1
endif
endif
IF( no_cl2_found .eq.2 .or. no_cl1_found.eq.2 ) then
IF( current_cl .eq. first_cl ) then
call xfilarea(xp,yp,np)
no_cl1_found = 0
no_cl2_found = 0
first_cl=0
current_cl=0
np = 0
ENDIF
ENDIF
121 CONTINUE
ENDDO ! loop over four sides
111 continue
IF(np.ne.0) then
call xfilarea(xp,yp,np)
endif
return
end
subroutine xcontcopt(kcontcopt)
integer icontcopt
common /xcontc_opt/ icontcopt
icontcopt = kcontcopt
return
end