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
Zur Redakteursansicht