SUBROUTINE EDITCH( INTRNL ) C C Notice of Public Domain nature of this Program C C 'This computer program is a work of the United States C Government and as such is not subject to protection by C copyright (17 U.S.C. # 105.) Any person who fraudulently C places a copyright notice or does any other act contrary C to the provisions of 17 U.S. Code 506(c) shall be subject C to the penalties provided therein. This notice shall not C be altered or removed from this software and is to be on C all reproductions.' C INCLUDE 'SIZES' IMPLICIT REAL (A-H,O-Z) REAL CART, DENMAT, BONDS INTEGER*2 ATBOND LOGICAL ERROR,MODATA,INTRNL,LCLDBG, LINALL,AMODE,EDMADE, REDRAW COMMON /ATOMS/ CO(3, NUMATM), IE( NUMATM), NATOMS, ATCHG( NUMATM) COMMON /GEOM/ COOLD(3, NUMATM),NA( NUMATM),NB( NUMATM),NC( NUMATM) COMMON /INTCOR/ XNDOGM(3, NUMATM),INTFRE(3, NUMATM) COMMON /EDIT/ MODATA, REDRAW COMMON / PATH / ICPATH, NPATH, PATH( 30) CHARACTER*6 ATSYMB COMMON /ATSYMB/ ATSYMB( 200) CHARACTER COMAND*80, ICCC*2, DUMMY*80 CHARACTER*2 CTEMP( 3) COMMON /COMM/ COMAND COMMON /VALNCE/ MAXVAL(200) C? COMMON /VANRAD/ VANRAD(200) LOGICAL DEBUG, DEBUGL, DEBUGN, DEBUGO, DEBUGP, DEBUGI COMMON /DEBCOM/ DEBUG, DEBUGL, DEBUGN, DEBUGO, DEBUGP, DEBUGI COMMON /DISPLY/ IREM(200), BSCALE, ATBOND( NUMATM, NUMATM), . ISTYPE, LATYPE, IMASK( NUMATM), ISCOLO COMMON /LINES/ CART(2, NUMATM),LIST( NUMATM), LATOMS, LINALL COMMON /DENSTY/ DENMAT( MPACK ), BONDS( MPACK ) DIMENSION IVAL( NUMATM) DATA BMAX /10.0D0/ C ICCC = 'CC' IF ( INTRNL ) ICCC = 'IC' AMODE = .FALSE. 10 CONTINUE EDMADE=.FALSE. IF ( COMAND( :1) .EQ. 'Q') RETURN IF ( COMAND( :1) .NE. ' ') THEN IA = READA( COMAND, 1, ERROR) IF ( ERROR .OR. IA .LT. 1 ) THEN CALL DEBUGR('BAD ATOM NUMBER...TRY AGAIN.') COMAND = ' ' GOTO 10 ENDIF ELSE IF ( AMODE ) THEN IA=IAOLD+1 AMODE = .FALSE. IF (IA .GT. NATOMS ) RETURN ELSE RETURN ENDIF ENDIF 15 CONTINUE IF (IA .GT. NATOMS ) THEN WRITE (*,*) 'Reference number too big ',NATOMS,' is max.' AMODE=.FALSE. COMAND = ' ' GO TO 10 ELSE IAOLD=IA DO 33 J=1, 3 IF( INTFRE( J, IA) .GT. 9) THEN WRITE( CTEMP( J), '(1X, A1)') INTFRE( J, IA) ELSE WRITE( CTEMP( J), '(I2)') INTFRE( J, IA) ENDIF 33 CONTINUE IF ( INTRNL ) THEN WRITE (*,1050) ICCC, IA, ATSYMB(IE(IA)), . XNDOGM(1,IA), CTEMP(1), XNDOGM(2,IA), CTEMP(2), . XNDOGM(3,IA), CTEMP(3), NA(IA),NB(IA),NC(IA) ELSE WRITE (*,1050) ICCC, IA, ATSYMB(IE(IA)), . CO(1,IA), CTEMP(1), CO(2,IA), CTEMP(2), . CO(3,IA), CTEMP(3), NA(IA),NB(IA),NC(IA) ENDIF * SAVE OLD COORDINATES XOLD = CO( 1, IA) YOLD = CO( 2, IA) ZOLD = CO( 3, IA) IEOLD = IE( IA) NATEMP = NA( IA) NBTEMP = NB( IA) NCTEMP = NC( IA) 1050 FORMAT (1X,A2, I3,':', A6,1X,F12.6,1X,A2,1X,2(F8.3,1X,A2,1X), . 3(1X,I3)) 30 CONTINUE CALL POPARG( COMAND, COMAND) IF (COMAND(:1) .EQ. ' ') THEN CALL UPROMP( 'CHANGE: Which parameter ? ') READ (*, '( A )', END=9000 ) COMAND CALL LCLEAN( COMAND, COMAND, .TRUE.) ENDIF IF (COMAND(:1) .EQ. ' ' ) GOTO 10 IF ( COMAND(1:1) .GE. '0' .AND. COMAND(1:1) .LE. '9') GOTO 10 AMODE=.TRUE. 32 IF (COMAND(:1) .EQ. 'H' .OR. COMAND(:1) .EQ. '?') THEN COMAND = 'DRAW EDIT CHANGE' CALL HELP ( COMAND ) COMAND = ' ' GO TO 30 ELSEIF (COMAND(:1) .EQ. 'Q' ) THEN RETURN ELSEIF (COMAND(:1) .EQ. 'T' . .OR. COMAND(:1) .EQ. 'S') THEN CALL POPARG( COMAND, COMAND) IF (COMAND(:1) .EQ. ' ') THEN CALL UPROMP( 'CHANGE: New atomic symbol ') READ (*, '( A )' ) COMAND CALL LCLEAN(COMAND,COMAND, .TRUE.) ENDIF II = INDEX(COMAND,' ')-1 IF ( II .LT. 1) THEN CALL DEBUGR(' No symbol entered.') GO TO 10 ENDIF IJ = NUMELE( COMAND( 1: II) ) IF ( IJ.LT.1 .OR. IJ.GT.200 ) THEN WRITE (*,*) 'Invalid symbol '//COMAND(:2) COMAND = COMAND( II:) GO TO 10 ENDIF 42 IE(IA) = IJ MODATA=.TRUE. REDRAW = .TRUE. EDMADE = .TRUE. ELSEIF (COMAND(:1) .EQ. 'B' ) THEN IF ( INTRNL ) THEN CALL POPARG( COMAND, COMAND) IF (COMAND(:1) .EQ. ' ') THEN CALL UPROMP ('CHANGE: New bond: ') READ (*, '( A )' ) COMAND ENDIF AAA = READA(COMAND,1,ERROR) IF (AAA .GT. 10.0D0) THEN WRITE (*, . '(1X, F17.5,'' IS RATHER LONG FOR A BOND.'')') AAA CALL UPROMP( 'Is it correct? [Yes/no] ') READ (*,'(A)', END=10) DUMMY CALL LCLEAN( DUMMY, DUMMY, .TRUE.) IF ( DUMMY(1:1) .EQ. 'N' ) THEN COMAND = ' ' GO TO 10 ENDIF ENDIF IF (ERROR) THEN WRITE (*,*) 'CHANGE: READA error:',AAA,' no change.' ELSE MODATA = .TRUE. REDRAW = .TRUE. XNDOGM(1,IA)=AAA EDMADE = .TRUE. ENDIF ELSE CALL DEBUGR('MODE IS CARTESIAN...NO CHANGE MADE.') COMAND = ' ' GOTO 10 ENDIF ELSEIF (COMAND(:1) .EQ. 'A' ) THEN IF ( INTRNL ) THEN CALL POPARG( COMAND, COMAND) IF (COMAND(:1) .EQ. ' ') THEN CALL UPROMP( 'CHANGE: New angle: ') READ (*, '( A )' ) COMAND ENDIF AAA = READA(COMAND,1,ERROR) IF (ERROR) THEN WRITE (*,*) 'CHANGE: READA error:',AAA,' no change.' COMAND = ' ' GOTO 10 ELSE MODATA = .TRUE. REDRAW = .TRUE. XNDOGM(2,IA)=AAA EDMADE = .TRUE. ENDIF ELSE CALL DEBUGR('MODE IS CARTESIAN...NO CHANGE MADE.') COMAND = ' ' GOTO 10 ENDIF ELSEIF (COMAND(:1) .EQ. 'D' ) THEN IF ( INTRNL ) THEN CALL POPARG( COMAND, COMAND) IF (COMAND(:1) .EQ. ' ') THEN CALL UPROMP( 'CHANGE: New dihedral: ') READ (*, '( A )' ) COMAND ENDIF AAA = READA(COMAND,1,ERROR) IF (ERROR) THEN WRITE (*,*) 'CHANGE: READA error:',AAA,' no change.' COMAND = ' ' ELSE MODATA = .TRUE. REDRAW = .TRUE. XNDOGM(3,IA)=AAA EDMADE = .TRUE. ENDIF ELSE CALL DEBUGR('MODE IS CARTESIAN...NO CHANGE MADE.') COMAND = ' ' GOTO 10 ENDIF ELSEIF (COMAND(:1) .EQ. 'X' ) THEN IF ( INTRNL ) THEN CALL DEBUGR('MODE IS INTERNAL...NO CHANGE MADE.') COMAND = ' ' GOTO 10 ELSE CALL POPARG( COMAND, COMAND) IF (COMAND(:1) .EQ. ' ') THEN CALL UPROMP( 'CHANGE: New X coordinate: ') READ (*, '( A )' ) COMAND ENDIF AAA = READA(COMAND,1,ERROR) IF (AAA .GT. BMAX) THEN WRITE (*, . '(1X, F17.5,'' IS RATHER FAR FOR A DISTANCE.'')') AAA CALL UPROMP( 'Is it correct? [Yes/no] ') READ (*,'(A)', END=10) DUMMY CALL LCLEAN( DUMMY, DUMMY, .TRUE.) IF ( DUMMY(1:1) .EQ. 'N' ) THEN COMAND = ' ' GO TO 10 ELSE BMAX = AAA ENDIF ENDIF IF (ERROR) THEN WRITE (*,*) 'CHANGE: READA error:',AAA,' no change.' COMAND = ' ' ELSE MODATA = .TRUE. REDRAW = .TRUE. CO( 1, IA) = AAA EDMADE = .TRUE. ENDIF ENDIF ELSEIF (COMAND(:1) .EQ. 'Y' ) THEN IF ( INTRNL ) THEN CALL DEBUGR('MODE IS INTERNAL...NO CHANGE MADE.') COMAND = ' ' GOTO 10 ELSE CALL POPARG( COMAND, COMAND) IF (COMAND(:1) .EQ. ' ') THEN CALL UPROMP( 'CHANGE: New Y coordinate: ') READ (*, '( A )' ) COMAND ENDIF AAA = READA(COMAND,1,ERROR) IF (ERROR) THEN WRITE (*,*) 'CHANGE: READA error:',AAA,' no change.' COMAND = ' ' ELSE MODATA = .TRUE. REDRAW = .TRUE. CO( 2, IA) = AAA EDMADE = .TRUE. ENDIF ENDIF ELSEIF (COMAND(:1) .EQ. 'Z' ) THEN IF ( INTRNL ) THEN CALL DEBUGR('MODE IS INTERNAL...NO CHANGE MADE.') COMAND = ' ' GOTO 10 ELSE CALL POPARG( COMAND, COMAND) IF (COMAND(:1) .EQ. ' ') THEN CALL UPROMP( 'CHANGE: New Z coordinate: ') READ (*, '( A )' ) COMAND ENDIF AAA = READA(COMAND,1,ERROR) IF (ERROR) THEN WRITE (*,*) 'CHANGE: READA error:',AAA,' no change.' COMAND = ' ' ELSE MODATA = .TRUE. REDRAW = .TRUE. CO( 3, IA) = AAA EDMADE = .TRUE. ENDIF ENDIF ELSEIF (COMAND(:2) .EQ. 'NA' ) THEN CALL POPARG( COMAND, COMAND) IF (COMAND(:1) .EQ. ' ') THEN CALL UPROMP('CHANGE: New NA: ') READ (*, '( A )' ) COMAND ENDIF AAA = READA(COMAND,1,ERROR) IF (ERROR) THEN WRITE (*,*) 'CHANGE: READA error:',AAA,' no change.' COMAND = ' ' ELSEIF( AAA .GE. IA ) THEN WRITE (*,*) 'NA value must be LESS than ',IA COMAND = ' ' ELSEIF( AAA.LT. 1) THEN CALL DEBUGR( 'That NA value is too small.') COMAND = ' ' ELSE MODATA = .TRUE. IF ( INTRNL) REDRAW = .TRUE. NA(IA)=AAA EDMADE = .TRUE. ENDIF ELSEIF (COMAND(:2) .EQ. 'NB' ) THEN CALL POPARG( COMAND, COMAND) IF (COMAND(:1) .EQ. ' ') THEN CALL UPROMP( 'CHANGE: New NB: ') READ (*, '( A )' ) COMAND ENDIF AAA = READA(COMAND,1,ERROR) IF (ERROR) THEN WRITE (*,*) 'CHANGE: READA error:',AAA,' no change.' COMAND = ' ' ELSEIF( AAA .GE. IA) THEN WRITE (*,*) 'NB value must be LESS than ',IA COMAND = ' ' ELSEIF( AAA.LT. 1) THEN CALL DEBUGR( 'That NA value is too small.') COMAND = ' ' ELSE MODATA = .TRUE. IF ( INTRNL) REDRAW = .TRUE. NB(IA)=AAA EDMADE = .TRUE. ENDIF ELSEIF (COMAND(:2) .EQ. 'NC' ) THEN CALL POPARG( COMAND, COMAND) IF (COMAND(:1) .EQ. ' ') THEN CALL UPROMP( 'CHANGE: New NC: ') READ (*, '( A )' ) COMAND ENDIF AAA = READA(COMAND,1,ERROR) IF (ERROR) THEN WRITE (*,*) 'CHANGE: READA error:',AAA,' no change.' COMAND = ' ' ELSEIF( AAA .GE. IA ) THEN WRITE (*,*) 'NC value must be LESS than ',IA COMAND = ' ' ELSEIF( AAA.LT. 1) THEN CALL DEBUGR( 'That NA value is too small.') COMAND = ' ' ELSE MODATA = .TRUE. IF ( INTRNL) REDRAW = .TRUE. NC(IA)=AAA EDMADE = .TRUE. ENDIF ELSEIF (COMAND(:2) .EQ. 'IB' ) THEN CALL POPARG( COMAND, COMAND) IF (COMAND(:1) .EQ. ' ') THEN CALL UPROMP('CHANGE: New IB: ') READ (*, '( A )' ) COMAND ENDIF IF ( COMAND(1:1).GE.'A' .AND. COMAND(1:1).LE.'Z') THEN AAA = ICHAR( COMAND(1:1) ) ELSEIF ( COMAND(1:1).GE.'a' .AND. COMAND(1:1).LE.'z') THEN AAA = ICHAR( COMAND(1:1) ) - 32 ELSE AAA = READA(COMAND,1,ERROR) ENDIF IF (ERROR) THEN WRITE (*,*) 'CHANGE: READA error:',AAA,' no change.' COMAND = ' ' ELSEIF( (AAA.GT.1.OR.AAA.LT.-1) .AND.(IA.NE.1) ) THEN CALL DEBUGR('Bad value.') COMAND = ' ' ELSE MODATA = .TRUE. INTFRE(1,IA)=AAA EDMADE = .TRUE. IF ( AAA.EQ.-1 ) THEN IF( ICPATH.GT.0 .AND. ICPATH.NE.IA) THEN WRITE( DUMMY, '('' You already have an atom with'', . '' a path flag. It is '',I4)') ICPATH CALL DEBUGR( DUMMY(1: 56) ) ELSE ICPATH = IA ENDIF ENDIF ENDIF ELSEIF (COMAND(:2) .EQ. 'IA' ) THEN CALL POPARG( COMAND, COMAND) IF (COMAND(:1) .EQ. ' ') THEN CALL UPROMP('CHANGE: New IA: ') READ (*, '( A )' ) COMAND ENDIF IF ( COMAND(1:1).GE.'A' .AND. COMAND(1:1).LE.'Z') THEN AAA = ICHAR( COMAND(1:1) ) ELSEIF ( COMAND(1:1).GE.'a' .AND. COMAND(1:1).LE.'z') THEN AAA = ICHAR( COMAND(1:1) ) - 32 ELSE AAA = READA(COMAND,1,ERROR) ENDIF IF (ERROR) THEN WRITE (*,*) 'CHANGE: READA error:',AAA,' no change.' COMAND = ' ' ELSEIF( AAA .GT. 1 .OR. AAA .LT. -1 ) THEN CALL DEBUGR('Bad value.') COMAND = ' ' ELSE MODATA = .TRUE. INTFRE( 2, IA)=AAA EDMADE = .TRUE. IF ( AAA.EQ.-1 ) THEN IF( ICPATH.GT.0 .AND. ICPATH.NE.IA) THEN WRITE( DUMMY, '('' You already have an atom with'', . '' a path flag. It is '',I4)') ICPATH CALL DEBUGR( DUMMY(1: 56) ) ELSE ICPATH = IA ENDIF ENDIF ENDIF ELSEIF (COMAND(:2) .EQ. 'ID' ) THEN CALL POPARG( COMAND, COMAND) IF (COMAND(:1) .EQ. ' ') THEN CALL UPROMP('CHANGE: New ID: ') READ (*, '( A )' ) COMAND ENDIF IF ( COMAND(1:1).GE.'A' .AND. COMAND(1:1).LE.'Z') THEN AAA = ICHAR( COMAND(1:1) ) ELSEIF ( COMAND(1:1).GE.'a' .AND. COMAND(1:1).LE.'z') THEN AAA = ICHAR( COMAND(1:1) ) - 32 ELSE AAA = READA(COMAND,1,ERROR) ENDIF IF (ERROR) THEN WRITE (*,*) 'CHANGE: READA error:',AAA,' no change.' COMAND = ' ' ELSEIF( AAA .GT. 1 .OR. AAA .LT. -1 ) THEN CALL DEBUGR('Bad value.') COMAND = ' ' ELSE MODATA = .TRUE. INTFRE( 3, IA)=AAA EDMADE = .TRUE. IF ( AAA.EQ.-1 ) THEN IF( ICPATH.GT.0 .AND. ICPATH.NE.IA) THEN WRITE( DUMMY, '('' You already have an atom with'', . '' a path flag. It is '',I4)') ICPATH CALL DEBUGR( DUMMY(1: 56) ) ELSE ICPATH = IA ENDIF ENDIF ENDIF ENDIF CALL POPARG( COMAND, COMAND) IF (COMAND(:1) .NE. ' ') GO TO 32 IF (EDMADE) THEN IF ( IA.LE.NA(IA) .OR. IA.LE.NB(IA) .OR. IA.LE.NC(IA) ) THEN CALL DEBUGR('ERROR IN CONNECTIVITY') NA( IA) = NATEMP NB( IA) = NBTEMP NC( IA) = NCTEMP COMAND = ' ' GOTO 15 ENDIF IF ( NA(IA).EQ. NB(IA) .AND. IA.GT.1 ) THEN CALL DEBUGR('ERROR IN CONNECTIVITY') NA( IA) = NATEMP NB( IA) = NBTEMP NC( IA) = NCTEMP COMAND = ' ' GOTO 15 ENDIF IF ( NA(IA).EQ.NC(IA) .AND. IA.GT.2 ) THEN CALL DEBUGR('ERROR IN CONNECTIVITY') NA( IA) = NATEMP NB( IA) = NBTEMP NC( IA) = NCTEMP COMAND = ' ' GOTO 15 ENDIF IF ( NB(IA).EQ.NC(IA) .AND. IA.GT.3 ) THEN CALL DEBUGR('ERROR IN CONNECTIVITY') NA( IA) = NATEMP NB( IA) = NBTEMP NC( IA) = NCTEMP COMAND = ' ' GOTO 15 ENDIF DO 533 J=1, 3 IF( INTFRE( J, IA) .GT. 9) THEN WRITE( CTEMP( J), '(1X, A1)') INTFRE( J, IA) ELSE WRITE( CTEMP( J), '(I2)') INTFRE( J, IA) ENDIF 533 CONTINUE IF ( INTRNL ) THEN WRITE (*,1050) ICCC, IA, ATSYMB(IE(IA)), . XNDOGM(1,IA), CTEMP(1), XNDOGM(2,IA), CTEMP(2), . XNDOGM(3,IA), CTEMP(3), NA(IA),NB(IA),NC(IA) ELSE WRITE (*,1050) ICCC, IA, ATSYMB(IE(IA)), . CO(1,IA), CTEMP(1), CO(2,IA), CTEMP(2), . CO(3,IA), CTEMP(3), NA(IA),NB(IA),NC(IA) ENDIF IF ( INTRNL ) THEN TEMPXX=CO(1,1) TEMPYY=CO(2,1) TEMPZZ=CO(3,1) CALL GMETRY(NUATOM,NATOMS,IE,XNDOGM,NA,NB,NC,CO,ERROR) CALL TOTROT(TEMPXX,TEMPYY,TEMPZZ) ELSE CALL XYZMND( NATOMS, CO, NA, NB, NC, XNDOGM) ENDIF IF ( ABS( XOLD-CO(1,IA)).GT.1.0D-3 .OR. . ABS( YOLD-CO(2,IA)).GT.1.0D-3 .OR. . ABS( ZOLD-CO(3,IA)).GT.1.0D-3 .OR. . IEOLD.NE.IE(IA) ) THEN BONDS( 1 ) = 0 CALL SETBON( .FALSE. ) CALL PLOT( 0, 0, 9 ) CALL LDRAW(-IA) CALL SETLAB CALL LDRAW(IA) ENDIF XOLD = CO( 1, IA) YOLD = CO( 2, IA) ZOLD = CO( 3, IA) IEOLD = IE( IA) NATEMP = NA( IA) NBTEMP = NB( IA) NCTEMP = NC( IA) GOTO 30 ENDIF ENDIF GOTO 10 9000 CONTINUE RETURN END