      PROGRAM C3DCON
C
C     PROGRAMMER: RONG-SHENG ZHOU
C	          CHEMISTRY DEPARTMENT
C	          BOSTON COLLEGE, 10/89
C
C     COPYRIGHT @1990 BY RONG-SHENG ZHOU.
C
C     3D ELECTRON DENSITY CAGE CONTOURING AND STRUCTURE MODEL DRAWING.
C     FOR A COMPLETE DESCRIPTION OF THE FEATURES, SEE C3DCON.TEX.
C
      INCLUDE 'C3DCON.CBS'
      LOGICAL   DALINE
C
C  PARSE THE ACTIVATING DCL COMMAND LINE...
C  (THE 2 LINES ARE ONLY NEEDED IF C3DCON IS RUN STANDALONE)...
C
C      TERM = IF_DCL_PUT( 'C3DCON' )
C      IF( TERM.LT.0 ) GOTO 888
C
C  INITIALIZE THE GRAPHICS LIBRARY...
C
      CALL IFINIT_SESSION
      IF( .NOT.IF_DCL_HARDCOPY() ) TERM = IFINIT_ITM(0)
      INIT = .FALSE.
C
C  INITIALIZE C3DCON...
C
      CALL C3DCON_INIT
C
C  CHECK COMMAND LINE INPUT...
C
      DALINE = .FALSE.
      CALL C3DCON_DCL( KEY )
      IF( KEY.NE.0 ) GOTO 333
C
C  CONDUCT THE DIALOGUE...
C
  222 CALL C3DCON_MENU( KEY )
      IF( KEY.NE.0 ) THEN
          IF( .NOT.IFINIT_DIFF() ) GOTO 999
          GOTO 444
      ENDIF
C
C  CARRY OUT THE PLOTTING...
C
  333 CALL C3DCON_PLOT
      IF( TERM.EQ.1 ) THEN
          CALL IFANSI_CLEAR(0)
      ELSE
          CALL IFINIT_LINE(-3)
      ENDIF
      WRITE(6,334)
  334 FORMAT(' C3DCON> Please press a desired function key:')
C
C  PRESENT LOCAL COMMAND MENU...
C
  444 CALL IFANSI_VIDEO(47)
      WRITE(6,445)
  445 FORMAT(' C3DCON> 0>Exit  1>Hardcopy  2>Layout    3>Dialogue',
     +'   4>Toggle  5>Zoom'/'         ?>Help  6>Redraw    7>St/Mono',
     +'   8>Edit_plot  9>Rotate  $>DCL/VMS')
      CALL IFANSI_CURSOR(0,8)
      CALL IFQIOW_KEY( KEY )

      IF( KEY.EQ.26 .OR. KEY.EQ.48 .OR. KEY.EQ.69 ) GOTO 999
      IF( DALINE ) THEN
          CALL IFINIT_LINE(-3)
          DALINE = .FALSE.
      ENDIF
      IF( KEY.EQ.49 ) THEN	!HARDCOPY WITH PAGE SETUP
          CALL IFCOPY( HPAR(1), PLOTID )
          CALL C3DCON_WRITE( PARFIL )
          CALL IFINIT_LINE( -3 )
      ELSE IF( KEY.EQ.-80 ) THEN	!PF1: HARDCOPY WITHOUT PAGE SETUP
          CALL IFANSI_LEDS(1)
          CALL IFFEED( HPAR(1), PLOTID, ' ' )
          CALL IFANSI_LEDS(0)
      ELSE IF( KEY.EQ.50 ) THEN		!LAYOUT
          IF( DESFIL.EQ.' ' ) THEN
              DESFIL = PARFIL
              CALL IFMISC_NAMEXT( DESFIL, '.DES' )
          ENDIF
          CALL LAYOUT_AUX( 2, XORG, YORG, DESFIL )
      ELSE IF( KEY.EQ.13 .OR. KEY.EQ.51 .OR. KEY.EQ.-82 ) THEN !DIALOGUE
          GOTO 222
      ELSE IF( KEY.EQ.52 ) THEN    	!TOGGLE
          CALL C3DCON_TOGGLE
      ELSE IF( KEY.EQ.53 ) THEN 	!ZOOM
          CALL C3DCON_ZOOM
      ELSE IF( KEY.EQ.54 ) THEN		!REDRAW THE PLOT
          GOTO 333
      ELSE IF( KEY.EQ.55 ) THEN 	!STEREO/MONO
          CALL C3DCON_FLIP
      ELSE IF( KEY.EQ.56 ) THEN		!EDIT PLOT
          CALL C3DCON_EDIT
      ELSE IF( KEY.EQ.57 ) THEN		!ROTATE PLOT
          CALL C3DCON_ROTATE
      ELSE IF( KEY.EQ.32 .OR. KEY.EQ.63 .OR. KEY.EQ.-81 ) THEN  !HELP
          CALL IFMISC_HLP( 'C3DCON', '$ MENU', -2, 0 )
          DALINE = .TRUE.
      ELSE IF( KEY.EQ.36 .OR. KEY.EQ.-83 ) THEN	!SPAWN
          CALL IFMISC_SPAWN( '$', 0 )
          CALL IFINIT_LINE( -3 )
      ELSE
          CALL IFMISC_OOPS( 5, 0, 0, ' ' )
      ENDIF
      GOTO 444
  999 CALL IFINIT_EXIT
      CALL EXIT
      END

      SUBROUTINE C3DCON_DCL( ICODE )
C
C     THIS ROUTINE CHECKS THE DCL COMMAND LINE.
C
      INCLUDE 'C3DCON.CBS'
      INTEGER   C3DCON_READ
C
C  GET THE SETUP FILE NAME...
C
      ICODE = 0
      PARFIL = ' '
      CALL IF_DCL_FILE( 1, PARFIL )
      IF( PARFIL.EQ.' ' ) CALL IF_DCL_SETUP( PARFIL )
      IF( PARFIL.EQ.' ' ) THEN
          PARFIL = 'C3DCON.PAR'
          RETURN
      ENDIF
      INIT = .TRUE.
      SLIN = -1
      SCOL = 0
      IERR = C3DCON_READ( PARFIL )
      IF( IERR.NE.0 ) GOTO 555
C
C  MAKE THE HARDCOPY...
C
      ICODE = 1
      IF( IF_DCL_HARDCOPY() ) THEN
          CALL C3DCON_PLOT
          CALL IFCOPY( HPAR(1), PLOTID )
      ENDIF
      GOTO 999
C
C  ERROR FROM READING A DATA_FILE...
C
  555 IF( IERR.GT.0 ) THEN
          WRITE(6,666) PARFIL
  666     FORMAT(' %C3DCON: can not open file ',A32)
      ELSE
          WRITE(6,777) PARFIL
  777     FORMAT(' %C3DCON: error in reading file ',A32)
      ENDIF
  999 IF( .NOT.IF_DCL_HARDCOPY() ) RETURN
      CALL EXIT
      END

      SUBROUTINE C3DCON_MENU( ICODE )
C
C     THIS ROUTINE CONDUCTS THE DIALOGUE AND 
C     RETURNS WITH "ICODE=1" IF QUITING.
C
      INCLUDE 'C3DCON.CBS'
      PARAMETER   (NKS = 57)
      CHARACTER    KWD(NKS)*2
      CHARACTER    TEXT*77, KEY*2, QUIT*4, SYM*1
      EQUIVALENCE (SYM,TEXT(3:3)), (KEY,TEXT(1:2))
      COMMON/MENU/ IKEY, NCHS, TEXT
C
C  2 LETTER ACCESS CODES TO GRAPH PARAMETERS...
C
      DATA KWD /
     + 'F0', 'M1', 'M2', 'M3', 'M4', 'F1', 'F2', 'F3',
     + 'GT', 'RO', 'CD', 'AT', 'SC', 'SL', 'SA', 'AX', 
     + 'CP', 'UC', 'ON', 'CL', 'MP', 'BX', 'CC', 'LI',
     + 'BL', 'CS', 'SY', 'SR', '3D', 'NN', 'AN', 'FI', 
     + 'FX', 'FY', 'FZ', 'FT', 'FC', 'FS', 'OR', 'BN',
     + 'D1', 'D2', 'DL', 'T1', 'T2', 'T3', 'T4', 'T5',
     + 'T6', 'T7', 'T8', 'T9', 'CH', 'ID', 'OS', 'LB',
     + 'LT' /
C
C  PRESENT THE DIALOGUE MENU...
C
      JSET = 1                 !BOND SET POINTER
      SLIN = 21
      SCOL = 6
      CALL C3DCON_FORM
C
C  START THE DIALOGUE LOOP...
C
  111 CALL IFANSI_VIDEO(47)
      CALL IFANSI_TEXT('C3DCON> ', 8, 22, 1 )
      CALL IFANSI_CLEAR(4)
      IKEY = IFQIOW( NCHS, TEXT )	!INPUT VIA QIOW
      IF( IKEY.EQ.26) GOTO 888	        !CTRL/Z PRESSED
      IF( NCHS.EQ.0 ) GOTO 111
      NCHS = IFMISC_STRIP(TEXT)
      CALL   IFMISC_UPPER(2,KEY)
      QUIT = TEXT(1:4)
      CALL   IFMISC_UPPER(4,QUIT)
      IF( QUIT.EQ.'QUIT' .OR. QUIT.EQ.'EXIT' ) GOTO 888
      IF( NCHS.EQ.2 .AND. KEY.EQ.'GO' ) GOTO 999
      CALL C3DCON_CLEAR_OOPS
C
C  COMMAND INPUT...
C
      IF( SYM.NE.'='  ) THEN
          CALL C3DCON_COMM
      ELSE
C
C  PARAMETER INPUT...
C
          DO IKEY = 1, NKS
             IF( KEY.EQ.KWD(IKEY) ) GOTO 222
          ENDDO
          CALL IFMISC_OOPS( 2, SLIN, SCOL, KEY )
      ENDIF
      GOTO 111
C
C  WE HAVE A VALID KEYWORD...
C
  222 TEXT = TEXT(4:)
      NCHS = NCHS-3
      IF( IKEY.LT.9 ) THEN
          CALL C3DCON_FILES             !GET FILES
      ELSE IF( IKEY.LT.19 ) THEN
          CALL C3DCON_SETUP1            !OVERALL PARAMETERS
      ELSE IF( IKEY.LT.26 ) THEN
          CALL C3DCON_SETUP2            !CONTOURING PARAMETERS
      ELSE
          CALL C3DCON_SETUP3            !MODEL DRAWING PARAMETERS
      ENDIF
      GOTO 111
  888 ICODE = 1				!QUIT FROM THE DIALOGUE
      CALL IFANSI_CLEAR(2)
      RETURN
  999 IF( NATM.EQ.0 .AND. MAPFIL(1).EQ.' ' ) GOTO 888
      CALL C3DCON_WRITE( PARFIL )	!SAVE THE CURRENT SETUP
      ICODE = 0
      RETURN
      END

      SUBROUTINE C3DCON_FORM
C
C     THIS ROUTINE LAYOUTS THE DIALOGUE MENU.
C
      INCLUDE 'C3DCON.CBS'
      INTEGER   C3DCON_READ
      CHARACTER TEXT*77
      COMMON/MENU/ IKEY, NCHS, TEXT

      IF( SCOL.EQ.0 ) RETURN
      CALL IFINIT_LINE(24)
      TEXT = 'C3DCON: A 3D Map Contouring and Atomic Model Plotting'
      CALL IFANSI_TITLE( TEXT )
      CALL IFANSI_VIDEO(47)
      WRITE(6,1001)
 1001 FORMAT(' GT='/' RO=',25X,'CD=',25X,'AT='/
     +' SC=',13X,'SA=',9X,'SL=',25X,'AX=')
      IF( TERM.NE.2 ) CALL IFANSI_VIDEO(90)
      WRITE(6,1002)
 1002 FORMAT(' CP=',53X,'UC=',20X,' ')
      IF( TERM.EQ.2 ) THEN
          CALL IFANSI_VIDEO(50)
      ELSE
          CALL IFANSI_VIDEO(90)
      ENDIF
      WRITE(6,2000)
 2000 FORMAT('      * * * * *    M A P   D R A W I N G'
     +,'   P A R A M E T E R S    * * * * *      ')
      CALL IFANSI_VIDEO(47)
      WRITE(6,2001)
 2001 FORMAT(
     +' M1=',12X,'GRID:',10X,'MIN_D:',12X,'MAX_D:',12X,'SD='/
     +' M2=',12X,'GRID:',10X,'MIN_D:',12X,'MAX_D:',12X,'SD='/
     +' M3=',12X,'GRID:',10X,'MIN_D:',12X,'MAX_D:',12X,'SD='/
     +' M4=',12X,'GRID:',10X,'MIN_D:',12X,'MAX_D:',12X,'SD='/
     +' ON=',14X,'CL=')
      IF( TERM.NE.2 ) CALL IFANSI_VIDEO(90)
      WRITE(6,2002)
 2002 FORMAT(' MP=',5X,'BX=',22X,'CC=',13X,'LI=',13X,'BL=',11X,' ')
      IF( TERM.EQ.2 ) THEN
          CALL IFANSI_VIDEO(50)
      ELSE
          CALL IFANSI_VIDEO(90)
      ENDIF
      WRITE(6,3000)
 3000 FORMAT('      * * * * *   M O D E L   D R A W I N G'
     +,'   P A R A M E T E R S   * * * * *    ')
      CALL IFANSI_VIDEO(47)
      WRITE(6,3001)
 3001 FORMAT(' F1=',11X,'NSYMMS:',10X,'CS=',4X,'SY=',8X,
     +'ID=',10X,'OS=',/' F2=',11X,
     +'NATOMS:',4X,'/',5X,'SR=',7X,'3D=',16X,'NN=',11X,'AN='/
     +5X,'FI=',7X,'FX=',7X,'FY=',7X,'FZ=',7X,'FT=',7X,'FC=',7X,
     +'FS=',7X,'OR='/15X,'SET:  /   BN=',17X,'D1=',7X,'D2=',7X,
     +'DL=',/' F3=',11X,'T1=',10X,'T2=',10X,'T3=',10X,'T4=',10X,
     +'T5='/' F0=',11X,'T6=',10X,'T7=',10X,'T8=',10X,'T8=',10X,'CH=')
      CALL IFANSI_VIDEO(90)
      WRITE(6,3002)
 3002 FORMAT(15X'LB=',16X,'LT=',43X,' ')
      CALL IFANSI_VIDEO(20)
      WRITE(6,5000)
 5000 FORMAT(' oops:'//' Auxiliary: GO, EXIT, DOWN/PF1, UP/PF3,',
     +' HELP/PF2, DCL/PF4, REFRESH, RESET,',6X,' ',/' _commands:',
     +' LOAD, READ, SAVE, LOCATE, INCLUDE, EXCLUDE, DISTANCE,',
     +' TIME',10X,' ',$)
      CALL IFANSI_VIDEO(47)
C
C  READ SETUP FILE...
C
      IF( .NOT.INIT ) THEN
          TEXT = 'Enter run file to read/create ['
          TEXT(32:) = PARFIL
          NCHS = IFMISC_LENG(TEXT)
          TEXT(NCHS+1:) = ']:'
          NCHS = IFMISC_PROMPT(TEXT,TEXT,SLIN+1,1)
          IF( NCHS.GT.0 ) PARFIL = TEXT(1:NCHS)
          TEXT = ' Reading run file'
          TEXT(19:) = PARFIL
          CALL C3DCON_OOPS( TEXT )
          IKEY = C3DCON_READ( PARFIL )
          INIT = .TRUE.
          CALL C3DCON_CLEAR_OOPS
      ENDIF
C
C  INSERT THE PARAMETERS...
C
      CALL C3DCON_PARS( 0 )
      RETURN
      END

      SUBROUTINE C3DCON_INIT
C
C     THIS ROUTINE INITIALIZES COMMON-BLOCK PARAMETERS.
C
      INCLUDE 'C3DCON.CBS'
C
C  INITIALIZE OVERALL GRAPH PARAMETERS...
C      
      PARFIL = 'C3DCON.PAR'
      SYMFIL = ' '
      MODFIL = ' '
      DESFIL = ' '
      TITLE  = ' '
      DO I = 1, 3
         ORIG(I) = 0.0
         SLAB(I) = 0.0
      ENDDO
      CLIP = .FALSE.
      ROTA(1) =-15.0
      ROTA(2) = 15.0
      ROTA(3) =  0.0
      CENT = ' '
      XORG = 5.0
      YORG = 4.0
      A2IN = 1.0
      SANG = 0.0
      AXES = 0.0
      DO I=1, 6
         CELL(I) = 0.0
      ENDDO
      UNIC(1) = 0
      UNIC(2) = 1
      UNIC(3) = 1
C
C  CONTOURING PARAMETERS NEXT...
C
      DO I = 1, 3
         CBOX(I) = 5.0
      ENDDO
      DO I=1, 4
         SCAL(I) = 1.0
         OFFS(I) = 0.0
         DSIG(I) = 0.0
         DMIN(I) = 0.0
         DMAX(I) = 0.0
         FLAG(I) = 1
         CPEN(I) = 2
         LINE(I) = 1
         BOLD(I) = 1
         CLEV(I) = 0.0
         MAPFIL(I) = ' '
      ENDDO
      BACK = .TRUE.
C
C  MODEL DRAWING PARAMETERS...
C
      MSYM = 0
      MATM = 0
      NATM = 0
      NSYM = 0
      NBND = 0
      NSUB = 0
      SYMM = .TRUE.
      SYMC = .FALSE.
      EDGE = .FALSE.
      NORM = .FALSE.
      IDON = .FALSE.
      EXIN = .FALSE.
      SRAD = 4.0            !DEFAULT TO SPHERE-ENCLOSURE
      DO I = 1, 3
         DBOX(I) = 0.0
      ENDDO
      NSTR = 0
      NEND = 0
      FRMT(1,1) = 1
      FRMT(2,1) = 8
      FRMT(1,2) = 9
      FRMT(2,2) = 18
      FRMT(1,3) = 19
      FRMT(2,3) = 28
      FRMT(1,4) = 29
      FRMT(2,4) = 38
      FRMT(1,5) = 39
      FRMT(2,5) = 41
      FRMT(1,6) = 0
      FRMT(2,6) = 0
      FRMT(1,7) = 0
      FRMT(2,7) = 0
      IDPN = 0
      IDFN = 1
      IDSZ = 0.1
      OXYZ(1) = 0.0
      OXYZ(2) = 0.0
      OXYZ(3) = 0.0
      DO I=1, MAXC
         DO J=1, 4
            CONN(J,I) = 0
         ENDDO
         DO J=5,7
            CONN(J,I) = 1
         ENDDO
         D1D2(1,I) = 0.0
         D1D2(2,I) = 0.0
         D1D2(3,I) = 0.1
      ENDDO
      DO I=1, 9
         LABL = I
         IF( LABL.GT.7 ) LABL = 7
         BPEN(I) = LABL
         BTYP(I) = 0
         BSIZ(I) = 0.1
         BALL(I) = ' '
      ENDDO
      LABL = 0
      BPOS(1) =-4.0
      BPOS(2) = 3.5
      BPOS(3) = 0.1
      BARC = 10
      RETURN
      END

      SUBROUTINE C3DCON_PARS( ITT )
C
C     THIS ROUTINE INSERTS PLOT PARAMETERS INTO THE DIALOG MENU.
C
      INCLUDE 'C3DCON.CBS'
      CHARACTER YES*3, TEXT*80

      IF( SCOL.EQ.0 ) RETURN
      IT = ITT
      IF( IT.GT.0 ) IT = IT-1
      IF( IT.EQ.0 ) THEN
          CALL IFANSI_VIDEO(20)
          TEXT = ' Type HELP (or press PF2) if you need any'
          CALL IFANSI_TEXT( TEXT, 42, 21, 8 )
          CALL IFANSI_VIDEO(30)
          CALL IFANSI_TEXT( PARFIL, 10, 19, 4 )
      ENDIF
C
C  DISPLAY OVERALL GRAPH PARAMETERS...
C
      IF( IT.GT.0 ) CALL IFANSI_VIDEO(30)
      IF( IT.EQ.0 .OR. IT.EQ.8 ) CALL IFANSI_TEXT( TITLE, 77, 2, 4 )
      IF( IT.EQ.0 .OR. IT.EQ.9 ) CALL IFANSI_FFL( ROTA,3,'3F8.3',3,4 )
      IF( IT.EQ.0 .OR. IT.EQ.10) CALL IFANSI_FFL( ORIG,3,'3F8.4',3,32)
      IF( IT.EQ.0 .OR. IT.EQ.11) CALL IFANSI_TEXT( CENT, 8, 3, 60 )
      IF( IT.EQ.0 .OR. IT.EQ.12) CALL IFANSI_FFL( A2IN,1,'F8.3',4,4)
      IF( IT.EQ.0 .OR. IT.EQ.14) CALL IFANSI_FFL( SANG,1,'F8.3',4,20)
      IF( IT.EQ.0 .OR. IT.EQ.13) CALL IFANSI_FFL( SLAB,3,'3F8.3',4,32)
      IF( IT.EQ.0 .OR. IT.EQ.15) CALL IFANSI_FFL( AXES,1,'F6.1',4,60)
      IF( IT.EQ.0 .OR. IT.EQ.16 ) CALL IFANSI_FFL( CELL,6,'6F8.3',5,4)
      IF( IT.EQ.0 .OR. IT.EQ.17 ) CALL IFANSI_IFL( UNIC,3,'3I2',5,60)
C
C  DISPLAY CONTOURING PARAMETERS...
C
      IF( IT.LT.5 ) THEN
          I1 = IT
          I2 = IT
          IF( IT.EQ.0 ) THEN
              I1 = 1
              I2 = 4
          ENDIF
          DO I=I1, I2
             CALL IFANSI_TEXT( MAPFIL(I), 10, I+6, 4 )
             CALL IFANSI_VIDEO(20)
             CALL IFANSI_IFL( GRID(1,I), 3, '3I3', I+6, 21 )
             CALL IFANSI_FFL( DMIN(I), 1, 'G11.4', I+6, 37 )
             CALL IFANSI_FFL( DMAX(I), 1, 'G11.4', I+6, 55 )
             CALL IFANSI_FFL( DSIG(I), 1, 'G11.4', I+6, 70 )
             CALL IFANSI_VIDEO(30)
          ENDDO
      ENDIF
      IF( IT.EQ.0 .OR. IT.EQ.1 ) THEN
          CALL IFANSI_FFL( CELL,6,'6F8.3',5,4 )
          CALL IFANSI_FFL( CLEV,4,'4G15.7',11,21)
      ENDIF
      IF(IT.EQ.0.OR.IT.EQ.18) CALL IFANSI_IFL( FLAG,4,'4I3',11,4)
      IF(IT.EQ.0.OR.IT.EQ.19) CALL IFANSI_FFL( CLEV,4,'4G15.7',11,21)
      IF( IT.EQ.0 .OR. IT.EQ.20 ) THEN
          YES = 'NO'
          IF( BACK ) YES = 'YES'
          CALL IFANSI_TEXT( YES, 3, 12, 4 )
      ENDIF
      IF(IT.EQ.0.OR.IT.EQ.21) CALL IFANSI_FFL( CBOX,3,'3F7.2',12,12)
      IF( IT.EQ.0 .OR. IT.EQ.22 ) CALL IFANSI_IFL( CPEN,4,'4I3',12,37)
      IF( IT.EQ.0 .OR. IT.EQ.23 ) CALL IFANSI_IFL( LINE,4,'4I3',12,53)
      IF( IT.EQ.0 .OR. IT.EQ.24 ) CALL IFANSI_IFL( BOLD,4,'4I3',12,69)
C
C  MODEL DRAWING PARAMETERS...
C
      IF( IT.EQ.0 .OR. IT.EQ.5 ) THEN
          CALL IFANSI_TEXT( SYMFIL, 10, 14, 4 )
          CALL IFANSI_VIDEO(20)
          CALL IFANSI_IFL( MSYM, 1, 'I3', 14, 22 )
          CALL IFANSI_VIDEO(30)
      ENDIF
      IF( IT.EQ.0 .OR. IT.EQ.25 ) THEN
          YES = 'NO'
          IF( SYMC ) YES = 'YES'
          CALL IFANSI_TEXT( YES, 3, 14, 35 )
      ENDIF
      IF( IT.EQ.0 .OR. IT.EQ.26 ) THEN
          YES = 'NO'
          IF( SYMM ) YES = 'YES'
          CALL IFANSI_TEXT( YES, 3, 14, 42 )
      ENDIF
      IF( IT.EQ.0 .OR. IT.EQ.6 ) THEN
          CALL IFANSI_TEXT( MODFIL, 10, 15, 4 )
          CALL IFANSI_VIDEO(20)
          CALL IFANSI_IFL( NSYM, 1, 'I4', 15, 22 )
          CALL IFANSI_IFL( MATM, 1, 'I4', 15, 27 )
          CALL IFANSI_VIDEO(30)
      ENDIF
      IF(IT.EQ.0.OR.IT.EQ.27) CALL IFANSI_FFL( SRAD,1,'F6.2',15,35)
      IF(IT.EQ.0.OR.IT.EQ.28) CALL IFANSI_FFL( DBOX,3,'3F5.2',15,45)
      IF(IT.EQ.0.OR.IT.EQ.29) THEN
          CALL IFANSI_IFL( NSTR, 1, 'I5', 15, 64 )
          CALL IFANSI_IFL( NEND, 1, 'I5', 15, 69 )
      ENDIF
      IF( IT.EQ.0 .OR. IT.EQ.30 ) THEN
          YES = 'NO'
          IF( EDGE ) YES = 'YES'
          CALL IFANSI_TEXT( YES, 3, 15, 78 )
      ENDIF
      IF(IT.EQ.0.OR.IT.EQ.31) CALL IFANSI_IFL(FRMT(1,1),2,'2I3',16, 8)
      IF(IT.EQ.0.OR.IT.EQ.32) CALL IFANSI_IFL(FRMT(1,2),2,'2I3',16,18)
      IF(IT.EQ.0.OR.IT.EQ.33) CALL IFANSI_IFL(FRMT(1,3),2,'2I3',16,28)
      IF(IT.EQ.0.OR.IT.EQ.34) CALL IFANSI_IFL(FRMT(1,4),2,'2I3',16,38)
      IF(IT.EQ.0.OR.IT.EQ.35) CALL IFANSI_IFL(FRMT(1,5),2,'2I3',16,48)
      IF(IT.EQ.0.OR.IT.EQ.36) CALL IFANSI_IFL(FRMT(1,6),2,'2I3',16,58)
      IF(IT.EQ.0.OR.IT.EQ.37) CALL IFANSI_IFL(FRMT(1,7),2,'2I3',16,68)
      IF(IT.EQ.0.OR.IT.EQ.38) THEN
          YES = 'NO'
          IF( NORM ) YES = 'YES'
          CALL IFANSI_TEXT( YES, 3, 16, 78 )
      ENDIF

      IF( IT.EQ.0 .OR. IT.EQ.39 ) THEN
          CALL IFANSI_VIDEO(20)
          CALL IFANSI_IFL( JSET, 1, 'I2', 17, 19 )
          CALL IFANSI_IFL( MAXC, 1, 'I2', 17, 22 )
          CALL IFANSI_VIDEO(30)
          CALL IFANSI_IFL( CONN(1,JSET), 2, '2I2', 17, 28 )
          CALL IFANSI_IFL( CONN(3,JSET), 2, '2I2', 17, 33 )
          CALL IFANSI_IFL( CONN(5,JSET), 3, '3I2', 17, 38 )
      ENDIF
      IF(IT.EQ.0.OR.IT.EQ.40)
     +CALL IFANSI_FFL(D1D2(1,JSET),1,'F6.3',17,48)
      IF(IT.EQ.0.OR.IT.EQ.41)
     +CALL IFANSI_FFL(D1D2(2,JSET),1,'F6.3',17,58)
      IF(IT.EQ.0.OR.IT.EQ.42)
     +CALL IFANSI_FFL(D1D2(3,JSET),1,'F6.3',17,68)
      IF(IT.EQ.0.OR.IT.EQ.7 ) CALL IFANSI_TEXT( DESFIL, 10, 18, 4 )
      IF( IT.EQ.0 .OR. (IT.GT.42.AND.IT.LT.52) ) THEN
          IF( IT.EQ.0 ) THEN
              I1 = 1
              I2 = 9
          ELSE
              I1 = IT-42
              I2 = I1
          ENDIF
          DO I=I1, I2
             IF( I.LT.6 ) THEN
                 J = I
                 L = 18
             ELSE
                 J = I-5
                 L = 19
             ENDIF
             CALL IFANSI_IFL( BPEN(I), 1, 'I1', L, 5+J*13 )
             CALL IFANSI_IFL( BTYP(I), 1, 'I3', L, 6+J*13 )
             CALL IFANSI_FFL( BSIZ(I), 1, 'F5.2', L, 9+J*13 )
          ENDDO
      ENDIF
      IF(IT.EQ.0.OR.IT.EQ.52) CALL IFANSI_IFL(BARC,1,'I2',19,70 )
      IF(IT.EQ.0.OR.IT.EQ.53) THEN
          CALL IFANSI_IFL( IDPN,1,'I2',14,53 )
          CALL IFANSI_IFL( IDFN,1,'I2',14,55 )
          CALL IFANSI_FFL( IDSZ,1,'F5.2',14,57 )
      ENDIF
      IF(IT.EQ.0.OR.IT.EQ.54) CALL IFANSI_FFL(OXYZ,3,'3F5.2',14,66)
      IF(IT.EQ.0.OR.IT.EQ.55) THEN
          CALL IFANSI_IFL( LABL, 1, 'I2', 20, 18 )
          CALL IFANSI_FFL( BPOS, 3, '3F4.1', 20, 20 )
      ENDIF
      IF( IT.EQ.0 .OR. IT.EQ.56 ) THEN
          DO I=1, 9
             CALL IFANSI_TEXT( BALL(I), 4, 20, I*5+32 )
          ENDDO
      ENDIF
      RETURN
      END

      SUBROUTINE C3DCON_PARS_JSET
