C        COPYRIGHT 1985 UNIVERSITY OF GLASGOW                           0001.000
C        CRYSTAL STRUCTURE ILLUSTRATION PROGRAM ORTEP                   0002.000
C        GX PACKAGE  APRIL 1985   PAUL R. MALLINSON                     0003.000
C                                                                       0004.000
      SUBROUTINE CRT(X,Y,I1,I2)                                         4752.000
C     ***** CATHODE-RAY-TUBE PACKAGE USING GKS    P.R.M. MARCH 1989
C     ***** SUBROUTINE CRT IS CALLED BY SUBROUTINES F200 AND SCRIBE *** 4755.000
         CHARACTER*25 PROMPT
         CHARACTER*4 USCAN,CBUF,SUB
         EXTERNAL XYBLOK                                                4756.000
         COMMON/PLOTDEV/IOG
         COMMON/CALCMP/ORG(2),SCALE,AX(500),AY(500),K                  
         DATA PROMPT/'Press <cr> to continue'/
         DATA USCAN/'1F180000'X/,SUB/'1A000000'X/
         DATA CBUF/'1B0C1800'X/
         DATA SECS/0.1/          
         IF (I2.EQ.1) THEN                                              4758.000
         GO TO (1,2),I1+1                                               4759.000
C        MOVE TO X,Y                                                    4760.000
 1       AX(1)=X+ORG(1)
         AY(1)=Y+ORG(2)
         RETURN                                                         4762.000
C        DRAW TO X,Y                                                    4763.000
 2       AX(2)=X+ORG(1)
         AY(2)=Y+ORG(2)
         CALL GKS$POLYLINE(2,AX,AY)
         AX(1)=AX(2)
         AY(1)=AY(2)
         ELSE IF (I2.EQ.0) THEN                                         4765.000
         IF (IOG.EQ.2) THEN
            CALL GKS$DEACTIVATE_WS(IOG)
            CALL GKS$CLOSE_WS(IOG)
         ENDIF
         IF (IOG.EQ.0) THEN
C            WRITE (6,'(A4)') SUB
            CALL GKS$OPEN_GKS('ERRORFILE')
C     OPEN TEKTRONIX 4010 TERMINAL
            CALL GKS$OPEN_WS(1,'SCREEN',231)
         ENDIF
         IOG=1
         CALL GKS$ACTIVATE_WS(IOG)
         CALL GKS$SET_DEFER_STATE(IOG,0,1)
         CALL GKS$SET_WINDOW(1,0.,7.,0.,7.)
         CALL GKS$SET_VIEWPORT(1,0.,1.,0.,1.)
         CALL GKS$SELECT_XFORM(1)
         ELSE IF (I2.EQ.7) THEN                                         4769.000
C     SWITCH FROM GRAPHICS TO ALPHA MODE
C         WRITE (6,'(A4)') USCAN
C         ELSE IF (I2.EQ.8) THEN                                         4771.000
C     CLEAR ALPHA DISPLAY
C         WRITE (6,'(A4)') SUB
         ELSE IF (I2.EQ.6) THEN                                         4773.000
         ORG(1)=X                                                       4774.000
         IF (X.NE.0.) RETURN                                            4775.000
         CALL GKS$TEXT(0.1,0.15,PROMPT)
         READ (7,*)
         CALL GKS$CLEAR_WS(1,1)
C     SWITCH TO ALPHA MODE FOR OUTPUT
C         WRITE (6,'(A4)') CBUF
         CALL LIB$WAIT(SECS)                                   
         ELSE IF (I2.EQ.5) THEN                                         4777.000
         CALL GKS$TEXT(0.1,0.1,PROMPT)
         READ (7,*)
         CALL GKS$CLEAR_WS(1,1)
C         WRITE (6,'(A4)') CBUF
         CALL LIB$WAIT(SECS)                                   
         ENDIF                                                          4779.000
      RETURN                                                            4780.000
      END                                                               4781.000
C     ******** TEKTRONIX 4662 PLOTTER PACKAGE.                          4782.000
         BLOCK DATA XYBLOK                                              4783.000
         COMMON/PLOTDEV/IOG
         COMMON/CALCMP/ORG(2),SCALE,AX(500),AY(500),K
         DATA ORG/2*0./,IOG/0/,K/0/
         END                                                            4786.000
         SUBROUTINE PLOTS(N)                                            4787.000
         CHARACTER*25 PROMPT
         CHARACTER*4 CBUF
         EXTERNAL XYBLOK                                                4788.000
         COMMON/PLOTDEV/IOG                                             4789.000
         COMMON/CALCMP/ORG(2),SCALE,AX(500),AY(500),K
         DATA PROMPT/'Press <cr> to continue'/
         DATA CBUF/'1B0C1800'X/,SECS/0.1/
         N=0                                                            4791.000
         IF (IOG.EQ.1) THEN
             CALL GKS$TEXT(0.1,0.1,PROMPT)
             READ (7,*)
             CALL GKS$CLEAR_WS(1,1)
