SUBROUTINE EDITOR 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, 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 COMMON /SYMTRY/ ISYM(10,NUMATM) COMMON / PATH / ICPATH, NPATH, PATH( 30) CHARACTER*1 NULL, SEPRAT CHARACTER*6 ATSYMB COMMON /ATSYMB/ ATSYMB( 200) CHARACTER*80 STRREP, STRNEW, STRWRK, COMAND, DUMMY, UPCASE CHARACTER*80 KEYWRD,KOMENT,TITLE COMMON /KEYS/ KEYWRD,KOMENT,TITLE COMMON /COMM/ COMAND 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 DIMENSION IVAL( NUMATM) * * THIS FUNCTIONS IS USED INTERNALLY 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 ) ** ** C * WE NEED TO FINE THE VALUE OF THE SYMBOL 'DD' * INTDD = 0 DO 1 I = 1, 200 IF ( ATSYMB( I) .EQ. 'DD' ) THEN INTDD = I ENDIF 1 CONTINUE IF ( INTDD .EQ. 0 ) . CALL DEBUGR( 'In EDIT, error finding symbol DD.') IF ( NATOMS .LT. 0 ) NATOMS = 0 LINALL=.TRUE. AMODE=.FALSE. INTRNL = .TRUE. NULL=CHAR(0) LCLDBG=DEBUG * FIRST, IF THERE ARE ANY ATOMS, WE FIGURE OUT IF ANY ALREADY EXCEED * THE RECCOMMENDED VALENCY. WE DO THIS SO AS NOT TO AGGRAVATE * THE HAPLESS USER LATER IF S/HE DOES ANY REAL EDITING. IF ( NATOMS .GT. 0) THEN CALL XYZMND( NATOMS, CO, NA, NB, NC, XNDOGM) DO 3 J=1,NATOMS IF ( IE( J) .GE. 99 ) GOTO 3 IVAL(J)=0 NBOND=0 SSEP1=VANRAD(IE(J)) DO 2 I=1,NATOMS IF ( IE( I) .GE. 99 ) GOTO 2 IF ( I .EQ. J) GO TO 2 DIST=ATDIST(J,I) SSEP=(SSEP1+VANRAD(IE(I)))*BSCALE IF ( DIST .LE. SSEP) NBOND=NBOND+1 IF ( NBOND .GT. MAXVAL(IE(J))) IVAL(J)=NBOND 2 CONTINUE 3 CONTINUE ENDIF OLTYPE = ISTYPE ISTYPE = 1 IF ( OLTYPE .NE. ISTYPE ) THEN CALL PLOT(0,0,8) CALL UPROMP . ('Draw:EDIT: I must re-draw the display before editing.') CALL UPROMP . (' Shall I continue? (Yes/no) ') READ (5, '(A)', END=10) COMAND CALL LCLEAN( COMAND, COMAND, .TRUE.) IF ( COMAND(1:1) .NE. ' ' .AND. COMAND(1:1) .NE. 'Y') RETURN CALL SETLAB CALL PICTUR REDRAW = .FALSE. ENDIF 10 CONTINUE C? CALL PLOT(0,0,8) CALL UPROMP( ' Draw:EDIT> ') READ ( *, '( A )', END=10 ) COMAND CALL LCLEAN(COMAND,COMAND, .TRUE.) IF (COMAND(:1) .EQ. 'H' .OR. COMAND(:1) .EQ. '?') THEN AMODE=.FALSE. COMAND = 'DRAW EDIT' CALL HELP ( COMAND ) ELSEIF (COMAND(:2) .EQ. 'PI' .OR. COMAND(1:2) .EQ. 'RE') THEN CALL SETLAB CALL PICTUR REDRAW = .FALSE. ELSEIF (COMAND(:1) .EQ. 'U' ) THEN * UPDATE PICTURE CALL SETLAB CALL PICTUR REDRAW = .FALSE. ELSEIF( COMAND(1:1) .EQ. 'S' ) THEN * EDITING SYMMETRY IF ( ISYM(1,1) .GT. 0 ) THEN DO 45 J= 1, NUMATM IF ( ISYM( 1,J) .LE. 0 ) GOTO 46 DO 40 I= 10, 1, -1 IF ( ISYM(I, J) .NE. 0 ) GOTO 42 40 CONTINUE I = 1 42 WRITE ( DUMMY, '(20(I4,'','') )') (ISYM(K,J),K=1,I) 45 CONTINUE 46 WRITE ( *, '(A)') DUMMY ENDIF CALL DEBUGR( 'SORRY, I can''t handle symmetry editing yet.') ELSEIF ( COMAND(1:2) .EQ. 'PA' ) THEN * EDITING REACTION PATH VALUES IF ( NPATH .GT. 0) THEN II = 1 DO 80 I= 1, NPATH WRITE ( DUMMY( II: ), '( F7.2, '','')') PATH( I) CALL LCLEAN( DUMMY, DUMMY, .FALSE.) II = LLENG( DUMMY ) 80 CONTINUE WRITE (*, '(A)') DUMMY( 1: II) CALL DEBUGR( 'SORRY, I can''t handle path editing yet.') ELSE CALL DEBUGR( 'This file does NOT have PATH information.') ENDIF ELSEIF ( COMAND(1:1) .EQ. 'E' ) THEN COMAND = COMAND( 2: ) CALL LCLEAN( COMAND, COMAND, .TRUE.) IF (COMAND(1:1) .EQ. ' ') THEN CALL UPROMP(' Which line of text (1,2,3) [1] ? ') READ (*, '(A)', END=10) COMAND CALL LCLEAN( COMAND, COMAND, .TRUE.) IF ( COMAND(1:1) .EQ. ' ') COMAND = '1' ENDIF IF ( COMAND(1:1) .EQ. '1' .OR. COMAND(1:1) .EQ. 'K') THEN ITEMP = 1 STRWRK = KEYWRD ELSEIF ( COMAND(1:1) .EQ. '2' .OR. COMAND(1:1) .EQ. 'C') THEN ITEMP = 2 STRWRK = KOMENT ELSEIF ( COMAND(1:1) .EQ. '3' .OR. COMAND(1:1) .EQ. 'T') THEN ITEMP = 3 STRWRK = TITLE ELSE CALL DEBUGR( 'I can only handle the three TEXT lines') COMAND = ' ' GOTO 10 ENDIF WRITE (*, *) STRWRK(1:79) CALL UPROMP( 'Your request (Sub, Replace) ? ') READ (*, '(A)', END=10) COMAND IF ( COMAND(1:1) .EQ. '?' ) THEN COMAND = 'DRAW EDIT EDIT' CALL HELP( COMAND ) COMAND = ' ' GOTO 10 ELSEIF ( COMAND(1:1).EQ.'S' .OR. COMAND(1:1).EQ.'s') THEN IS1 = 2 30 CONTINUE SEPRAT = COMAND(IS1:IS1) IF ( SEPRAT .EQ. ' ' ) THEN IS1 = IS1 + 1 IF(IS1.LT.5) GOTO 30 CALL DEBUGR('Improper format, no space after S.') GOTO 10 ENDIF STRREP = COMAND( IS1+1: ) IS1 = INDEX( STRREP, SEPRAT) IF ( IS1 .EQ. 0 ) THEN WRITE (*,*) 'Improper format, I could not find', . ' the second delimiter '//SEPRAT GOTO 10 ENDIF STRNEW = STRREP( IS1+1: ) IS1 = IS1 - 1 STRREP = STRREP( 1: IS1 ) IS2 = INDEX( STRWRK, STRREP(1:IS1) ) IF ( IS2 .EQ. 0 ) THEN DUMMY = UPCASE( STRREP) STRREP = DUMMY IS2 = INDEX( STRWRK, STRREP(1:IS1) ) IF ( IS2 .EQ. 0 ) THEN WRITE (*,*) 'Sorry, i can''t find the string to '// . 'change:'//STRREP(1:IS1) GOTO 10 ENDIF ENDIF IS3 = INDEX( STRNEW, SEPRAT) IF ( IS3 .EQ. 0 ) THEN IS3 = LLENG( STRNEW)+1 ENDIF IS3 = IS3 - 1 IF ( IS3 .GT. 0 ) THEN STRNEW = STRNEW( 1: IS3) WRITE (*,*) 'READY TO REPLACE '//STRREP(1:IS1)// . ' WITH '//STRNEW(1:IS3) IF ( IS2 .GT. 1 ) THEN STRWRK = STRWRK( 1: IS2-1)// . STRNEW(1:IS3)//STRWRK( IS2+IS1: ) ELSE STRWRK = STRNEW(1:IS3)//STRWRK( IS2+IS1: ) ENDIF ELSE WRITE (*,*) 'REMOVING '//STRREP(1:IS1) STRWRK = STRWRK( 1: IS2-1)//STRWRK( IS2+IS1: ) ENDIF ELSEIF ( COMAND(1:1).EQ.'R' .OR. COMAND(1:1).EQ.'r') THEN CALL DEBUGR('Ok, enter REPLACEMENT line below this one.') READ (*, '(A)', END=10 ) COMAND STRWRK = COMAND COMAND = ' ' ELSEIF ( COMAND(1:1) .NE. ' ') THEN COMAND = ' ' CALL DEBUGR('I only understand two actions: R and S') GOTO 10 ENDIF CALL DEBUGR( STRWRK(1:79) ) IF ( ITEMP .EQ. 1) KEYWRD = STRWRK IF ( ITEMP .EQ. 2) KOMENT = STRWRK IF ( ITEMP .EQ. 3) TITLE = STRWRK MODATA = .TRUE. ELSEIF ( COMAND(1:2) .EQ. 'PL' ) THEN * TO PLACE AN ATOM (COORDINATES WILL BE COMPUTED) CALL UPROMP ('What atom type ?') READ (*,'(A)') COMAND CALL LCLEAN( COMAND, COMAND, .TRUE. ) ITEMP = NUMELE( COMAND(1: LLENG( COMAND) ) ) CALL UPROMP( 'Is the new atom BETWEEN or PERPENDICULAR? ') READ (*,'(A)') COMAND CALL LCLEAN( COMAND, COMAND, .TRUE. ) IF ( COMAND(1:1) .EQ. 'B' ) THEN CALL UPROMP( 'What atom(s) bracket this new one ? ') READ (*,'(A)') COMAND CALL LCLEAN( COMAND, COMAND, .TRUE. ) IAVG = 0 XNEW = 0.0D0 YNEW = 0.0D0 ZNEW = 0.0D0 5000 ITEMP1 = READA( COMAND, 1, ERROR ) IF ( .NOT.ERROR .AND. ITEMP1.GT.1 .AND. . ITEMP1.LT.NATOMS ) THEN XNEW = XNEW + CO( 1, ITEMP1) YNEW = YNEW + CO( 2, ITEMP1) ZNEW = ZNEW + CO( 3, ITEMP1) IAVG = IAVG + 1 COMAND = COMAND( INDEX( COMAND, ' '): ) CALL LCLEAN( COMAND, COMAND, .TRUE.) GOTO 5000 ENDIF WRITE (*,*) 'IAVG=',IAVG ELSEIF( COMAND(1:1) .EQ. 'P') THEN * PERPENDICULAR TO THE PLANE * FIRST THE EQUATION OF THE PLANE: A X + B Y + C Z + D = 0 CALL UPROMP( 'Enter three atoms to define it: ') READ (*,'(A)') COMAND CALL LCLEAN( COMAND, COMAND, .TRUE. ) I1 = READA( COMAND, 1, ERROR) COMAND = COMAND( INDEX( COMAND, ' '): ) CALL LCLEAN( COMAND, COMAND, .TRUE.) I2 = READA( COMAND, 1, ERROR) COMAND = COMAND( INDEX( COMAND, ' '): ) CALL LCLEAN( COMAND, COMAND, .TRUE.) I3 = READA( COMAND, 1, ERROR) DET1 = ( CO(2,I2)- CO(2,I1) ) * ( CO(3,I3)- CO(3,I1)) - . ( CO(3,I2)- CO(3,I1) ) * ( CO(2,I3)- CO(2,I1)) DET2 = ( CO(3,I2)- CO(3,I1) ) * ( CO(1,I3)- CO(1,I1)) - . ( CO(1,I2)- CO(1,I1) ) * ( CO(3,I3)- CO(3,I1)) DET3 = ( CO(1,I2)- CO(1,I1) ) * ( CO(2,I3)- CO(2,I1)) - . ( CO(2,I2)- CO(2,I1) ) * ( CO(1,I3)- CO(1,I1)) PLANEA = DET1 PLANEB = DET2 PLANEC = DET3 PLANED = -DET1*CO(1,I1) - DET2*CO(2,I1) - DET3*CO(3,I1) WRITE (*,'('' EQUATION OF PLANE: '',F9.3,''X '', . F9.3,''Y '',F9.3,''Z '',F9.3)') . PLANEA, PLANEB, PLANEC, PLANED * NOW FOR THE POINT AT THE PROPER DISTANCE * FIRST THE Y-COORDINATE (BECAUSE I CHOOSE IT FIRST) DIST = 2.0 YNEW = DIST * SQRT( PLANEA*PLANEA + PLANEB*PLANEB + . PLANEC*PLANEC) YNEW = YNEW + (PLANEA*PLANEA+PLANEC*PLANEC)*CO(2,I2)/PLANEB . - PLANEA*CO(1,I2) . - PLANEC*CO(3,I2) YNEW = YNEW*PLANEB / . ( PLANEA*PLANEA+PLANEB*PLANEB+PLANEC*PLANEC) XNEW = PLANEA*(YNEW-CO(2,I2))/PLANEB + CO(1,I2) ZNEW = PLANEC*(YNEW-CO(2,I2))/PLANEB + CO(3,I2) IAVG = 1 ELSE CALL DEBUGR('NOT A VALID CHOICE') ENDIF IF ( IAVG .GT. 0 ) THEN CALL UPROMP( 'What connectivity (ie, NA, NB, NC) ') READ (*,'(A)') COMAND CALL LCLEAN( COMAND, COMAND, .TRUE. ) NA( NATOMS+1) = READA( COMAND, 1, ERROR) COMAND = COMAND( INDEX( COMAND, ' '): ) CALL LCLEAN( COMAND, COMAND, .TRUE.) NB( NATOMS+1) = READA( COMAND, 1, ERROR) COMAND = COMAND( INDEX( COMAND, ' '): ) CALL LCLEAN( COMAND, COMAND, .TRUE.) NC( NATOMS+1) = READA( COMAND, 1, ERROR) NATOMS = NATOMS + 1 CO( 1, NATOMS) = XNEW/IAVG CO( 2, NATOMS) = YNEW/IAVG CO( 3, NATOMS) = ZNEW/IAVG IE( NATOMS) = ITEMP CALL XYZMND( NATOMS, CO, NA, NB, NC, XNDOGM) CALL TOTROT(TEMPXX,TEMPYY,TEMPZZ) CALL SETLAB CALL LDRAW( NATOMS) ELSE CALL DEBUGR('NO UPDATE.') ENDIF ELSEIF (COMAND(:2) .EQ. 'IN') THEN CALL POPARG( COMAND, COMAND) 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) CALL INFO ELSEIF (COMAND(:5) .EQ. 'DEBUG') THEN COMAND = COMAND( INDEX( COMAND, ' '): ) CALL LCLEAN( COMAND, COMAND, .TRUE.) IF (DEBUG ) THEN DEBUG=.FALSE. CALL DEBUGR( 'Debug off.' ) ELSE DEBUG=.TRUE. CALL DEBUGR( 'Debug on.' ) ENDIF ELSEIF (COMAND(:1) .EQ. 'F' ) THEN COMAND = COMAND( INDEX( COMAND, ' '): ) CALL LCLEAN( COMAND, COMAND, .TRUE.) CALL DEBUGR('USE SPECIFIC FILE NAMES FOR OUTPUT & PLOT.') ELSEIF (COMAND(:1) .EQ. 'Q') THEN COMAND = COMAND( INDEX( COMAND, ' '): ) CALL LCLEAN( COMAND, COMAND, .TRUE.) 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) * FIRST WE CHECK FOR ANY EDITED OUT (TYPE=DD) ATOMS K = 0 LASTAT = 1 90 DO 92 I= LASTAT, NATOMS-K IF ( ATSYMB(IE(I)) .EQ. 'DD') THEN LASTAT = I DO 95 II = I+1, NATOMS CO( 1, II-1) = CO( 1, II) CO( 2, II-1) = CO( 2, II) CO( 3, II-1) = CO( 3, II) IE( II-1 ) = IE( II ) INTFRE( 1, II-1) = INTFRE( 1, II) INTFRE( 2, II-1) = INTFRE( 2, II) INTFRE( 3, II-1) = INTFRE( 3, II) IF ( NA(II) .GE. I) THEN NA( II-1 ) = NA(II)-1 ELSE NA( II-1 ) = NA( II ) ENDIF IF ( NB(II) .GE. I) THEN NB( II-1 ) = NB(II) - 1 ELSE NB( II-1 ) = NB( II) ENDIF IF ( NC(II) .GE. I) THEN NC( II-1 ) = NC(II) - 1 ELSE NC( II-1) = NC( II) ENDIF 95 CONTINUE K = K + 1 GOTO 90 ENDIF 92 CONTINUE IF ( K .GT. 0 ) THEN WRITE ( DUMMY, '(''I have removed'',I3,'' atoms.'')') K CALL LCLEAN( DUMMY, DUMMY, .TRUE.) CALL DEBUGR( DUMMY(1: 25) ) NATOMS = NATOMS - K TEMPXX=CO(1,1) TEMPYY=CO(2,1) TEMPZZ=CO(3,1) CALL XYZMND( NATOMS, CO, NA, NB, NC, XNDOGM) CALL TOTROT(TEMPXX,TEMPYY,TEMPZZ) CALL SETLAB ENDIF ISTYPE = OLTYPE DEBUG=LCLDBG LINALL=.FALSE. RETURN ELSEIF ((COMAND(:1).GE.'0'.AND.COMAND(:1).LE.'9') .OR. . (AMODE.AND.COMAND(:1).EQ.' ') ) THEN EDMADE=.FALSE. IA = READA(COMAND,1,ERROR) IF (AMODE.AND.ERROR) THEN IA=IAOLD+1 ENDIF IF (IA .GT. NATOMS ) THEN WRITE (*,*) 'Reference number too big',NATOMS,'is max.' AMODE=.FALSE. GO TO 10 ELSE AMODE=.TRUE. IAOLD=IA CALL EDITCH( INTRNL ) ENDIF COMAND = COMAND( INDEX( COMAND, ' '): ) CALL LCLEAN( COMAND, COMAND, .TRUE.) ELSEIF ( COMAND( 1: 2) .EQ. 'M ' ) THEN CALL DEBUGR('AMBIGUOUS REQUEST, USE MORE CHARACTERS.') COMAND = ' ' GOTO 10 ELSEIF ( COMAND( 1: 2) .EQ. 'ME' .OR. . COMAND( 1: 2) .EQ. 'MR' ) THEN CALL EDITMR( INTRNL ) COMAND = ' ' GOTO 10 ELSEIF ( COMAND( 1: 2) .EQ. 'MO') THEN COMAND = COMAND( INDEX( COMAND, ' '): ) CALL LCLEAN( COMAND, COMAND, .TRUE.) IF ( COMAND( :1) .EQ. ' ') THEN IF ( INTRNL ) THEN CALL DEBUGR('CURRENT MODE: INTERNAL.') ELSE CALL DEBUGR('CURRENT MODE: CARTESIAN.') ENDIF CALL UPROMP( 'Draw: Edit: MODE> Internal or Cartesian ? ') READ ( *, '( A )' ) COMAND CALL LCLEAN( COMAND, COMAND, .TRUE.) ENDIF IF ( COMAND( :1) .EQ. 'I') THEN INTRNL = .TRUE. CALL DEBUGR('MODE INTERNAL.') ELSEIF ( COMAND( :1) .EQ. 'C') THEN INTRNL = .FALSE. CALL DEBUGR('MODE CARTESIAN.') ELSEIF ( COMAND( :1) .NE. ' ') THEN CALL DEBUGR('ALLOWED RESPONSES: INTERNAL or CARTESAIN.') ENDIF COMAND = COMAND( INDEX( COMAND, ' '): ) CALL LCLEAN( COMAND, COMAND, .TRUE.) ELSEIF (COMAND(:1) .EQ. '-') THEN AMODE=.FALSE. COMAND = COMAND(2:) IF ( COMAND(1:1) .EQ. ' ') THEN IIATOM = NATOMS ELSE IIATOM = READA( COMAND, 1, ERROR) IF (ERROR) THEN CALL DEBUGR('INPUT ERROR') COMAND = ' ' GOTO 10 ENDIF ENDIF IF (IIATOM .GT. NATOMS .OR. IIATOM .LT. 1 ) THEN WRITE ( COMAND, '( ''Invalid number: '', I4)' ) IIATOM CALL DEBUGR( COMAND(:20) ) ELSE IF ( IIATOM .EQ. NATOMS ) THEN CALL LDRAW( -IIATOM ) 56 NATOMS=NATOMS-1 IF ( IE( NATOMS) .EQ. INTDD) GOTO 56 CALL XYZMND( NATOMS, CO, NA, NB, NC, XNDOGM) ELSE * WE SEARCH FOR ANY ATOMS WHICH DIRECTLY REFER TO ATOM "IIATOM" DO 58 I = IIATOM+1, NATOMS IF( NA(I) .EQ. IIATOM .OR. NB(I) .EQ. IIATOM . .OR. NC(I) .EQ. IIATOM) THEN WRITE (COMAND,'('' ATOM '',I4, . '' is referenced to atom '',I4, . ''. Uncouple them to proceed.'')') . IIATOM, I CALL DEBUGR( COMAND(:70) ) COMAND = ' ' GOTO 10 ENDIF 58 CONTINUE CALL LDRAW(-IIATOM) IE(IIATOM) = INTDD ENDIF WRITE ( COMAND, '( ''Atom '', I4,'' removed.'')' ) . IIATOM CALL DEBUGR( COMAND( :18) ) REDRAW = .TRUE. MODATA = .TRUE. ENDIF CALL POPARG( COMAND, COMAND) ELSEIF (COMAND(:1) .EQ. '+' ) THEN AMODE=.FALSE. COMAND = COMAND( 2: ) CALL LCLEAN( COMAND, COMAND, .TRUE.) IF ( COMAND(1:1) .EQ. ' ') THEN CALL EDITAD( INTRNL ) ELSE CALL EDITIN( INTRNL ) ENDIF COMAND = COMAND( INDEX( COMAND, ' '): ) CALL LCLEAN( COMAND, COMAND, .TRUE.) ELSEIF (COMAND(:2) .EQ. 'DU' ) THEN * add dummy atom between two existing atoms AMODE=.FALSE. COMAND=COMAND(INDEX(COMAND,' ')+1:) CALL LCLEAN( COMAND, COMAND, .TRUE.) IF (COMAND(:1) .EQ. ' ') THEN CALL UPROMP( 'Dummy atom between which two atoms ?') READ (*, '( A )' ) COMAND CALL LCLEAN (COMAND, COMAND, .TRUE.) ENDIF IPT1 = READA (COMAND, 1, ERROR) IF (ERROR) THEN CALL DEBUGR('Error in first atom number.') GO TO 10 ENDIF IF (IPT1 .LE. 0 .OR. IPT1 .GT. NATOMS) THEN CALL DEBUGR('First atom number out of range.') GO TO 10 ENDIF IS = INDEX (COMAND,' ') DO 60 ISS= IS, 80 IF (COMAND(ISS:ISS) .NE. ' ') GO TO 65 60 CONTINUE CALL DEBUGR('Second atom number not found.') GO TO 10 65 IPT2 = READA (COMAND,ISS,ERROR) IF (ERROR) THEN CALL DEBUGR('Error in second atom number.') GO TO 10 ENDIF IF (IPT2 .LE. 0 .OR. IPT2 .GT. NATOMS) THEN CALL DEBUGR('Second atom number out of range.') GO TO 10 ENDIF IF (IPT1.EQ.IPT2) THEN CALL DEBUGR('The two atoms must be different.') GOTO 10 ENDIF IF ( IPT1 .GT. IPT2) THEN ISS = IPT2 IPT2 = IPT1 IPT1 = ISS ENDIF c IF ( NA(IPT2) .NE. IPT1) THEN c WRITE (*,1060) IPT1,IPT2 c1060 FORMAT ( 1X, 'Atoms ',I3,' and ',I3,' are not', c . ' connected.') c GO TO 10 c ENDIF DO 66 I=NATOMS+1,IPT2,-1 IE(I+1) = IE(I) CO(1,I+1) = CO(1,I) INTFRE(1,I+1) = INTFRE(1,I) CO(2,I+1) = CO(2,I) INTFRE(2,I+1) = INTFRE(2,I) CO(3,I+1) = CO(3,I) INTFRE(3,I+1) = INTFRE(3,I) IF (NA(I) .GE. IPT2) THEN NA(I+1)=NA(I)+1 ELSE NA(I+1) = NA(I) ENDIF IF (NB(I) .GE. IPT2) THEN NB(I+1)=NB(I)+1 ELSE NB(I+1) = NB(I) ENDIF IF (NC(I) .GE. IPT2) THEN NC(I+1)=NC(I)+1 ELSE NC(I+1) = NC(I) ENDIF 66 CONTINUE IE(IPT2) = 99 CO(1,IPT2) = (CO(1,IPT1) + CO(1,IPT2+1))/2 CO(2,IPT2) = (CO(2,IPT1) + CO(2,IPT2+1))/2 CO(3,IPT2) = (CO(3,IPT1) + CO(3,IPT2+1))/2 NA(IPT2)=NA(IPT2+1) NB(IPT2)=NB(IPT2+1) NC(IPT2)=NC(IPT2+1) IF ( IPT2 .LT. 4 ) THEN IF ( IPT2 .LT. 3) THEN NB( IPT2+1) = 2 ELSE NC( IPT2+1) = 3 ENDIF ENDIF NATOMS = NATOMS + 1 CALL XYZMND( NATOMS, CO, NA, NB, NC, XNDOGM) CALL SETLAB REDRAW = .TRUE. MODATA = .TRUE. COMAND = COMAND( INDEX( COMAND, ' '): ) CALL LCLEAN( COMAND, COMAND, .TRUE.) ELSE COMAND = COMAND( INDEX( COMAND, ' '): ) CALL LCLEAN( COMAND, COMAND, .TRUE.) CALL DEBUGR('SORRY, NOT DONE YET.') ENDIF GO TO 10 END