SUBROUTINE SETBON( USER ) INCLUDE 'SIZES' IMPLICIT REAL (A-H,O-Z) INTEGER*2 ATBOND CHARACTER*80 TITLE,COMAND CHARACTER*6 ATSYMB INTEGER TBONDS REAL DENMAT, BONDS, VANRAD DIMENSION EVEC( 3, 3) LOGICAL ERROR, MODATA, REDRAW, USER LOGICAL DEBUG, DEBUGL, DEBUGN, DEBUGO, DEBUGP, DEBUGI COMMON /DEBCOM/ DEBUG, DEBUGL, DEBUGN, DEBUGO, DEBUGP, DEBUGI COMMON /ATOMS/ CO( 3, NUMATM), IE( NUMATM), NATOMS, ATCHG( NUMATM) COMMON /INTCOR/ XNDOGM(3, NUMATM),INTFRE(3, NUMATM) COMMON /GEOM/ COOLD(3, NUMATM),NA( NUMATM),NB( NUMATM),NC( NUMATM) COMMON /ATSYMB/ ATSYMB( 200) COMMON /DISPLY/ IREM(200), BSCALE, ATBOND( NUMATM, NUMATM), . ISTYPE, LATYPE, IMASK( NUMATM), ISCOLO COMMON /ORBITS/ EVAL(100),ORBS(100,100) COMMON /DENSTY/ DENMAT( MPACK ), BONDS( MPACK ) COMMON /COMM/ COMAND COMMON /EDIT/ MODATA, REDRAW COMMON /VANRAD/ VANRAD(200) DATA TBONDS /-99/ ************ * LOCAL FUNCTION DEFINITION ATDIST(I,J) = SQRT((CO(1,I)-CO(1,J))**2+ . (CO(2,I)-CO(2,J))**2+ . (CO(3,I)-CO(3,J))**2) ************ * * IF THE LOGICAL 'USER' IS TRUE, WE WILL ASK THE USER FOR HIS OPINION * IF ( USER ) THEN CALL UPROMP('Do you want to alter BOND SELECTION or '// . 'COVALENT RADII (B or C) [B] ? ') READ ( *, '(A)', END=399 ) COMAND CALL LCLEAN( COMAND, COMAND, .TRUE.) IF ( COMAND( 1: 1) .EQ. 'C') THEN CALL UPROMP( 'COVALENT RADIUS of which atom type? ') READ ( *, '(A)', END=399 ) COMAND CALL LCLEAN( COMAND, COMAND, .TRUE.) IRAD = NUMELE( COMAND(1: INDEX( COMAND,' ')-1) ) IF ( IRAD .LE. 0 ) THEN WRITE (*, *) 'I do not recognize that atomic symbol.' ELSE WRITE ( *, '( '' What new radius do you want, '', . ''the default is '',F4.2,'' Angstroms ?'')') VANRAD( IRAD) READ (*, '(A)') COMAND CALL LCLEAN( COMAND, COMAND, .TRUE.) RADIUS = READA( COMAND, 1, ERROR) IF ( .NOT. ERROR .AND. COMAND(1:1).NE.' ') THEN IF ( RADIUS .LT. 0.0D0 ) THEN CALL DEBUGR( 'This will draw NO BONDS.') RADIUS = 0.0D0 ELSEIF ( RADIUS .GT. 4.0 ) THEN CALL DEBUGR( . 'That choice will draw excessive bonds.') ENDIF VANRAD( IRAD) = RADIUS WRITE ( *, '('' OK, all '',A,'' now have radius '', . F4.2,'' Angstroms.'')') ATSYMB( IRAD), VANRAD( IRAD) COMAND = ' ' ENDIF ENDIF ELSE IF ( TBONDS .EQ. 0 ) THEN CALL DEBUGR('I am using your manual selection of bonds.') ELSEIF ( TBONDS .GT. 0 ) THEN WRITE (*,*) 'I am using the bond order data from the '// . 'input file.' ELSE CALL DEBUGR('I am using covalent radii to select bonds.') WRITE (*,'('' The SCALE FACTOR is '',F5.3 )') BSCALE ENDIF 1 CALL UPROMP('What bond selection method do you want '// . '(BONDORDER, RADII, or MANUAL)? ') READ ( *, '(A)', END=9000 ) COMAND CALL LCLEAN( COMAND, COMAND, .TRUE.) IF ( COMAND( 1: 1) .EQ. ' ') THEN CALL DEBUGR( 'No change in bonding.') REDRAW = .FALSE. RETURN ELSEIF( COMAND( 1: 1) .EQ. 'B' ) THEN IF ( BONDS ( 1 ) .GT. 1.0D-3 ) THEN IF ( TBONDS .NE. 1 ) REDRAW = .TRUE. TBONDS = 1 ELSE WRITE (*,*) 'Your input file did not contain ', . 'bond selection information.' ENDIF CALL POPARG( COMAND, COMAND) ELSEIF( COMAND( 1: 1) .EQ. 'R' ) THEN * USE COVALENT RADII TO SELECT BONDS IF ( TBONDS .NE. -1 ) REDRAW = .TRUE. TBONDS = -1 WRITE ( *,'('' The current SCALE FACTOR is '', . F5.3)') BSCALE CALL UPROMP('I normally use a value of 1.400'// . ' What value do you want? ') READ (*, '(A)', END=9000 ) COMAND CALL LCLEAN( COMAND, COMAND, .TRUE.) ZSCALE = READA( COMAND, 1, ERROR) IF ( ERROR .OR. (ZSCALE .LT. 0.0D0) ) THEN CALL DEBUGR( 'No change to SCALE FACTOR.') ELSE BSCALE = ZSCALE ENDIF CALL POPARG( COMAND, COMAND) ELSEIF( COMAND( 1: 1) .EQ. 'M' ) THEN IF ( TBONDS .NE. 0 ) REDRAW = .TRUE. TBONDS = 0 CALL POPARG( COMAND, COMAND) ELSE CALL DEBUGR( 'I didn''t recognize that.') GOTO 1 ENDIF ENDIF ELSE REDRAW = .TRUE. IF ( TBONDS .EQ. -99 ) THEN IF ( BONDS ( 1 ) .GT. 1.0D-3 ) THEN TBONDS = 1 CALL DEBUGR('Now using Bondorder information.') ELSE TBONDS = -1 CALL DEBUGR('Now using covalent radii for bonding.') ENDIF ENDIF ENDIF * * NOW TO ACTUALLY PROCESS THE BONDING STYLE * IF ( TBONDS .GT. 0 ) THEN * USING BOND ORDER MATRIX NBDS = 0 K = 0 DO 110 I = 1, NATOMS IF ( IE( I ) .EQ. 99 ) GOTO 110 DO 100 J = 1, I IF ( IE( J ) .EQ. 99 ) GOTO 100 K = K + 1 IF ( I .EQ. J) GOTO 100 IF ( BONDS( K ) .LT. 5.0D-1 ) THEN ATBOND( I, J ) = 0 ATBOND( J, I ) = 0 ELSE ATBOND( I, J ) = 1 ATBOND( J, I ) = 1 NBDS = NBDS + 1 ENDIF 100 CONTINUE 110 CONTINUE WRITE (*,*) 'NR BONDS VIA BONDORDER: NBDS =', NBDS ELSEIF( TBONDS .LT. 0 ) THEN * USING COVALENT RADII DO 200 I= 1, NATOMS DO 202 J= 1, NATOMS IF(I.EQ.J) GOTO 202 DIST = ATDIST( I, J ) RADII = VANRAD( IE ( I)) + VANRAD( IE ( J)) IF ( DIST .LE. RADII*BSCALE ) THEN ATBOND( I, J) = 1 ELSE ATBOND( I, J) = 0 ENDIF 202 CONTINUE 200 CONTINUE ELSEIF ( USER ) THEN CALL DEBUGR('You want MANUAL selection of bonds.') 300 CALL UPROMP('Enter a pair of atoms (negative unbonds): ') READ ( *, '(A)', END=399 ) COMAND CALL LCLEAN( COMAND, COMAND, .TRUE.) IF ( COMAND( 1: 1) .EQ. ' ') GOTO 399 I = READA( COMAND, 1, ERROR ) IF ( ERROR .OR. I.EQ.0 ) THEN CALL DEBUGR('I couldn''t understand the first part.') GOTO 300 ENDIF CALL POPARG( COMAND, COMAND) IF ( COMAND(1:1) .NE.'*') THEN J = READA( COMAND, 1, ERROR ) IF ( ERROR .OR. J.EQ.0 ) THEN CALL DEBUGR('I couldn''t understand the second part.') GOTO 300 ENDIF IF ( I .LT. 0 .OR. J .LT. 0 ) THEN ATBOND( ABS( I), ABS( J)) = 0 ATBOND( ABS( J), ABS( I)) = 0 ELSEIF( I.GT.0 .AND. J.GT.0 ) THEN ATBOND( I, J) = 1 ATBOND( J, I) = 1 ELSE CALL DEBUGR('ERROR ON ONE OF THE NUMBERS.') ENDIF ELSE IF(I.GT.0) THEN CALL DEBUGR('WILDCARD (*) ONLY ALLOWED FOR REMOVAL.') GOTO 300 ENDIF DO 350 J=1, NATOMS ATBOND( ABS( I), J) = 0 ATBOND( J, ABS( I)) = 0 350 CONTINUE ENDIF REDRAW = .TRUE. GOTO 300 ENDIF 399 CONTINUE 9000 RETURN END