C
C     THIS ROUTINE DISPLAYS THE CURRENT SET OF BOND PARAMETERS.
C
      DO I= 40, 43
         CALL C3DCON_PARS( I )
      ENDDO
      RETURN
      END

      SUBROUTINE C3DCON_COMM
C
C     THIS ROUTINE PARSES THE DIALOGUE COMMANDS.
C
      INCLUDE 'C3DCON.CBS'
      CHARACTER TEXT*77
      COMMON/MENU/ IKEY, NCHS, TEXT
C
C  IF "TEXT" IS A SINGLE WORD AND CONTAINS A DOT,
C  TAKE IT AS A SETUP FILENAME TO BE PLOTTED...
C
      CALL IFMISC_UPPER(NCHS,TEXT)		!CONVERT TO UPPERCASES
      JKEY = INDEX( TEXT(1:NCHS), ' ' )
      IF( JKEY.EQ.0 ) THEN
          JKEY = INDEX( TEXT(1:NCHS), '.' )
          IF( JKEY.GT.0 ) THEN
              IKEY = 1
              CALL C3DCON_FILES
              RETURN
          ENDIF
      ENDIF
      IF( TEXT(1:4).EQ.'DOWN'
     + .OR. (IKEY.EQ.27.AND.TEXT(1:2).EQ.'OP') ) THEN
C
C  DOWN...
          JSET = JSET + 1
          IF( JSET.GT.MAXC ) JSET = 1
          CALL C3DCON_PARS_JSET
      ELSE IF( TEXT(1:2).EQ.'UP'
     + .OR. (IKEY.EQ.27 .AND. TEXT(1:2).EQ.'OR') ) THEN
C
C  UP...
          JSET = JSET - 1
          IF( JSET.LT.1 ) JSET = MAXC
          CALL C3DCON_PARS_JSET
      ELSE IF( TEXT(1:4).EQ.'LOAD' ) THEN
C
C  LOAD...
          IKEY = 1
          NCHS = IFMISC_NEXT(TEXT)
          CALL C3DCON_FILES
      ELSE IF( TEXT(1:4).EQ.'READ' ) THEN
C
C  READ...
          IKEY = 7
          NCHS = IFMISC_NEXT(TEXT)
          CALL C3DCON_FILES
      ELSE IF( TEXT(1:3).EQ.'RES' ) THEN
C
C  RESET...
          CALL C3DCON_INIT
          CALL C3DCON_PARS( 0 )
      ELSE IF( TEXT(1:3).EQ.'LOC' ) THEN
C
C  LOCATE...
          NCHS = IFMISC_NEXT(TEXT)
          CALL C3DCON_LOCATE
      ELSE IF( TEXT(1:4).EQ.'SAVE' ) THEN
          NCHS = IFMISC_NEXT(TEXT)
          CALL C3DCON_SAVE
      ELSE IF( TEXT(1:3).EQ.'INC' ) THEN
C
C  INCLUDE...
          NCHS = IFMISC_NEXT(TEXT)
          CALL C3DCON_EXIN( .TRUE. )
      ELSE IF( TEXT(1:3).EQ.'EXC' ) THEN
C
C  EXCLUDE...
          NCHS = IFMISC_NEXT(TEXT)
          CALL C3DCON_EXIN( .FALSE. )
      ELSE IF( TEXT(1:4).EQ.'HELP'
     + .OR. (IKEY.EQ.27 .AND. TEXT(1:2).EQ.'OQ') ) THEN
C
C  HELP...
          IKEY = IFMISC_HLP( 'C3DCON', TEXT, SLIN, SCOL )
          IF( IKEY.EQ.0 ) CALL C3DCON_FORM
      ELSE IF( TEXT(1:3).EQ.'REF' ) THEN
C
C  REFRESH...
          CALL C3DCON_FORM
      ELSE IF( TEXT(1:3).EQ.'DCL' .OR. TEXT(1:3).EQ.'VMS'
     + .OR. (IKEY.EQ.27 .AND. TEXT(1:3).EQ.'OS') ) THEN
C
C  SPAWN...
          CALL IFANSI_CLEAR(2)
          CALL IFMISC_SPAWN( TEXT, 0 )
          CALL C3DCON_FORM
      ELSE IF( TEXT(1:4).EQ.'TIME' ) THEN
C
C  TIME...
          CALL IFMISC_TIME
      ELSE IF( TEXT(1:3).EQ.'DIS' ) THEN
C
C  DISTANCE...
          IF( NSYM.EQ.0 ) GOTO 888
          NCHS = IFMISC_NEXT(TEXT)
          CALL C3DCON_DISTANCE
      ELSE
          IF( IKEY.NE.27 ) THEN
              CALL IFMISC_OOPS( 2, SLIN, SCOL, TEXT )
          ELSE
              CALL IFMISC_OOPS( 5, SLIN, SCOL, ' ' )
          ENDIF
      ENDIF
      RETURN
  888 CALL C3DCON_OOPS(' Atom table empty.')
      RETURN
      END

      SUBROUTINE C3DCON_FILES
C
C     THIS ROUTINE READS A FILE.
C
      INCLUDE 'C3DCON.CBS'
      INTEGER   C3DCON_READ,C3DCON_MAPFIL,C3DCON_MODFIL,C3DCON_SYMFIL
      CHARACTER TEXT*77
      COMMON/MENU/ IKEY, NCHS, TEXT

      IF( NCHS.EQ.0 .AND. IKEY.EQ.1 ) THEN
          NCHS = IFMISC_PROMPT('_Filename:',TEXT,SLIN+1,9)
          IF( NCHS.EQ.0 ) GOTO 999
      ENDIF
      IF( NCHS.GT.32 ) GOTO 777
      CALL IFMISC_UPPER(NCHS,TEXT)
      IF( IKEY.EQ.1 ) THEN
          NCHS = C3DCON_READ( TEXT(1:NCHS) )
          IF( DESFIL.EQ.' ' ) THEN
              DESFIL = PARFIL
              CALL IFMISC_NAMEXT( DESFIL, '.DES' )
          ENDIF
      ELSE IF( IKEY.LT.6 ) THEN
          I = IKEY-1
          IF( NCHS.EQ.0 ) THEN
              MAPFIL(I) = ' '
              DO J=1, 9
                 GRID(J,I) = 0
              ENDDO
              DMIN(I) = 0.0
              DMAX(I) = 0.0
              DSIG(I) = 0.0
          ELSE
              IF( IKEY.GT.2 .AND. MAPFIL(1).EQ.' ' ) GOTO 666
              NCHS = C3DCON_MAPFIL( I, TEXT(1:NCHS) )
          ENDIF
      ELSE IF( IKEY.EQ.6 ) THEN
          IF( NCHS.EQ.0 ) THEN
              SYMFIL = ' '
              MSYM = 0
              NSYM = 0
          ELSE
              NCHS = C3DCON_SYMFIL( TEXT(1:NCHS) )
          ENDIF
      ELSE IF( IKEY.EQ.7 ) THEN
          IF( NCHS.EQ.0 ) THEN
              MATM = 0
              NATM = 0
              NSYM = 0
              NBND = 0
              MODFIL = ' '
          ELSE
              NCHS = C3DCON_MODFIL( TEXT(1:NCHS) )
          ENDIF
      ELSE IF( IKEY.EQ.8 ) THEN
          DESFIL = TEXT(1:NCHS)
          NCHS   = 0
      ENDIF
      IF( NCHS.NE.0 ) GOTO 888
      CALL C3DCON_PARS(IKEY)
      GOTO 999
  666 CALL C3DCON_OOPS(' Enter 1st density file to start with.')
      GOTO 999
  777 CALL IFMISC_OOPS( 7, SLIN, SCOL, TEXT )
      GOTO 999
  888 IF( NCHS.GT.0 ) THEN
          CALL IFMISC_OOPS( 1, SLIN, SCOL, TEXT )
      ELSE
          CALL IFMISC_OOPS( 14, SLIN, SCOL, TEXT )
      ENDIF
  999 RETURN
      END

      INTEGER   FUNCTION C3DCON_MAPFIL( IFILE, PFILE )
C
C     THIS ROUTINE READS THE HEADER OF A DENSITY FILE.
C
      INCLUDE 'C3DCON.CBS'
      PARAMETER (MMAP = 128)
      LOGICAL   YES
      CHARACTER TEXT*64, FNAME*32, PFILE*(*)
      DIMENSION KP(9), RP(11)

      FNAME = PFILE
      CALL IFMISC_DEFEXT( FNAME, '.MAP' )
      INQUIRE( FILE=FNAME, EXIST=YES )
      IF( .NOT.YES ) GOTO 888
      OPEN( UNIT=13, FILE=FNAME, STATUS='OLD', FORM='UNFORMATTED',
     +      ACCESS='DIRECT', RECORDTYPE='FIXED', READONLY, ERR=888 )
      J = IFILE
      READ(13,REC=1,ERR=777) TEXT(1:64), KP, RP
      I = MMAP*MMAP
      K = (KP(5)-KP(4)+1) * (KP(7)-KP(6)+1)
      IF( K.GT.I ) GOTO 666
      K = (KP(5)-KP(4)+1) * (KP(9)-KP(8)+1)
      IF( K.GT.I ) GOTO 666
      K = (KP(9)-KP(8)+1) * (KP(7)-KP(6)+1)
      IF( K.GT.I ) GOTO 666
      DO I=1,9
         GRID(I,J) = KP(I)
      ENDDO
      SCAL(J) = RP(7)
      OFFS(J) = RP(8)
      DSIG(J) = RP(9)
      DMIN(J) = RP(10)
      DMAX(J) = RP(11)
      IF( J.EQ.1 ) THEN
          IF( TITLE.EQ.' ' ) TITLE = TEXT(1:64)
          IF( CELL(1).EQ.0.0 ) THEN
              DO I=1, 6
                 CELL(I) = RP(I)
              ENDDO
          ENDIF
          IF( CLEV(1).EQ.0 .AND. CLEV(2).EQ.0 .AND. CLEV(3).EQ.0
     +   .AND.CLEV(4).EQ.0 ) THEN
              DO I=1, 4
                 CLEV(I) = DSIG(J)*I
              ENDDO
          ENDIF
      ENDIF
      MAPFIL(J) = FNAME
      C3DCON_MAPFIL = 0
      GOTO 999
  666 CALL C3DCON_OOPS(' Map grid overflow.')
      C3DCON_MAPFIL = 0
      GOTO 999
  888 C3DCON_MAPFIL = 1
      GOTO 999
  777 C3DCON_MAPFIL = -1
  999 CLOSE(UNIT=13)
      RETURN
      END

      INTEGER   FUNCTION C3DCON_SYMFIL( PFILE )
C
C     THIS ROUTINE READS THE SYMMETRY FILE.
C
      INCLUDE 'C3DCON.CBS'
      LOGICAL   YES
      CHARACTER TEXT*80, FNAME*32, PFILE*(*)
      DIMENSION RP(12), KP(12)
C
C  OPEN THE SYMMETRY FILE...
C
      FNAME = PFILE
      CALL IFMISC_DEFEXT( FNAME, '.SYM' )
      INQUIRE( FILE=FNAME, EXIST=YES )
      IF( .NOT.YES ) GOTO 888
      OPEN( UNIT=13, FILE=FNAME, STATUS='OLD', FORM='FORMATTED',
     +CARRIAGECONTROL='LIST', READONLY, ERR=888 )
C
C  READ IN THE SYMMETRY OPERATORS...
C
      MSYM = 0
  111 READ(13,112,ERR=777,END=555) TEXT
  112 FORMAT(A80)
      NCHS = IFMISC_STRIP(TEXT)
      IF( NCHS.EQ.0 ) GOTO 111
      NCHS = IFMISC_DECODE( TEXT, NCHS, 12, RP, KP )
      IF( NCHS.EQ.0 ) GOTO 777
      K = 0
      DO I=1, 3
         DO J=1, 3
            K = K + 1
            IF( RP(K).NE.0.0 .AND. ABS(RP(K)).NE.1.0 ) GOTO 777
            ROTM(I,J,MSYM+1) = RP(K)
         ENDDO
         K = K + 1
         IF( ABS(RP(K)).GE.1.0 ) GOTO 777
         TRAN(I,MSYM+1) = RP(K)
      ENDDO
      MSYM = MSYM + 1
      IF( MSYM.LT.MAXS ) GOTO 111
      CALL C3DCON_OOPS(' symmetry operator table full.')
  555 IF( MSYM.EQ.0 ) GOTO 777
      SYMFIL = FNAME
      C3DCON_SYMFIL = 0
      GOTO 999
  888 C3DCON_SYMFIL = 1
      GOTO 999
  777 C3DCON_SYMFIL = -1
  999 CLOSE(UNIT=13)
      RETURN
      END

      INTEGER   FUNCTION C3DCON_MODFIL( PFILE )
C
C     THIS ROUTINE READS THE STRUCTURE MODEL FILE.
C
      INCLUDE 'C3DCON.CBS'
      LOGICAL   YES
      CHARACTER ID*8, TEXT*132, FNAME*32, PFILE*(*)
      REAL      AA(3)
      INTEGER   C3DCON_NSUB, ABC
      COMMON/TRAN/ ABC(3)
C
C  OPEN THE MODEL FILE...
C
      FNAME = PFILE
      CALL IFMISC_DEFEXT( FNAME, '.XYZ' )
      INQUIRE( FILE=FNAME, EXIST=YES )
      IF( .NOT.YES ) GOTO 888
      OPEN( UNIT=13, FILE=FNAME, STATUS='OLD', FORM='FORMATTED',
     +CARRIAGECONTROL='LIST', READONLY, ERR=888 )
