SUBROUTINE EDITAD( 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, VANRAD INTEGER*2 ATBOND LOGICAL DEBUG, DEBUGL, DEBUGN, DEBUGO, DEBUGP, DEBUGI 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 CHARACTER*6 ATSYMB, CHAR7*1 COMMON /ATSYMB/ ATSYMB( 200) CHARACTER COMAND*80, ICCC*2 COMMON /VALNCE/ MAXVAL(200) COMMON /VANRAD/ VANRAD(200) 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) * * LOGICAL INTRNL INDICATES MODE OF ADDING NEW ATOMS * .TRUE. ==> INTERNAL COORDINATES * .FALSE. ==> CARTESIAN COORDINATES * * HERE IS AFUNCTION USED INTERNAL TO THIS ROUTINE * 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 ) ** ** CHAR7 = CHAR(7) ICCC = 'CC' IF ( INTRNL ) ICCC = 'IC' 50 IIATOM=NATOMS+1 51 CONTINUE CALL PLOT (0,0,8) WRITE( COMAND,'(A2,'' of atom '', I4,'':'')') ICCC, IIATOM CALL UPROMP( COMAND( 1: INDEX( COMAND, ':')) ) READ ( *, '( A )', END=9000 ) COMAND CALL LCLEAN(COMAND, COMAND, .TRUE.) IF ( COMAND(:1) .EQ. 'Q') RETURN IF ( COMAND(:1) .EQ. ' ') RETURN CALL GETIC(COMAND,IT,B,IB,A,IA,D,ID,MA,MB,MC,ERROR) IF ( MA.GE.IIATOM .OR. (MA.LT.1 .AND. IIATOM.GT.1)) THEN ERROR=.TRUE. WRITE (*,*) CHAR7//'ERROR IN NA.' ENDIF IF ( MB.GE.IIATOM .OR. (MB.LT.1 .AND. IIATOM.GT.2)) THEN ERROR=.TRUE. WRITE (*,*) CHAR7//'ERROR IN NB.' ENDIF IF ( MC.GE.IIATOM .OR. (MC.LT.1 .AND. IIATOM.GT.3)) THEN ERROR=.TRUE. WRITE (*,*) CHAR7//'ERROR IN NC.' ENDIF IF ( MA.EQ.MB .AND. IIATOM.GT.1) THEN ERROR = .TRUE. WRITE (*,*) CHAR7//'ERROR - NA AND NB ARE EQUAL.' ENDIF IF ( MA.EQ.MC .AND. IIATOM.GT.1) THEN ERROR=.TRUE. WRITE (*,*) CHAR7//'ERROR - NA AND NC ARE EQUAL.' ENDIF IF ( MB.EQ.MC .AND. IIATOM.GT.2) THEN ERROR=.TRUE. WRITE (*,*) CHAR7//'ERROR - NB AND NC ARE EQUAL.' ENDIF IF (ERROR) THEN WRITE (*,*) CHAR7//'DATA ERROR.' IF ( IT .LT. 1 .OR. IT .GT. 200 ) THEN WRITE (*,1050) IIATOM, '??????',B,IB,A,IA,D,ID,MA,MB,MC ELSE WRITE (*,1050) IIATOM, ATSYMB(IT),B,IB,A,IA,D,ID,MA,MB,MC ENDIF 1050 FORMAT ( 1X, I4, ':', A6, 1X, F12.4, 1X, I2, 1X, . 2( F8.3, 1X, I2, 1X), 3(1X,I4)) CALL DEBUGR('Please try again from the start', . ' of that last line.') ERROR=.FALSE. GO TO 51 ENDIF NATOMS=NATOMS+1 IE(NATOMS)=IT IF (NATOMS .EQ. 1) THEN INTFRE(1,NATOMS)=0 ELSE INTFRE(1,NATOMS)=IB ENDIF IF (NATOMS .LE. 2) THEN INTFRE(2,NATOMS)=0 ELSE INTFRE(2,NATOMS)=IA ENDIF IF (NATOMS .LE. 3) THEN INTFRE(3,NATOMS)=0 ELSE INTFRE(3,NATOMS)=ID ENDIF NA(NATOMS)=MA NB(NATOMS)=MB NC(NATOMS)=MC IF ( INTRNL ) THEN XNDOGM(1,NATOMS)=B XNDOGM(2,NATOMS)=A XNDOGM(3,NATOMS)=D 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 CO(1,NATOMS)=B CO(2,NATOMS)=A CO(3,NATOMS)=D CALL XYZMND( NATOMS, CO, NA, NB, NC, XNDOGM) ENDIF BONDS( 1 ) = 0 CALL SETBON( .FALSE. ) DO 54 J=1,NATOMS IF ( IE( J) .GE. 99 ) GOTO 54 NBOND=0 SSEP1=VANRAD(IE(J)) DO 52 I=1,NATOMS IF ( IE( I) .GE. 99 ) GOTO 52 IF ( I .EQ. J) GO TO 52 C? DIST=ATDIST(J,I) C? SSEP=(SSEP1+VANRAD(IE(I)))*BSCALE C? IF ( DIST .LE. SSEP) NBOND=NBOND+1 IF ( ATBOND( J, I) .GT. 0 ) NBOND = NBOND+1 52 CONTINUE IF ( NBOND .GT. MAXVAL(IE(J)) .AND. NBOND .GT. IVAL(J) ) THEN IVAL(J)=NBOND WRITE (*,1007) CHAR7,J,NBOND 1007 FORMAT ( 1X,A,'ATOM ',I4,' has ',I2,' BONDS:' ) COMAND = ' ' IIT = 1 DO 53 I=1,NATOMS IF ( IE( I) .GE. 99) GOTO 53 IF ( I .EQ. J) GOTO 53 DIST=ATDIST(J,I) C? SSEP=(SSEP1+VANRAD(IE(I)))*BSCALE C? IF (DIST .LE. SSEP) THEN IF ( ATBOND( J, I) .GT. 0 ) THEN WRITE (COMAND(IIT:),1006) I,DIST 1006 FORMAT ( ' To: ',I3,' by ',F6.4,'; ' ) IIT = INDEX( COMAND(IIT:), ';') + IIT IF ( IIT .GE. 60) THEN WRITE (*,*) COMAND(:IIT) IIT = 1 ENDIF ENDIF 53 CONTINUE IF ( IIT .GT. 1) WRITE (*,*) COMAND(:IIT) ENDIF 54 CONTINUE IF ( NATOMS .GT. 3) THEN CALL SETLAB CALL LDRAW(NATOMS) ELSE CALL SETLAB CALL PICTUR ENDIF REDRAW = .TRUE. MODATA=.TRUE. GO TO 50 9000 CONTINUE CONTINUE END