C             WRITE (6,'(A4)') CBUF
             CALL LIB$WAIT(SECS)
             CALL GKS$DEACTIVATE_WS(1)
         ENDIF
         IOG=2
C      open PostScript printer
         CALL GKS$OPEN_WS(IOG,'PLOTTER',61)
         CALL GKS$ACTIVATE_WS(IOG)
         CALL GKS$SET_DEFER_STATE(IOG,0,1)
         CALL GKS$SET_WINDOW(2,0.,10.,0.,10.)
         CALL GKS$SET_VIEWPORT(2,0.,1.,0.,1.)
         CALL GKS$SELECT_XFORM(2)
         CALL GKS$SET_TEXT_HEIGHT(0.1)
         CALL GKS$SET_PLINE_LINEWIDTH(2.0)
         RETURN                                                         4798.000
         END                                                            4799.000
         SUBROUTINE PLOT(X,Y,N)                                         4800.000
         CHARACTER*4 CBUF
         EXTERNAL XYBLOK                                                4756.000
         COMMON/PLOTDEV/IOG
         COMMON/CALCMP/ORG(2),SCALE,AX(500),AY(500),K                  
         DATA CBUF/'1B0C1800'X/,SECS/0.1/
C        TERMINATE PLOT IF IABS(N)=999                                  4802.000
         I=IABS(N)                                                      4803.000
         IF (I.EQ.999) GO TO 7                                          4804.000
         IF (N.LE.0) GO TO 6                                            4805.000
C        IABS(N)=2 MEANS DRAW TO (X,Y)                                  4806.000
C        IABS(N)=3 MEANS MOVE TO (X,Y)                                  4807.000
         GO TO (7,2,3),I                                                4808.000
C        MOVE TO X,Y                                                    4760.000
 3       IF (K.GT.1) THEN
         CALL GKS$POLYLINE(K,AX,AY)
         ENDIF
         AX(1)=X+ORG(1)
         AY(1)=Y+ORG(2)
         K=1
         RETURN                                                         4810.000
C        DRAW TO X,Y                                                    4763.000
 2       K=K+1
         AX(K)=X+ORG(1)
         AY(K)=Y+ORG(2)
         IF (K.EQ.500) THEN
         CALL GKS$POLYLINE(K,AX,AY)
         K=1
         AX(1)=AX(K)
         AY(1)=AY(K)
         ENDIF
         RETURN                                                         4812.000
C        ESTABLISH NEW ORIGIN AT (X,0)                                  4813.000
 6       ORG (1)=X                                                      4814.000
         IF (X.NE.0.0)  RETURN                                          4815.000
         WRITE (6,*) 'Press <cr> to continue plotting'
         READ (7,*)
         CALL GKS$CLEAR_WS(IOG,0)
         RETURN
 7       CALL GKS$DEACTIVATE_WS(IOG)
         CALL GKS$CLOSE_WS(1)
         IF (IOG.EQ.2) CALL GKS$CLOSE_WS(2)
         CALL GKS$CLOSE_GKS
C         WRITE (6,'(A4)') CBUF
         CALL LIB$WAIT(SECS)
         RETURN             
         END                                                            4821.000
         SUBROUTINE SYMBOL(X,Y,H,IBCD,TH,M)                             4822.000
         CHARACTER*8 BCD
         DIMENSION IBCD(2),X(1)   
         COMMON/CALCMP/ORG(2),SCALE,AX(500),AY(500),K
         N=M                                                            4828.000
         IF (M.LT.0)  N=6                                               4829.000
         IF (M.GT.7) N=7                                                4830.000
         WRITE (BCD,'(2A4)') IBCD
         IF (M.GT.-2) GO TO 1                                           4834.000
C        DRAW TO X,Y                                                    4763.000
         AX(2)=X(1)+ORG(1)
         AY(2)=Y+ORG(2)
         CALL GKS$POLYLINE(2,AX,AY)
         AX(1)=AX(2)
         AY(1)=AY(2)
         GO TO 2                                                        4836.000
C        MOVE TO X,Y                                                    4760.000
 1       AX(1)=X(1)+ORG(1)
         AY(1)=Y+ORG(2)
 2       IF (H.GT.0.01)  THEN
           CALL GKS$TEXT(X(1)+ORG(1),Y+ORG(2),BCD)
         ENDIF
         RETURN                                                         4840.000
         END                                                            4841.000
         SUBROUTINE NUMBER(X,Y,H,D,THETA,M)                             4842.000
         RETURN                                                         4843.000
         END                                                            4844.000
         SUBROUTINE NEWPEN(N)                                           4845.000
         COMMON/PLOTDEV/IOG                                             4846.000
         IF (IOG.NE.2) RETURN          
C         CALL XYPEN(N)           
         RETURN                                                         4849.000
         END                                                            4850.000
         SUBROUTINE EMPTYBUF
         COMMON/CALCMP/ORG(2),SCALE,AX(500),AY(500),K
         IF (K.GT.1) THEN
         CALL GKS$POLYLINE(K,AX,AY)
         K=0
         ENDIF
         RETURN
         END