C
C  TRY TO READ UNIT CELL AND ATOM LINE FORMAT FROM THE ATOM FILE...
C
      CALL C3DCON_SCAN( 13 )
      DO I=1, 6
         IF( CELL(I).EQ.0.0 ) THEN
         CALL C3DCON_OOPS(' Unit cell parameters (CP)
     + not yet specified.')
         GOTO 999
         ENDIF
      ENDDO
      IF( FRMT(1,2).LT.1 .OR. FRMT(1,3).LT.1 .OR. FRMT(1,4).LT.1 ) THEN
      CALL C3DCON_OOPS(' x,y,z formats (FX,FY,FZ) not yet specified.')
          GOTO 999
      ENDIF
      TEXT = ' Reading atom file'
      TEXT(20:) = FNAME
      JR = IFMISC_LENG( TEXT )
      TEXT(JR+2:) = '(CTRL/C to abort)...'
      CALL C3DCON_OOPS( TEXT )
C
C  TRAP A CTRL/C INTERRUPT....
C
      CALL IFQAST_CTRLC
C
C  SETUP TRANFORMATION MATRICES...
C
      CALL C3DCON_MATRIX(0.0)
C
C  INITIALIZE FOR READ...
C
      MATM = 0
      NATM = 0
      NSYM = 0
      YES  = .FALSE.
      IF( NSTR.GT.0 ) YES = .TRUE.
      ITT = 1       !ACTIVE ATOM TYPE
      ICC = 1       !ACTIVE ATOM CONNECTION CLASS
      K1  = 0       !SYMMETRY INCLUSIVE POINTER
      K2  = 0       !SYMMETRY INCLUSIVE POINTER
C
C  GET NUMBER OF STRIDES ALONG A,B,C AXES FOR TRANSLATION SEARCH...
C
      IF( SYMM ) THEN
          IF( SRAD.EQ.0.0 ) THEN
              DO I=1, 3
                 ABC(I) = INT(DBOX(I)+0.5)
              ENDDO
          ELSE
              DO I=1, 3
                 ABC(I) = 1
              ENDDO
          ENDIF
      ELSE
          DO I=1, 3
             ABC(I) = 0      !NO TRANSLATION SEARCH
          ENDDO
      ENDIF
C
C  READ AN ATOM...
C
      NLINE = 0
  111 READ(13,112,ERR=777,END=555) TEXT
  112 FORMAT(A132)
      IF( TEXT(1:1).EQ.'!' .OR. TEXT(1:1).EQ.'%' ) GOTO 111 !COMMENTS
      NLINE = NLINE + 1
      IF( IFCTRL_C() ) THEN
          NATM = 0
          MATM = 0
          NSYM = 0
          MODFIL = FNAME
          CALL C3DCON_CLEAR_OOPS
          GOTO 9999
      ENDIF
C
C  TEST FOR RANGE AND/OR EXCLUSIVE/INCLUSIVE SET OF ATOMS...
C
      IF( YES .AND. (NLINE.LT.NSTR.OR.NLINE.GT.NEND) ) GOTO 111
      NCHS = IFMISC_LENG(TEXT)
      IF( NCHS.EQ.0 ) GOTO 111
      IF( NSUB.GT.0 ) THEN
          IT = C3DCON_NSUB( TEXT )
          IF( IT.GT.0 ) GOTO 111
      ENDIF
C
C  DECODE THE LINE...
C
      CALL C3DCON_ATOM( NCHS, TEXT, FRMT, ID, AA, IT, IC, K1, K2 )
      IF( NCHS.EQ.0 ) GOTO 777
      MATM = MATM + 1
      IF( IT.GT.0 .AND. IT.LT.10  ) ITT = IT
      IF( IC.GT.0 .AND. IC.LT.128 ) ICC = IC
C
C  SCREEN THIS ONE AGAINST SYMMETRY AND ENCLOSURE VOLUME...
C
      IF( EDGE ) THEN            !CONVERT TO FRACTIONAL UNITS
           DO I=1, 3
              AA(I) = AA(I)/CELL(I)
           ENDDO
      ENDIF
      IF( NORM ) THEN                 !DEORTHOGONALIZE
          DO I=1, 3
             AA(I) = AA(I)*CELL(I)
          ENDDO
          CALL C3DCON_MV( THOR, AA )
      ENDIF
      CALL C3DCON_TRAN( ID, AA, ITT, ICC, 0 )
      IF( MSYM.GT.1 ) CALL C3DCON_SYMM( ID, AA, ITT, ICC, K1, K2 )
      IF( NSYM.LT.MAXA ) GOTO 111
      CALL C3DCON_OOPS(' atom table full.')
C
C  END OF ATOM FILE..
C  LOAD THE UNIT CELL VERTICES AS PHONY ATOMS...
C
  555 DO I=1, 3
         AA(I) = 0.0
      ENDDO
      ID = ' '
      CALL C3DCON_TRAN( ID, AA, 1, 0, 0 )
      IF( NSYM.EQ.0 ) GOTO 666
C
C  SET INITIAL ATOM ID FLAGS...
C
      IF( YES .AND. MATM.LT.NEND ) NEND = MATM
      DO I=1, NSYM
         SHOW(I) = IDON
      ENDDO
      NBND   = 0               !CLEAR EXTRA BONDS FOR NEW MODEL
      MODFIL = FNAME
      CALL C3DCON_CLEAR_OOPS
      GOTO 668
  666 IF( YES ) THEN
          NSTR = 0
          NEND = 0
      ENDIF
      IF( MATM.GT.0 .OR. MODFIL.EQ.' ' ) MODFIL = FNAME
      CALL C3DCON_OOPS(' no atom loaded from the atom file.')
  668 IF( YES ) CALL C3DCON_PARS( 30 )
C
C  SET FLAGS AND RETURN...
C
 9999 C3DCON_MODFIL = 0
      CALL IFQAST_CLEAR
      GOTO 999
  888 C3DCON_MODFIL = 1
      GOTO 999
  777 C3DCON_MODFIL = -1
      CALL IFQAST_CLEAR
  999 CLOSE(UNIT=13)
      RETURN
      END

      SUBROUTINE C3DCON_SCAN( LUN )
C
C     THIS ROUTINE INTENDS TO READ THE UNIT CELL AND THE ATOM
C     LINE COLUMN FORMAT FROM THE ATOM FILE BY SEARCHING THE
C     THE FIRST 5 LINES OF THE FILE FOR THE FOLLOWING:
C
C           %CP=a,b,c,alpha,beta,gamma
C           %FM=I1,I2,X1,X2,Y1,Y2,Z1,Z2,T1,T2,C1,C2,S1,S2
C
      INCLUDE 'C3DCON.CBS'
      CHARACTER TEXT*80
      DIMENSION RP(14), KP(14)

      DO I=1, 5
         READ(LUN,111,END=999) TEXT
 111     FORMAT(A80)
         NCHS = IFMISC_STRIP(TEXT)
         IF( NCHS.GT.0 ) THEN
             CALL IFMISC_UPPER(NCHS,TEXT)
             IF( TEXT(1:4).EQ.'%CP=' ) THEN
                 NCHS = IFMISC_DECODE(TEXT(5:),NCHS-4,6,RP,KP)
                 IF( NCHS.GT.0 ) THEN
                     DO J=1, 6
                        IF( RP(J).GT.0.0 ) CELL(J) = RP(J)
                     ENDDO
                     CALL C3DCON_PARS( 17 )
                 ENDIF
             ELSE IF( TEXT(1:4).EQ.'%FM=' ) THEN
                 NCHS = IFMISC_DECODE(TEXT(5:),NCHS-4,14,RP,KP)
                 IF( NCHS.GT.0 ) THEN
                     DO J=1, 7
                        IF( RP(J*2-1).GT.0.0 ) FRMT(1,J) = RP(J*2-1)
                        IF( RP(J*2  ).GT.0.0 ) FRMT(2,J) = RP(J*2)
                     ENDDO
                     DO J=32, 38
                        CALL C3DCON_PARS( J )
                     ENDDO
                 ENDIF
             ENDIF
         ENDIF
      ENDDO
 999  REWIND(UNIT=LUN)
      RETURN
      END

      INTEGER   FUNCTION C3DCON_NSUB( TEXT )
C
C     THIS ROUTINE TESTS A LINE OF INPUT TEXT FROM ATOM FILE
C     FOR INCLUSIVE/EXCLUSIVE LINES.
C
C     EXIN=.TRUE. ----- "SUID" LIST IS INCLUSIVE.
C     EXIN=.FALSE. ---- "SUID" LIST IS EXCLUSIVE.
C
      INCLUDE 'C3DCON.CBS'
      CHARACTER TEXT*(*)

      DO I=1, NSUB
         IF( SUBC(1,I).GT.0 ) THEN  !SUID(I) COLUMN POSITION IS SPECIFIED
             IT = 0
             IF( TEXT(SUBC(1,I):SUBC(2,I)).EQ.SUID(I) ) IT = 1
         ELSE                       !SEARCH TEXT FOR SUID(I)
             IT = INDEX( TEXT, SUID(I) )
         ENDIF
         IF( IT.GT.0 ) GOTO 111
      ENDDO
      IF( EXIN ) IT = 1
      GOTO 999
  111 IF( EXIN ) IT = 0
  999 C3DCON_NSUB = IT
      RETURN
      END

      SUBROUTINE C3DCON_ATOM( NCHS,TEXT,FRMT,ID,AA,IT,IC,K1,K2 )
C
C     THIS ROUTINE DECODES A LINE OF "TEXT" FOR ATOM PARAMETERS.
C
      CHARACTER ID*8, TEXT*(*)
      INTEGER   FRMT(2,7), KP(2)
      REAL      AA(3), RP(2)

      NK = NCHS
      ID = ' '
      IT = 0
      IC = 0
C
C  GET ATOM ID...
C
      I1 = FRMT(1,1)
      IF( I1.GT.0 .AND. I1.LE.NK ) THEN
          I2 = FRMT(2,1)
          IF( I2.GT.NK ) I2 = NK
          ID = TEXT(I1:I2)
          I1 = IFMISC_STRIP(ID)
      ENDIF
C
C  GET ATOM'S X-COORDINATE...
C
      I1 = FRMT(1,2)
      IF( I1.GT.0 .AND. I1.LE.NK ) THEN
          I2 = FRMT(2,2)
          IF( I2.GT.NK ) I2 = NK
          READ(TEXT(I1:I2),111,ERR=888) AA(1)
      ENDIF
  111 FORMAT(F20.0)
C
C  GET ATOM'S Y-COORDINATE...
C
      I1 = FRMT(1,3)
      IF( I1.GT.0 .AND. I1.LE.NK ) THEN
          I2 = FRMT(2,3)
          IF( I2.GT.NK ) I2 = NK
          READ(TEXT(I1:I2),111,ERR=888) AA(2)
      ENDIF
C
C  GET ATOM'S Z-COORDINATE...
C
      I1 = FRMT(1,4)
      IF( I1.GT.0 .AND. I1.LE.NK ) THEN
          I2 = FRMT(2,4)
          IF( I2.GT.NK ) I2 = NK
          READ(TEXT(I1:I2),111,ERR=888) AA(3)
      ENDIF
C
C  GET ATOM TYPE...
C
      I1 = FRMT(1,5)
      IF( I1.GT.0 .AND. I1.LE.NK ) THEN
          I2 = FRMT(2,5)
          IF( I2.GT.NK ) I2 = NK
          READ(TEXT(I1:I2),222,ERR=888) IT
      ENDIF
  222 FORMAT(I5)
C
C  GET ATOM CONNECTION CLASS FLAG...
C
      I1 = FRMT(1,6)
      IF( I1.GT.0 .AND. I1.LE.NK ) THEN
          I2 = FRMT(2,6)
          IF( I2.GT.NK ) I2 = NK
          READ(TEXT(I1:I2),222,ERR=888) IC
      ENDIF
C
C  GET ATOM SYMMETRY GENERATION FLAGS...
C
      I1 = FRMT(1,7)
      K1 = 0
      K2 = 0
      IF( I1.GT.0 .AND. I1.LE.NK ) THEN
          I2 = FRMT(2,7)
          IF( I2.GT.NK ) I2 = NK
          I2 = IFMISC_DECODE( TEXT(I1:I2), I2-I1+1, 2, RP, KP )
          K1 = RP(1)+0.5
          K2 = RP(2)+0.5
          IF( K2.GT.0 .AND. K1.GT.K2 ) THEN
              I1 = K1
              K1 = K2
              K2 = I1
          ENDIF
      ENDIF
      RETURN
 888  NCHS = 0
      RETURN
      END

      SUBROUTINE C3DCON_SYMM( ID, AA, IT, IC, K1, K2 )
C
C     THIS ROUTINE GETS SYMMETRY RELATED ATOMS.
C
      INCLUDE 'C3DCON.CBS'
      REAL      AA(3), BB(3)
      CHARACTER ID*8
C
C  APPLY SYMMETRY OPERATORS ...
C  ASSUMING THE 1ST OPERATOR IS THE IDENTITY...
C
      DO 111 J=2, MSYM
         IF( K1.GT.0 ) THEN
            IF( K2.EQ.0 ) THEN
                IF( J.NE.K1 ) GOTO 111
            ELSE
                IF( J.LT.K1.OR.J.GT.K2 ) GOTO 111
            ENDIF
         ENDIF
         DO I=1, 3
            BB(I) = AA(I)
         ENDDO
         CALL C3DCON_MV(ROTM(1,1,J),BB)
         DO I=1, 3
            BB(I) = BB(I) + TRAN(I,J)
         ENDDO
         CALL C3DCON_TRAN( ID, BB, IT, IC, J )
         IF( NSYM.GE.MAXA ) GOTO 999
  111 CONTINUE
  999 RETURN
      END

      SUBROUTINE C3DCON_TRAN( ID, AA, IT, IC, IS )
C
C     THIS ROUTINE GETS TRANSLATION RELATED ATOMS...
C
      INCLUDE 'C3DCON.CBS'
      CHARACTER ID*8
      REAL      AA(3), BB(3)
      INTEGER   C3DCON_TEST, ABC
      COMMON/TRAN/ ABC(3)

      DO I=-ABC(1), ABC(1)
         BB(1) = AA(1) + FLOAT(I)
         DO J=-ABC(2), ABC(2)
            BB(2) = AA(2) + FLOAT(J)
            DO K=-ABC(3), ABC(3)
               BB(3) = AA(3) + FLOAT(K)
               IF(C3DCON_TEST(BB).GT.0) CALL C3DCON_LIST(ID,BB,IT,IC,IS)
            ENDDO
         ENDDO
      ENDDO
      RETURN
      END

      INTEGER   FUNCTION C3DCON_TEST( AA )
C
C     THIS ROUTINE TESTS AN ATOM FOR ENCLOSURE.
C
      INCLUDE 'C3DCON.CBS'
      INTEGER   C3DCON_CLIP
      REAL   AA(3), BB(3)

      IT = 0
      DO I=1, 3
         BB(I) = AA(I)-ORIG(I)
      ENDDO
      IF( SRAD.EQ.0.0 ) THEN     !TRICLINIC BOX
          DO I=1, 3
             IF( ABS(BB(I)).GT.DBOX(I) ) GOTO 9
          ENDDO
      ELSE
          CALL C3DCON_MV( GALL, BB )
          IF(SQRT(BB(1)*BB(1)+BB(2)*BB(2)+BB(3)*BB(3)).GT.SRAD) GOTO 9
      ENDIF
      IT = 1
C
C  TEST FOR CLIPPING IF SLAB IS ON...
C
      IF( CLIP ) THEN
          IF( SRAD.EQ.0.0 ) CALL C3DCON_MV( GALL, BB )
          IT = C3DCON_CLIP( SLAB, BB )
      ENDIF
  9   C3DCON_TEST = IT
      RETURN
      END

      INTEGER   FUNCTION C3DCON_CLIP( SLAB, BB )
C
C     THIS ROUTINE TESTS AN ATOM FOR THE RETNAGULAR CLIPPING BOX.
C
      REAL   SLAB(3), BB(3)
      DO I=1, 3
         IF( SLAB(1).GT.0.0 .AND. ABS(BB(1)).GT.SLAB(1) ) GOTO 9
         IF( SLAB(2).GT.0.0 .AND. ABS(BB(2)).GT.SLAB(2) ) GOTO 9
         IF( SLAB(3).GT.0.0 .AND. ABS(BB(3)).GT.SLAB(3) ) GOTO 9
      ENDDO
      C3DCON_CLIP = 1
      RETURN
   9  C3DCON_CLIP = 0
      RETURN
      END

      SUBROUTINE C3DCON_LIST( ID, AA, IT, IC, IS )
C
C     THIS ROUTINE PUTS AN ATOM INTO ATOM ARRAY.
C
C	ID --- ATOM ID (CHAR*8).
C	AA --- XYZ FRACTIONAL COORDINATES.
C	IT --- ATOM TYPE FLAG (1-9).
C	IC --- ATOM CONNECTION CLASS FLAG (>0).
C	IS --- POINTER TO SYMMETRY TABLE.
C
      INCLUDE 'C3DCON.CBS'
      PARAMETER (ERROR= 0.000001)
      REAL      AA(3), BB(3)
      CHARACTER ID*8

      IF( IC.GT.0 .AND. NSYM.EQ.MAXA ) RETURN
C
C  CHECK FOR DUPLICATED ATOMS...
C
      DO I=1, 3
         BB(I) = AA(I)-ORIG(I)
      ENDDO
      IF( IC.GT.0 ) THEN       !REGULAR ATOMS
          DO J=1, NSYM
             IF( IC.EQ.ATCL(J)
     +       .AND. ABS(ATOM(1,J)-BB(1)).LT.ERROR
     +       .AND. ABS(ATOM(2,J)-BB(2)).LT.ERROR
     +       .AND. ABS(ATOM(3,J)-BB(3)).LT.ERROR ) RETURN
          ENDDO
      ELSE                     !UNIT CELL VERTICES
          DO J=1, NSYM
     	     IF(   ABS(ATOM(1,J)-BB(1)).LT.ERROR
     +       .AND. ABS(ATOM(2,J)-BB(2)).LT.ERROR
     +       .AND. ABS(ATOM(3,J)-BB(3)).LT.ERROR ) THEN
                  ATCL(J) = -ATCL(J)
                  RETURN
             ENDIF
          ENDDO
      ENDIF
      NATM = NATM + 1
      ATID(NATM) = ID
      ATBB(NATM) = IT
      ATCL(NATM) = IC
      ATSY(NATM) = IS
      DO I=1, 3
         ATOM(I,NATM) = BB(I)
      ENDDO
      IF( IC.GT.0 ) NSYM = NSYM + 1
      RETURN
      END

      SUBROUTINE C3DCON_EXIN( YES )
C
C     THIS ROUTINE ADDS AN ENTRY TO THE EXCLUSIVE/INCLUSIVE 
C     LIST OF ATOMS FROM ATOM FILE.
C
      INCLUDE 'C3DCON.CBS'
      DIMENSION RP(2), KP(2)
      LOGICAL   YES
      CHARACTER ID*8, TEXT*77
      COMMON/MENU/ IKEY, NCHS, TEXT

      IF( NCHS.EQ.0 ) THEN        !INITIALIZE THE LIST
          EXIN = YES
          NSUB = 0
          CALL C3DCON_OOPS(' inclusive/exclusive list empty.')
          RETURN
      ENDIF
      IF( YES .NE. EXIN ) THEN    !INITIALIZE THE LIST
          EXIN = YES
          NSUB = 0
      ELSE IF( NSUB.EQ.MAXI ) THEN
          CALL C3DCON_OOPS('inclusive/exclusive entries full.')
          RETURN
      ENDIF
      IF( TEXT(1:1).EQ.'"' ) THEN
          IKEY = INDEX(TEXT(2:NCHS),'"') + 1
          IF( IKEY.LT.3 ) GOTO 888
          ID = TEXT(2:IKEY-1)
          IF( IKEY.LT.NCHS ) THEN
              TEXT = TEXT(IKEY+1:)
          ELSE
              IKEY = 0
          ENDIF
      ELSE
          IKEY = INDEX( TEXT(1:NCHS), ' ' )
          IF( IKEY.EQ.0 ) THEN
              ID = TEXT(1:8)
          ELSE
              ID = TEXT(1:IKEY-1)
              TEXT = TEXT(IKEY+1:)
          ENDIF
      ENDIF
      IF( IKEY.GT.0 ) THEN
          NCHS = IFMISC_DECODE( TEXT, NCHS-IKEY+1, 2, RP, KP )
          IF( NCHS.EQ.0 ) GOTO 888
          I1 = RP(1)+0.5
          IF( I1.LT.1 .OR. I1.GT.132 ) GOTO 888
          I2 = RP(2)+0.5
          IF( I2.LT.1 .OR. I2.GT.132 .OR. I2.LT.I1 ) GOTO 888
      ELSE
          I1 = 0
          I2 = 0
      ENDIF
      NSUB = NSUB + 1
      SUID(NSUB) = ID
      SUBC(1,NSUB) = I1
      SUBC(2,NSUB) = I2
      RETURN
  888 CALL IFMISC_OOPS( 3, SLIN, SCOL, TEXT )
      RETURN
      END

      SUBROUTINE C3DCON_SETUP1
C
C     THIS ROUTINE SETUPS OVERALL GRAPH PARAMETERS.
C
      INCLUDE 'C3DCON.CBS'
      INTEGER   C3DCON_MODFIL
      CHARACTER TEXT*77
      COMMON/MENU/ IKEY, NCHS, TEXT
      DIMENSION KP(10), RP(10)

      IF( IKEY.NE.9 .AND. NCHS.EQ.0 ) THEN
          CALL IFMISC_OOPS( 4, SLIN, SCOL, ' ' )
          RETURN
      ENDIF
      IF( IKEY.EQ.9 ) THEN
          TITLE = TEXT
      ELSE IF( IKEY.EQ.10 ) THEN
          NCHS = IFMISC_DECODE( TEXT, NCHS, 3, RP, KP )
          IF( NCHS.EQ.0 ) GOTO 777
          DO I=1, 3
             IF( KP(I).NE.0 ) ROTA(I) = MOD(INT(RP(I)),360)
          ENDDO
      ELSE IF( IKEY.EQ.11 ) THEN
          NCHS = IFMISC_DECODE( TEXT, NCHS, 3, RP, KP )
          IF( NCHS.EQ.0 ) GOTO 777
          DO I=1, 3
             IF( KP(I).NE.0 ) THEN
                 IF( ABS(RP(I)).GE.1.0 ) GOTO 777
                 ORIG(I) = RP(I)
             ENDIF
          ENDDO
          CENT = ' '
          CALL C3DCON_PARS( 12 )
          IF( MODFIL.NE.' ' ) THEN
              NCHS = C3DCON_MODFIL(MODFIL)  !RELOAD ATOM TABLE
              CALL C3DCON_PARS( 7 )
          ENDIF
      ELSE IF( IKEY.EQ.12 ) THEN
          CALL C3DCON_LOCATE
          GOTO 999
      ELSE IF( IKEY.EQ.13 ) THEN
          NCHS = IFMISC_DECODE( TEXT, NCHS, 1, RP, KP )
          IF( NCHS.EQ.0 ) GOTO 777
          IF( RP(1).LT.0.0 .OR. RP(1).GT.9999.0 ) GOTO 777
          A2IN = RP(1)
      ELSE IF( IKEY.EQ.14 ) THEN
          NCHS = IFMISC_DECODE( TEXT, NCHS, 3, RP, KP )
          IF( NCHS.EQ.0 ) GOTO 777
          DO I=1, 3
             IF( KP(I).NE.0 ) THEN
                 IF( RP(I).LT.0.0 ) GOTO 777
                 SLAB(I) = RP(I)
             ENDIF
          ENDDO
          CLIP = .FALSE.
          IF(SLAB(1).GT.0.OR.SLAB(2).GT.0.OR.SLAB(3).GT.0) CLIP=.TRUE.
      ELSE IF( IKEY.EQ.15 ) THEN
          NCHS = IFMISC_DECODE( TEXT, NCHS, 1, RP, KP )
          IF( NCHS.EQ.0 ) GOTO 777
          SANG = MOD(INT(RP(1)),360)
      ELSE IF( IKEY.EQ.16 ) THEN
          NCHS = IFMISC_DECODE( TEXT, NCHS, 1, RP, KP )
          IF( NCHS.EQ.0 ) GOTO 777
          IF( RP(1).LT.0.0 .OR. RP(1).GT.9999.0) GOTO 777
          AXES = RP(1)
      ELSE IF( IKEY.EQ.17 ) THEN
          NCHS = IFMISC_DECODE( TEXT, NCHS, 6, RP, KP )
          IF( NCHS.EQ.0 ) GOTO 777
          DO I=1, 3
             IF( KP(I).NE.0 ) THEN
                 IF( RP(I).LT.0.0 ) GOTO 777
                 CELL(I) = RP(I)
             ENDIF
          ENDDO
          DO I=4, 6
             IF( KP(I).NE.0 ) THEN
                 F = RP(I)
                 IF( F.LT.0.0 .OR. F.GE.180.0 ) GOTO 777
                 IF( F.EQ.0.0 ) F = 90.0
                 CELL(I) = F
             ENDIF
          ENDDO
          IF( MODFIL.NE.' ' ) THEN
              NCHS = C3DCON_MODFIL(MODFIL)  !RELOAD ATOM TABLE
              CALL C3DCON_PARS( 7 )
          ENDIF
      ELSE IF( IKEY.EQ.18 ) THEN
          NCHS = IFMISC_DECODE( TEXT, NCHS, 3, RP, KP )
          IF( NCHS.EQ.0 ) GOTO 777
          IF( KP(1).NE.0 ) THEN
              J = RP(1)+0.5
              IF( J.LT.0 .OR. J.GT.9 ) GOTO 777
              UNIC(1) = J
          ENDIF
          DO I=2, 3
             IF( KP(I).NE.0 ) THEN
                 J = RP(I)+0.5
                 IF( J.LT.1 .OR. J.GT.9 ) GOTO 777
                 UNIC(I) = J
             ENDIF
          ENDDO
      ENDIF
      CALL C3DCON_PARS( IKEY )
      GOTO 999
  777 CALL IFMISC_OOPS( 3, SLIN, SCOL, TEXT )
  999 RETURN
      END

      SUBROUTINE C3DCON_SETUP2
C
C     THIS ROUTINE SETUPS CONTOURING PARAMETERS.
C
      INCLUDE 'C3DCON.CBS'
      CHARACTER TEXT*77
      COMMON/MENU/ IKEY, NCHS, TEXT
      DIMENSION KP(10), RP(10)

      IF( NCHS.EQ.0 ) THEN
          CALL IFMISC_OOPS( 4, SLIN, SCOL, ' ' )
          RETURN
      ENDIF
      IF( IKEY.EQ.21 ) THEN
          CALL IFMISC_UPPER(NCHS,TEXT)
          IF( TEXT(1:NCHS).EQ.'YES' ) BACK = .TRUE.
          IF( TEXT(1:NCHS).EQ.'NO'  ) BACK = .FALSE.
      ELSE
          NCHS = IFMISC_DECODE( TEXT, NCHS, 4, RP, KP )
          IF( NCHS.EQ.0 ) GOTO 777
          IF( IKEY.EQ.19 ) THEN
              DO I=1, 4
                 IF( KP(I).NE.0 ) THEN
                     J = RP(I)+0.5
                     IF( J.LT.0 .OR. J.GT.1 ) GOTO 777
                     FLAG(I) = J
                 ENDIF
              ENDDO
          ELSE IF( IKEY.EQ.20 ) THEN
              DO I=1, 4
                 IF( KP(I).NE.0 ) CLEV(I) = RP(I)
              ENDDO
          ELSE IF( IKEY.EQ.22 ) THEN
              DO I=1, 3
                 IF( KP(I).NE.0 ) THEN
                     F = RP(I)
                     IF( F.LT.2.0 .OR. F.GT.2.0*CELL(I) ) GOTO 777
                     CBOX(I) = F
                 ENDIF
              ENDDO
          ELSE IF( IKEY.EQ.23 ) THEN
              DO I=1, 4
                 IF( KP(I).NE.0 ) THEN
                     J = RP(I)+0.5
                     IF( J.LT.1 .OR. J.GT.9 ) GOTO 777
                     CPEN(I) = J
                 ENDIF
              ENDDO
          ELSE IF( IKEY.EQ.24 ) THEN
              DO I=1, 4
                 IF( KP(I).NE.0 ) THEN
                     J = RP(I)+0.5
                     IF( J.LT.1 .OR. J.GT.9 ) GOTO 777
                     LINE(I) = J
                 ENDIF
              ENDDO
          ELSE IF( IKEY.EQ.25 ) THEN
              DO I=1, 4
                 IF( KP(I).NE.0 ) THEN
                     J = RP(I)+0.5
                     IF( J.LT.1 .OR. J.GT.9 ) GOTO 777
                     BOLD(I) = J
                 ENDIF
              ENDDO
          ENDIF
      ENDIF
      CALL C3DCON_PARS( IKEY )
      GOTO 999
  777 CALL IFMISC_OOPS( 3, SLIN, SCOL, TEXT )
  999 RETURN
      END

      SUBROUTINE C3DCON_SETUP3
C
C     THIS ROUTINE SETUPS MODEL DRAWING PARAMETERS.
C
      INCLUDE 'C3DCON.CBS'
      INTEGER   C3DCON_MODFIL
      CHARACTER TEXT*77
      COMMON/MENU/ IKEY, NCHS, TEXT
      DIMENSION KP(10), RP(10)

      IF( NCHS.EQ.0 .AND. IKEY.NE.57 ) THEN
          CALL IFMISC_OOPS( 4, SLIN, SCOL, ' ' )
          RETURN
      ENDIF
      IF( IKEY.EQ.26 ) THEN
          CALL IFMISC_UPPER(NCHS,TEXT)
          IF( TEXT(1:NCHS).EQ.'YES' ) SYMC = .TRUE.
          IF( TEXT(1:NCHS).EQ.'NO'  ) SYMC = .FALSE.
      ELSE IF( IKEY.EQ.27 ) THEN
          CALL IFMISC_UPPER(NCHS,TEXT)
          IF( TEXT(1:NCHS).EQ.'YES' ) SYMM = .TRUE.
          IF( TEXT(1:NCHS).EQ.'NO'  ) SYMM = .FALSE.
      ELSE IF( IKEY.EQ.28 ) THEN
          NCHS = IFMISC_DECODE( TEXT, NCHS, 1, RP, KP )
          IF( NCHS.EQ.0 ) GOTO 777
          F = RP(1)
          IF( F.LT.0.0 .OR. F.GT.1.5*CELL(1) .OR.
     +        F.GT.1.5*CELL(2) .OR. F.GT.1.5*CELL(3) ) GOTO 777
          SRAD = F
          DO I=1, 3
             DBOX(I) = 0.0
          ENDDO
          CALL C3DCON_PARS( 29 )
          IF( MODFIL.NE.' ' ) THEN
              NCHS = C3DCON_MODFIL(MODFIL)  !RELOAD ATOM TABLE
              CALL C3DCON_PARS( 7 )
          ENDIF
      ELSE IF( IKEY.EQ.29 ) THEN
          NCHS = IFMISC_DECODE( TEXT, NCHS, 3, RP, KP )
          IF( NCHS.EQ.0 ) GOTO 777
          DO I=1, 3
             IF( KP(I).NE.0 ) THEN
                 F = RP(I)
                 IF( F.LT.0.01 .OR. F.GT.5.0 ) GOTO 777
                 DBOX(I) = F
             ENDIF
          ENDDO
          SRAD = 0.0
          CALL C3DCON_PARS( 28 )
          IF( MODFIL.NE.' ' ) THEN
              NCHS = C3DCON_MODFIL(MODFIL)  !RELOAD ATOM TABLE
              CALL C3DCON_PARS( 7 )
          ENDIF
      ELSE IF( IKEY.EQ.30 ) THEN
          NCHS = IFMISC_DECODE( TEXT, NCHS, 2, RP, KP )
          IF( NCHS.EQ.0 ) GOTO 777
          DO I=1, 2
             IF( KP(I).NE.0 ) THEN
                 J = RP(I)+0.5
                 IF( J.LT.1 ) J = 1
                 IF( J.GT.9999 ) J = 9999
                 IF( I.EQ.1 ) NSTR = J
                 IF( I.EQ.2 ) NEND = J
             ENDIF
          ENDDO
          IF( NSTR.GT.NEND ) GOTO 777
          IF( MODFIL.NE.' ' ) THEN
              NCHS = C3DCON_MODFIL(MODFIL)  !RELOAD ATOM TABLE
              CALL C3DCON_PARS( 7 )
          ENDIF
      ELSE IF( IKEY.EQ.31 ) THEN
          CALL IFMISC_UPPER(NCHS,TEXT)
          IF( TEXT(1:NCHS).EQ.'YES' ) EDGE = .TRUE.
          IF( TEXT(1:NCHS).EQ.'NO'  ) EDGE = .FALSE.
      ELSE IF( IKEY.GT.31 .AND. IKEY.LT.39 ) THEN
          NCHS = IFMISC_DECODE( TEXT, NCHS, 2, RP, KP )
          IF( NCHS.EQ.0 ) GOTO 777
          DO I=1, 2
             IF( KP(I).NE.0 ) THEN
                 J = RP(I)
                 IF( J.LT.0 .OR. J.GT.132 ) GOTO 777
                 FRMT(I,IKEY-31) = J
             ENDIF
          ENDDO
          IF( FRMT(1,IKEY-31).GT.FRMT(2,IKEY-31) ) GOTO 777
      ELSE IF( IKEY.EQ.39 ) THEN
          CALL IFMISC_UPPER(NCHS,TEXT)
          IF( TEXT(1:NCHS).EQ.'YES' ) NORM = .TRUE.
          IF( TEXT(1:NCHS).EQ.'NO'  ) NORM = .FALSE.
      ELSE IF( IKEY.EQ.40 ) THEN
          NCHS = IFMISC_DECODE( TEXT, NCHS, 10, RP, KP )
          IF( NCHS.EQ.0 ) GOTO 777
          DO I=1, 4
             IF( KP(I).NE.0 ) THEN
                 J = RP(I)+0.5
                 IF( J.LT.0 .OR. J.GT.9 ) GOTO 777
                 CONN(I,JSET) = J
             ENDIF
          ENDDO
          DO I=1, 2
             NCHS = 1+(I-1)*2
             IF( CONN(NCHS,JSET).GT.CONN(2*I,JSET) ) THEN
                 J = CONN(NCHS,JSET)
                 CONN(NCHS,JSET) = CONN(2*I,JSET)
                 CONN(2*I,JSET) = J
             ENDIF
          ENDDO
          DO I=5, 7
             IF( KP(I).NE.0 ) THEN
                 J = RP(I)+0.5
                 IF( J.LT.1 .OR. J.GT.9 ) GOTO 777
                 CONN(I,JSET) = J
             ENDIF
          ENDDO
          DO I=8, 10
             IF( KP(I).NE.0 ) THEN
                 F = RP(I)
                 IF( F.LT.0.0 .OR. F.GT.99.0 ) GOTO 777
                 D1D2(I-7,JSET) = F
                 CALL C3DCON_PARS( 33+I )
             ENDIF
          ENDDO
      ELSE IF( IKEY.GT.40 .AND. IKEY.LT.44 ) THEN
          NCHS = IFMISC_DECODE( TEXT, NCHS, 1, RP, KP )
          IF( NCHS.EQ.0 ) GOTO 777
          F = RP(1)
          IF( F.LT.0.0 .OR. F.GT.99.999 ) GOTO 777
          D1D2(IKEY-40,JSET) = F
      ELSE IF( IKEY.GT.43 .AND. IKEY.LT.53 ) THEN
          NCHS = IFMISC_DECODE( TEXT, NCHS, 3, RP, KP )
          IF( NCHS.EQ.0 ) GOTO 777
          I = IKEY-43
          IF( KP(1).NE.0 ) THEN
              J = RP(1)+0.5
              IF( J.LT.0 .OR. J.GT.9 ) GOTO 777
              BPEN(I) = J
          ENDIF
          IF( KP(2).NE.0 ) THEN
              J = RP(2)+0.5
              IF( IABS(J).GT.MAXT ) GOTO 777
              BTYP(I) = J
          ENDIF
          IF( KP(3).NE.0 ) THEN
              F = RP(3)
              IF( F.LT.0.01 .OR. F.GT.99.99 ) GOTO 777
              BSIZ(I) = F
          ENDIF
      ELSE IF( IKEY.EQ.53 ) THEN
          NCHS = IFMISC_DECODE( TEXT, NCHS, 1, RP, KP )
          IF( NCHS.EQ.0 ) GOTO 777
          J = RP(1)+0.5
          IF( J.LT.1 .OR. J.GT.90 ) GOTO 777
          BARC = J
      ELSE IF( IKEY.EQ.54 ) THEN
          NCHS = IFMISC_DECODE( TEXT, NCHS, 3, RP, KP )
          IF( NCHS.EQ.0 ) GOTO 777
          IF( KP(1).NE.0 ) THEN
              J = RP(1)
              IF( J.LT.0 .OR. J.GT.9 ) GOTO 777
              IF( IDPN.NE.J ) THEN
                  IDPN = J
                  IDON = .FALSE.
                  IF( IDPN.GT.0 ) IDON = .TRUE.
                  DO I=1, NSYM
                     SHOW(I) = IDON
                  ENDDO
              ENDIF
          ENDIF
          IF( KP(2).NE.0 ) THEN
              J = RP(2)
              IF( J.LT.1 .OR. J.GT.9 ) GOTO 777
              IDFN = J
          ENDIF
          IF( KP(3).NE.0 ) THEN
              F = RP(3)
              IF( F.LT.0.02 .OR. F.GT.0.5 ) GOTO 777
              IDSZ = F
          ENDIF
      ELSE IF( IKEY.EQ.55 ) THEN
          NCHS = IFMISC_DECODE( TEXT, NCHS, 3, RP, KP )
          IF( NCHS.EQ.0 ) GOTO 777
          DO I=1, 3
             IF( KP(I).NE.0 ) THEN
                 IF( ABS(RP(I)).GT.0.5 ) GOTO 777
                 OXYZ(I) = RP(I)
             ENDIF
          ENDDO
      ELSE IF( IKEY.EQ.56 ) THEN
          NCHS = IFMISC_DECODE( TEXT, NCHS, 3, RP, KP )
          IF( NCHS.EQ.0 ) GOTO 777
          IF( KP(1).NE.0 ) THEN
              J = RP(1)
              IF( IABS(J).GT.2 ) GOTO 777
              LABL = J
          ENDIF
          IF( KP(2).NE.0 ) THEN
              F = RP(2)
              IF( F.LT.-5.0 .OR. F.GT.4.0 ) GOTO 777
              BPOS(1) = F
          ENDIF
          IF( KP(3).NE.0 ) THEN
              F = RP(3)
              IF( F.LT.-4.0 .OR. F.GT.3.5 ) GOTO 777
              BPOS(2) = F
          ENDIF
          IF( KP(4).NE.0 ) THEN
              F = RP(4)
              IF( F.LT.0.02 .OR. F.GT.1.0 ) GOTO 777
              BPOS(3) = F
          ENDIF
      ELSE IF( IKEY.EQ.57 ) THEN
          CALL C3DCON_LABL( NCHS, TEXT )
      ENDIF
      CALL C3DCON_PARS(IKEY)
      GOTO 999
  777 CALL IFMISC_OOPS( 3, SLIN, SCOL, TEXT )
  999 RETURN
      END

      SUBROUTINE C3DCON_LABL( NK, TEXT )
C
C     THIS ROUTINE DECODES THE BALL LABEL TEXT LINE.
C
      INCLUDE 'C3DCON.CBS'
      CHARACTER SYM*1, LAS*1, TEXT*(*)

      NCHS = NK
      IF( NCHS.EQ.0 ) THEN
          DO I=1, 9
             BALL(I) = ' '
          ENDDO
      ELSE
          J = 0
          K = 1
          LAS = ','
          DO I=1, NCHS
             SYM = TEXT(I:I)
             IF( SYM.EQ.',' ) THEN
                 J = J + 1
                 IF( LAS.NE.',' ) BALL(J) = TEXT(K:I-1)
                 K = I + 1
             ELSE IF( SYM.EQ.' ' ) THEN
                 IF( LAS.EQ.' ' .OR. LAS.EQ.',' ) THEN
                     K = I + 1
                 ELSE
                     J = J + 1
                     BALL(J) = TEXT(K:I-1)
                     K = I + 1
                 ENDIF
             ENDIF
             IF( J.EQ.9 ) RETURN
             LAS = SYM
          ENDDO
          J = J + 1
          BALL(J) = TEXT(K:NCHS)
      ENDIF
      RETURN
      END

      SUBROUTINE C3DCON_WRITE( PFILE )
C
C     THIS ROUTINE WRITES OUT THE CURRENT RUN SETUP FILE.
C
      INCLUDE 'C3DCON.CBS'
      CHARACTER FNAME*32, PFILE*(*)
C
C  OPEN THE OUTPUT FILE...
C
      FNAME = PFILE
      CALL IFMISC_DEFEXT( FNAME, '.PAR' )
      OPEN(UNIT=1,FILE=FNAME,STATUS='UNKNOWN',FORM='FORMATTED',
     +CARRIAGECONTROL='LIST')
C
C  WRITE OUT COMMON-BLOCK PARAMETERS...
C
      WRITE(1,111) UNIC,CELL,ORIG,AXES,CBOX,ROTA,A2IN,SLAB,SANG,
     +FLAG,CLEV,CPEN,LINE,BOLD,SRAD,DBOX,NSTR,NEND,IDPN,IDFN,
     +IDSZ,OXYZ,FRMT,BARC,(BPEN(I),BTYP(I),BSIZ(I),I=1,9),
     +LABL,BPOS,BALL,HPAR,BACK,SYMM,SYMC,EDGE,NORM,EXIN,
     +MAPFIL,SYMFIL,MODFIL,DESFIL,TITLE,PLOTID,CENT
  111 FORMAT('CP=',3I4,6F8.3,/'CD=',4F10.4,/'BX=',3F10.4,/
     +'RO=',3F10.4,/'SC=',F10.4,/'SL=',3F10.4,/'SA=',F10.4,/
     +'ON=',4I4,/'CL=',4G13.6,/'CC=',4I4,/'LI=',4I4,/'BL=',4I4,/
     +'SR=',4F10.4,2I4,/'IP=',2I4,4F8.3,/'FM=',14I4,/'BB=',I4,
     +9(2I3,F5.2),/'LB=',I4,3F8.3,/'LT=',9(A4,X),/
     +'H1=',10F7.2,/'H2=',10F7.2,/'NO=',6I4,/
     +'M1=',A32,/'M2=',A32,/'M3=',A32,/'M4=',A32,/'F1=',A32,/
     +'F2=',A32,/'F3=',A32,/'GT=',A77,/'ID=',A32,/'AT=',A8)
C
C  WRITE OUT CONNETIVITY PARAMETERS...
C
      DO I=1, MAXC
         IF( CONN(1,I).GT.0 ) WRITE(1,222) (CONN(J,I),J=1,7),
     +                                     (D1D2(J,I),J=1,3)
      ENDDO
  222 FORMAT('BN=',7I3,3F8.3)
C
C  WRITE OUT EXTRA BONDS...
C
      DO I=1, NBND
         WRITE(1,333) (BOND(J,I),J=1,5)
      ENDDO
  333 FORMAT('BD=',5I5)
C
C  WRITE OUT EXCLUSIVE/INCLUSIVE SET OF ATOMS...
C
      DO I=1, NSUB
         WRITE(1,444) SUBC(1,I),SUBC(2,I),SUID(I)
      ENDDO
  444 FORMAT('EX=',2I5,1X,A8)
      CLOSE(UNIT=1)
      RETURN
      END

      SUBROUTINE C3DCON_SAVE
C
C     THIS ROUTINE SAVES THE CURRENT PLOT SETUP INTO A FILE.
C
      INCLUDE 'C3DCON.CBS'
      CHARACTER TEXT*77, JUNK*77
      COMMON/MENU/ IKEY, NCHS, TEXT

      IF( NCHS.EQ.0 ) THEN
          NCHS = IFMISC_PROMPT('_Filename:',TEXT,SLIN+1,9)
          IF( NCHS.EQ.0 ) GOTO 999
      ENDIF
      IF( NCHS.GT.32 ) GOTO 777
      JUNK = ' Plot saved in file'
      JUNK(21:) = TEXT(1:NCHS)
      CALL C3DCON_WRITE(TEXT(1:NCHS))
      CALL C3DCON_OOPS( JUNK )
      GOTO 999
  777 CALL IFMISC_OOPS( 7, SLIN, SCOL, TEXT )
  999 RETURN
      END

      INTEGER   FUNCTION C3DCON_READ( PFILE )
C
C     THIS ROUTINE READS A RUN SETUP FILE.
C
      INCLUDE 'C3DCON.CBS'
      INTEGER   C3DCON_MAPFIL, C3DCON_MODFIL, C3DCON_SYMFIL
      CHARACTER KEY*2, TEXT*128, FNAME*32, PFILE*(*)
      LOGICAL   YES
      DIMENSION KP(30), RP(30)
      PARAMETER (NKS = 34)
      CHARACTER KWD(NKS)*2
      DATA KWD /   'M1', 'M2', 'M3', 'M4', 'F1', 'F2', 'F3', 'GT',
     + 'ID', 'AT', 'LT', 'LB', 'CP', 'CD', 'BX', 'RO', 'SC', 'SL',
     + 'SA', 'ON', 'CL', 'CC', 'LI', 'BL', 'SR', 'IP', 'FM', 'BB',
     + 'H1', 'H2', 'NO', 'BN', 'BD', 'EX' /
C
C  OPEN THE SETUP FILE...
C
      FNAME = PFILE
      CALL IFMISC_DEFEXT( FNAME, '.PAR' )
      INQUIRE( FILE=FNAME, EXIST=YES )
      IF( .NOT.YES ) GOTO 888
      OPEN(UNIT=1,FILE=FNAME,STATUS='OLD',FORM='FORMATTED',ERR=888)
C
C  READ THE KEYWORDS ONE BY ONE...
C
      NSUB = 0
      NBND = 0
      MBND = 0
  111 READ(1,112,ERR=889,END=999) KEY, TEXT
  112 FORMAT(A2,1X,A128)
      CALL IFMISC_UPPER(2,KEY)
      DO IK=1, NKS
         IF( KEY.EQ.KWD(IK) ) GOTO 222
      ENDDO
      GOTO 889
C
C  DECODE A VALID KEYWORD....
C
  222 NCHS = IFMISC_STRIP(TEXT)
      IF( IK.LT.5 ) THEN
          IF( TEXT.NE.' ' ) THEN
              NCHS = C3DCON_MAPFIL( IK, TEXT )
              IF( NCHS.NE.0 ) MAPFIL(IK) = ' '
          ENDIF
      ELSE IF( IK.EQ.5 ) THEN
          IF( TEXT.NE.' ' ) THEN
              NCHS = C3DCON_SYMFIL( TEXT )
              IF( NCHS.NE.0 ) SYMFIL = ' '
          ENDIF
      ELSE IF( IK.EQ.6 ) THEN
          IF( TEXT.NE.' ' ) THEN
              NCHS = C3DCON_MODFIL( TEXT )
              IF( NCHS.NE.0 ) MODFIL = ' '
          ENDIF
      ELSE IF( IK.EQ.7 ) THEN
          IF( TEXT.NE.' ' ) DESFIL = TEXT
      ELSE IF( IK.EQ.8 ) THEN
          TITLE = TEXT
      ELSE IF( IK.EQ.9 ) THEN
          PLOTID= TEXT
      ELSE IF( IK.EQ.10 ) THEN
          CENT  = TEXT
      ELSE IF( IK.EQ.11 ) THEN
          DO IK=1,9
             BALL(IK) = TEXT(5*IK-4:5*IK-1)
          ENDDO
      ELSE
          IF( NCHS.GT.0 ) THEN
              J = 2
              IF( IK.NE.NKS ) J = 28
              NCHS = IFMISC_DECODE(TEXT,NCHS,J,RP,KP)
          ENDIF
          IF( NCHS.EQ.0 ) GOTO 889
          IF( IK.EQ.12 ) THEN
              LABL = RP(1)
              BPOS(1) = RP(2)
              BPOS(2) = RP(3)
              BPOS(3) = RP(4)
          ELSE IF( IK.EQ.13 ) THEN
              DO IK=1, 3
                 UNIC(IK) = RP(IK)+0.5
              ENDDO
              DO IK=1, 6
                 CELL(IK) = RP(IK+3)
              ENDDO
          ELSE IF( IK.EQ.14 ) THEN
              DO IK=1, 3
                 ORIG(IK) = RP(IK)
              ENDDO
              AXES = RP(4)
          ELSE IF( IK.EQ.15 ) THEN
              DO IK=1, 3
                 CBOX(IK) = RP(IK)
              ENDDO
          ELSE IF( IK.EQ.16 ) THEN
              DO IK=1, 3
                 ROTA(IK) = RP(IK)
              ENDDO
          ELSE IF( IK.EQ.17 ) THEN
              A2IN = RP(1)
          ELSE IF( IK.EQ.18 ) THEN
              CLIP = .FALSE.
              DO IK=1, 3
                 SLAB(IK) = RP(IK)
                 IF( SLAB(IK).GT.0.0 ) CLIP = .TRUE.
              ENDDO
          ELSE IF( IK.EQ.19 ) THEN
              SANG = RP(1)
          ELSE IF( IK.EQ.20 ) THEN
              DO IK=1, 4
                 FLAG(IK) = RP(IK)+0.5
              ENDDO
          ELSE IF( IK.EQ.21 ) THEN
              DO IK=1, 4
                 CLEV(IK) = RP(IK)
              ENDDO
          ELSE IF( IK.EQ.22 ) THEN
              DO IK=1, 4
                 CPEN(IK) = RP(IK)+0.5
              ENDDO
          ELSE IF( IK.EQ.23 ) THEN
              DO IK=1, 4
                 LINE(IK) = RP(IK)+0.5
              ENDDO
          ELSE IF( IK.EQ.24 ) THEN
              DO IK=1, 4
                 BOLD(IK) = RP(IK)+0.5
              ENDDO
          ELSE IF( IK.EQ.25 ) THEN
              SRAD = RP(1)
              DO IK=1, 3
                 DBOX(IK) = RP(IK+1)
              ENDDO
              NSTR = RP(5)+0.5
              NEND = RP(6)+0.5
          ELSE IF( IK.EQ.26 ) THEN
              IDPN = RP(1)+0.5
              IDFN = RP(2)+0.3
              IDSZ = RP(3)
              DO IK=1, 3
                 OXYZ(IK) = RP(IK+3)
              ENDDO
              IDON = .FALSE.
              IF( IDPN.GT.0 ) IDON = .TRUE.
          ELSE IF( IK.EQ.27 ) THEN
              DO IK=1, 7
                 FRMT(1,IK) = RP(IK*2-1)+0.5
                 FRMT(2,IK) = RP(IK*2  )+0.5
              ENDDO
          ELSE IF( IK.EQ.28 ) THEN
              BARC = RP(1)+0.5
              DO IK=1, 9
                 BPEN(IK) = RP(IK*3-1)+0.5
                 BTYP(IK) = RP(IK*3  )+0.5
                 BSIZ(IK) = RP(IK*3+1)
              ENDDO
          ELSE IF( IK.EQ.29 ) THEN
              DO IK=1, 10
                 HPAR(IK) = RP(IK)
              ENDDO
          ELSE IF( IK.EQ.30 ) THEN
              DO IK=1, 10
                 HPAR(IK+10) = RP(IK)
              ENDDO
          ELSE IF( IK.EQ.31 ) THEN
              BACK = INT(RP(1))
              SYMM = INT(RP(2))
              SYMC = INT(RP(3))
              EDGE = INT(RP(4))
              NORM = INT(RP(5))
              EXIN = INT(RP(6))
          ELSE IF( IK.EQ.32 .AND. MBND.LT.MAXC ) THEN
              MBND = MBND + 1
              DO IK=1, 7
                 CONN(IK,MBND) = RP(IK)+0.5
              ENDDO
              DO IK=1, 3
                 D1D2(IK,MBND) = RP(IK+7)
              ENDDO
          ELSE IF( IK.EQ.33 .AND. NBND.LT.MAXB ) THEN
              NBND = NBND + 1
              DO IK=1, 5
                 BOND(IK,NBND) = RP(IK)+0.5
              ENDDO
          ELSE IF( IK.EQ.34 .AND. NSUB.LT.MAXI ) THEN
              NSUB = NSUB + 1
              SUBC(1,NSUB) = RP(1)+0.5
              SUBC(2,NSUB) = RP(2)+0.5
              SUID(  NSUB) = TEXT(NCHS+1:)
          ENDIF
      ENDIF
      GOTO 111
  999 C3DCON_READ = 0
      PARFIL = FNAME
      DO J= MBND+1, MAXC      !CLEAR THE REST OF CONNECTION GROUPS
         DO IK=1, 4
            CONN(IK,J) = 0
         ENDDO
      ENDDO
      GOTO 777
  888 C3DCON_READ = 1
      GOTO 777
  889 C3DCON_READ = -1
  777 CLOSE(UNIT=1)
      RETURN
      END

      SUBROUTINE C3DCON_LOCATE
C
C     THIS ROUTINE LOCATES AN ATOM AS CONTOUR BOX CENTER.
C
      INCLUDE 'C3DCON.CBS'
      CHARACTER ID*8, TEXT*77, DI*132
      COMMON/MENU/ IKEY, NCHS, TEXT
      REAL      AA(3)
      INTEGER   C3DCON_MODFIL, C3DCON_NSUB
      LOGICAL   YES

      IF( NCHS.EQ.0 ) THEN
          NCHS = IFMISC_PROMPT('_Enter atom ID:',TEXT,SLIN+1,9)
          IF( NCHS.EQ.0 ) RETURN
      ENDIF
      IF( MODFIL.EQ.' ' ) GOTO 666
C
C  OPEN THE ATOM FILE FOR SEARCH...
C
      CALL C3DCON_OOPS(' Working (CTRL/C to abort)...')
      CALL IFQAST_CTRLC     !TRAP A CTRL/C INTERRUPT
      OPEN( UNIT=13, FILE=MODFIL, STATUS='OLD', READONLY,
     +      FORM='FORMATTED', CARRIAGECONTROL='LIST', ERR=666 )
C
C  TRY TO READ UNIT CELL AND ATOM LINE FORMAT FROM THE ATOM FILE...
C
      CALL C3DCON_SCAN( 13 )
      DO I=1, 6
         IF( CELL(I).EQ.0.0 ) THEN
         CALL C3DCON_OOPS(' Unit cell parameters (CP)
     + not yet specified.')
         GOTO 99
         ENDIF
      ENDDO
      IF( FRMT(1,2).LT.1 .OR. FRMT(1,3).LT.1 .OR. FRMT(1,4).LT.1 ) THEN
      CALL C3DCON_OOPS(' x,y,z formats (FX,FY,FZ) not yet specified.')
          GOTO 99
      ENDIF
C
C  SETUP TRANFORMATION MATRICES...
C
      CALL C3DCON_MATRIX(0.0)
C
C  SEARCH ATOM FILE FOR THE ID...
C
      YES= .FALSE.
      IF( NSTR.GT.0 ) YES = .TRUE.
      NLINE = 0
  111 READ(13,222,ERR=777,END=888) DI
  222 FORMAT(A132)
      IF( DI(1:1).EQ.'!' .OR. DI(1:1).EQ.'%' ) GOTO 111 !COMMENTS
      NLINE = NLINE + 1
      IF( IFCTRL_C() ) THEN
          CALL C3DCON_CLEAR_OOPS
          GOTO 99
      ENDIF
C
C  TEST FOR RANGE AND/OR EXCLUSIVE/INCLUSIVE SET OF ATOMS...
C
      IF( YES .AND. (NLINE.LT.NSTR.OR.NLINE.GT.NEND) ) GOTO 111
      NCH = IFMISC_LENG(DI)
      IF( NCH.EQ.0 ) GOTO 111
      IF( NSUB.GT.0 ) THEN
          IT = C3DCON_NSUB( DI )
          IF( IT.GT.0 ) GOTO 111
      ENDIF
C
C  DECODE THE LINE...
C
      CALL C3DCON_ATOM( NCH, DI, FRMT, ID, AA, IT, IC, K1, K2 )
      IF( NCH.EQ.0 ) GOTO 777
      IF( ID.NE.TEXT(1:NCHS) ) GOTO 111
C
C  ATOM FOUND...
C
      CLOSE(UNIT=13)
      CALL IFQAST_CLEAR
      IF( EDGE ) THEN
           DO I=1, 3
              AA(I) = AA(I)/CELL(I)
           ENDDO
      ENDIF
      IF( NORM ) THEN
          DO I=1, 3
             AA(I) = AA(I)*CELL(I)
          ENDDO
          CALL C3DCON_MV( THOR, AA )
      ENDIF
      DO I=1, 3
         ORIG(I) = AA(I)
      ENDDO
      CENT = ID
      CALL C3DCON_MODFIL( MODFIL )
      CALL C3DCON_PARS( 7 )
      CALL C3DCON_PARS( 11 )
      CALL C3DCON_PARS( 12 )
      CALL C3DCON_OOPS(' contour box center relocated.')
      GOTO 99
  666 CALL C3DCON_OOPS(' atom file not yet specified.')
      GOTO 99
  777 CALL IFMISC_OOPS( 14, SLIN, SCOL, DI )
      GOTO 999
  888 CALL C3DCON_OOPS(' can not find the atom in atom file.' )
  999 CALL IFQAST_CLEAR
   99 CLOSE(UNIT=13)
      RETURN
      END

      SUBROUTINE C3DCON_OOPS( TEXT )
      INCLUDE 'C3DCON.CBS'
      CHARACTER TEXT*(*)

      IF( SCOL.EQ.0 ) RETURN
      NCHS = IFMISC_LENG( TEXT )
      IF( SLIN.GT.0 .AND. SCOL.GT.0 ) THEN
          CALL C3DCON_CLEAR_OOPS
          CALL IFANSI_TEXT( TEXT, NCHS, SLIN, SCOL )
      ELSE
          WRITE(6,1) TEXT(1:NCHS)
  1       FORMAT('_%C3DCON: ',A)
      ENDIF
      RETURN
      END

      SUBROUTINE C3DCON_CLEAR_OOPS
      INCLUDE 'C3DCON.CBS'

      IF( SCOL.EQ.0 ) RETURN
      CALL IFANSI_CURSOR(SLIN,SCOL)
      CALL IFANSI_CLEAR(4)
      RETURN
      END

      SUBROUTINE C3DCON_PLOT
C
C     THIS ROUTINE CARRIES OUT THE PLOTTING.
C
      INCLUDE 'C3DCON.CBS'
      LOGICAL      PAIR
      COMMON/PLOT/ PAIR, ATIN, ZOOM, ISEG(10,2)
C
C  INITTIALIZE THE PLOT SESSION...
C
      CALL IFINIT_LINE(3)
      CALL IFINIT_PLOT( XORG, YORG, PARFIL )
      IF( IFCTRL_C() ) GOTO 999
      ZOOM = 1.0
      ATIN = A2IN
      PAIR = .FALSE.
      CLIP = .FALSE.
      DO I=1, 3
         SLAB(I) = SLAB(I)*A2IN
         IF( SLAB(I).GT.0.0 ) CLIP = .TRUE.
      ENDDO
      DO I=1, 10
         ISEG(I,1) = 0
         ISEG(I,2) = 0
      ENDDO
C
C  DRAW GRAPH TITLE...
C
      IF( TITLE.NE.' ' ) THEN
          CALL IFSPEN(1)
          CALL IFTEXT_CENT( -XORG, 10.0-XORG, 6.8-YORG, 6.8-YORG,
     +                      TITLE, 0.15, 0.15 )
      ENDIF
C
C  LOOP OVER STEREO PAIR IF SANG.NE.0.0 ...
C
      IF( SANG.NE.0.0 ) CALL IFPLOT_VECT( -2.5, 0.0, -3 )
C
C  SETUP TRANFORMATION MATRICES...
C
  111 IF( PAIR ) THEN
          CALL C3DCON_MATRIX(  0.5*SANG )
      ELSE
          CALL C3DCON_MATRIX( -0.5*SANG )
      ENDIF
      IF( IFCTRL_C() ) GOTO 999
C
C  DISPLAY THE PLOT ORIENTATION...
C
      IF( AXES.GT.0.0 ) CALL C3DCON_AXES
C
C  CONTOUR THE DENSITY BOX NEXT...
C
      IF( BACK .AND. MAPFIL(1).NE.' ' ) CALL C3DCON_CONT
      IF( IFCTRL_C() ) GOTO 999
C
C  DRAW THE STRUCTURE MODEL FIRST...
C
      IF( NSYM.GT.0 ) CALL C3DCON_MODEL
      IF( IFCTRL_C() ) GOTO 999
      IF( .NOT.PAIR .AND. SANG.NE.0.0 ) THEN
          CALL IFPLOT_VECT( 5.0, 0.0, -3 )
          PAIR = .TRUE.
          GOTO 111
      ENDIF
      IF( PAIR ) CALL IFPLOT_VECT(-2.5,0.0,-3)
      IF( IFCTRL_C() ) GOTO 999
C
C  DRAW BALL LABELS IF REQUESTED...
C
      IF( NSYM.GT.0 .AND. LABL.NE.0 ) THEN
          CALL C3DCON_LABEL
          IF( IFCTRL_C() ) GOTO 999
      ENDIF
C
C  OVERLAY THE LAYOUT IF AT ALL...
C
      IF( DESFIL.NE.' ' ) CALL LAYOUT_AUX(0,XORG,YORG,DESFIL)
C
C  END THE PLOT SESSION...
C
  999 CALL IFINIT_PLOT_END
      DO I=1, 3
         SLAB(I) = SLAB(I)/A2IN
      ENDDO
      RETURN
      END

      SUBROUTINE C3DCON_MATRIX( STA )
C
C     THIS ROUTINE COMPUTES THE TRANSFORM MATRICES.
C
C	STA --- EXTRA ROTATION ON Y-AXIS FOR STEREO VIEW.
C
      INCLUDE 'C3DCON.CBS'
      REAL   A(3,3), B(3,3), C(3,3)
C
C  INITIALIZE...
C
      DO J=1,3
         DO I=1,3
            A(I,J) = 0.0
            B(I,J) = 0.0
            C(I,J) = 0.0
         ENDDO
      ENDDO
      CA = COSD(ROTA(1))
      SA = SIND(ROTA(1))
      CB = COSD(ROTA(2)+STA)
      SB = SIND(ROTA(2)+STA)
      CC = COSD(ROTA(3))
      SC = SIND(ROTA(3))
      A(1,1) = 1.0        !ROTATION MATRIX ABOUT X-AXIS
      A(2,2) = CA
      A(3,3) = CA
      A(2,3) = SA
      A(3,2) = -SA
      B(1,1) = CB         !ROTATION MATRIX ABOUT Y-AXIS
      B(2,2) = 1.0
      B(3,3) = CB
      B(1,3) = -SB
      B(3,1) = SB
      C(1,1) = CC         !ROTATION MATRIX ABOUT Z-AXIS
      C(2,2) = CC
      C(3,3) = 1.0
      C(1,2) = SC
      C(2,1) = -SC
C
C  ORTH IS THE ROTATION MATRIX IN THE ORTHONORMAL PLOT COORDINATE SYSTEM.
C  ROTATION ORDER: A-AXIS, C-AXIS, B-AXIS (SINCE THE DEFAULT ROTATION AXIS
C  FOR STEREO VIEWING IS AROUND Y-AXIS, IT MUST BE THE LAST ROTATION TO
C  PERFORM IN ORDER FOR STEREO VIEW TO WORK UNDER ANY ROTATIONS AROUND
C  A-AXIS AND C-AXIS).
C
C  MATRIX MULTIPLICATION ASSOCIATES BUT IS NOT COMMUTATIVE...
C
      CALL C3DCON_MM(B,C,GALL)
      CALL C3DCON_MM(GALL,A,ORTH)
C
C  A IS THE ORTHOGONAL MATRIX FROM CRYSTAL AXES TO CARTESIAN SYSTEM...
C
      CA = COSD(CELL(4))
      CB = COSD(CELL(5))
      CC = COSD(CELL(6))
      SC = SIND(CELL(6))
      A(1,1) = CELL(1)
      A(2,2) = CELL(2)*SC
      A(3,3) = CELL(3)*SQRT(ABS(SC*SC-CA*CA-CB*CB+2.0*CA*CB*CC))/SC
      A(1,2) = CELL(2)*CC
      A(1,3) = CELL(3)*CB
      A(2,3) = CELL(3)*(CA-CB*CC)/SC
      A(2,1) = 0.0
      A(3,1) = 0.0
      A(3,2) = 0.0
C
C  THOR IS THE INVERSE OF A (DEORTHOGONALIZATION MATRIX)...
C
      THOR(1,1) = 1.0/A(1,1)
      THOR(2,2) = 1.0/A(2,2)
      THOR(3,3) = 1.0/A(3,3)
      THOR(1,2) = -A(1,2)/A(1,1)/A(2,2)
      THOR(2,3) = -A(2,3)/A(2,2)/A(3,3)
      THOR(1,3) = -(A(1,2)*THOR(2,3)+A(1,3)*THOR(3,3))/A(1,1)
      THOR(2,1) = 0.0
      THOR(3,1) = 0.0
      THOR(3,2) = 0.0
C
C  GALL IS THE OVERALL TRANFORM MATRIX FROM UNIT CELL 
C  TO PLOT SYSTEM AFTER ROTATION (NORMALIZATION BEFORE ROTATION)...
C
      CALL C3DCON_MM(ORTH,A,GALL)
      RETURN
      END

      SUBROUTINE C3DCON_CONT
C
C     THIS ROUTINE DOES THE ACTUAL 3D CONTOURING.
C
      INCLUDE 'C3DCON.CBS'
      PARAMETER (MMAP = 128)
      BYTE      BCLV, Z
      LOGICAL      PAIR, OPEN, FULL
      COMMON/CON0/ NCOL,NROW,BCLV,IDIR,JDIR,KDIR,FIXM(3),XINV(3),ZCOO
      COMMON/CON1/ Z(MMAP*MMAP),IREC(5*MMAP),XP(5*MMAP),YP(5*MMAP)
      COMMON/CON9/ L, LUN, IXI(2,3), IJK(3), IGRD(9), FULL(3)
      COMMON/PLOT/ PAIR, ATIN, ZOOM, ISEG(10,2)
C
C  START LOOP OVER THE CONTOUR LEVELS...
C
      LUN = 0
      DO IC=1, 4
         IF( MAPFIL(IC).NE.' ' ) THEN
             LUN = LUN + 1
             III = IC
         ENDIF
      ENDDO
      OPEN = .FALSE.
      IF( LUN.EQ.0 ) RETURN
      DO 1234 IC=1, 4
         IF( FLAG(IC).EQ.0 ) GOTO 1234   !SKIP THIS LEVEL
C
C  GET THE BOX BOUNDARY IN GRID UNITS...
C  CONVERT CONTOUR LEVEL TO THE BYTE LEVEL...
C
      IF( LUN.GT.1 .AND. MAPFIL(IC).NE.' ' ) THEN
          DO I=1, 9
             IGRD(I) = GRID(I,IC)
          ENDDO
          BCLV = CLEV(IC)*SCAL(IC)+OFFS(IC)
          CLOSE(UNIT=LUN)
          OPEN( UNIT=LUN, FILE=MAPFIL(IC), STATUS='OLD', READONLY,
     +          FORM='UNFORMATTED', ACCESS='DIRECT', ERR=888 )
      ELSE
          IF( LUN.EQ.2 .OR. LUN.EQ.3 ) GOTO 1234
          DO I=1, 9
             IGRD(I) = GRID(I,III)
          ENDDO
          BCLV = CLEV(IC)*SCAL(III)+OFFS(III)
          IF( .NOT.OPEN ) THEN
                CLOSE(UNIT=LUN)
          OPEN( UNIT=LUN, FILE=MAPFIL(III), STATUS='OLD', READONLY,
     +          FORM='UNFORMATTED', ACCESS='DIRECT', ERR=888 )
                OPEN = .TRUE.
          ENDIF
      ENDIF
      DO I=1, 3
         J = INT(IGRD(I)*(ORIG(I)-0.5*CBOX(I)/CELL(I))-0.5)
         K = INT(IGRD(I)*(ORIG(I)+0.5*CBOX(I)/CELL(I))+0.5)
         FIXM(I) = FLOAT(IGRD(I))*ORIG(I)-FLOAT(J)
         XINV(I) = A2IN/FLOAT(IGRD(I))
         IXI(1,I) = J
         IXI(2,I) = K
         L = J
         J = IGRD(2+2*I)
         K = IGRD(3+2*I)
         IJK(I) = K-J+1
         FULL(I) = .TRUE.
         IF( IJK(I).LT.IGRD(I) ) THEN
             FULL(I)= .FALSE.
             IF( IXI(2,I).LT.J ) GOTO 777
             IF( IXI(1,I).LT.J ) IXI(1,I) = J
             IF( IXI(2,I).GT.K ) IXI(2,I) = K
             FIXM(I) = FIXM(I) - FLOAT(IXI(1,I)-L)
         ENDIF
      ENDDO
C
C  START LOOP ALONG A,B,C AXES RESPECTIVELY....
C
      IF( TERM.EQ.1 .AND. .NOT.IF_DCL_HARDCOPY() ) WRITE(6,4321) IC
 4321 FORMAT('_%C3DCON_CONT: contouring at level #',I1,'...')
      CALL IFSEG_PIVOT( 0.0, 0.0 )
      IF( PAIR ) THEN
          CALL IFSEG_OPEN( 30+IC )
          ISEG(IC,2) = 30+IC
      ELSE
          CALL IFSEG_OPEN( 20+IC )
          ISEG(IC,1) = 20+IC
      ENDIF
      CALL IFSPEN( CPEN(IC) )
      CALL IFSTYL( LINE(IC), BOLD(IC) )
      DO IDIR=1, 3
         IF( IDIR.EQ.1 ) THEN           !ALONG A-AXIS
             JDIR = 2
             KDIR = 3
         ELSE IF( IDIR.EQ.2 ) THEN      !ALONG B-AXIS
             JDIR = 1
             KDIR = 3
         ELSE                           !ALONG C-AXIS
             JDIR = 1
             KDIR = 2
         ENDIF
         NCOL = IXI(2,JDIR)-IXI(1,JDIR)+1
         NROW = IXI(2,KDIR)-IXI(1,KDIR)+1
         IF( NCOL*NROW.GT.MMAP*MMAP ) GOTO 888
C
C  STEP ALONG THE AXIS LAYER BY LAYER...
C
         K = 0
         DO L = IXI(1,IDIR), IXI(2,IDIR)
            IF( IFCTRL_C() ) GOTO 999
            ZCOO = XINV(IDIR)*(FLOAT(K)-FIXM(IDIR))
            CALL C3DCON_LAYER          !LOAD THIS LAYER
            IF( IFCTRL_C() ) GOTO 999
            CALL C3DCON_DRAW           !CONTOUR IT
            K = K + 1
         ENDDO
      ENDDO
      CALL IFSEG_OPEN( 0 )             !CLOSE THE SEGMENT
 1234 CONTINUE
      GOTO 999
  777 WRITE(6,778)
  778 FORMAT(' _oops: contour box not overlapping the input grid.')
      GOTO 999
  888 WRITE(6,889)
  889 FORMAT(' _oops: map grid overflow.')
  999 CLOSE(UNIT=LUN)
      CALL IFSTYL( 1, 1 )
      RETURN
      END

      SUBROUTINE C3DCON_LAYER
C
C     THIS ROUTINE LOADS A LAYER OF DENSITY FROM THE DENSITY FILE.
C
      PARAMETER (MMAP = 128)
      BYTE      BCLV, Z
      LOGICAL   FULL
      COMMON/CON0/ NCOL,NROW,BCLV,IDIR,JDIR,KDIR,FIXM(3),XINV(3),ZCOO
      COMMON/CON1/ Z(MMAP*MMAP),IREC(5*MMAP),XP(5*MMAP),YP(5*MMAP)
      COMMON/CON9/ L, LUN, IXI(2,3), IJK(3), IGRD(9), FULL(3)
      BYTE      BLOCK(MMAP*MMAP)
      INTEGER   C3DCON_GRID
C
C  JREC IS THE RECORD POINTER INTO DENSITY FILE FOR LAYER "L"...
C
      IF( FULL(IDIR) ) THEN
          JREC = C3DCON_GRID( IGRD(IDIR), L ) + 2   !REC#1 IS THE HEADER
      ELSE
          JREC = L - IGRD(2+2*IDIR) + 2
      ENDIF
      IF( IDIR.GT.1 ) JREC = JREC + IJK(1)
      IF( IDIR.GT.2 ) JREC = JREC + IJK(2)
      MCOL = IJK(JDIR)
      MROW = IJK(KDIR)
      READ(LUN,REC=JREC) (BLOCK(I),I=1,MROW*MCOL)
C
C  REPACK GRID ACCORDING TO THE CURRENT 2D BOX POSITION IN THE UNIT CELL...
C
      JREC = 0
      DO JY = IXI(1,KDIR), IXI(2,KDIR)
         IF( FULL(KDIR) ) THEN
             IY = C3DCON_GRID( MROW, JY )
         ELSE
             IY = JY - IGRD(2+2*KDIR)
         ENDIF
         DO JX = IXI(1,JDIR), IXI(2,JDIR)
            IF( FULL(JDIR) ) THEN
                IX = C3DCON_GRID( MCOL, JX ) + 1
            ELSE
                IX = JX - IGRD(2+2*JDIR) + 1
            ENDIF
            JREC = JREC + 1
            Z(JREC) = BLOCK(IX+IY*MCOL)
         ENDDO
      ENDDO
      RETURN
      END

      INTEGER   FUNCTION C3DCON_GRID( I, J )
C
C     THIS ROUTINE BRINGS AN OUTOFF-BOUND GRID POINT BACK TO UNIT CELL.
C
      II = I
      JJ = J
   1  IF( JJ.GE.0 ) GOTO 2
      JJ = II+JJ
      GOTO 1
   2  IF( JJ.LT.II ) GOTO 3
      JJ = JJ-II
      GOTO 2
   3  C3DCON_GRID = JJ
      RETURN
      END

      SUBROUTINE C3DCON_DRAW
C
C     SINGLE CONTOUR LINE TRACEOUT ROUTINE.
C
      PARAMETER (MMAP = 128)
      BYTE      CV, Z
      COMMON/CON0/ MT,NT,CV,IDIR,JDIR,KDIR,FIXM(3),XINV(3),ZCOO
      COMMON/CON1/ Z(MMAP*MMAP),IREC(5*MMAP),XP(5*MMAP),YP(5*MMAP)
      COMMON/CON2/ JD, IX, IY, IDX, IDY, ISS, NP, N, IS, IS0,
     +IX0, IY0, DCP, INX(8), INY(8), CCV, MMM
      DATA INX/ -1, -1,  0,  1,  1,  1,  0, -1 /
      DATA INY/  0,  1,  1,  1,  0, -1, -1, -1 /
C
C  INITIALIZE...
C
      JD  = MT
      NP  = 0
      ISS = 0
      CCV = CV
      MT1 = MT-1
      NT1 = NT-1
      MMM = 5*MMAP
C
C  CONTOUR THE MAP...
C
      DO 111 I=1,MT1
         IF( Z(I).GE.CV .OR. Z(I+1).LT.CV ) GOTO 111
         IX0 = I+1
         IX  = I+1
         IY0 = 1
         IY  = 1
         IS0 = 1
         IS  = 1
         IDX = -1
         IDY = 0
         CALL C3DCON_TRACE
  111 CONTINUE

      J = MT-JD
      DO 222 I=1,NT1
         J = J+JD
         IF( Z(J).GE.CV .OR. Z(J+JD).LT.CV ) GOTO 222
         IX0 = MT
         IX  = MT
         IY0 = I+1
         IY  = I+1
         IDX = 0
         IDY = -1
         IS0 = 7
         IS  = 7
         CALL C3DCON_TRACE
  222 CONTINUE

      J = MT+NT1*JD+1
      DO 333 I=1,MT1
         J = J-1
         IF( Z(J).GE.CV .OR. Z(J-1).LT.CV ) GOTO 333
         IX0 = MT-I
         IX  = MT-I
         IY0 = NT
         IY  = NT
         IDX = 1
         IDY = 0
         IS0 = 5
         IS  = 5
         CALL C3DCON_TRACE
  333 CONTINUE

      J = NT*JD+1
      DO 444 I=1,NT1
         J = J-JD
         IF( Z(J).GE.CV .OR. Z(J-JD).LT.CV ) GOTO 444
         IX0 = 1
         IX  = 1
         IY0 = NT-I
         IY  = NT-I
         IDX = 0
         IDY = 1
         IS0 = 3
         IS  = 3
         CALL C3DCON_TRACE
  444 CONTINUE

      ISS = 1
      L   = 0
      DO 666 J=2,NT1
         L = L+JD
      DO 555 I=1,MT1
         L = L+1
         IF( Z(L).GE.CV .OR. Z(L+1).LT.CV ) GOTO 555
         K = L+1
         DO ID=1,NP
            IF( IREC(ID).EQ.K ) GOTO 555
         ENDDO
         IX0 = I+1
         IX  = I+1
         IY0 = J
         IY  = J
         IDX = -1
         IDY = 0
         IS0 = 1
         IS  = 1
         CALL C3DCON_TRACE
  555 CONTINUE
  666 L = L-MT1
      RETURN
      END

      SUBROUTINE C3DCON_TRACE
C
C     THIS ROUTINE TRACES SINGLE CONTOUR LINE.
C
      PARAMETER (MMAP = 128)
      BYTE      CV, Z
      COMMON/CON0/ MT,NT,CV,IDIR,JDIR,KDIR,FIXM(3),XINV(3),ZCOO
      COMMON/CON1/ Z(MMAP*MMAP),IREC(5*MMAP),XP(5*MMAP),YP(5*MMAP)
      COMMON/CON2/ JD, IX, IY, IDX, IDY, ISS, NP, N, IS, IS0,
     +IX0, IY0, DCP, INX(8), INY(8), CCV, MMM
      LOGICAL   YES

      IF( IFCTRL_C() ) RETURN
      N=0
      JY=JD*(IY-1)+IX
      MY=JD*IDY+IDX+JY
      YES = .FALSE.
  100 IF( N.EQ.MMM ) THEN
          YES = .TRUE.
          GO TO 999
      ENDIF
      N=N+1
      IF( IDX.GT.0 ) GO TO 120
      IF( IDX.LT.0 ) GO TO 110
      ITP = Z(JY)
      JTP = ITP
      ITP = IDY*(ITP-CV)
      JTP = JTP-Z(JD*IDY+JY)
      YP(N) = FLOAT(IY-1) + FLOAT(ITP)/FLOAT(JTP)
      XP(N) = FLOAT(IX-1)
      GO TO 130
  110 NP=NP+1
      IREC(NP)=JY
  120 ITP = Z(JY)
      JTP = ITP
      ITP = IDX*(ITP-CV)
      JTP = JTP-Z(JY+IDX)
      XP(N) = FLOAT(IX-1) + FLOAT(ITP)/FLOAT(JTP)
      YP(N) = FLOAT(IY-1)
  130 IS=IS+1
  140 IF (IS .LE. 8) GO TO 150
      IS=IS-8
  150 IDX=INX(IS)
      IDY=INY(IS)
      IX2=IX+IDX
      IY2=IY+IDY
      IR=IDX*IDY
      IF (ISS .EQ. 0) GO TO 160
      IF ((IS.NE.IS0) .OR. (IY.NE.IY0) .OR. (IX.NE.IX0)) GO TO 170
      N=N+1
      XP(N)=XP(1)
      YP(N)=YP(1)
      GO TO 999
  160 IF( (IX2.EQ.0).OR.(IX2.GT.MT).OR.(IY2.EQ.0).OR.(IY2.GT.NT) )
     +GO TO 999
  170 MY=JD*IDY+IDX+JY
      IF (IR .GT. 0) GO TO 200
      IF (IR .LT. 0) GO TO 190
      IF (CV .GT. Z(MY)) GO TO 100
      IX=IX2
      IY=IY2
  180 IS=IS+5
      JY=MY
      GO TO 140
  190 KY=JY+IDX
      LY=MY-IDX
      GO TO 210
  200 KY=MY-IDY
      LY=JY+IDY
  210 ITP = Z(JY)
      ITP = ITP + Z(KY)
      ITP = ITP + Z(LY)
      ITP = ITP + Z(MY)
      DCP = FLOAT(ITP/4)
C      DCP = (Z(JY)+Z(KY)+Z(LY)+Z(MY))/4   !INTEGER OVERFLOW
      IF( CCV.LE.DCP ) GOTO 220
      CALL C3DCON_POINT(JY)
      GO TO 130
  220 IF (IR .GE. 0) GO TO 230
      IX=IX2
      IDX=-IDX
      CALL C3DCON_POINT(KY)
      IY=IY2
      IDY=-IDY
      GO TO 240
  230 IY=IY2
      IDY=-IDY
      CALL C3DCON_POINT(KY)
      IX=IX2
      IDX=-IDX
  240 IF (CV .LE. Z(MY)) GO TO 180
      CALL C3DCON_POINT(MY)
      IF (IR .GE. 0) GO TO 250
      IX=IX+IDX
      IDX=-IDX
      GO TO 260
  250 IY=IY+IDY
      IDY=-IDY
  260 IF (CV .GT. Z(LY)) GO TO 290
      IS=IS-1
      JY=LY
      GO TO 150
  290 CALL C3DCON_POINT(LY)
      IF (IR .GE. 0) GO TO 300
      IY=IY+IDY
      GO TO 130
  300 IX=IX+IDX
      GO TO 130
C
C  DRAW THE CONTOUR...
C
  999 IF( N.GT.1 ) CALL C3DCON_PROJ(N)
      IF( YES ) THEN
          N = 0
          YES = .FALSE.
          GOTO 100
      ENDIF
      RETURN
      END

      SUBROUTINE C3DCON_POINT(J)
C
C     THIS ROUTINE GETS A DENSITY POINT.
C
      PARAMETER (MMAP = 128)
      BYTE      CV, Z
      COMMON/CON0/ MT,NT,CV,IDIR,JDIR,KDIR,FIXM(3),XINV(3),ZCOO
      COMMON/CON1/ Z(MMAP*MMAP),IREC(5*MMAP),XP(5*MMAP),YP(5*MMAP)
      COMMON/CON2/ JD, IX, IY, IDX, IDY, ISS, NP, N, IS, IS0,
     +IX0, IY0, DCP, INX(8), INY(8), CCV, MMM

      N = N+1
      T = Z(J)
      B = T-DCP
      IF( B.NE.0.0 ) THEN
          V = 0.5*(T-CCV)/B
      ELSE
          V = 0.5
      ENDIF
      XP(N) = FLOAT(IX-1)+FLOAT(IDX)*V
      YP(N) = FLOAT(IY-1)+FLOAT(IDY)*V
      RETURN
      END

      SUBROUTINE C3DCON_PROJ(NPTS)
C
C     THIS ROUTINE TRANSFORMS, CLIPS AND PARALELL-PROJECTS
C     A 3D-CONTOUR LINE.
C
      INCLUDE 'C3DCON.CBS'
      PARAMETER (MMAP = 128)
      BYTE      BCLV, Z
      COMMON/CON0/ NCOL,NROW,BCLV,IDIR,JDIR,KDIR,FIXM(3),XINV(3),ZCOO
      COMMON/CON1/ Z(MMAP*MMAP),IREC(5*MMAP),XP(5*MMAP),YP(5*MMAP)
      REAL      AA(3)
      INTEGER   C3DCON_CLIP
C
C  TAKE CARE OF THE 1ST POINT...
C
      IF( IFCTRL_C() ) RETURN
      XTEM = XINV(JDIR)*(XP(1)-FIXM(JDIR))
      YTEM = XINV(KDIR)*(YP(1)-FIXM(KDIR))
      CALL C3DCON_XYZ( IDIR, XTEM, YTEM, ZCOO, AA )
      CALL C3DCON_MV( GALL, AA )
      CALL IFPLOT_VECT( AA(1), AA(2), 3 )
C
C  START LOOP OVER THE REST OF CONTOUR POINTS...
C
      NP = NPTS
      DO I=2, NP
         XTEM = XINV(JDIR)*(XP(I)-FIXM(JDIR))
         YTEM = XINV(KDIR)*(YP(I)-FIXM(KDIR))
         CALL C3DCON_XYZ( IDIR, XTEM, YTEM, ZCOO, AA )
         CALL C3DCON_MV( GALL, AA )
         IP = 2
         IF( CLIP .AND. C3DCON_CLIP(SLAB,AA).EQ.0 ) IP = 3
         CALL IFPLOT_VECT( AA(1), AA(2), IP )
      ENDDO
      RETURN
      END

      SUBROUTINE C3DCON_MM(A,B,C)
C
C     THIS ROUTINE MULTIPLIES TWO 3x3 MATRIXES.
C
      REAL   A(3,3), B(3,3), C(3,3)
      DO K=1,3
         DO I=1,3
            SUM = 0.0
            DO J=1,3
               SUM = SUM + A(I,J)*B(J,K)
            ENDDO
            C(I,K) = SUM
         ENDDO
      ENDDO
      RETURN
      END

      SUBROUTINE C3DCON_MV(A,V)
C
C     THIS ROUTINE MULTIPLIES A 3x3 MATRIX BY A VECTOR.
C
      REAL   A(3,3), V(3), B(3)
      DO I=1,3
         SUM = 0.0
         DO J=1,3
            SUM = SUM + A(I,J)*V(J)
         ENDDO
         B(I) = SUM
      ENDDO
      V(1) = B(1)
      V(2) = B(2)
      V(3) = B(3)
      RETURN
      END

      SUBROUTINE C3DCON_XYZ( ID, X, Y, Z, AA )
C
C     THIS ROUTINE CONVERTS CONTOUR ORIENTATION TO SCREEN ORIENTATION.
C
      REAL   AA(3)
      IDIR = ID
      IF( IDIR.EQ.1 ) THEN
          AA(1) = Z
          AA(2) = X
          AA(3) = Y
      ELSE IF( IDIR.EQ.2 ) THEN
          AA(1) = X
          AA(2) = Z
          AA(3) = Y
      ELSE
          AA(1) = X
          AA(2) = Y
          AA(3) = Z
      ENDIF
      RETURN
      END

      SUBROUTINE C3DCON_MODEL
C
C     THIS ROUTINE DRAWS THE STRUCTURE MODEL.
C
      INCLUDE 'C3DCON.CBS'
      LOGICAL      PAIR, LINK(MAXX)
      COMMON/PLOT/ PAIR, ATIN, ZOOM, ISEG(10,2)
      CHARACTER ID*8
      INTEGER   ZBUF, C3DCON_NBND, C3DCON_D1D2, C3DCON_CLIP
      COMMON/OVER/ ZBUF(MAXX), AZYX(MAXX), AXYZ(3,MAXX)
C
C  TRANSFORM ATOM COORDINATES...
C
      DO J=1, NATM
         IF( IFCTRL_C() ) GOTO 999
         DO I=1, 3
            AXYZ(I,J) = A2IN*ATOM(I,J)
         ENDDO
         CALL C3DCON_MV( GALL, AXYZ(1,J) )
         AZYX(J) = AXYZ(3,J)
         ZBUF(J) = J
         LINK(J) = .FALSE.
      ENDDO
C
C  SORT Z-COORDINATES (AZYX) OF ALL ATOMS IN ASCENDING ORDER
C  AND STORE THE POINTERS IN ARRAY "ZBUF", AND DRAW THEM IN 
C  THE SORTED ORDER (OVERLAP REMOVAL IS NOT CODED AS SUCH
C  BUT RATHER BY TAKING THE ADVANTAGE OF REPLACE-WRITING
C  OF A PIXEL-GRAPHICS DEVICE LIKE A VIDEO TERMINAL OR A 
C  POST-SCRIPT LASER PRINTER)...
C
      CALL C3DCON_ZSORT( NATM, AZYX, ZBUF )
      CALL IFSEG_PIVOT( 0.0, 0.0 )
      IF( PAIR ) THEN
          CALL IFSEG_OPEN( 35 )
          ISEG(5,2) = 35
      ELSE
          CALL IFSEG_OPEN( 25 )
          ISEG(5,1) = 25
      ENDIF
      IF( TERM.EQ.1 .AND. .NOT.IF_DCL_HARDCOPY() ) WRITE(6,4321)
 4321 FORMAT('_%C3DCON_MODEL: Drawing atoms...')
      CALL IFSTYL(1,2)
      DO I=1, NATM
         IF( IFCTRL_C() ) GOTO 999
         J = ZBUF(I)
         IF( ATCL(J).NE.0 .AND. (.NOT.CLIP.OR.
     +       C3DCON_CLIP(SLAB,AXYZ(1,J)).EQ.1) ) THEN
             K = ATBB(J)
             L = IABS(BTYP(K))
             IF( L.GT.0 ) THEN
                 AX = AXYZ(1,J)
                 AY = AXYZ(2,J)
                 R1 = A2IN*BSIZ(K)
                 CALL IFSPEN( BPEN(K) )
                 CALL C3DCON_BALL( TERM, L, AX, AY, R1, BARC )
             ENDIF
         ENDIF
      ENDDO
      CALL IFSTYL(1,1)
      CALL IFSEG_OPEN( 0 )
C
C  FIND MAXIMAM BOND LENGH IN THE BONDING SETUP GROUPS...
C
      CMAX = 0.0
      DO I=1, MAXC
         IF( CONN(1,I).GT.0 .AND. D1D2(2,I).GT.CMAX ) CMAX = D1D2(2,I)
      ENDDO
      IF( CMAX.EQ.0.0 ) GOTO 888      !NO BOND SPECIFIED
C
C  CONNECT ATOMS...
C  DISCONNECTION HIERARCHY IS AS FOLLOW:
C
C	(0) NEGATIVE BTYP(I) FOR ATOM TYPE I;
C	(1) EXTRA BONDS, NEGATIVE IN "BOND(3,I)" LIST;
C	(2) CLIPPED OUT IF Z-CLIP IS ON;
C	(3) DIFF CONNECTION CLASS FLAGS;
C	(4) DIFF SYMMETRY OPERATOR FLAGS (IF SYMC IS .FALSE.);
C	(5) NOT IN BONDING SETUP GROUPS FROM ARRAY "CONN".
C
C  DISCONNECTED ATOMS WITH BTYP(I)=0 ARE PLOTTED AS 3D CROSSES.
C  UNIT CELL VERTICES (CONNECTION CLASS FLAGS=0) ARE EXCLUDED...
C
      IF( TERM.EQ.1 .AND. .NOT.IF_DCL_HARDCOPY() ) WRITE(6,4322)
 4322 FORMAT('_%C3DCON_MODEL: Drawing bonds...')
      CALL IFSEG_PIVOT( 0.0, 0.0 )
      IF( PAIR ) THEN
          CALL IFSEG_OPEN( 36 )
          ISEG(6,2) = 36
      ELSE
          CALL IFSEG_OPEN( 26 )
          ISEG(6,1) = 26
      ENDIF
      DO 444 I1=1, NATM-1
         IF( IFCTRL_C() ) GOTO 999
         J1 = ZBUF(I1)
         I  = ATCL(J1)
         IF( I.EQ.0 ) GOTO 444         !CELL VERTEX
         K  = ATBB(J1)
         IF( BTYP(K).LT.0 ) GOTO 444   !ATOM TYPE NOT TO BE CONNECTED
         IF( CLIP .AND. C3DCON_CLIP(SLAB,AXYZ(1,J1)).EQ.0 ) GOTO 444
         J  = ATSY(J1)
         AX = AXYZ(1,J1)
         AY = AXYZ(2,J1)
         AZ = AXYZ(3,J1)
         DO 222 I2=I1+1, NATM
            IF( IFCTRL_C() ) GOTO 999
            J2 = ZBUF(I2)
            BZ = AXYZ(3,J2)
            IF( BZ-AZ.GT.CMAX ) GOTO 333
            N1 = ATCL(J2)
            IF( N1.EQ.0 .OR. IABS(I).NE.IABS(N1) ) GOTO 222  !CLASS MISMATCH
            L  = ATBB(J2)
            IF( BTYP(L).LT.0 ) GOTO 222   !ATOM TYPE NOT TO BE CONNECTED
            IF( NBND.GT.0 .AND. C3DCON_NBND(J1,J2).GT.0 ) GOTO 222  !BOND BREAK
            IF( CLIP .AND. C3DCON_CLIP(SLAB,AXYZ(1,J2)).EQ.0 ) GOTO 222
            IF( SYMM.AND..NOT.SYMC.AND.J.NE.ATSY(J2) ) GOTO 222
            IF( C3DCON_D1D2(K,L,N1,N2,N3,R1,R2,DL).GT.0 ) GOTO 222
            BX = AXYZ(1,J2)
            BY = AXYZ(2,J2)
            DD = SQRT((AX-BX)**2+(AY-BY)**2+(AZ-BZ)**2)
            IF( DD.GT.R1 .AND. DD.LT.R2 ) THEN
                CALL IFSPEN(N1)
                CALL IFSTYL(1,N2)
                CALL C3DCON_BOND( N3, N2, DL, I1, I2 )
                LINK(J1) = .TRUE.
                LINK(J2) = .TRUE.
            ENDIF
  222    CONTINUE
  333    IF( .NOT.LINK(J1) .AND. BTYP(K).EQ.0 ) THEN
             CALL IFSPEN(BPEN(K))
             CALL C3DCON_CROSS( A2IN*BSIZ(K), AX, AY )
         ENDIF
  444 CONTINUE
C
C  TAKE CARE OF THE LAST ATOM IF IT'S NOT BONDED...
C
      I = ZBUF(NATM)
      IF( .NOT.LINK(I) ) THEN
          J = ATBB(I)
          K = ATCL(I)
          IF( K.NE.0 .AND. BTYP(J).EQ.0 .AND.
     +      (.NOT.CLIP.OR.C3DCON_CLIP(SLAB,AXYZ(1,I)).EQ.1) ) THEN
              CALL IFSPEN(BPEN(J))
              CALL C3DCON_CROSS(A2IN*BSIZ(J),AXYZ(1,I),AXYZ(2,I))
          ENDIF
      ENDIF
      CALL IFSEG_OPEN( 0 )
      IF( IFCTRL_C() ) GOTO 999
C
C  DRAW EXTRA BONDS NEXT...
C
  888 IF( NBND.GT.0 ) THEN
          CALL C3DCON_BONDS
      ELSE
          ISEG(7,1) = 4000
      ENDIF
      IF( IFCTRL_C() ) GOTO 999
C
C  DRAW UNIT CELL OUTLINE IF REQUESTED...
C
      IF( UNIC(1).GT.0 ) CALL C3DCON_CELL
      IF( IFCTRL_C() ) GOTO 999
C
C  DRAW THE ATOM ID'S NEXT...
C
      IF( TERM.EQ.1 .AND. .NOT.IF_DCL_HARDCOPY() ) WRITE(6,4323)
 4323 FORMAT('_%C3DCON_MODEL: Drawing atom id labels...')
      CALL C3DCON_ATID
  999 CALL IFSTYL( 1, 1 )
      RETURN
      END

      INTEGER   FUNCTION C3DCON_NBND( I1, I2 )
C
C     THIS ROUTINE CHECKS FOR USER-SPECIFIED BROKEN BONDS.
C
      INCLUDE 'C3DCON.CBS'
      ITT = IT
      C3DCON_NBND = 1
      DO I=1, NBND
         IF( BOND(3,I).LT.0 ) THEN    !BOND BREAK
             IF( (I1.EQ.BOND(1,I).AND.I2.EQ.BOND(2,I))
     +       .OR.(I2.EQ.BOND(1,I).AND.I1.EQ.BOND(2,I)) ) RETURN
         ENDIF
      ENDDO
      C3DCON_NBND = 0
      RETURN
      END

      INTEGER   FUNCTION C3DCON_D1D2( M, N, I, J, K, D1, D2, DL )
C
C     THIS ROUTINE CHECKS FOR USER SETUP BONDING GROUPS.
C
      INCLUDE 'C3DCON.CBS'

      MM = M
      NN = N
      DO IC = 1, MAXC
         IF( CONN(1,IC).GT.0 ) THEN
             IF( MM.GE.CONN(1,IC).AND.MM.LE.CONN(2,IC)
     +     .AND. NN.GE.CONN(3,IC).AND.NN.LE.CONN(4,IC) ) GOTO 111
             IF( NN.GE.CONN(1,IC).AND.NN.LE.CONN(2,IC)
     +     .AND. MM.GE.CONN(3,IC).AND.MM.LE.CONN(4,IC) ) GOTO 111
         ENDIF
      ENDDO
      C3DCON_D1D2 = 1
      RETURN
  111 I = CONN(5,IC)
      J = CONN(6,IC)
      K = CONN(7,IC)
      D1= A2IN*D1D2(1,IC)
      D2= A2IN*D1D2(2,IC)
      DL= A2IN*D1D2(3,IC)
      C3DCON_D1D2 = 0
      RETURN
      END

      SUBROUTINE C3DCON_CROSS( RD, AX, AY )
C
C     THIS ROUTINE DISPLAYS AN ATOM AS A CROSS.
C
      INCLUDE 'C3DCON.CBS'
      REAL   AA(3), BB(3)

      DO J=1, 3
         DO I=1, 3
            BB(I) = 0.0
         ENDDO
         BB(J) = RD
         CALL C3DCON_MV( ORTH, BB )
         CALL IFPLOT_VECT( AX+BB(1), AY+BB(2), 3 )
         CALL IFPLOT_VECT( AX-BB(1), AY-BB(2), 2 )
      ENDDO
      RETURN
      END

      SUBROUTINE C3DCON_BONDS
C
C     THIS ROUTINE DRAWS THE EXTRA BONDS.
C
      INCLUDE 'C3DCON.CBS'
      LOGICAL      PAIR
      COMMON/PLOT/ PAIR, ATIN, ZOOM, ISEG(10,2)
      INTEGER      ZBUF, C3DCON_CLIP
      COMMON/OVER/ ZBUF(MAXX), AZYX(MAXX), AXYZ(3,MAXX)
C
C  OPEN SEGMENTS TO SAVE THE PLOT...
C
      IF( SANG.NE.0.0 ) THEN
          CALL IFSEG_PIVOT( 0.0, 0.0 )
          IF( PAIR ) THEN
              CALL IFSEG_OPEN( 37 )
              ISEG(7,2) = 37
          ELSE
              CALL IFSEG_OPEN( 27 )
              ISEG(7,1) = 27
          ENDIF
      ELSE
          ISEG(7,1) = 4000
      ENDIF
      DL = 0.1*A2IN
      DO 111 K=1, NBND
         L = BOND(3,K)
         IF( L.LT.0 ) GOTO 111    !BROKEN BOND
         IF( CLIP ) THEN
             IF( C3DCON_CLIP(SLAB,AXYZ(1,I)).EQ.0 ) GOTO 111
             IF( C3DCON_CLIP(SLAB,AXYZ(1,J)).EQ.0 ) GOTO 111
         ENDIF
         I = BOND(1,K)
         J = BOND(2,K)
         IF( SANG.EQ.0.0 ) THEN
             CALL IFSEG_PIVOT( 0.0, 0.0 )
             CALL IFSEG_OPEN( ISEG(7,1)+K )
         ENDIF
         CALL IFSPEN( IABS(L) )
         L = BOND(4,K)
         CALL IFSTYL( 1, IABS(L) )
         IF( L.LT.0 ) THEN    !IN-SITU 3D BOND DISTANCE LABEL
             CALL C3DCON_DIST( A2IN, IDSZ, AXYZ(1,I), AXYZ(2,I),
     +            AXYZ(3,I), AXYZ(1,J), AXYZ(2,J), AXYZ(3,J) )
         ELSE                 !BOND
             CALL C3DCON_I1I2( I, I1, J, I2 )
             CALL C3DCON_BOND( BOND(5,K), L, DL, I1, I2 )
         ENDIF
         IF( SANG.EQ.0.0 ) CALL IFSEG_OPEN( 0 )
  111 CONTINUE
  999 IF( SANG.NE.0.0 ) CALL IFSEG_OPEN( 0 )
      CALL IFSTYL( 1, 1 )
      RETURN
      END

      SUBROUTINE C3DCON_ATID
C
C     THIS ROUTINE DRAWS THE ATOM ID.
C
      INCLUDE 'C3DCON.CBS'
      LOGICAL      PAIR
      COMMON/PLOT/ PAIR, ATIN, ZOOM, ISEG(10,2)
      INTEGER      ZBUF, C3DCON_CLIP
      COMMON/OVER/ ZBUF(MAXX), AZYX(MAXX), AXYZ(3,MAXX)
      CHARACTER ID*8
C
C  OFFSET ID POSITION ACCORDING TO OXYZ(I)...
C
      DO J=1, NATM
         DO I=1, 3
            AXYZ(I,J) = A2IN*(ATOM(I,J)-OXYZ(I)/CELL(I))
         ENDDO
         CALL C3DCON_MV( GALL, AXYZ(1,J) )
      ENDDO
C
C  OPEN SEGMENTS TO SAVE THE PLOT...
C
      IF( SANG.NE.0.0 ) THEN
          CALL IFSEG_PIVOT( 0.0, 0.0 )
          IF( PAIR ) THEN
              CALL IFSEG_OPEN( 38 )
              ISEG(8,2) = 38
          ELSE
              CALL IFSEG_OPEN( 28 )
              ISEG(8,1) = 28
          ENDIF
      ELSE
          ISEG(8,1) = 5000
      ENDIF
      CALL IFSPEN( IDPN )
      CALL IFFONT( IDFN )
      DO K=1, NATM
         I = ZBUF(K)
         IF( IFCTRL_C() ) GOTO 999
         ID = ATID(I)
         IF( SHOW(I) .AND. ID.NE.' ' .AND.
     +     (.NOT.CLIP.OR.C3DCON_CLIP(SLAB,AXYZ(1,I)).EQ.1) ) THEN
             IF( SANG.EQ.0.0 ) THEN
                 CALL IFSEG_PIVOT( 0.0, 0.0 )
                 CALL IFSEG_OPEN( ISEG(8,1)+I )
             ENDIF
             CALL IFTEXT( AXYZ(1,I), AXYZ(2,I), ID, IDSZ, IDSZ, 0.0 )
             IF( SANG.EQ.0.0 ) CALL IFSEG_OPEN( 0 )
         ELSE
             SHOW(I) = .FALSE.
         ENDIF
      ENDDO
      IF( SANG.NE.0.0 ) CALL IFSEG_OPEN( 0 )
      CALL IFFONT( 1 )
  999 RETURN
      END

      SUBROUTINE C3DCON_AXES
C
C     THIS ROUTINE DISPLAYS THE PLOT ORIENTATION.
C
      INCLUDE  'C3DCON.CBS'
      LOGICAL      PAIR
      COMMON/PLOT/ PAIR, ATIN, ZOOM, ISEG(10,2)
      REAL      AA(3)
      CHARACTER AXIS(3)*1
      DATA AXIS / 'a', 'b', 'c' /

      CALL IFSEG_PIVOT( 0.0, 0.0 )
      IF( PAIR ) THEN
          CALL IFSEG_OPEN( 40 )
          ISEG(10,2) = 40
      ELSE
          CALL IFSEG_OPEN( 30 )
          ISEG(10,1) = 30
      ENDIF
      CALL IFSPEN( 1 )
      DO I=1, 3
         DO J=1, 3
            AA(J) = 0.0
         ENDDO
         AA(I) = A2IN*AXES
         CALL C3DCON_MV( ORTH, AA )
         CALL IFPLOT_VECT( 0.0, 0.0, 3 )
         CALL IFPLOT_VECT( AA(1), AA(2), 2 )
         CALL IFTEXT( AA(1), AA(2), AXIS(I), 0.1, 0.1, 0.0 )
      ENDDO
      CALL IFSEG_OPEN( 0 )
      RETURN
      END

      SUBROUTINE C3DCON_FLIP
C
C     THIS ROUTINE TOGGLES PLOT BETWEEN STEREO AND MONO MODE.
C
      INCLUDE 'C3DCON.CBS'
      SAVE SOLD

      IF( SANG.NE.0.0 ) THEN
          SOLD = SANG
          SANG = 0.0
      ELSE IF( SOLD.NE.0.0 ) THEN
          SANG = SOLD
      ELSE
          SANG = 6.0
      ENDIF
      CALL C3DCON_PLOT
      RETURN
      END

      SUBROUTINE C3DCON_TOGGLE
C
C     THIS ROUTINE IMPLEMENTS SOME TOGGLE SWITCHES.
C
      INCLUDE  'C3DCON.CBS'
      BYTE      FKEY(2)
      LOGICAL   PAIR, EXIT
      COMMON/PLOT/ PAIR, ATIN, ZOOM, ISEG(10,2)
      INTEGER   JSEG(10,2)

      IF( TERM.NE.2 ) GOTO 888
      CALL IFMAC_MACROS(1)
      CALL IFINIT_FKEYS( 'MAP1', 'MAP2', 'MAP3', 'MAP4', 'ATOMS',
     + 'BONDS', 'IDS', 'CELL' )
      DO K=1, 2
         DO I=1, 10
            IF( ISEG(I,K).GT.0 ) THEN
                JSEG(I,K) = ISEG(I,K)
            ELSE
                JSEG(I,K) = 0
            ENDIF
         ENDDO
      ENDDO
      EXIT = .FALSE.
 1    WRITE(6,2)
 2    FORMAT(' C3DCON> Press F1,...,F8 to toggle,',
     +' GEras to refresh, RETURN to exit'/' C3DCON_TOGGLE> ',$)
 3    READ(5,4,ERR=1,END=999) FKEY
 4    FORMAT(2A1)
      IF( FKEY(1).LT.33 ) GOTO 999
      IKEY = FKEY(2)-48
 111  IF( IKEY.LT.1 .OR. IKEY.GT.8 ) GOTO 3

 222  IF( IKEY.LT.7 .AND. JSEG(IKEY,1).NE.0 ) THEN    !TOGGLE MAPS
          K = -JSEG(IKEY,1)
          CALL IFSEG_HIDE( K )
          JSEG(IKEY,1) = K
          IF( PAIR ) THEN
              K = -JSEG(IKEY,2)
              CALL IFSEG_HIDE( K )
              JSEG(IKEY,2) = K
          ENDIF
      ENDIF
      IF( IKEY.EQ.8 ) THEN              !TOGGLE CELL OUTLINE AND AXES
          DO I=9, 10
             K = -JSEG(I,1)
             IF( K.NE.0 ) THEN
                 CALL IFSEG_HIDE( K )
                 JSEG(I,1) = K
                 IF( PAIR ) THEN
                     K = -JSEG(I,2)
                     CALL IFSEG_HIDE( K )
                     JSEG(I,2) = K
                 ENDIF
             ENDIF
          ENDDO
      ENDIF
      IF( IKEY.EQ.6 ) THEN              !TOGGLE BONDS
          IF( PAIR .AND. JSEG(7,1).NE.0 ) THEN
              K = -JSEG(7,1)
              CALL IFSEG_HIDE( K )
              JSEG(7,1) = K
              K = -JSEG(7,2)
              CALL IFSEG_HIDE( K )
              JSEG(7,2) = K
          ELSE
              K = -JSEG(7,1)
              DO I=1, NBND
                 IF( BOND(3,I).GT.0 ) THEN
                     IF( K.GT.0 ) THEN
                         CALL IFSEG_HIDE( K+I )
                     ELSE
                         CALL IFSEG_HIDE( K-I )
                     ENDIF
                 ENDIF
              ENDDO
              JSEG(7,1) = K
          ENDIF
      ENDIF
      IF( IKEY.EQ.7 ) THEN       !TOGGLE ATOM IDS
          IF( PAIR .AND. JSEG(8,1).NE.0 ) THEN
              K = -JSEG(8,1)
              CALL IFSEG_HIDE( K )
              JSEG(8,1) = K
              K = -JSEG(8,2)
              CALL IFSEG_HIDE( K )
              JSEG(8,2) = K
          ELSE
              K = -JSEG(8,1)
              DO I=1, NATM
                 IF( SHOW(I) ) THEN
                     IF( K.GT.0 ) THEN
                         CALL IFSEG_HIDE( K+I )
                     ELSE
                         CALL IFSEG_HIDE( K-I )
                     ENDIF
                 ENDIF
              ENDDO
              JSEG(8,1) = K
          ENDIF
      ENDIF
      CALL IFINIT_DUMP
      IF( EXIT ) GOTO 777
      GOTO 1
  999 EXIT = .TRUE.
  777 DO K=1, 10
         IF( JSEG(K,1).LT.0 ) THEN
             IKEY = K
             IF( K.EQ.8 ) IKEY = 7
             IF( K.EQ.9 ) IKEY = 8
             GOTO 222
         ENDIF
      ENDDO
      CALL IFSEG_OPEN(-4)
      CALL IFMAC_MACROS(0)
      RETURN
  888 CALL IFMISC_OOPS( 17, 0, 0, 'TOGGLE' )
      RETURN
      END

      SUBROUTINE C3DCON_ZOOM
C
C     THIS ROUTINE ZOOMS THE CURRENT PLOT.
C
      INCLUDE 'C3DCON.CBS'
      LOGICAL      PAIR
      COMMON/PLOT/ PAIR, ATIN, ZOOM, ISEG(10,2)
      BYTE     FKEY(2)
      REAL     IFPACK_DECTEK

      IF( TERM.NE.2 ) GOTO 888
      CALL IFMAC_MACROS(1)
      CALL IFINIT_FKEYS( '110%', '120%', '90%', '80%',
     + ' ', ' ', ' ', ' ' )
C
C  READ A GIN REPORT FROM TERMINAL...
C
      CALL IFINIT_DIF(0)
  111 WRITE(6,112)
  112 FORMAT(' C3DCON> Press F1/F2/F3/F4 to zoom up/down,',
     +' GEras to refresh, CR to exit'/' C3DCON_ZOOM> ',$)
      READ(5,222,ERR=111,END=999) FKEY
  222 FORMAT(2A1)
      IF( FKEY(1).LT.33 ) GOTO 999
      IKEY = FKEY(2)-48
      IF( IKEY.EQ.1 ) THEN       !F1: ZOOM UP BY 10%
          ZOOM = IFPACK_DECTEK(1.1*ZOOM)
      ELSE IF( IKEY.EQ.2 ) THEN  !F3: ZOOM UP BY 20%
          ZOOM = IFPACK_DECTEK(1.2*ZOOM)
      ELSE IF( IKEY.EQ.3 ) THEN  !F2: ZOOM DOWN BY 10%
          ZOOM = IFPACK_DECTEK(0.9*ZOOM)
      ELSE IF( IKEY.EQ.4 ) THEN  !F4: ZOOM DOWN BY 20%
          ZOOM = IFPACK_DECTEK(0.8*ZOOM)
      ELSE
          GOTO 111
      ENDIF
      IF( PAIR ) THEN
          CALL IFPLOT_VECT(-2.5,0.0,-3)
          DO I=1, 10
             K = ISEG(I,1)
             IF(K.GT.0) CALL IFSEG_TRAN(K,0.0,0.0,0.0,ZOOM,ZOOM)
          ENDDO
          CALL IFPLOT_VECT(5.0,0.0,-3)
          DO I=1, 10
             K = ISEG(I,2)
             IF(K.GT.0) CALL IFSEG_TRAN(K,0.0,0.0,0.0,ZOOM,ZOOM)
          ENDDO
          CALL IFPLOT_VECT(-2.5,0.0,-3)
      ELSE
          DO I=1, 10
             IF( I.NE.7 ) THEN
                 K = ISEG(I,1)
                 IF(K.GT.0) CALL IFSEG_TRAN(K,0.0,0.0,0.0,ZOOM,ZOOM)
             ELSE IF( I.EQ.6 ) THEN
                 DO K=1, NBND
      IF(BOND(3,K).GT.0) CALL IFSEG_TRAN(ISEG(7,1)+K,0,0,0,ZOOM,ZOOM)
                 ENDDO
             ELSE IF( I.EQ.7 ) THEN
                 DO K=1, NATM
             IF(SHOW(K)) CALL IFSEG_TRAN(ISEG(8,1)+K,0,0,0,ZOOM,ZOOM)
                 ENDDO
             ENDIF
          ENDDO
      ENDIF
      CALL IFINIT_DUMP
      GOTO 111
  999 CALL IFSEG_OPEN(-4)
      CALL IFMAC_MACROS(0)
      CALL IFINIT_DIF(1)
      A2IN = ATIN*ZOOM
      RETURN
  888 CALL IFMISC_OOPS( 17, 0, 0, 'ZOOM' )
      RETURN
      END

      SUBROUTINE C3DCON_ROTATE
C
C     THIS ROUTINE IMPLEMENTS INCREMENTAL ROTATION.
C
      INCLUDE 'C3DCON.CBS'
      CHARACTER TEXT*32
      DIMENSION RP(3), KP(3)

 1    WRITE(6,2)
 2    FORMAT(' C3DCON_ROTATE> Enter delta angles (x,y,z): ',$)
      READ(5,3,ERR=1,END=999) TEXT
 3    FORMAT(A32)
      IF( TEXT.EQ.' ' ) GOTO 999
      I = IFMISC_STRIP(TEXT)
      IF( I.GT.0 ) I = IFMISC_DECODE( TEXT, I, 3, RP, KP )
      IF( I.EQ.0 ) GOTO 1
      DO I=1, 3
         ROTA(I) = MOD(INT(ROTA(I)+RP(I)),360)
      ENDDO
      CALL C3DCON_PLOT
 999  RETURN
      END

      SUBROUTINE C3DCON_DASH( DD, AX, AY, AZ, BX, BY, BZ )
C
C     THIS ROUTINE DRAWS A 3D DASH LINE.
C
      DT = SQRT((AX-BX)**2+(AY-BY)**2+(AZ-BZ)**2)
      DL = DD
      CALL IFPLOT_VECT( AX, AY, 3 )
      IP = 1
      SP = 0.0
  111 SP = SP + DL
      IF( SP.GE.DT ) GOTO 999
      FC = SP/(DT-SP)
      FD = 1.0+FC
      CX = (AX+FC*BX)/FD
      CY = (AY+FC*BY)/FD
      IF( IP.GT.0 ) THEN
          CALL IFPLOT_VECT( CX, CY, 2 )
      ELSE
          CALL IFPLOT_VECT( CX, CY, 3 )
      ENDIF
      IP = -IP
      GOTO 111
  999 IF( IP.GT.0 ) CALL IFPLOT_VECT( BX, BY, 2 )
      RETURN
      END

      REAL   FUNCTION C3DCON_ANGL(X1,Y1,Z1,X2,Y2,Z2,X3,Y3,Z3)
C
C     THIS ROUTINE COMPUTS THE ANGLE BETWEEN LINE 1-2 AND LINE 2-3.
C
      DX = X1-X2
      DY = Y1-Y2
      DZ = Z1-Z2
      EX = X3-X2
      EY = Y3-Y2
      EZ = Z3-Z2
      AN = (DX*EX+DY*EY+DZ*EZ) /
     +     SQRT((DX*DX+DY*DY+DZ*DZ)*(EX*EX+EY*EY+EZ*EZ))
      IF( AN.LT.-1.0 ) AN = -1.0
      IF( AN.GT. 1.0 ) AN =  1.0
      C3DCON_ANGL = ACOSD( AN )
      RETURN
      END

      REAL   FUNCTION C3DCON_TORS(X1,Y1,Z1,X2,Y2,Z2,X3,Y3,Z3,X4,Y4,Z4)
C
C     THIS ROUTINE COMPUTS THE TORSION ANGLE AMONG 4 ATOMS.
C
      A2 = X1-X3
      B2 = Y1-Y3
      C2 = Z1-Z3
      A3 = X2-X3
      B3 = Y2-Y3
      C3 = Z2-Z3
      A1 = B2*C3-B3*C2
      B1 = A3*C2-A2*C3
      C1 = A2*B3-A3*B2
      A2 = X2-X4
      B2 = Y2-Y4
      C2 = Z2-Z4
      A3 = X3-X4
      B3 = Y3-Y4
      C3 = Z3-Z4
      A11 = B2*C3-B3*C2
      B11 = A3*C2-A2*C3
      C11 = A2*B3-A3*B2
      ANG = (A1*A11+B1*B11+C1*C11)/
     +      SQRT( (A1*A1+B1*B1+C1*C1)*(A11*A11+B11*B11+C11*C11) )
      IF( ANG.LT.-1.0 ) ANG = -1.0
      IF( ANG.GT. 1.0 ) ANG =  1.0
      C3DCON_TORS = ACOSD( ANG )
      RETURN
      END

      SUBROUTINE C3DCON_DIST( A2IN, SIZE, X1,Y1,Z1,X2,Y2,Z2 )
C
C     THIS ROUTINE DISPLAYS A BOND DISTANCE LABEL.
C
      PARAMETER (R2D = 57.29577951, PI=3.141592654)
      CHARACTER ID*6
      HT = 0.8*SIZE
      IF( HT.LT.0.02 ) HT = 0.02     !MIN FONT SIZE
      DIST = SQRT( (X1-X2)**2 + (Y1-Y2)**2 + (Z1-Z2)**2 )
      WRITE(ID,111) DIST/A2IN
  111 FORMAT(F6.2)
      NC = IFMISC_STRIP(ID)
      IF( NC.GT.0 .AND. NC*HT.LE.DIST ) THEN
          FC = 0.5*(DIST-NC*HT)
          FC = FC/(DIST-FC)
          FD = 1.0+FC
          X3 = (X1+FC*X2)/FD
          Y3 = (Y1+FC*Y2)/FD
          FC = ATAN((Y2-Y1)/(X2-X1))
          IF( X2.LT.X1 ) FC = FC + PI
          X3 = X3 - 0.02*SIN(FC)
          Y3 = Y3 + 0.02*COS(FC)
          CALL IFTEXT( X3, Y3, ID, HT, HT, FC*R2D )
      ENDIF
      RETURN
      END

      SUBROUTINE C3DCON_ZSORT( N, A, B )
C
C     MODIFIED SINGLETON SORT ROUTINE (CACM 12, 185 (1969)).
C     B IS PASSIVE ARRAY TO BE SORTED ON A.
C     N IS NUMBER OF POINTS IN THE ARRAYS.
C
      INTEGER I, II, IJ, IL(16), IU(16), J, K, L, M, U, B(1)
      REAL S, T, A(1)

      II = 1
      I = II
      J = N
      M = 1
  10  IF (I .GE. J) GO TO 100
C
C  ORDER ENDS AND MIDPOINT OF SEGMENT BOUNDED BY I AND J
C
  20  K = I
      IJ = (I + J)/2
      T = A(IJ)
      IF (A(I) .LE. T) GO TO 30
      A(IJ) = A(I)
      A(I) = T
      T = A(IJ)
      U = B(I)
      B(I) = B(IJ)
      B(IJ) = U

  30  L = J
      IF (A(J) .GE. T) GO TO 50
      A(IJ) = A(J)
      A(J) = T
      T = A(IJ)
      U = B(IJ)
      B(IJ) = B(J)
      B(J) = U

      IF (A(I) .LE. T) GO TO 50
      A(IJ) = A(I)
      A(I) = T
      T = A(IJ)
      U = B(IJ)
      B(IJ) = B(I)
      B(I) = U
      GO TO 50
C
C  INTERCHANGE ELEMENT .LE. T WITH ELEMENT .GE. T
C
  40  S = A(L)
      A(L) = A(K)
      A(K) = S
      U = B(L)
      B(L) = B(K)
      B(K) = U
C
C  SCAN DOWN SEQUENCE BETWEEN K AND L FOR ELEMENT .LE. T
C
  50  L = L - 1
      IF (A(L) .GT. T) GO TO 50
C
C  NOW SCAN UP FOR ELEMENT .GE. T
C
  60  K = K + 1
      IF (A(K) .LT. T) GO TO 60
      IF (K - L) 40, 70, 80
C
C  AVOID UNNECESSARY INTERCHANGE
C
  70  K = K + 1
      L = L - 1
C
C  STACK ENDPOINTS OF LONGER SEQUENCE
C
  80  IF (L - I .LE. J - K) GO TO 90
      IL(M) = I
      IU(M) = L
      M = M + 1
      I = K
      GO TO 110

  90  IL(M) = K
      IU(M) = J
      M = M + 1
      J = L
      GO TO 110
C
C  UNSTACK A SAVED SEQUENCE
C
  100 M = M - 1
      IF (M .EQ. 0) RETURN
      I = IL(M)
      J = IU(M)
C
C  SELECT SORTING METHOD
C
  110 IF (J - I .GE. 11) GO TO 20
      IF (I .EQ. II) GO TO 10
C
C  SHORT SEQUENCES (EXCEPT THE FIRST) ARE ORDERED BY A SINKING SORT
C
      I = I - 1
  120 I = I + 1
      IF (I .EQ. J) GO TO 100
      IF (A(I) .LE. A(I+1)) GO TO 120
      T = A(I+1)
      U = B(I+1)
      K = I
  130 A(K+1) = A(K)
      B(K+1) = B(K)
      K = K - 1
      IF (A(K) .GT. T) GO TO 130
      A(K+1) = T
      B(K+1) = U
      GO TO 120
      END

      SUBROUTINE C3DCON_DSORT( N, A, C )
C
C     MODIFIED SINGLETON SORT ROUTINE (CACM 12, 185 (1969)).
C     C IS PASSIVE ARRAY TO BE SORTED ON A.
C     N IS NUMBER OF POINTS IN THE ARRAYS.
C
      INTEGER I, II, IJ, IL(16), IU(16), J, K, L, M, V, C(1)
      REAL S, T, A(1)

      II = 1
      I = II
      J = N
      M = 1
  10  IF (I .GE. J) GO TO 100
C
C  ORDER ENDS AND MIDPOINT OF SEGMENT BOUNDED BY I AND J
C
  20  K = I
      IJ = (I + J)/2
      T = A(IJ)
      IF (A(I) .LE. T) GO TO 30
      A(IJ) = A(I)
      A(I) = T
      T = A(IJ)
      V = C(I)
      C(I) = C(IJ)
      C(IJ) = V

  30  L = J
      IF (A(J) .GE. T) GO TO 50
      A(IJ) = A(J)
      A(J) = T
      T = A(IJ)
      V = C(IJ)
      C(IJ) = C(J)
      C(J) = V

      IF (A(I) .LE. T) GO TO 50
      A(IJ) = A(I)
      A(I) = T
      T = A(IJ)
      V = C(IJ)
      C(IJ) = C(I)
      C(I) = V
      GO TO 50
C
C  INTERCHANGE ELEMENT .LE. T WITH ELEMENT .GE. T
C
  40  S = A(L)
      A(L) = A(K)
      A(K) = S
      V = C(L)
      C(L) = C(K)
      C(K) = V
C
C  SCAN DOWN SEQUENCE BETWEEN K AND L FOR ELEMENT .LE. T
C
  50  L = L - 1
      IF (A(L) .GT. T) GO TO 50
C
C  NOW SCAN UP FOR ELEMENT .GE. T
C
  60  K = K + 1
      IF (A(K) .LT. T) GO TO 60
      IF (K - L) 40, 70, 80
C
C  AVOID UNNECESSARY INTERCHANGE
C
  70  K = K + 1
      L = L - 1
C
C  STACK ENDPOINTS OF LONGER SEQUENCE
C
  80  IF (L - I .LE. J - K) GO TO 90
      IL(M) = I
      IU(M) = L
      M = M + 1
      I = K
      GO TO 110

  90  IL(M) = K
      IU(M) = J
      M = M + 1
      J = L
      GO TO 110
C
C  UNSTACK A SAVED SEQUENCE
C
  100 M = M - 1
      IF (M .EQ. 0) RETURN
      I = IL(M)
      J = IU(M)
C
C  SELECT SORTING METHOD
C
  110 IF (J - I .GE. 11) GO TO 20
      IF (I .EQ. II) GO TO 10
C
C  SHORT SEQUENCES (EXCEPT THE FIRST) ARE ORDERED BY A SINKING SORT
C
      I = I - 1
  120 I = I + 1
      IF (I .EQ. J) GO TO 100
      IF (A(I) .LE. A(I+1)) GO TO 120
      T = A(I+1)
      V = C(I+1)
      K = I
  130 A(K+1) = A(K)
      C(K+1) = C(K)
      K = K - 1
      IF (A(K) .GT. T) GO TO 130
      A(K+1) = T
      C(K+1) = V
      GO TO 120
      END

      SUBROUTINE C3DCON_BOND( BT, BW, DL, I1, I2 )
C
C     THIS ROUTINE DRAWS A BOND WITH OVERLAP CHECKING.
C
      INCLUDE 'C3DCON.CBS'
      PARAMETER    (NOVER= 50)    !MAX NUMBER OF OVERLAPPING ATOMS PER BOND.
      INTEGER      BT, BW         !BOND TYPE (1=SOLID,OTHER=DASH)
      REAL         DRXY(4,NOVER), DDDD(NOVER)
      INTEGER      ZBUF, ATOP(NOVER), C3DCON_TANZ, C3DCON_D123
      COMMON/OVER/ ZBUF(MAXX), AZYX(MAXX), AXYZ(3,MAXX)
C
C  INITIALIZE...
C
      I  = ZBUF(I1)
      J  = ZBUF(I2)
      AX = AXYZ(1,I)
      AY = AXYZ(2,I)
      AZ = AXYZ(3,I)
      BX = AXYZ(1,J)
      BY = AXYZ(2,J)
      BZ = AXYZ(3,J)
      RI = 0.0
      RJ = 0.0
      K  = ATBB(I)
      N  = IABS(BTYP(K))
      IF( ATCL(I).NE.0 .AND. N.GT.1 .AND. N.LE.MAXT ) RI=A2IN*BSIZ(K)
      K  = ATBB(J)
      N  = IABS(BTYP(K))
      IF( ATCL(J).NE.0 .AND. N.GT.1 .AND. N.LE.MAXT ) RJ=A2IN*BSIZ(K)
      DX = BX-AX
      DY = BY-AY
      DZ = BZ-AZ
      D1 = SQRT( DX*DX + DY*DY )      !2D DISTANCE BETWEEN I1 AND I2.
      IF( D1.LT.0.01 .OR. D1.LT.RI .OR. D1.LT.RJ ) GOTO 999
C
C  UPDATE BOTH ENDS OF BOND...
C
      IF( RI.GT.0.0 ) THEN
          DD = SQRT(DZ*DZ+D1*D1)   !3D DISTANCE BETWEEN I1 AND I2
          D2 = D1*RI/DD            !2D PROJECTION FROM I1 CENTER TO ITS SURFACE
          CALL C3DCON_DIV( 1, D2, D1, AX, AY, AZ, BX, BY, BZ )
          IF( RJ.GT.0.0 .AND. D1.LT.RJ ) GOTO 999     !BOND SHADOWED BY I2.
      ENDIF
      IF( BT.EQ.1 )  CALL IFPLOT_VECT( AX, AY, 3 )
      IF( RJ.GT.0.0 ) CALL C3DCON_DIV( 2,D1-RJ,D1,AX,AY,AZ,BX,BY,BZ )
C
C  FIND ATOMS THAT ARE OVERLAPPING WITH THE BOND...
C  WW IS HALF OF THE BOND WIDTH...
C  (ASSUMING 0.25 UNIT LINE WIDTH IN THE POSTSCRIPT DRIVER)...
C
      LO = 0
      WW = 0.00174*IABS(BW)
      DO 111 K=1, NATM
         IF( K.EQ.I1 .OR. K.EQ.I2 ) GOTO 111
         N = ZBUF(K)
         M = ATBB(N)
         L = IABS(BTYP(M))
         IF( ATCL(N).EQ.0 .OR. L.LT.2 .OR. L.GT.MAXT ) GOTO 111
         RK = A2IN*BSIZ(M) + WW
         CZ = AXYZ(3,N)
         IF( CZ+RK.LE.AZ ) GOTO 111   !BELOW THE BOND
C
C  DD IS THE SQUARE OF SHORTEST 2D DISTANCE FROM ATOM K TO BOND...
C  D2 IS THE DISTANCE BETWEEN ATOM K AND I1/I2...
C
         CX = AXYZ(1,N)
         CY = AXYZ(2,N)
         DD = C3DCON_D2L( AX,AY,0, BX,BY,0, CX,CY,0 )
         IF( DD.LT.RK*RK ) THEN        !OVERLAPPING IN 2D WITH BOND LINE
             D2 = SQRT( (CX-BX)**2 + (CY-BY)**2 )
             D3 = SQRT( (CX-AX)**2 + (CY-AY)**2 )
             IF( C3DCON_D123(D1,D2,D3,RK ).GT.0 ) GOTO 111
             IF( CZ-RK.LT.BZ ) THEN
                 N = C3DCON_TANZ(AX,AY,AZ,BX,BY,BZ,CX,CY,CZ,RK,DD,D3)
                 IF( N.GT.0 ) GOTO 111     !BALL BELOW BOND SEGMENT
                 IF( N.LT.0 ) GOTO 999     !BOND OVERSHADOWED BY THE BALL
             ELSE
                 IF( D2.LE.RK.AND.D3.LE.RK ) GOTO 999   !BALL OVERSHADOW BOND
             ENDIF
             LO = LO + 1
             DDDD(LO) = SQRT( ABS(D3*D3-DD) ) - SQRT( ABS(RK*RK-DD) )
             DRXY(1,LO) = DD
             DRXY(2,LO) = RK
             DRXY(3,LO) = CX
             DRXY(4,LO) = CY
             ATOP(LO) = LO
             IF( LO.EQ.NOVER ) THEN
                 WRITE(6,222)
                 GOTO 999
             ENDIF
         ENDIF
  111 CONTINUE
  222 FORMAT(' %C3DCON_BOND: bond ignored due to too many',
     +' overlapping atoms.')
C
C  LO IS THE TOTAL NUMBER ATOMS OVERLAPPING WITH THE BOND...
C  DRAW THE BOND THROUGH THEM...
C
      DD = 0.0
      IF( LO.EQ.0 ) GOTO 444
      IF( BT.NE.1 ) THEN
          DX = AX
          DY = AY
          DZ = AZ
      ENDIF
C
C  SORT THE LO ARRAY BY DISTANCES TO I1...
C
      IF( LO.GT.1 ) CALL C3DCON_DSORT( LO,DDDD,ATOP )
      DO 333 K=1, LO
         N  = ATOP(K)
         RI = DRXY(1,N)
         RK = DRXY(2,N)
         CX = DRXY(3,N)
         CY = DRXY(4,N)
         D2 = SQRT( (CX-BX)**2 + (CY-BY)**2 )
         D3 = SQRT( (CX-AX)**2 + (CY-AY)**2 )
         IF( C3DCON_D123(D1,D2,D3,RK).GT.0 ) GOTO 333
         DD = SQRT( ABS(RK*RK-RI) )
         RK = SQRT( ABS(D3*D3-RI) )
         IF( (RK-DD).GT.2.0*WW ) THEN   !DRAW TO ATOM
             CALL C3DCON_DIV( 1, RK-DD,D1, AX,AY,AZ, BX,BY,BZ )
             IF( BT.EQ.1 ) THEN
                 CALL IFPLOT_VECT( AX, AY, 2 )
             ELSE
                 CALL C3DCON_DASH( DL, DX,DY,DZ, AX,AY,AZ )
                 DX = AX
                 DY = AY
                 DZ = AZ
             ENDIF
             DD = 2.0*DD
         ELSE                      !JUMP OVER ATOM
             D2 = SQRT( ABS(D2*D2-RI) )
             IF( D2.GT.D1 ) THEN
                 DD = DD - RK
             ELSE
                 DD = DD + RK
             ENDIF
         ENDIF
         IF( DD.LT.D1 ) THEN
             CALL C3DCON_DIV( 1, DD, D1, AX, AY, AZ, BX, BY, BZ )
             IF( BT.EQ.1 ) THEN
                 CALL IFPLOT_VECT( AX, AY, 3 )
             ELSE
                 DX = AX
                 DY = AY
                 DZ = AZ
             ENDIF
             DD = 0.0
         ELSE
             GOTO 999
         ENDIF
  333 CONTINUE
  444 IF( D1.GT.0 .AND. DD.LT.D1 ) THEN
          IF( BT.EQ.1 ) THEN
              CALL IFPLOT_VECT( BX, BY, 2 )
          ELSE
              CALL C3DCON_DASH( DL, AX,AY,AZ, BX,BY,BZ )
          ENDIF
      ENDIF
  999 RETURN
      END

      INTEGER   FUNCTION C3DCON_D123( D1, D2, D3, RK )
C
C     THIS ROUTINE TESTS IF AN ATOM TOUCHING THE BOND LINE
C     IS OUTSIDE THE BOND SEGMENT.
C
      IF( D2.LT.D3 .AND. D1.LT.D3 .AND. D2.GT.RK ) GOTO 9
      IF( D3.LT.D2 .AND. D1.LT.D2 .AND. D3.GT.RK ) GOTO 9
      C3DCON_D123 = 0
      RETURN
  9   C3DCON_D123 = 1
      RETURN
      END

      INTEGER   FUNCTION
     +C3DCON_TANZ( XX1,YY1,ZZ1, XX2,YY2,ZZ2, XX3,YY3,ZZ3, RD,Q1,Q2 )
C
C     THIS ROUTINE TESTS IF A BOND PENETRATES AN ATOM.
C     IF TRUE, RETURN WITH EFFECTIVE BALL RADIA AND CENTER.
C
      X1 = XX1
      Y1 = YY1
      Z1 = ZZ1
      X2 = XX2
      Y2 = YY2
      Z2 = ZZ2
      X3 = XX3
      Y3 = YY3
      Z3 = ZZ3
      RK = RD
C
C  D1 --- DISTANCE BETWEEN BOND LOWER END TO THE ATOM.
C  D2 --- DISTANCE BETWEEN BOND HIGHER END TO THE ATOM.
C  D3 --- BOND LENGTH.
C  A1 --- THREE POINT ANGLE AROUND BOND LOWER END.
C  A2 --- THREE POINT ANGLE AROUND BOND HIGHER END.
C
      D1 = SQRT( (X1-X3)**2 + (Y1-Y3)**2 + (Z1-Z3)**2 )
      D2 = SQRT( (X3-X2)**2 + (Y3-Y2)**2 + (Z3-Z2)**2 )
      IF( D1.LE.RK .AND. D2.LE.RK ) GOTO 777
      D3 = SQRT( (X1-X2)**2 + (Y1-Y2)**2 + (Z1-Z2)**2 )
      A1 = C3DCON_ANGL( X3,Y3,Z3, X1,Y1,Z1, X2,Y2,Z2 )
      A2 = C3DCON_ANGL( X3,Y3,Z3, X2,Y2,Z2, X1,Y1,Z1 )
C
C  DD IS THE SQUARE OF SHORTEST 3D DISTANCE FROM THE ATOM TO THE BOND...
C
      DD = C3DCON_D2L( X1,Y1,Z1, X2,Y2,Z2, X3,Y3,Z3 )
      IF( DD.GE.RK*RK ) GOTO 111
C
C  BOND PENETRATES THE BALL, FIND THE TWO INTERCEPT POINTS
C  ON THE SURFACE OF THE BALL ...
C
      D4 = SQRT(ABS(RK*RK-DD))
      IF( A1.LT.90.0 ) THEN
          D5 = SQRT(ABS(D1*D1-DD)) - D4
          CALL C3DCON_DIV( 1, D5, D3, X1,Y1,Z1, X2,Y2,Z2 )
          CALL C3DCON_DIV( 2, 2.0*D4, D3, X1,Y1,Z1, X2,Y2,Z2 )
      ELSE
          D5 = SQRT(ABS(D2*D2-DD)) - D4
          CALL C3DCON_DIV( 1, D5, D3, X2,Y2,Z2, X1,Y1,Z1 )
          CALL C3DCON_DIV( 2, 2.0*D4, D3, X2,Y2,Z2, X1,Y1,Z1 )
      ENDIF
C
C  CALCULATE EFFECTIVE BALL SIZE AND ITS CENTER FOR PROJECTION...
C
      IF( D1.LE.RK ) Z1 = Z3-0.01               !LOWER END IN THE BALL
      IF( D2.LE.RK ) Z2 = Z3-0.01               !HIGHER END IN THE BALL
      IF( Z1.LE.Z3 .AND. Z2.LE.Z3 ) GOTO 888    !BOTH ENDS ARE INVISIBLE
      IF( Z1.LT.Z3  .OR. Z2.LT.Z3 )
     +    CALL C3DCON_2XY( X1,Y1,Z1, X2,Y2,Z2, X3,Y3,Z3, RK )
      Q1 = 0.0
      RD = 0.5*SQRT( (X2-X1)**2 + (Y2-Y1)**2 )
      XX3= 0.5*(X1+X2)
      YY3= 0.5*(Y1+Y2)
      Q2 = SQRT( (XX1-XX3)**2 + (YY1-YY3)**2 )
      GOTO 888
C
C  BOND NOT PENETRATING THE BALL, IS IT ABOVE OR BELOW THE BALL...
C
  111 IF( Z3.LE.Z1 ) GOTO 999        !ABOVE THE BALL
      IF( Z3.GE.Z2 ) GOTO 888        !BELOW THE BALL
      IF( A1.LT.90.0 ) THEN
          D4 = SQRT( ABS(D1*D1-DD) )
          CALL C3DCON_DIV( 1, D4, D3, X1,Y1,Z1, X2,Y2,Z2 )
          IF( Z1.GE.Z3 ) GOTO 999
      ENDIF
C
C  RETURN...
C
  888 C3DCON_TANZ = 0
      RETURN
  999 C3DCON_TANZ = 1
      RETURN
  777 C3DCON_TANZ = -1
      END

      SUBROUTINE C3DCON_2XY( X1,Y1,Z1, X2,Y2,Z2, X3,Y3,Z3, RD )
C
C     THIS ROUTINE FINDS THE TWO INTERCEPT POINTS OF A LINE(1,2)
C     INTERCEPTING WITH A CIRCLE(3,RD), I.E. THE TWO ROOTS OF A 
C     2ND ORDER POLYNOMIAL WITH COEFS IN AAA,BBB,CCC.
C
      PARAMETER (ERROR=0.001)

      RR = RD*RD
      IF( ABS(X2-X1).GT.ERROR .AND. ABS(Y2-Y1).GT.ERROR ) THEN
          DXY = (X2-X1)/(Y2-Y1)
          DXX = X1-X3
          DYY = Y1-Y3
          AAA = 1.0+DXY*DXY
          BBB = 2.0*DXY*DXX - 2.0*DXY*DXY*DYY
          CCC = DXY*DXY*DYY*DYY + DXX*DXX - 2.0*DXY*DXX*DYY - RR
          DDD = SQRT( ABS(BBB*BBB-4.0*AAA*CCC) )
          YY1 = 0.5*(DDD-BBB)/AAA + Y3
          YY2 =-0.5*(DDD+BBB)/AAA + Y3
          XX1 = DXY*(YY1-Y1) + X1
          XX2 = DXY*(YY2-Y1) + X1
          AAA = SQRT( (X1-XX1)**2 + (Y1-YY1)**2 )
          BBB = SQRT( (X2-XX1)**2 + (Y2-YY1)**2 )
          IF( Z1.LT.Z3 ) THEN
              IF( AAA.LT.BBB ) THEN
                  X1 = XX1
                  Y1 = YY1
              ELSE
                  X1 = XX2
                  Y1 = YY2
              ENDIF
          ELSE
              IF( AAA.LT.BBB ) THEN
                  X2 = XX2
                  Y2 = YY2
              ELSE
                  X2 = XX1
                  Y2 = YY1
              ENDIF
          ENDIF
      ELSE
          AAA = C3DCON_D2L( X1,Y1,0, X2,Y2,0, X3,Y3,0 )
          AAA = SQRT( ABS(RR-AAA) )
          IF( ABS(X2-X1).GT.ERROR ) THEN
              IF( Z1.LT.Z3 ) THEN
                  IF( X1.LT.X2 ) THEN
                      X1 = X3-AAA
                  ELSE
                      X1 = X3+AAA
                  ENDIF
              ELSE
                  IF( X1.LT.X2 ) THEN
                      X2 = X3+AAA
                  ELSE
                      X2 = X3-AAA
                  ENDIF
              ENDIF
          ELSE
              IF( Z1.LT.Z3 ) THEN
                  IF( Y1.LT.Y2 ) THEN
                      Y1 = Y3-AAA
                  ELSE
                      Y1 = Y3+AAA
                  ENDIF
              ELSE
                  IF( Y1.LT.Y2 ) THEN
                      Y2 = Y3+AAA
                  ELSE
                      Y2 = Y3-AAA
                  ENDIF
              ENDIF
          ENDIF
      ENDIF
      RETURN
      END

      REAL   FUNCTION C3DCON_D2L( X1,Y1,Z1, X2,Y2,Z2, X3,Y3,Z3 )
C
C     THIS ROUTINE COMPUTES THE SQUARE OF SHORTEST DISTANCE 
C     FROM POINT 3 TO THE LINE (1,2). WORKS IN 2D AND 3D.
C
      DX = X2-X1
      DY = Y2-Y1
      DZ = Z2-Z1
      CX = X3-X1
      CY = Y3-Y1
      CZ = Z3-Z1
      DD = CX*CX+CY*CY+CZ*CZ-(DX*CX+DY*CY+DZ*CZ)**2/(DX*DX+DY*DY+DZ*DZ)
      C3DCON_D2L = ABS(DD)
      RETURN
      END

      SUBROUTINE C3DCON_DIV( IC, DIV, SEG, X1, Y1, Z1, X2, Y2, Z2 )
C
C     THIS ROUTINE RETURNS THE DIVISION POINT DIV/SEG.
C
      IF( DIV.NE.SEG ) THEN
          FC = DIV/(SEG-DIV)
          FD = 1.0+FC
          XD = (X1+FC*X2)/FD
          YD = (Y1+FC*Y2)/FD
          ZD = (Z1+FC*Z2)/FD
      ELSE
          XD = X2
          YD = Y2
          ZD = Z2
      ENDIF
      IF( IC.EQ.1 ) THEN
          X1 = XD
          Y1 = YD
          Z1 = ZD
          SEG= SEG-DIV
      ELSE
          X2 = XD
          Y2 = YD
          Z2 = ZD
          SEG= DIV
      ENDIF
      RETURN
      END

      SUBROUTINE C3DCON_I1I2( I, I1, J, I2 )
C
C     THIS ROUTINE RETURNS ATOM I'S I1 AND ATOM J'S I2
C     POINTERS IN THE SORTED ZBUF.
C
      INCLUDE 'C3DCON.CBS'
      INTEGER      ZBUF
      COMMON/OVER/ ZBUF(MAXX), AZYX(MAXX), AXYZ(3,MAXX)

      DO K=1, NATM
         IF( ZBUF(K).EQ.I ) GOTO 111
      ENDDO
 111  I1 = K
      DO K=1, NATM
         IF( ZBUF(K).EQ.J ) GOTO 222
      ENDDO
 222  I2 = K
      IF( I1.GT.I2 ) THEN
          K  = I1
          I1 = I2
          I2 = K
      ENDIF
      RETURN
      END

      SUBROUTINE C3DCON_CELL
C
C     THIS ROUTINE DRAWS THE OUTLINE OF UNIT CELL(S).
C
      PARAMETER    (ERROR= 0.001)
      INCLUDE      'C3DCON.CBS'
      INTEGER      ZBUF
      COMMON/OVER/ ZBUF(MAXX), AZYX(MAXX), AXYZ(3,MAXX)
      LOGICAL      PAIR
      COMMON/PLOT/ PAIR, ATIN, ZOOM, ISEG(10,2)

      CALL IFSEG_PIVOT( 0.0, 0.0 )
      IF( PAIR ) THEN
          CALL IFSEG_OPEN( 39 )
          ISEG(9,2) = 39
      ELSE
          CALL IFSEG_OPEN( 29 )
          ISEG(9,1) = 29
      ENDIF
      CALL IFSPEN( UNIC(1) )
      CALL IFSTYL( 1, UNIC(2) )
      DL = 0.2*A2IN
      CX = CELL(1)*A2IN
      CY = CELL(2)*A2IN
      CZ = CELL(3)*A2IN
      DO 222 I1=1, NATM-1
         IF( IFCTRL_C() ) GOTO 999
         I = ZBUF(I1)
         IF( ATCL(I).GT.0 ) GOTO 222
         AX = AXYZ(1,I)
         AY = AXYZ(2,I)
         AZ = AXYZ(3,I)
         DO 111 I2=I1+1, NATM
            IF( IFCTRL_C() ) GOTO 999
            J = ZBUF(I2)
            IF( ATCL(J).GT.0 ) GOTO 111
            BX = AXYZ(1,J)
            BY = AXYZ(2,J)
            BZ = AXYZ(3,J)
            DD = SQRT( (AX-BX)**2+(AY-BY)**2+(AZ-BZ)**2 )
            IF( ABS(DD-CX).LT.ERROR .OR. ABS(DD-CY).LT.ERROR .OR.
     +ABS(DD-CZ).LT.ERROR ) CALL C3DCON_BOND(UNIC(3),UNIC(2),DL,I1,I2)
 111  CONTINUE
 222  CONTINUE
 999  CALL IFSEG_OPEN( 0 )
      RETURN
      END

      SUBROUTINE C3DCON_EDIT
C
C     THIS ROUTINE IMPLEMENTS ON-LINE GRAPHICS EDITING
C     ON TEK-4100 TERMINAL ONLY.
C
      INCLUDE 'C3DCON.CBS'
      LOGICAL      PAIR
      COMMON/PLOT/ PAIR, ATIN, ZOOM, ISEG(10,2)
      INTEGER      ZBUF, C3DCON_CLIP
      COMMON/OVER/ ZBUF(MAXX), AZYX(MAXX), AXYZ(3,MAXX)
      CHARACTER ID*8
      BYTE      ESC, BEEP
      INTEGER   JSEG(10), IR(4)

      IF( TERM.NE.2 ) THEN
          CALL IFMISC_OOPS( 17, 0, 0, 'EDIT_PLOT' )
          RETURN
      ENDIF
C
C  IF STEREO PAIR IS ON, FLIP TO MONO DISPLAY...
C
      IF( PAIR ) CALL C3DCON_FLIP
C
C  GET ATOM COORDINATES...
C
      DO J=1, NATM
         DO I=1, 3
            AXYZ(I,J) = A2IN*ATOM(I,J)
         ENDDO
         CALL C3DCON_MV( GALL, AXYZ(1,J) )
         AZYX(J) = AXYZ(3,J)
         ZBUF(J) = J
      ENDDO
      CALL C3DCON_ZSORT( NATM, AZYX, ZBUF )
      DO J=1, 10
         JSEG(J) = IABS(ISEG(J,1))
      ENDDO
C
C  ENABLE TERMINAL GIN...
C
      CALL IFGIN_ABLE( -2 )			!ENABLE GIN PICKER
      CALL IFSEG_MOVE( 0, 0.0, 0.0 )		!MOVE CURSOR TO ORIGIN
      DO  I= 1, 8                               !DEFINE 8 FKEYS
          CALL IFMAC_DEFINE( 127+I, 1, 48+I )
      ENDDO
      CALL IFMAC_DEFINE(-155, 1, 32 )           !MOUSE_UNSHIFT_LEFT
      CALL IFMAC_DEFINE(-161, 1, 49 )           !MOUSE_SHIFT_LEFT
      CALL IFMAC_DEFINE(-157, 1, 52 )           ! "   _UNSHIFT_MIDDLE
      CALL IFMAC_DEFINE(-163, 1, 50 )           ! "   _SHIFT_MIDDLE
      CALL IFMAC_DEFINE(-159, 1, 53 )           ! "   _UNSHIFT_RIGHT
      CALL IFMAC_DEFINE(-165, 1, 54 )           ! "   _SHIFT_RIGHT
      CALL IFINIT_FKEYS( 'DISTANCE', 'ANGLE', 'TORSION',
     +'FLIP_ID', 'PUT_BOND', 'DEL_BOND', 'PUT_DIST', 'DEL_DIST' )
C
C  DISABLE DI FILE OUTPUT FOR THE SESSION...
C
      CALL IFINIT_DIF( 0 )
C
C  START THE GIN LOOP...
C
      NT = 0
      ESC = 27
      BEEP = 7
      WRITE(6,1234) BEEP
 1234 FORMAT(' C3DCON_EDIT> Enter ? if you need any help.',
     +' Press RETURN to exit.',A1,$)
C
C  READ A GIN REPORT FROM TERMINAL...
C
  111 WRITE(6,112)
  112 FORMAT(' C3DCON_EDIT> ',$)
      IKEY = IFGIN_REPORT( NSEG, XPOS, YPOS )
      IF( IKEY.EQ.0 ) GOTO 999
      IF( IKEY.EQ.63 ) THEN
          CALL C3DCON_EDIT_HELP
          GOTO 111
      ENDIF
      IF( IKEY.NE.32 .AND. IKEY.NE.52 ) GOTO 222
C
C  GET THE ATOM TOUCHED BY THE CURSOR...
C
      IF( NSEG.GT.JSEG(8).AND.NSEG.LE.JSEG(8)+NATM ) THEN
          I = NSEG-JSEG(8)
          GOTO 444
      ENDIF
      DO I=1, NATM
         DIST = SQRT((XPOS-AXYZ(1,I))**2+(YPOS-AXYZ(2,I))**2)
         IF( DIST.LT.0.05 ) GOTO 333
      ENDDO
      GOTO 889
C
C  GET THE BOND TOUCHED BY THE CURSOR...
C
  222 IF( IKEY.NE.54 .AND. IKEY.NE.56 ) GOTO 444
      IF( NSEG.GT.JSEG(7).AND.NSEG.LE.JSEG(7)+NBND ) THEN
          I = NSEG-JSEG(7)
          GOTO 777
      ENDIF
      IF( IKEY.EQ.56 ) GOTO 889
      GOTO 7777
  333 NSEG = JSEG(8) + I
  444 IF( IKEY.GT.51 ) GOTO 555
C
C  SHOW ATOM ID/DISTANCE/BOND ANGLE/TORSION...
C  A STACK OF 4 ATOMS ARE SAVED (LAST IN AND FIRST OUT)...
C
      IF( IKEY.EQ.32 ) THEN
          WRITE(6,445) ESC,ATID(I),ESC
          IF( NT.EQ.4 ) THEN
              DO K=1, 3
                 IR(K) = IR(K+1)
              ENDDO
              NT = 3
          ENDIF
          NT = NT + 1
          IR(NT) = I
      ELSE
          IF( NT.LT.IKEY-47 ) GOTO 800
          I = IR(NT)
          J = IR(NT-1)
          IF( IKEY.EQ.49 ) THEN        !SHOW DISTANCE
              DIST = SQRT( (AXYZ(1,J)-AXYZ(1,I))**2 + (AXYZ(2,J)
     +        -AXYZ(2,I))**2 + (AXYZ(3,J)-AXYZ(3,I))**2 )/A2IN
              WRITE(6,446) ATID(J), ATID(I), DIST
          ELSE IF( IKEY.EQ.50 ) THEN   !SHOW ANGLE
              K = IR(NT-2)
              DIST = C3DCON_ANGL( AXYZ(1,K),AXYZ(2,K),AXYZ(3,K),
     +                            AXYZ(1,J),AXYZ(2,J),AXYZ(3,J),
     +                            AXYZ(1,I),AXYZ(2,I),AXYZ(3,I))
              WRITE(6,447) ATID(K), ATID(J), ATID(I), DIST
          ELSE IF( IKEY.EQ.51 ) THEN   !SHOW TORSION
              K = IR(NT-2)
              L = IR(NT-3)
              DIST = C3DCON_TORS( AXYZ(1,L),AXYZ(2,L),AXYZ(3,L),
     +                            AXYZ(1,K),AXYZ(2,K),AXYZ(3,K),
     +                            AXYZ(1,J),AXYZ(2,J),AXYZ(3,J),
     +                            AXYZ(1,I),AXYZ(2,I),AXYZ(3,I))
              WRITE(6,448) ATID(L), ATID(K), ATID(J), ATID(I), DIST
          ENDIF
      ENDIF
  445 FORMAT(' C3DCON_EDIT> I AM ',A1,'[43;30m',A8,A1,'[44;37m')
  446 FORMAT(' C3DCON_EDIT> FROM ',A8,' - ',A8,': DIST=',F8.4,'A')
  447 FORMAT(' C3DCON_EDIT> FROM ',A8,' - ',A8,' - ',A8,': ANG=',
     +F8.2,1X,'deg')
  448 FORMAT(' C3DCON_EDIT> FROM ',A8,' - ',A8,' - ',A8,' - ',A8,
     +': TOR=',F8.2,1X,'deg')
      GOTO 111
  555 IF( IKEY.NE.52 ) GOTO 666
C
C  TOGGLE ATOM ID LABEL...
C
      IF( .NOT.SHOW(I) ) THEN
          IF( CLIP .AND. C3DCON_CLIP(SLAB,AXYZ(1,I)).EQ.0 ) GOTO 889
          ID = ATID(I)
          IF( ID.NE.' ' ) THEN
              CALL IFSEG_PIVOT( 0.0, 0.0 )
              CALL IFSEG_OPEN( NSEG )
              IF( IDPN.EQ.0 ) IDPN = 1
              CALL IFSPEN( IDPN )
              CALL IFFONT( IDFN )
              CALL IFTEXT( AXYZ(1,I), AXYZ(2,I), ID, IDSZ,IDSZ, 0.0 )
              CALL IFSEG_OPEN( 0 )
              CALL IFINIT_DUMP
              SHOW(I) = .TRUE.
          ENDIF
      ELSE
          CALL IFSEG_OPEN( -NSEG )
          CALL IFINIT_DUMP
          SHOW(I) = .FALSE.
      ENDIF
      GOTO 111
  666 IF( IKEY.NE.53 .AND. IKEY.NE.55 ) GOTO 888
C
C  CONNECT A BOND...
C
      IF( NT.LT.2 ) GOTO 800
      J = IR(NT)
      I = IR(NT-1)
      IF( I.EQ.J ) GOTO 111
      IF( NBND.EQ.MAXB ) GOTO 802
      IF( IKEY.EQ.53 ) THEN
          CALL IFGIN_ABLE( 0 )
  665     WRITE(6,667)
  667     FORMAT(' C3DCON_EDIT> Bond color, width, type [1,1,1]: ',$)
          READ(5,668,ERR=665,END=669) K,L,N
  668     FORMAT(3I5)
  669     IF( K.LT.1 ) THEN
              K = 1
              L = 1
              N = 1
          ELSE
              IF( K.LT.1 .OR. K.GT.8 ) GOTO 665
              IF( L.LT.1 .OR. L.GT.99) GOTO 665
              IF( N.LT.1 .OR. N.GT.9 ) GOTO 665
          ENDIF
          CALL IFGIN_ABLE( -2 )
          CALL IFSEG_MOVE( 0, 0.0, 0.0 )
      ENDIF
      NBND = NBND + 1
      BOND(1,NBND) = I
      BOND(2,NBND) = J
      CALL IFSEG_PIVOT( 0.0, 0.0 )
      CALL IFSEG_OPEN( JSEG(7)+NBND )
      IF( IKEY.EQ.53 ) THEN
          BOND(3,NBND) = K
          BOND(4,NBND) = L
          BOND(5,NBND) = N
          CALL IFSPEN( K )
          CALL C3DCON_I1I2( I, I1, J, I2 )
          CALL C3DCON_BOND( N, L, 0.1*A2IN, I1, I2 )
      ELSE
          CALL IFSPEN( IDPN )
          CALL IFFONT( IDFN )
          BOND(3,NBND) = IDPN
          BOND(4,NBND) = -L
          BOND(5,NBND) = 0
          CALL C3DCON_DIST( A2IN, IDSZ, AXYZ(1,I), AXYZ(2,I),
     +    AXYZ(3,I), AXYZ(1,J), AXYZ(2,J), AXYZ(3,J) )
      ENDIF
      CALL IFSEG_OPEN( 0 )
      CALL IFINIT_DUMP
      GOTO 111
C
C  ERASE AN EXTRA BOND...
C
  777 IF( NBND.EQ.0 ) GOTO 111
      CALL IFSEG_OPEN( -NSEG )
      DO K=I, NBND-1
         DO L=1, 5
            BOND(L,K) = BOND(L,K+1)
         ENDDO
         CALL IFSEG_RENAME( JSEG(7)+K+1, JSEG(7)+K )
      ENDDO
      CALL IFINIT_DUMP
      NBND = NBND - 1
      GOTO 111
C
C  BREAK A MODEL BOND...
C
 7777 IF( NT.LT.2 ) GOTO 800
      J = IR(NT)
      I = IR(NT-1)
      IF( I.EQ.J ) GOTO 111
      IF( NBND.EQ.MAXB ) GOTO 802
      NBND = NBND + 1
      BOND(1,NBND) = I
      BOND(2,NBND) = J
      BOND(3,NBND) =-1
      BOND(4,NBND) = 0
      BOND(5,NBND) = 0
      WRITE(6,7778) ATID(I), ATID(J)
 7778 FORMAT(' C3DCON_EDIT> ',A8,' - ',A8,' bond break.')
      GOTO 111
C
C  ERROR REPORTS...
C
  800 WRITE(6,801) BEEP
  801 FORMAT(' C3DCON_EDIT> not enough atoms to work with.',A1)
      GOTO 111
  802 WRITE(6,803) BEEP, MAXB
  803 FORMAT(' C3DCON_EDIT> too many bonds/labels (max ',A1,I3,')')
      GOTO 111
  888 CALL IFMISC_OOPS( 5, 0, 0, ' ' )
      GOTO 111
  889 CALL IFMISC_OOPS( 19, 0, 0, ' ' )
      GOTO 111
C
C  END OF EDIT...
C
  999 CALL IFGIN_ABLE( 0 )		!DISABLE GIN
      CALL IFMAC_MACROS(0)		!ERASE GIN MACROS
      CALL IFSEG_OPEN(-4)               !ERASE FKEY DEFINITIONS
      CALL IFINIT_DIF( 1 )              !ENABLE DI FILE OUTPUT
      RETURN
      END

      SUBROUTINE C3DCON_EDIT_HELP
C
C     THIS ROUTINE DISPLAYS ON-LINE HELP FOR C3DCON_EDIT.
C
      CALL IFGIN_ABLE( 0 )		!DISABLE GIN
      IKEY = IFMISC_TYPE( 'GRAFIT$HLP:C3DCON_HELP.HLP', 'EDIT', 21 )
      IF( IKEY.GT.0 ) CALL IFMISC_OOPS( 9, 0, 0, ' ' )
      CALL IFGIN_ABLE( -2 )		!ENABLE GIN
      CALL IFSEG_MOVE( 0, 0.0, 0.0 )	!MOVE CURSOR TO ORIGIN
      CALL IFINIT_LINE(-3)
      RETURN
      END

      SUBROUTINE C3DCON_LABEL
C
C     THIS ROUTINE DRAWS ATOM BALL LABELS.
C
      INCLUDE 'C3DCON.CBS'

      CALL IFSEG_PIVOT( 0.0, 0.0 )
      CALL IFSEG_OPEN( 20 )
      XP = BPOS(1)
      YP = BPOS(2)
      SZ = BPOS(3)
      DO I=1, 9
         K = IABS(BTYP(I))
         IF( K.GT.0 ) THEN
             R1 = A2IN*BSIZ(I)
             CALL IFSPEN( BPEN(I) )
             CALL C3DCON_BALL( TERM, K, XP, YP, R1, BARC )
             IF( BALL(I).NE.' ' ) CALL IFTEXT( XP+R1+SZ,
     +           YP-0.6*SZ, BALL(I), SZ, SZ, 0.0 )
             IF( IABS(LABL).EQ.1 ) THEN  !HORIZONTAL PATH
                 XP = XP + LABL*(6.0*SZ+R1+R1)
             ELSE                        !VERTICAL PATH
                 YP = YP + 0.5*LABL*(R1+R1+SZ)
             ENDIF
         ENDIF
      ENDDO
      CALL IFSEG_OPEN( 0 )
      RETURN
      END

      SUBROUTINE C3DCON_BALL( IT, IK, AX, AY, R1, IC )
C
C     THIS ROUTINE DRAWS A BALL OF TYPE "IK".
C
C     WARNING: IF ADDITIONAL BALL TYPES ARE IMPLEMENTED HERE,
C     MAKE SURE THAT PARAMETER "MAXT" IS PROPERLY SET FIRST.
C
      REAL      RR(10)
      DATA RR/ 0.95, 0.9, 0.8, 0.7, 0.6, 0.5, 0.4, 0.3, 0.2, 0.1 /

      L  = IABS(IK)
      AZ = FLOAT(IC)
      IF( L.EQ.1 ) THEN
          CALL C3DCON_CROSS( R1, AX, AY )  !3D CROSS
      ELSE
C
C  SPEED UP SCREEN DRAWING, SIMPLE SOLID CIRCLES ARE USED...
C
          IF( IT.NE.1 ) THEN
              CALL IFINIT_DIF(0)
              CALL IFFILL(1)
              CALL IFARCS_CIRCLE( AX, AY, R1, 22.5 )
              CALL IFFILL(0)
              CALL IFINIT_DIF(1)
          ENDIF
C
C  FOR HARCOPY, DRAW THE FANCY BALLS...
C
          N1 = IFINIT_ITM(1)        !ASSUME VT100 TERMINAL
          IF( L.EQ.2 ) THEN
              CALL IFFILL( 11 )
          ELSE IF( L.EQ.3 .OR. L.EQ.6 .OR. L.EQ.7 ) THEN
              CALL IFFILL( 9 )
          ELSE IF( L.EQ.4 .OR. L.EQ.8 ) THEN
              CALL IFFILL( 4 )
          ELSE IF( L.EQ.5 .OR. L.EQ.9 ) THEN
               CALL IFSTYL(4,2)
               IF( L.EQ.5 ) CALL IFFILL( 11 )
               IF( L.EQ.9 ) CALL IFFILL( 8 )
          ELSE
              CALL IFFILL( 1 )
          ENDIF
          CALL IFARCS_CIRCLE( AX, AY, R1, AZ )
          CALL IFFILL( 0 )
          IF( L.EQ.5 .OR. L.EQ.9 ) CALL IFSTYL(1,2)
          IF( L.EQ.6 .OR. L.EQ.9 ) THEN
              CALL IFFILL(-11 )
              CALL IFARCS_CIRCLE( AX-0.18*R1, AY, 0.81*R1, AZ )
              CALL IFFILL( 0 )
          ENDIF
          IF( L.EQ.7 .OR. L.EQ.8 ) THEN
              BX = 0.2*R1
              BY = 0.8*R1
              CALL IFFILL(-11 )
              CALL IFARCS_ELLP( AX-BY,AY, BX,2.0*BX, AZ )
              CALL IFFILL( 0 )
          ENDIF
          IF( L.GE.10 .AND. L.LE.14 ) THEN
              DO I=1, 10
                 BX = R1*RR(I)
                 BY = 0.5*(R1-BX)
                 CALL IFFILL( -I-1 )
                 IF( L.EQ.10 ) THEN
                     CALL IFARCS_CIRCLE( AX, AY, BX, AZ )
                 ELSE IF( L.EQ.11 ) THEN
                     CALL IFARCS_CIRCLE( AX-BY, AY, BX, AZ )
                 ELSE IF( L.EQ.12 ) THEN
                     CALL IFARCS_CIRCLE( AX+BY, AY, BX, AZ )
                 ELSE IF( L.EQ.13 ) THEN
                     CALL IFARCS_CIRCLE( AX, AY-BY, BX, AZ )
                 ELSE IF( L.EQ.14 ) THEN
                     CALL IFARCS_CIRCLE( AX, AY+BY, BX, AZ )
                 ENDIF
                 CALL IFFILL( 0 )
              ENDDO
          ENDIF
          IF( L.GE.15 .AND. L.LE.18 ) THEN
              DO I=1, 10
                 BX = R1*RR(I)
                 BY = R1-BX
                 BZ = BX*(1.0-RR(I))
                 CALL IFFILL( -I-1 )
                 IF( L.EQ.15 ) THEN
                     CALL IFARCS_ELLP( AX-BY,AY, BX,BX+BZ, AZ )
                 ELSE IF( L.EQ.16 ) THEN
                     CALL IFARCS_ELLP( AX+BY,AY, BX,BX+BZ, AZ )
                 ELSE IF( L.EQ.17 ) THEN
                     CALL IFARCS_ELLP( AX,AY-BY, BX+BZ,BX, AZ )
                 ELSE IF( L.EQ.18 ) THEN
                     CALL IFARCS_ELLP( AX,AY+BY, BX+BZ,BX, AZ )
                 ENDIF
                 CALL IFFILL( 0 )
              ENDDO
          ENDIF
          N1 = IFINIT_ITM(IT)        !RESET TERMINAL TYPE
      ENDIF
      RETURN
      END

      SUBROUTINE C3DCON_DISTANCE
C
C     THIS ROUTINE COMPUTES INTERATOMIC DISTANCE.
C
C     COMMAND SYNTAX: DISTANCE D1,D2,I1,I2,I3,I4/OUTPUT=filename
C
C     WHERE /OUTPUT=filename IS OUTPUT REDIRECT (DEFAULT TO SCREEN);
C           D1,D2 ARE DISTANCE CUTOFFS;
C           I1,I2 ARE OPTIONAL ORIGIN ATOM TYPE RUN;
C           I3,I4 ARE OPTIONAL TARGET ATOM TYPE RUN.
C
      INCLUDE     'C3DCON.CBS'
      CHARACTER    TEXT*77, FNAME*32
      COMMON/MENU/ IKEY, NCHS, TEXT
      DIMENSION    RP(6), KP(6)
      INTEGER      ZBUF
      COMMON/OVER/ ZBUF(MAXX), AZYX(MAXX), AXYZ(3,MAXX)
C
C  GET COMMAND PARAMETERS...
C
      IF( NCHS.EQ.0 ) THEN
          TEXT='Command syntax: DIST D1,D2,I1,I2,I3,I4/OUTPUT=filename'
          CALL C3DCON_OOPS( TEXT )
          NCHS = IFMISC_PROMPT('_DIST:',TEXT,SLIN+1,9)
          IF( NCHS.EQ.0 ) GOTO 999
      ENDIF
      FNAME = ' '
      I1 = INDEX( TEXT(1:NCHS), '/O' )
      IF( I1.GT.1 ) THEN
          I2 = INDEX( TEXT(I1:NCHS), '=' )
          IF( I2.GT.0 ) FNAME = TEXT(I1+I2:NCHS)
          NCHS = I1-1
      ENDIF
      NCHS = IFMISC_DECODE( TEXT, NCHS, 6, RP, KP )
      IF( NCHS.EQ.0 ) GOTO 888
      D1 = 0
      D2 = 0
      IF( KP(1).GT.0 ) D1 = RP(1)
      IF( KP(2).GT.0 ) D2 = RP(2)
      IF( D1.GE.D2 ) GOTO 888
      I1 = 0
      I2 = 0
      I3 = 0
      I4 = 0
      IF( KP(3).GT.0 ) I1 = RP(3)
      IF( KP(4).GT.0 ) I2 = RP(4)
      IF( KP(5).GT.0 ) I3 = RP(5)
      IF( KP(6).GT.0 ) I4 = RP(6)
      IF( I1.LT.0 .OR. I1.GT.9 ) GOTO 888
      IF( I2.LT.0 .OR. I2.GT.9 ) GOTO 888
      IF( I3.LT.0 .OR. I3.GT.9 ) GOTO 888
      IF( I4.LT.0 .OR. I4.GT.9 ) GOTO 888
C
C  OPEN OUTPUT FILE IF REQUESTED...
C
      LUN = 6
      IF( FNAME.NE.' ' ) THEN
          LUN = 13
          CALL C3DCON_OOPS(' Working (CTRL/C to abort)...')
          OPEN( UNIT=LUN, FILE=FNAME, STATUS='NEW', FORM='FORMATTED' )
      ELSE
          CALL IFANSI_CLEAR(0)
      ENDIF
      CALL IFQAST_CTRLC     !TRAP A CTRL/C INTERRUPT
C
C  ORTHOGONALIZE THE ATOM COORDINATES...
C
      DO J=1, NSYM
         DO I=1, 3
            AXYZ(I,J) = ATOM(I,J)
         ENDDO
         CALL C3DCON_MV( GALL, AXYZ(1,J) )
      ENDDO
C
C  COMPUTE THE DISTANCES...
C
      NCHS = IFMISC_LENG(TEXT)
      WRITE(LUN,333) TEXT(1:NCHS)
 333  FORMAT(' C3DCON_DISTANCE: ',A,/
     +,' FROM        COORDINATE(FRACTIONAL)    SYM_#  '
     +,' TO          COORDINATE(FRACTIONAL)    SYM_#  ')
 444  FORMAT(1X,A8,'(',3F9.4,',',I3,') ...',1X,A8,'(',3F9.4,',',
     +I3,') ... D=',F7.3)
      DO 222 I=1, NSYM
         IT = ATBB(I)
         IF( I1.GT.0 .AND. (IT.LT.I1.OR.IT.GT.I2) ) GOTO 222
         AX = AXYZ(1,I)
         AY = AXYZ(2,I)
         AZ = AXYZ(3,I)
         DO 111 J=I+1, NSYM
            IF( IFCTRL_C() ) GOTO 889
            IT = ATBB(J)
            IF( I3.GT.0 .AND. (IT.LT.I3.OR.IT.GT.I4) ) GOTO 111
            BX = AXYZ(1,J)
            BY = AXYZ(2,J)
            BZ = AXYZ(3,J)
            DD = SQRT( (AX-BX)**2+(AY-BY)**2+(AZ-BZ)**2 )
            IF( DD.LT.D1 .OR. DD.GT.D2 ) GOTO 111
            KP(1) = ATSY(I)
            IF( KP(1).EQ.0 ) KP(1) = 1
            KP(2) = ATSY(J)
            IF( KP(2).EQ.0 ) KP(2) = 1
            WRITE(LUN,444) ATID(I), (ATOM(K,I),K=1,3), KP(1),
     +      ATID(J), (ATOM(K,J),K=1,3), KP(2), DD
  111    CONTINUE
  222 CONTINUE
C
C  IT'S DONE...
C
      CALL IFQAST_CLEAR
      IF( LUN.NE.6 ) THEN
          TEXT = ' Output written to'
          TEXT(23:) = FNAME
          CALL C3DCON_OOPS(TEXT)
          CLOSE(UNIT=LUN)
      ELSE
          CALL IFANSI_VIDEO(30)
          WRITE(6,555)
  555     FORMAT(/' Hit RETURN to continue...',$)
          READ(5,666,ERR=777,END=777) I1
  666     FORMAT(I1)
  777     CALL C3DCON_FORM
      ENDIF
  999 RETURN
  889 IF( LUN.NE.6 ) THEN
          CLOSE(UNIT=LUN)
          CALL C3DCON_CLEAR_OOPS
      ELSE
          CALL C3DCON_FORM
      ENDIF
      RETURN
  888 CALL IFMISC_OOPS( 3, SLIN, SCOL, TEXT )
      RETURN
      END

