Porting DISSPLA Programs to DISLIN
C-------------------------------------------------------------------------
C This file contains some notes and interface routines for porting DISSPLA
C programs to DISLIN.
C
C One big difference between DISLIN and DISSPLA are the plot coordinates:
C DISLIN uses normally integer coordinates with 100 points per cm where the
C point (0, 0) is located in the upper left corner. DISSPLA uses by default
C inch with the origin in the lower left corner.
C Additional, many routines in DISLIN have different names and parameters.
C
C The following routines have the same names in DISLIN and DISSPLA, but a
C different parameter list or meaning. These routines must be renamed in the
C DISSPLA code. A trailing '_DP' is used in the interface. The routines
C are:
C
C PAGE, UNITS, MESSAG, ANGLE, GRAF, CURVE, FRAME, GRACE, HEIGHT, RESET,
C STRTPT, CONNPT, VECTOR, RLVEC, GRAF3D, RLMESS, LEGEND, SPLINE, BARS
C VBARS, HBARS, POLAR, THKCRV, GRID, GETMAT, SURMAT
C
C The interface contains wrapper routines for the following routines and
C functions.
C
C PAGE, UNITS, MESSAG, GRAF, CURVE, FRAME, GRACE, HEIGHT, ENDGR, ANGLE,
C PSPLOT, PHYSOR, AREA2D, HWROT, NEWCLR, SETCLR, THKFRM, REALNO, INTNO,
C ENDPL, DONEPL, XTICKS, YTICKS, ZTICKS, INTAXS, XINTAX, YINTAX, ZINTAX,
C XREVTK, YREVTK, ZREVTK, XAXEND, YAXEND, ZAXEND, XNONUM, YNONUM, ZNONUM,
C XAXCTR, YAXCTR, ZAXCTR, RLREAL, RLINT, RLMESS, XLABGR, YLABGR, XYLAB
C XNAME, YNAME, SWISSL, SWISSM, SCLPIC, XAXANG, YAXANG, ZAXANG, XLOG, YLOG,
C LOGLOG, NOBRDR, OREL, STRTPT, CONNPT, VECTOR, RLVEC, THKVEC, RESET, XMESS
C GRAF3D, X3NAME, Y3NAME, Z3NAME, VOLM3D, AXES3D, VUABS, VUANGL, VIEW,
C LEGEND, LINES, LEGNAM, LINEAR, STEP, BARS, BARWID, SHDCHA, VBARS, HBARS,
C POLAR, SETEND, THKCRV, BLSYM, SWISSB, CHRPAT, HWSHD, XLGAXS, YLGAXS
C XLEGND, YLEGND, BLREC, BLKEY, BLOFF, XGRAXS, YGRAXS, GETMAT, SURMAT,
C BGNMAT, ENDMAT, RELPT3, XREAL
C
C The following routines have the same meaning and parameter list and don't
C need to be ported.
C
C CROSS, MARKER,
C COMPLX, SIMPLX, DUPLX, SERIF, TRIPLX
C CHNDSH, CHNDOT, DASH, DOT, LINESP
C BOX3D
C
C Notes:
C - Dislin is initialized in PAGE. If PAGE is not called, it is initialized
C in AREA2D.
C - PSPLOT is an example for an initialization routine of DISSPLA and
C creates by default a DISLIN PostScript file. You can also plot directly
C to the screen if you change the keyword 'PS' to 'CONS' in METAFL.
C PSPLOT defines also some global variables for scaling etc.
C - The final target should be to replace the DISSPLA routines directly by
C DISLIN routines in the source code. The interface routines may help to
C understand the differences better between DISSPLA nad DISLIN.
C
C Date : 16.11.2007
C Version: 2.0
C Author : H. Michels
C-------------------------------------------------------------------------
SUBROUTINE PSPLOT(CFIL,XPAGE,YPAGE,PENWD)
COMMON /CDISSPL1/XCM,XFRM,XVEC,IBOR,IHDR,NLEG,IXGRF,IYGRF,IPHYS
CHARACTER*(*) CFIL
CALL SETFIL (CFIL)
CALL METAFL ('PS')
NX=XPAGE*100+0.5
NY=YPAGE*100+0.5
CALL PAGE(NX,NY)
CALL COMMON_INI
C PSPLOT defines cm as default plot unit
XCM=1.0
END
SUBROUTINE PAGE_DP(XPAGE,YPAGE)
COMMON /CDISSPL1/XCM,XFRM,XVEC,IBOR,IHDR,NLEG,IXGRF,IYGRF,IPHYS
NX=XPAGE*XCM*100+0.5
NY=YPAGE*XCM*100+0.5
CALL PAGE (NX, NY)
CALL DISLIN_INI
END
SUBROUTINE AREA2D (X, Y)
COMMON /CDISSPL1/XCM,XFRM,XVEC,IBOR,IHDR,NLEG,IXGRF,IYGRF,IPHYS
NX=X*XCM*100+0.5
NY=Y*XCM*100+0.5
CALL GETLEV(NLEV)
IF(NLEV.EQ.0) CALL DISLIN_INI
CALL AXSLEN(NX,NY)
C If PHYSOR is not called before center AREA2D
IF(IPHYS.EQ.0) THEN
CALL GETPAG(NXP,NYP)
CALL AXSPOS((NXP-NX)/2+70,NY+(NYP-NY)/2+70)
IPHYS=1
END IF
CALL GETPOS(NXA,NYA)
IF(IBOR.EQ.1) CALL PAGERA
END
SUBROUTINE UNITS_DP(CSTR)
COMMON /CDISSPL1/XCM,XFRM,XVEC,IBOR,IHDR,NLEG,IXGRF,IYGRF,IPHYS
CHARACTER*(*) CSTR,COPT*2
COPT=CSTR
CALL UPSTR(COPT)
IF((COPT.EQ.'CM').OR.(COPT.EQ.'CE')) THEN
XCM=1.0
ELSE IF(COPT.EQ.'IN') THEN
XCM=2.54
ELSE IF((COPT.EQ.'MI').OR.(COPT.EQ.'MM')) THEN
XCM=10.
END IF
END
SUBROUTINE RESET_DP(CSTR)
COMMON /CDISSPL1/XCM,XFRM,XVEC,IBOR,IHDR,NLEG,IXGRF,IYGRF,IPHYS
CHARACTER*(*) CSTR,COPT*4
C RESET may have different values for DISSPLA and DISLIN
CALL GETLEV(NLEV)
IF(NLEV.EQ.0) RETURN
COPT=CSTR
CALL UPSTR(COPT)
C For example
IF(COPT.EQ.'XTIC') THEN
CALL TICKS(2,'X')
ELSE IF(COPT.EQ.'YTIC') THEN
CALL TICKS(2,'Y')
ELSE IF(COPT.EQ.'ZTIC') THEN
CALL TICKS(2,'Z')
ELSE IF(COPT.EQ.'DASH') THEN
CALL SOLID
ELSE IF(COPT.EQ.'DOT') THEN
CALL SOLID
ELSE IF(COPT.EQ.'HWSH') THEN
RETURN
ELSE IF(COPT.EQ.'BLNK') THEN
CALL RESET('SHIELD')
ELSE
CALL RESET(CSTR)
END IF
END
SUBROUTINE FRAME_DP
COMMON /CDISSPL1/XCM,XFRM,XVEC,IBOR,IHDR,NLEG,IXGRF,IYGRF,IPHYS
N=XFRM+0.5
CALL FRAME(N)
CALL BOX2D
CALL FRAME(0)
END
SUBROUTINE THKFRM(X)
COMMON /CDISSPL1/XCM,XFRM,XVEC,IBOR,IHDR,NLEG,IXGRF,IYGRF,IPHYS
IF((X.GT.-1.0).AND.(X.LE.1.0)) THEN
XFRM=X*XCM*100
ELSE
XFRM=X
END IF
END
SUBROUTINE THKVEC(X)
COMMON /CDISSPL1/XCM,XFRM,XVEC,IBOR,IHDR,NLEG,IXGRF,IYGRF,IPHYS
IF(X.LT.1.0) THEN
XVEC=X*XCM*100
ELSE
CALL GETLIN(N)
XVEC=X*N
END IF
END
SUBROUTINE PHYSOR(X,Y)
COMMON /CDISSPL1/XCM,XFRM,XVEC,IBOR,IHDR,NLEG,IXGRF,IYGRF,IPHYS
NX=X*XCM*100+0.5
NY=Y*XCM*100+0.5
CALL GETPAG(NXP,NYP)
CALL AXSPOS(NX,NYP-NY)
IPHYS=1
END
SUBROUTINE OREL(X,Y)
COMMON /CDISSPL1/XCM,XFRM,XVEC,IBOR,IHDR,NLEG,IXGRF,IYGRF,IPHYS
CALL GETPOS(NXA,NYA)
NX=X*XCM*100+0.5
NY=Y*XCM*100+0.5
CALL AXSPOS(NX+NXA,NYA-NY)
END
SUBROUTINE HWROT(CSTR)
CHARACTER*(*) CSTR,COPT*4
COPT=CSTR
CALL UPSTR(COPT)
IF((COPT.EQ.'AUTO').OR.(COPT.EQ.'COMI')) THEN
CALL PAGMOD('LAND')
ELSE
CALL PAGMOD('PORT')
END IF
END
SUBROUTINE NEWCLR(COL)
CHARACTER*(*) COL
CALL COLOR(COL)
END
SUBROUTINE SETCLR_DP(COL)
CHARACTER*(*) COL
CALL COLOR(COL)
END
SUBROUTINE SHDCHR(ARAY,NANG,GAPRAY,NGAPS)
c Dislin supports only shaded or not shaded characters
IF(NGAPS.EQ.0) THEN
CALL RESET('SHDCHA')
ELSE
CALL SHDCHA
END IF
END
SUBROUTINE ANGLE_DP(X)
N=NINT(X)
CALL ANGLE(N)
END
SUBROUTINE SETEND(CSTR,N)
COMMON /CDISSPL6/ CEND,NEND
CHARACTER*(*) CSTR,CEND*40
CEND=CSTR
NEND=N
END
SUBROUTINE MESSAG_DP(CMSG,N,XPOS,YPOS)
COMMON /CDISSPL1/XCM,XFRM,XVEC,IBOR,IHDR,NLEG,IXGRF,IYGRF,IPHYS
CHARACTER*(*) CMSG,CSTR*256
C Delete self-counting string (not necessary in DISLIN)
CSTR=CMSG
CALL CLEARSTR(CSTR)
IF((ICSTRING(XPOS,'ABUT').EQ.1).AND.
* (ICSTRING(YPOS,'ABUT').EQ.1)) THEN
NX=999
NY=999
ELSE
NX=XPOS+0.5
NY=YPOS+0.5
IF((NX.NE.999).OR.(NY.NE.999)) THEN
CALL GETPAG(NXP,NYP)
CALL GETPOS(NXA,NYA)
CALL GETHGT(NH)
NX=NXA+XPOS*XCM*100+0.5
NY=NYA-YPOS*XCM*100-NH+0.5
END IF
END IF
CALL MESSAG(CSTR,NX,NY)
END
SUBROUTINE RLMESS_DP(CSTR,N,XPOS,YPOS)
CHARACTER*(*) CSTR
CALL RLMESS(CSTR,XPOS,YPOS)
END
SUBROUTINE REALNO(X,N,XPOS,YPOS)
COMMON /CDISSPL1/XCM,XFRM,XVEC,IBOR,IHDR,NLEG,IXGRF,IYGRF,IPHYS
CHARACTER*40 CSTR
IF((ICSTRING(XPOS,'ABUT').EQ.1).AND.
* (ICSTRING(YPOS,'ABUT').EQ.1)) THEN
NX=999
NY=999
ELSE
NX=XPOS+0.5
NY=YPOS+0.5
IF((NX.NE.999).OR.(NY.NE.999)) THEN
CALL GETPAG(NXP,NYP)
CALL GETPOS(NXA,NYA)
CALL GETHGT(NH)
NX=NXA+XPOS*XCM*100+0.5
NY=NYA-YPOS*XCM*100-NH+0.5
END IF
END IF
IF(N.GE.100) THEN
NN=N-100
IF(NN.EQ.0) RETURN
CALL FCHA(X,NN,NL,CSTR)
CSTR(NN+1:)=' '
CALL MESSAG(CSTR,NX,NY)
ELSE IF(N.GE.0) THEN
CALL NUMBER(X,N,NX,NY)
ELSE
CALL NUMFMT('FEXP')
CALL NUMBER(X,-N,NX,NY)
CALL NUMFMT('FLOAT')
END IF
END
SUBROUTINE RLREAL(X,N,XPOS,YPOS)
CHARACTER*40 CSTR
IF(N.GE.100) THEN
NN=N-100
IF(NN.EQ.0) RETURN
CALL FCHA(X,NN,NL,CSTR)
CSTR(NN+1:)=' '
CALL RLMESS(CSTR,XPOS,YPOS)
ELSE IF(N.GE.0) THEN
CALL RLNUMB(X,N,XPOS,YPOS)
ELSE
CALL NUMFMT('FEXP')
CALL RLNUMB(X,-N,XPOS,YPOS)
CALL NUMFMT('FLOAT')
END IF
END
SUBROUTINE INTNO(N,XPOS,YPOS)
COMMON /CDISSPL1/XCM,XFRM,XVEC,IBOR,IHDR,NLEG,IXGRF,IYGRF,IPHYS
IF((ICSTRING(XPOS,'ABUT').EQ.1).AND.
* (ICSTRING(YPOS,'ABUT').EQ.1)) THEN
NX=999
NY=999
ELSE
NX=XPOS+0.5
NY=YPOS+0.5
IF((NX.NE.999).OR.(NY.NE.999)) THEN
CALL GETPAG(NXP,NYP)
CALL GETPOS(NXA,NYA)
CALL GETHGT(NH)
NX=NXA+XPOS*XCM*100+0.5
NY=NYA-YPOS*XCM*100-NH+0.5
END IF
END IF
X=N
CALL NUMBER(X,-1,NX,NY)
END
SUBROUTINE RLINT(N,XPOS,YPOS)
X=N
CALL RLNUMB(X,-1,XPOS,YPOS)
END
FUNCTION XMESS(CSTR,N)
COMMON /CDISSPL1/XCM,XFRM,XVEC,IBOR,IHDR,NLEG,IXGRF,IYGRF,IPHYS
CHARACTER*(*) CSTR
NL=NLMESS(CSTR)
XMESS=NL/(100*XCM)
END
FUNCTION XREAL(X,N)
COMMON /CDISSPL1/XCM,XFRM,XVEC,IBOR,IHDR,NLEG,IXGRF,IYGRF,IPHYS
CHARACTER*40 CSTR
IF(N.GE.100) THEN
NN=N-100
CALL FCHA(X,NN,NL,CSTR)
CSTR(NN+1:)=' '
NL=NLMESS(CSTR)
XREAL=NL/(100*XCM)
ELSE IF(N.GE.0) THEN
NL=NLNUMB(X,N)
XREAL=NL/(100*XCM)
ELSE
CALL NUMFMT('FEXP')
NL=NLNUMB(X,-N)
XREAL=NL/(100*XCM)
CALL NUMFMT('FLOAT')
END IF
END
SUBROUTINE CONNPT_DP(XPOS,YPOS)
COMMON /CDISSPL1/XCM,XFRM,XVEC,IBOR,IHDR,NLEG,IXGRF,IYGRF,IPHYS
CALL GETPOS(NXA,NYA)
X=NXA+XPOS*XCM*100
Y=NYA-YPOS*XCM*100
CALL CONNPT(X,Y)
END
SUBROUTINE STRTPT_DP(XPOS,YPOS)
COMMON /CDISSPL1/XCM,XFRM,XVEC,IBOR,IHDR,NLEG,IXGRF,IYGRF,IPHYS
CALL GETPOS(NXA,NYA)
X=NXA+XPOS*XCM*100
Y=NYA-YPOS*XCM*100
CALL STRTPT(X,Y)
END
SUBROUTINE VECTOR_DP(X1,Y1,X2,Y2,IVEC)
COMMON /CDISSPL1/XCM,XFRM,XVEC,IBOR,IHDR,NLEG,IXGRF,IYGRF,IPHYS
CALL GETLIN(NW)
CALL PENWID(XVEC)
CALL GETPOS(NXA,NYA)
NX1=NXA+X1*XCM*100
NY1=NYA-Y1*XCM*100
NX2=NXA+X2*XCM*100
NY2=NYA-Y2*XCM*100
CALL VECTOR(NX1,NY1,NX2,NY2,IVEC)
CALL LINWID(NW)
END
SUBROUTINE RLVEC_DP(X1,Y1,X2,Y2,IVEC)
COMMON /CDISSPL1/XCM,XFRM,XVEC,IBOR,IHDR,NLEG,IXGRF,IYGRF,IPHYS
CALL GETLIN(NW)
CALL PENWID(XVEC)
CALL RLVEC(X1,Y1,X2,Y2,IVEC)
CALL LINWID(NW)
END
SUBROUTINE ENDPL(IPLOT)
END
SUBROUTINE ENDGR(IOPT)
COMMON /CDISSPL1/XCM,XFRM,XVEC,IBOR,IHDR,NLEG,IXGRF,IYGRF,IPHYS
COMMON /CDISSPL5/IPOLAR,THETA
IHDR=0
DO I=1,4
CALL TITLIN(' ',I)
END DO
IXGRF=0
IYGRF=0
IPOLAR=0
CALL ENDGRF
END
SUBROUTINE DONEPL
CALL DISFIN
END
SUBROUTINE GRAF_DP (XORIG,XSTP,XMAX,YORIG,YSTP,YMAX)
COMMON /CDISSPL1/XCM,XFRM,XVEC,IBOR,IHDR,NLEG,IXGRF,IYGRF,IPHYS
COMMON /CDISSPL5/IPOLAR,THETA
REAL XRAY(2),YRAY(2)
C If XSTP = 'SCALE' or YSTP = 'SCALE', the automatic scaling in
C Dislin is used. For automatic scaling, the calculated scaling
c parameters are returned in GRAF. Therefore, the paramters in GRAF_DP
c must be copied to local variables, or GRAF will crash if constants
c are passed to GRAF_DP
XA=XORIG
XOR=XA
XE=XMAX
XS=XSTP
YA=YORIG
YOR=YA
YE=YMAX
YS=YSTP
IXSCL=0
IF(ICSTRING(XSTP,'SCAL').EQ.1) THEN
XRAY(1)=XA
XRAY(2)=XE
CALL SETSCL(XRAY,2,'X')
YS=1.
IXSCL=1
END IF
IYSCL=0
IF(ICSTRING(YSTP,'SCAL').EQ.1) THEN
YRAY(1)=YA
YRAY(2)=YE
CALL SETSCL(YRAY,2,'Y')
YS=1
IYSCL=1
END IF
IF((IXGRF.EQ.0).AND.(IYGRF.EQ.0)) THEN
CALL SETGRF('NONE','NONE','NONE','NONE')
ELSE IF(IYGRF.EQ.0) THEN
CALL SETGRF('NAME','NONE','TICKS','NONE')
ELSE IF(IXGRF.EQ.0) THEN
CALL SETGRF('NONE','NAME','NONE','TICKS')
ELSE
CALL SETGRF('NAME','NAME','TICKS','TICKS')
END IF
CALL GETLEN(NXL,NYL,NZL)
CALL GETPOS(NXA,NYA)
CALL AXSSCL('LIN','XY')
CALL GRAF(XA,XE,XOR,XS,YA,YE,YOR,YS)
CALL TITLE
IF(IXSCL.EQ.1) CALL SETSCL(XRAY,2,'XRESET')
IF(IYSCL.EQ.1) CALL SETSCL(YRAY,2,'YRESET')
CALL RESET('SETGRF')
END
SUBROUTINE XGRAXS(XORIG,XSTP,XMAX,XAXIS,CSTR,N,XPOS,YPOS)
COMMON /CDISSPL1/XCM,XFRM,XVEC,IBOR,IHDR,NLEG,IXGRF,IYGRF,IPHYS
CHARACTER*(*) CSTR
REAL XRAY(2)
CALL GETGRF(YA,YE,YOR,YS,'Y')
CALL ENDGRF
C X axis length may be changed
CALL GETLEN(NXL,NYL,NZL)
NXL=XAXIS*XCM*100+0.5
CALL AXSLEN(NXL,NYL)
XA=XORIG
XOR=XA
XE=XMAX
XS=XSTP
IXSCL=0
IF(ICSTRING(XSTP,'SCAL').EQ.1) THEN
XRAY(1)=XA
XRAY(2)=XE
CALL SETSCL(XRAY,2,'X')
YS=1.
IXSCL=1
END IF
C Position is realized via ORIGIN so that position of AREA2D is not
C changed
NX0=XPOS*XCM*100+0.5
NY0=YPOS*XCM*100+0.5
CALL ORIGIN(NX0,-NY0)
CALL NAME(CSTR,'X')
CALL AXSSCL('LIN','XY')
IF(N.EQ.0) THEN
CALL SETGRF('NONE','NONE','NONE','NONE')
ELSE IF(N.LT.0) THEN
CALL ORIGIN(NX0,-NY0+NYL)
CALL SETGRF('NONE','NONE','NAME','NONE')
ELSE
CALL SETGRF('NAME','NONE','NONE','NONE')
END IF
CALL GRAF(XA,XE,XOR,XS,YA,YE,YOR,YS)
IF(IXSCL.EQ.1) CALL SETSCL(XRAY,2,'XRESET')
CALL RESET('SETGRF')
CALL RESET('ORIGIN')
END
SUBROUTINE YGRAXS(YORIG,YSTP,YMAX,YAXIS,CSTR,N,XPOS,YPOS)
COMMON /CDISSPL1/XCM,XFRM,XVEC,IBOR,IHDR,NLEG,IXGRF,IYGRF,IPHYS
CHARACTER*(*) CSTR
REAL YRAY(2)
CALL GETGRF(XA,XE,XOR,XS,'X')
CALL ENDGRF
C Y axis length may be changed
CALL GETLEN(NXL,NYL,NZL)
NYL=YAXIS*XCM*100+0.5
CALL AXSLEN(NXL,NYL)
YA=YORIG
YOR=YA
YE=YMAX
YS=YSTP
IYSCL=0
IF(ICSTRING(YSTP,'SCAL').EQ.1) THEN
YRAY(1)=YA
YRAY(2)=YE
CALL SETSCL(YRAY,2,'Y')
YS=1
IYSCL=1
END IF
C Position is realized via ORIGIN so that position of AREA2D is not
C changed
NX0=XPOS*XCM*100+0.5
NY0=YPOS*XCM*100+0.5
CALL ORIGIN(NX0,-NY0)
CALL NAME(CSTR,'Y')
CALL AXSSCL('LIN','XY')
IF(N.EQ.0) THEN
CALL SETGRF('NONE','NONE','NONE','NONE')
ELSE IF(N.LT.0) THEN
CALL ORIGIN(NX0-NXL,-NY0)
CALL SETGRF('NONE','NONE','NONE','NAME')
ELSE
CALL SETGRF('NONE','NAME','NONE','NONE')
END IF
CALL GRAF(XA,XE,XOR,XS,YA,YE,YOR,YS)
IF(IYSCL.EQ.1) CALL SETSCL(YRAY,2,'YRESET')
CALL RESET('SETGRF')
CALL RESET('ORIGIN')
END
SUBROUTINE XLGAXS(XORIG,XCYCLE,XAXIS,CSTR,N,XPOS,YPOS)
COMMON /CDISSPL1/XCM,XFRM,XVEC,IBOR,IHDR,NLEG,IXGRF,IYGRF,IPHYS
CHARACTER*(*) CSTR
CALL GETGRF(YA,YE,YOR,YS,'Y')
CALL ENDGRF
C X axis length may be changed
CALL GETLEN(NXL,NYL,NZL)
NXL=XAXIS*XCM*100+0.5
CALL AXSLEN(NXL,NYL)
C Position is realized via ORIGIN so that position of AREA2D is not
C changed
NX0=XPOS*XCM*100+0.5
NY0=YPOS*XCM*100+0.5
CALL ORIGIN(NX0,-NY0)
XA=ALOG10(XORIG)
XE=XA+XAXIS/XCYCLE
XS=1.
IOR=XA
IF(IOR.LT.(XA-0.01)) IOR=IOR+1
XOR=IOR
CALL NAME(CSTR,'X')
CALL AXSSCL('LIN','Y')
CALL AXSSCL('LOG','X')
CALL LABELS('LOG','X')
CALL LABDIG(-1,'X')
IF(N.EQ.0) THEN
CALL SETGRF('NONE','NONE','NONE','NONE')
ELSE IF(N.LT.0) THEN
CALL ORIGIN(NX0,-NY0+NYL)
CALL SETGRF('NONE','NONE','NAME','NONE')
ELSE
CALL SETGRF('NAME','NONE','NONE','NONE')
END IF
CALL GRAF(XA,XE,XOR,XS,YA,YE,YOR,YS)
CALL LABELS('FLOAT','X')
CALL LABDIG(1,'X')
CALL RESET('SETGRF')
CALL RESET('ORIGIN')
END
SUBROUTINE YLGAXS(YORIG,YCYCLE,YAXIS,CSTR,N,XPOS,YPOS)
COMMON /CDISSPL1/XCM,XFRM,XVEC,IBOR,IHDR,NLEG,IXGRF,IYGRF,IPHYS
CHARACTER*(*) CSTR
CALL GETGRF(XA,XE,XOR,XS,'X')
CALL ENDGRF
C Y axis length may be changed
CALL GETLEN(NXL,NYL,NZL)
NYL=YAXIS*XCM*100+0.5
CALL AXSLEN(NXL,NYL)
C Position is realized via ORIGIN so that position of AREA2D is not
C changed
NX0=XPOS*XCM*100+0.5
NY0=YPOS*XCM*100+0.5
CALL ORIGIN(NX0,-NY0)
YA=ALOG10(YORIG)
YE=YA+YAXIS/YCYCLE
YS=1.
IOR=YA
IF(IOR.LT.(YA-0.01)) IOR=IOR+1
YOR=IOR
CALL NAME(CSTR,'Y')
CALL AXSSCL('LIN','X')
CALL AXSSCL('LOG','Y')
CALL LABELS('LOG','Y')
CALL LABDIG(-1,'Y')
IF(N.EQ.0) THEN
CALL SETGRF('NONE','NONE','NONE','NONE')
ELSE IF(N.LT.0) THEN
CALL ORIGIN(NX0-NXL,-NY0)
CALL SETGRF('NONE','NONE','NONE','NAME')
ELSE
CALL SETGRF('NONE','NAME','NONE','NONE')
END IF
CALL GRAF(XA,XE,XOR,XS,YA,YE,YOR,YS)
CALL LABELS('FLOAT','Y')
CALL LABDIG(1,'Y')
CALL RESET('SETGRF')
CALL RESET('ORIGIN')
END
SUBROUTINE GRID_DP(I,J)
COMMON /CDISSPL5/IPOLAR,THETA
IF(IPOLAR.EQ.1) THEN
CALL GRID(J,I)
ELSE
IF((I.EQ.0).AND.(J.EQ.0)) THEN
CALL FRAME(1)
CALL BOX2D
CALL FRAME(0)
ELSE
CALL GRID(I,J)
END IF
END IF
END
SUBROUTINE POLAR_DP (THEFAC,RSTEP,XDIST,YDIST)
COMMON /CDISSPL1/XCM,XFRM,XVEC,IBOR,IHDR,NLEG,IXGRF,IYGRF,IPHYS
COMMON /CDISSPL4/CXAX,CYAX
COMMON /CDISSPL5/IPOLAR,THETA
CHARACTER*132 CXAX,CYAX
IPOLAR=1
THETA=THEFAC
CALL GETPOS(NXA,NYA)
CALL GETLEN(NXL,NYL,NZL)
NX=XDIST*XCM*100+0.5
NY=YDIST*XCM*100+0.5
CALL AXSPOS(NXA-NXL/2+NX,NYA+NYL/2-NY)
CALL AXSTYP('CROSS')
X=NXL/(100*XCM)
XE=X*RSTEP/2
XOR=RSTEP
XSTP=RSTEP
YOR=0.
YSTP=30.
IF(IXGRF.EQ.0) THEN
CALL SETGRF('TICKS','NONE','TICKS','NONE')
ELSE
CALL SETGRF('NAME','NONE','TICKS','NONE')
END IF
CALL LABELS('none','y');
CALL TICKS(0,'y')
CALL NOLINE('y')
CALL NAME(' ','Y')
CALL POLAR(XE,XOR,XSTP,YOR,YSTP)
C Special handling for Y-axis title
IF(IYGRF.EQ.1) THEN
CALL ENDGRF
CALL SETGRF('NONE','NONE','NAME','NONE')
CALL NAME(CYAX,'X')
CALL POLAR(XE,XOR,XSTP,YOR,YSTP)
IF(IXGRF.EQ.1) THEN
CALL NAME(CXAX,'X')
ELSE
CALL NAME(' ','X')
END IF
CALL NAME(CYAX,'Y')
END IF
CALL TITLE
CALL RESET('SETGRF')
CALL TICKS(1,'y')
CALL RESET('NOLINE')
END
SUBROUTINE XLOG (XORIG,XCYCLE,YORIG,YSTEP)
CALL GETLEN(NXL,NYL,NZL)
XL=NXL/(100*2.54)
XA=ALOG10(XORIG)
XE=XA+XL/XCYCLE
XS=1.
IOR=XA
IF(IOR.LT.(XA-0.01)) IOR=IOR+1
XOR=IOR
YL=NYL/(100*2.54)
YA=YORIG
YE=YA+YL*YSTEP
YOR=YA
YS=YSTEP
CALL AXSSCL('LOG','X')
CALL AXSSCL('LIN','Y')
CALL LABELS('LOG','X')
CALL LABDIG(-1,'X')
CALL GRAF(XA,XE,XOR,XS,YA,YE,YOR,YS)
CALL TITLE
CALL LABELS('FLOAT','X')
CALL LABDIG(1,'X')
END
SUBROUTINE YLOG (XORIG,XSTEP,YORIG,YCYCLE)
CALL GETLEN(NXL,NYL,NZL)
XL=NXL/(100*2.54)
XA=XORIG
XE=XA+XL*XSTEP
XOR=XA
XS=XSTEP
YL=NYL/(100*2.54)
YA=ALOG10(YORIG)
YE=YA+YL/YCYCLE
YS=1.
IOR=YA
IF(IOR.LT.(YA-0.01)) IOR=IOR+1
YOR=IOR
CALL AXSSCL('LIN','X')
CALL AXSSCL('LOG','Y')
CALL LABELS('LOG','Y')
CALL LABDIG(-1,'Y')
CALL GRAF(XA,XE,XOR,XS,YA,YE,YOR,YS)
CALL TITLE
CALL LABELS('FLOAT','Y')
CALL LABDIG(1,'Y')
END
SUBROUTINE LOGLOG (XORIG,XCYCLE,YORIG,YCYCLE)
CALL GETLEN(NXL,NYL,NZL)
XL=NXL/(100*2.54)
XA=ALOG10(XORIG)
XE=XA+XL/XCYCLE
XS=1.
IOR=XA
IF(IOR.LT.(XA-0.01)) IOR=IOR+1
XOR=IOR
YL=NYL/(100*2.54)
YA=ALOG10(YORIG)
YE=YA+YL/YCYCLE
YS=1.
IOR=YA
IF(IOR.LT.(YA-0.01)) IOR=IOR+1
YOR=IOR
CALL AXSSCL('LOG','XY')
CALL LABELS('LOG','XY')
CALL LABDIG(-1,'XY')
CALL GRAF(XA,XE,XOR,XS,YA,YE,YOR,YS)
CALL TITLE
CALL LABELS('FLOAT','XY')
CALL LABDIG(1,'XY')
END
SUBROUTINE XLABGR (CRAY,IC,N,YORIG,YSTP,YMAX)
CHARACTER*(*) CRAY(N)
REAL YRAY(2)
XA=0.
XOR=0.
XE=N
XS=1.
YA=YORIG
YOR=YA
YE=YMAX
YS=YSTP
IYSCL=0
IF(ICSTRING(YSTP,'SCAL').EQ.1) THEN
YRAY(1)=YA
YRAY(2)=YE
CALL SETSCL(YRAY,2,'Y')
YS=1
IYSCL=1
END IF
CALL LABELS('MYLAB','X')
DO I=1,N
CALL MYLAB(CRAY(I),I,'X')
END DO
CALL AXSSCL('LIN','XY')
CALL GRAF(XA,XE,XOR,XS,YA,YE,YOR,YS)
CALL TITLE
IF(IYSCL.EQ.1) CALL SETSCL(YRAY,2,'YRESET')
CALL LABELS('FLOAT','X')
END
SUBROUTINE YLABGR (XORIG,XSTP,XMAX,CRAY,IC,N)
CHARACTER*(*) CRAY(N)
REAL XRAY(2)
YA=0.
YOR=0.
YE=N
YS=1.
XA=XORIG
XOR=XA
XE=XMAX
XS=XSTP
IXSCL=0
IF(ICSTRING(XSTP,'SCAL').EQ.1) THEN
XRAY(1)=XA
XRAY(2)=XE
CALL SETSCL(XRAY,2,'X')
XS=1
IXSCL=1
END IF
CALL LABELS('MYLAB','Y')
DO I=1,N
CALL MYLAB(CRAY(I),I,'Y')
END DO
CALL AXSSCL('LIN','XY')
CALL GRAF(XA,XE,XOR,XS,YA,YE,YOR,YS)
CALL TITLE
IF(IXSCL.EQ.1) CALL SETSCL(XRAY,2,'XRESET')
CALL LABELS('FLOAT','Y')
END
SUBROUTINE XYLAB (CXRAY,ICX,NX,CYRAY,ICY,NY)
CHARACTER*(*) CXRAY(NX),CYRAY(NY)
XA=0.
XOR=0.
XE=NX
XS=1.
YA=0.
YOR=0.
YE=NY
YS=1.
CALL LABELS('MYLAB','XY')
DO I=1,NX
CALL MYLAB(CXRAY(I),I,'X')
END DO
DO I=1,NY
CALL MYLAB(CYRAY(I),I,'Y')
END DO
CALL GRAF(XA,XE,XOR,XS,YA,YE,YOR,YS)
CALL TITLE
CALL LABELS('FLOAT','XY')
END
SUBROUTINE GRAF3D_DP (XORIG,XSTP,XMAX,YORIG,YSTP,YMAX,
* ZORIG,ZSTP,ZMAX)
REAL XRAY(2),YRAY(2),ZRAY(2)
XA=XORIG
XOR=XA
XE=XMAX
XS=XSTP
YA=YORIG
YOR=YA
YE=YMAX
YS=YSTP
ZA=ZORIG
ZOR=ZA
ZE=ZMAX
ZS=ZSTP
IXSCL=0
IF(ICSTRING(XSTP,'SCAL').EQ.1) THEN
XRAY(1)=XA
XRAY(2)=XE
CALL SETSCL(XRAY,2,'X')
YS=1.
IXSCL=1
END IF
IYSCL=0
IF(ICSTRING(YSTP,'SCAL').EQ.1) THEN
YRAY(1)=YA
YRAY(2)=YE
CALL SETSCL(YRAY,2,'Y')
YS=1
IYSCL=1
END IF
IZSCL=0
IF(ICSTRING(ZSTP,'SCAL').EQ.1) THEN
ZRAY(1)=ZA
ZRAY(2)=ZE
CALL SETSCL(ZRAY,2,'Z')
ZS=1
IZSCL=1
END IF
CALL GRAF3D(XA,XE,XOR,XS,YA,YE,YOR,YS,ZA,ZE,ZOR,ZS)
CALL TITLE
IF(IXSCL.EQ.1) CALL SETSCL(XRAY,2,'XRESET')
IF(IYSCL.EQ.1) CALL SETSCL(YRAY,2,'YRESET')
IF(IZSCL.EQ.1) CALL SETSCL(ZRAY,2,'ZRESET')
END
SUBROUTINE VOLM3D(X,Y,Z)
CALL AXIS3D(X,Y,Z)
END
SUBROUTINE AXES3D(CX,NX,CY,NY,CZ,NZ,X,Y,Z)
CHARACTER*(*) CX,CY,CZ
CALL NAME(CX,'X')
CALL NAME(CY,'Y')
CALL NAME(CZ,'Z')
CALL AXIS3D(X,Y,Z)
END
SUBROUTINE VUABS(X,Y,Z)
CALL VIEW3D(X,Y,Z,'ABS')
END
SUBROUTINE VIEW(X,Y,Z)
CALL VIEW3D(X,Y,Z,'USER')
END
SUBROUTINE VUANGL(X,Y,Z)
CALL VIEW3D(X,Y,Z,'ANGLE')
END
SUBROUTINE THKCRV_DP (X)
COMMON /CDISSPL1/XCM,XFRM,XVEC,IBOR,IHDR,NLEG,IXGRF,IYGRF,IPHYS
IF((X.GT.-1.0).AND.(X.LE.1.0)) THEN
N=X*XCM*100+0.5
ELSE
CALL GETLIN(NWID)
N=X*NWID+0.5
END IF
IF(N.LT.0) N=-N
CALL THKCRV(N)
END
SUBROUTINE BLSYM
CALL SHIELD('SYMBOL','ON')
END
SUBROUTINE CURVE_DP (XRAY,YRAY,N,IMRK)
COMMON /CDISSPL5/IPOLAR,THETA
REAL XRAY(N),YRAY(N)
CALL INCMRK(IMRK)
IF(IPOLAR.EQ.1) THEN
DO I=1,N
XRAY(I)=XRAY(I)*THETA
END DO
CALL CURVE(YRAY,XRAY,N)
DO I=1,N
XRAY(I)=XRAY(I)/THETA
END DO
ELSE
CALL CURVE(XRAY,YRAY,N)
END IF
END
SUBROUTINE STEP
CALL POLCRV('STEP')
END
SUBROUTINE LINEAR
CALL POLCRV('LINEAR')
END
SUBROUTINE SPLINE_DP
CALL POLCRV('SPLINE')
END
SUBROUTINE BARS_DP(X)
COMMON /CDISSPL1/XCM,XFRM,XVEC,IBOR,IHDR,NLEG,IXGRF,IYGRF,IPHYS
V=X*XCM*100+0.5
C Negative values of X are not supported
IF(V.LT.0) V=-V
CALL BARWTH(-V)
CALL POLCRV('BARS')
END
SUBROUTINE VBARS_DP (XRAY,Y1RAY,Y2RAY,N)
REAL XRAY(N),Y1RAY(N),Y2RAY(N)
CALL BARTYP('VERT')
CALL BARS(XRAY,Y1RAY,Y2RAY,N)
END
SUBROUTINE HBARS_DP (X1RAY,X2RAY,YRAY,N)
REAL X1RAY(N),X2RAY(N),YRAY(N)
CALL BARTYP('HORI')
CALL BARS(X1RAY,X2RAY,YRAY,N)
END
SUBROUTINE BARWID(X)
COMMON /CDISSPL1/XCM,XFRM,XVEC,IBOR,IHDR,NLEG,IXGRF,IYGRF,IPHYS
IF(X.GT.0.) THEN
V=X*XCM*100+0.5
CALL BARWTH(-V)
ELSE
CALL BARWTH(-X)
END IF
END
SUBROUTINE BARPAT(N)
CALL SHDPAT(N)
END
SUBROUTINE SCLPIC(F)
COMMON /CDISSPL1/XCM,XFRM,XVEC,IBOR,IHDR,NLEG,IXGRF,IYGRF,IPHYS
NH=F*XCM*100+0.5
CALL HSYMBL(NH)
END
SUBROUTINE GRACE_DP(X)
COMMON /CDISSPL1/XCM,XFRM,XVEC,IBOR,IHDR,NLEG,IXGRF,IYGRF,IPHYS
N=X*XCM*100+0.5
CALL GRACE(N)
END
SUBROUTINE HEIGHT_DP(X)
COMMON /CDISSPL1/XCM,XFRM,XVEC,IBOR,IHDR,NLEG,IXGRF,IYGRF,IPHYS
N=X*XCM*100+0.5
CALL HEIGHT(N)
END
SUBROUTINE HEADIN (CHDR, N, XF, NLINE)
COMMON /CDISSPL1/XCM,XFRM,XVEC,IBOR,IHDR,NLEG,IXGRF,IYGRF,IPHYS
CHARACTER*(*) CHDR,CSTR*132
C The heading is plottet with TITLE after GRAF
CSTR=CHDR
CALL CLEARSTR(CSTR)
CALL GETHGT(NH)
NH=XF*NH+0.5
CALL HTITLE(NH)
IF(IHDR.GT.4) RETURN
IHDR=IHDR+1
I=4-NLINE+IHDR
CALL TITLIN(CSTR,I)
END
SUBROUTINE XTICKS (N)
CALL TICKS (N, 'X')
END
SUBROUTINE YTICKS (N)
CALL TICKS (N, 'Y')
END
SUBROUTINE ZTICKS (N)
CALL TICKS (N, 'Z')
END
SUBROUTINE INTAXS
CALL LABDIG (-1, 'XY')
END
SUBROUTINE XINTAX
CALL LABDIG (-1, 'X')
END
SUBROUTINE YINTAX
CALL LABDIG (-1, 'Y')
END
SUBROUTINE ZINTAX
CALL LABDIG (-1, 'Z')
END
SUBROUTINE XREVTK
CALL TICPOS('REVERS','X')
END
SUBROUTINE YREVTK
CALL TICPOS('REVERS','Y')
END
SUBROUTINE ZREVTK
CALL TICPOS('REVERS','Z')
END
SUBROUTINE XAXCTR
CALL LABPOS('CENTER','X')
END
SUBROUTINE YAXCTR
CALL LABPOS('CENTER','Y')
END
SUBROUTINE ZAXCTR
CALL LABPOS('CENTER','Z')
END
SUBROUTINE XAXEND(COPT)
CHARACTER*(*) COPT
CALL AXENDS(COPT,'X')
END
SUBROUTINE YAXEND(COPT)
CHARACTER*(*) COPT
CALL AXENDS(COPT,'Y')
END
SUBROUTINE ZAXEND(COPT)
CHARACTER*(*) COPT
CALL AXENDS(COPT,'Z')
END
SUBROUTINE XNONUM
CALL LABELS('NONE','X')
END
SUBROUTINE YNONUM
CALL LABELS('NONE','Y')
END
SUBROUTINE ZNONUM
CALL LABELS('NONE','Z')
END
SUBROUTINE XNAME (CNAME, N)
COMMON /CDISSPL1/XCM,XFRM,XVEC,IBOR,IHDR,NLEG,IXGRF,IYGRF,IPHYS
COMMON /CDISSPL4/CXAX,CYAX
CHARACTER*(*) CNAME,CSTR*132,CXAX*132,CYAX*132
CSTR=CNAME
CALL CLEARSTR(CSTR)
IF(N.EQ.0) RETURN
CALL NAME (CSTR, 'X')
IXGRF=1
C Special handling for polar axis systems
CXAX=CSTR
END
SUBROUTINE YNAME (CNAME, N)
COMMON /CDISSPL1/XCM,XFRM,XVEC,IBOR,IHDR,NLEG,IXGRF,IYGRF,IPHYS
COMMON /CDISSPL4/CXAX,CYAX
CHARACTER*(*) CNAME,CSTR*132,CXAX*132,CYAX*132
CSTR=CNAME
CALL CLEARSTR(CSTR)
IF(N.EQ.0) RETURN
CALL NAME (CSTR, 'Y')
IYGRF=1
C Special handling for polar axis systems
CYAX=CSTR
END
SUBROUTINE X3NAME (CNAME, N)
CHARACTER*(*) CNAME,CSTR*132
CSTR=CNAME
CALL CLEARSTR(CSTR)
IF(N.EQ.0) RETURN
CALL NAME (CSTR, 'X')
END
SUBROUTINE Y3NAME (CSTR, N)
CHARACTER*(*) CSTR
IF(N.EQ.0) RETURN
CALL NAME (CSTR, 'Y')
END
SUBROUTINE Z3NAME (CSTR, N)
CHARACTER*(*) CSTR
IF(N.EQ.0) RETURN
CALL NAME (CSTR, 'Z')
END
SUBROUTINE SWISSL
CALL HELVES
END
SUBROUTINE SWISSM
CALL HELVE
END
SUBROUTINE SWISSB
C Not supported by Dislin
CALL HELVE
END
SUBROUTINE SCMPLX
C Not supported by Dislin
CALL COMPLX
END
SUBROUTINE HWSHD
C Not supported by Dislin
END
SUBROUTINE CHRPAT(N)
C Only N=16 is supported
IF(N.EQ.16) THEN
CALL SHDCHA
ELSE
CALL RESET('SHDCHA')
END IF
END
SUBROUTINE XAXANG(A)
IF(A.EQ.90.) THEN
CALL LABTYP('VERT','X')
ELSE
CALL LABTYP('HORI','X')
END IF
RETURN
END
SUBROUTINE YAXANG(A)
IF(A.EQ.90.) THEN
CALL LABTYP('VERT','Y')
ELSE
CALL LABTYP('HORI','Y')
END IF
RETURN
END
SUBROUTINE ZAXANG(A)
IF(A.EQ.90.) THEN
CALL LABTYP('VERT','Z')
ELSE
CALL LABTYP('HORI','Z')
END IF
RETURN
END
SUBROUTINE NOBRDR
COMMON /CDISSPL1/XCM,XFRM,XVEC,IBOR,IHDR,NLEG,IXGRF,IYGRF,IPHYS
IBOR=0
END
SUBROUTINE LINES(CSTR,IRAY,N)
COMMON /CDISSPL1/XCM,XFRM,XVEC,IBOR,IHDR,NLEG,IXGRF,IYGRF,IPHYS
COMMON /CDISSPL2/CLEG,CLGTIT
DIMENSION IRAY(1)
CHARACTER*(*) CSTR
CHARACTER*60 CLEG(100),CLGTIT*80
IF(NLEG.EQ.0) THEN
DO I=1,100
CLEG(I)=' '
END DO
END IF
IF((N.GE.1).AND.(N.LE.100)) THEN
CLEG(N)=CSTR
IF(N.GT.NLEG) NLEG=N
ELSE
WRITE(6,*) 'Not allowed sequence number in LINES!'
END IF
END
SUBROUTINE LEGNAM(CSTR,N)
COMMON /CDISSPL2/CLEG,CLGTIT
CHARACTER*(*) CSTR
CHARACTER*60 CLEG(100),CLGTIT*80
CLGTIT=CSTR
END
SUBROUTINE LEGEND_DP(IRAY,N,XPOS,YPOS)
COMMON /CDISSPL1/XCM,XFRM,XVEC,IBOR,IHDR,NLEG,IXGRF,IYGRF,IPHYS
COMMON /CDISSPL2/CLEG,CLGTIT
DIMENSION IRAY(1)
CHARACTER*60 CLEG(100),CLGTIT*80,CBUF*6000
CALL LEGINI(CBUF,NLEG,60)
CALL LEGTIT(CLGTIT)
DO I=1,NLEG
CALL LEGLIN(CBUF,CLEG(I),I)
END DO
NLX=NXLEGN(CBUF)
NLY=NYLEGN(CBUF)
CALL GETPOS(NXA,NYA)
NX=NXA+XPOS*XCM*100+0.5
NY=NYA-YPOS*XCM*100+0.5-NLY
CALL LEGPOS(NX,NY)
CALL RECFLL(NX,NY,NLX,NLY,0)
CALL LEGEND(CBUF,1)
END
FUNCTION XLEGND(IRAY,N)
COMMON /CDISSPL1/XCM,XFRM,XVEC,IBOR,IHDR,NLEG,IXGRF,IYGRF,IPHYS
COMMON /CDISSPL2/CLEG,CLGTIT
DIMENSION IRAY(1)
CHARACTER*60 CLEG(100),CLGTIT*80,CBUF*6000
CALL LEGINI(CBUF,N,60)
CALL LEGTIT(CLGTIT)
DO I=1,N
CALL LEGLIN(CBUF,CLEG(I),I)
END DO
XLEGND=NXLEGN(CBUF)
XLEGND=XLEGND/(100*XCM)
END
FUNCTION YLEGND(IRAY,N)
COMMON /CDISSPL1/XCM,XFRM,XVEC,IBOR,IHDR,NLEG,IXGRF,IYGRF,IPHYS
COMMON /CDISSPL2/CLEG,CLGTIT
DIMENSION IRAY(1)
CHARACTER*60 CLEG(100),CLGTIT*80,CBUF*6000
CALL LEGINI(CBUF,N,60)
CALL LEGTIT(CLGTIT)
DO I=1,N
CALL LEGLIN(CBUF,CLEG(I),I)
END DO
YLEGND=NYLEGN(CBUF)
YLEGND=YLEGND/(100*XCM)
END
SUBROUTINE BLREC(XORG,YORG,WIDE,HIGH,FRM)
COMMON /CDISSPL1/XCM,XFRM,XVEC,IBOR,IHDR,NLEG,IXGRF,IYGRF,IPHYS
CALL GETPOS(NXA,NYA)
NX=NXA+XORG*XCM*100+0.5
NY=NYA-YORG*XCM*100+0.5
NW=WIDE*XCM*100+0.5
NH=HIGH*XCM*100+0.5
NY=NY-NH
IF((FRM.GT.-1.0).AND.(FRM.LE.1.0)) THEN
NFRM=FRM*XCM*100
ELSE
NFRM=FRM+0.5
END IF
CALL FRAME(NFRM)
CALL SHLREC(NX,NY,NW,NH)
CALL FRAME(0)
END
SUBROUTINE BLKEY(ID)
CALL SHLIND(ID)
END
SUBROUTINE BLOFF(ID)
CALL SHLRES(ID)
END
SUBROUTINE BGNMAT(N,M)
PARAMETER (N1=100000)
COMMON /CDISSPL7/ NXDIM,NYDIM,NNRAY,XXRAY,YYRAY,ZZRAY
DIMENSION XXRAY(N1),YYRAY(N1),ZZRAY(N1)
NXDIM=N
NYDIM=M
NNRAY=0
END
SUBROUTINE GETMAT_DP(XRAY,YRAY,ZRAY,N,IOPT)
PARAMETER (N1=100000)
COMMON /CDISSPL7/ NXDIM,NYDIM,NNRAY,XXRAY,YYRAY,ZZRAY
DIMENSION XXRAY(N1),YYRAY(N1),ZZRAY(N1),
* XRAY(N),YRAY(N),ZRAY(N)
C GETMAT may be called multiple times
IF((N+NNRAY).GT.N1) THEN
WRITE(6,*) 'Not enough memory in GETMAT_DP'
WRITE(6,*) 'Please increase N1 in BGNMAT, GETMAT and ENDMAT'
ELSE
DO I=1,N
XXRAY(I+NNRAY)=XRAY(I)
YYRAY(I+NNRAY)=YRAY(I)
ZZRAY(I+NNRAY)=ZRAY(I)
END DO
NNRAY=NNRAY+N
END IF
END
SUBROUTINE ENDMAT(ZMAT,IOPT)
PARAMETER (N1=100000,N2=200000)
COMMON /CDISSPL7/ NXDIM,NYDIM,NNRAY,XXRAY,YYRAY,ZZRAY
DIMENSION XXRAY(N1),YYRAY(N1),ZZRAY(N1),
* ZMAT(1),IMAT(N2),WMAT(N2)
IF((NXDIM*NYDIM).GT.N2) THEN
WRITE(6,*) 'Not enough memory in ENDMAT'
WRITE(6,*) 'Please increase N2 in ENDMAT'
ELSE
CALL GETGRF(ZA,ZE,ZOR,ZSTP,'Z')
CALL GETMAT(XXRAY,YYRAY,ZZRAY,NNRAY,ZMAT,NXDIM,NYDIM,ZA,
* IMAT,WMAT)
END IF
END
SUBROUTINE SURMAT_DP(ZMAT,IXPTS,IXDIM,IYPTS,IYDIM,IOPT)
DIMENSION ZMAT(IXDIM,IYDIM)
CALL SURMAT(ZMAT,IXDIM,IYDIM,IXPTS,IYPTS)
END
SUBROUTINE RELPT3(A,B,C,X2INCH,Y2INCH)
COMMON /CDISSPL1/XCM,XFRM,XVEC,IBOR,IHDR,NLEG,IXGRF,IYGRF,IPHYS
CALL GETPOS(NXA,NYA)
CALL REL3PT(A,B,C,XP,YP)
X2INCH=(XP-NXA)/(100*XCM)
Y2INCH=(NYA-YP)/(100*XCM)
END
C === Utilities
SUBROUTINE COMMON_INI
COMMON /CDISSPL1/XCM,XFRM,XVEC,IBOR,IHDR,NLEG,IXGRF,IYGRF,IPHYS
COMMON /CDISSPL5/IPOLAR,THETA
COMMON /CDISSPL6/ CEND,NEND
CHARACTER*40 CEND
XCM=2.54
XFRM=0.03*XCM*100
IBOR=1
IHDR=0
IPHYS=0
IPOLAR=0
CEND='$'
NEND=1
END
SUBROUTINE CLEARSTR(CSTR)
COMMON /CDISSPL6/ CEND,NEND
CHARACTER*(*) CSTR,CEND*40
IF(NEND.LE.0) RETURN
I=INDEX(CSTR,CEND(1:NEND))
IF(I.NE.0) CSTR(I:)=' '
END
FUNCTION ICSTRING(X,CSTR)
CHARACTER*(*) CSTR,COP1*4,COP2*4,C1(4)*1
EQUIVALENCE (C1,V)
V=X
DO I=1,4
COP1(I:I)=C1(I)
END DO
COP2=CSTR
CALL UPSTR(COP1)
CALL UPSTR(COP2)
IF (COP1.EQ.COP2) THEN
ICSTRING=1
ELSE
ICSTRING=0
END IF
END
SUBROUTINE DISLIN_INI
COMMON /CDISSPL1/XCM,XFRM,XVEC,IBOR,IHDR,NLEG,IXGRF,IYGRF,IPHYS
COMMON /CDISSPL2/CLEG,CLGTIT
CHARACTER*60 CLEG(100),CLGTIT*80
CALL GETLEV(NLEV)
IF(NLEV.NE.0) RETURN
CALL DISINI
CALL COMPLX
CALL HEIGHT(30)
C Don't plot '$' in strings
CALL MIXALF
CALL LABTYP('VERT','Y')
CALL GETPAG(NXP,NYP)
CALL TICKS(1,'XYZ')
CALL HSYMBL(20)
CALL FRAME(0)
NLEG=0
CLGTIT='Legend'
XVEC=1.
IXGRF=0
IYGRF=0
END