SUBROUTINE MOVE INCLUDE 'SIZES' IMPLICIT REAL (A-H,O-Z) DIMENSION XDIST( NUMATM),YDIST( NUMATM),ZDIST( NUMATM) DIMENSION IGROUP( NUMATM) CHARACTER*80 VNAME,TITLE,COMAND LOGICAL ERROR, MODATA, REDRAW REAL VFREQ, VIBVEC COMMON/ATOMS/ CO(3, NUMATM),IE( NUMATM),NATOMS, ATCHG( NUMATM) COMMON/GEOM/ COOLD(3, NUMATM),NA( NUMATM),NB( NUMATM),NC( NUMATM) LOGICAL DEBUG, DEBUGL, DEBUGN, DEBUGO, DEBUGP, DEBUGI COMMON /DEBCOM/ DEBUG, DEBUGL, DEBUGN, DEBUGO, DEBUGP, DEBUGI COMMON /COMM/ COMAND COMMON /EDIT/ MODATA, REDRAW COMMON /FORCE/ VFREQ(3*NUMATM), VIBVEC(3*NUMATM,3*NUMATM), IDVECT COMMON /INTCOR/ XNDOGM(3, NUMATM), INTFRE(3, NUMATM) C 400 CALL UPROMP( 'Draw:MOVE> ') READ (5, '( A )' ) COMAND CALL LCLEAN(COMAND,COMAND, .TRUE.) IF (COMAND(:1) .EQ. 'H' .OR. COMAND(:1) .EQ. '?') THEN COMAND = 'DRAW MOVE' CALL HELP( COMAND ) COMAND = ' ' ELSEIF (COMAND(:1) .EQ. 'C' ) THEN WRITE (*,*) 'Cartesian movement' CALL UPROMP( . 'Move ALL ATOMS the same or INDIVIDUALLY ? ' ) READ (*, '( A )' ) COMAND CALL LCLEAN(COMAND,COMAND, .TRUE.) IF (COMAND(:1).EQ.'A' .OR. COMAND(1:1).EQ.'S') THEN CALL UPROMP( 'OK BY HOW MUCH (X,Y,Z ANGSTROMS) ' ) READ ( *, '( A )' ) COMAND CALL LCLEAN( COMAND, COMAND, .TRUE.) IF ( COMAND(:1) .EQ. ' ') GOTO 400 X = READA( COMAND, 1 , ERROR) IF ( ERROR ) THEN WRITE ( *, *) 'INPUT ERROR.' GOTO 400 ENDIF COMAND = COMAND( INDEX( COMAND, ' '):) CALL LCLEAN( COMAND, COMAND, .TRUE.) Y = READA( COMAND, 1, ERROR) IF ( ERROR ) THEN CALL UPROMP( 'Y DISPLACEMENT: ') READ ( *, '( A )' ) COMAND CALL LCLEAN( COMAND, COMAND, .TRUE.) IF ( COMAND(:1) .EQ. ' ') THEN Y = 0.0D0 ELSE Y = READA( COMAND, 1, ERROR) IF ( ERROR) Y = 0.0D0 ENDIF ENDIF COMAND = COMAND( INDEX( COMAND, ' '):) CALL LCLEAN( COMAND, COMAND, .TRUE.) Z = READA( COMAND, 1, ERROR) IF ( ERROR ) THEN CALL UPROMP( 'Z DISPLACEMENT: ') READ ( *, '( A )' ) COMAND CALL LCLEAN( COMAND, COMAND, .TRUE.) IF ( COMAND(:1) .EQ. ' ') THEN Z = 0.0D0 ELSE Z = READA( COMAND, 1, ERROR) IF ( ERROR) Y = 0.0D0 ENDIF ENDIF IF (DEBUG) WRITE (*,*) 'X,Y,Z=',X,Y,Z DO 401 I=1,NATOMS XDIST(I)=X YDIST(I)=Y 401 ZDIST(I)=Z CALL XYZMOV(XDIST,YDIST,ZDIST,0,IGROUP) REDRAW = .TRUE. RETURN ELSEIF( COMAND(1:1) .EQ. 'I')THEN CALL UPROMP( . 'Shall I move MANUALLY or by a NORMAL VIBRATION? ') READ ( *, '( A )', END=400 ) COMAND CALL LCLEAN(COMAND, COMAND, .TRUE.) IF ( COMAND(:1) .EQ.'M' )THEN WRITE (6,454) NATOMS 454 FORMAT ( ' I will prompt you for each of the ',I4, 1 ' atoms; you must enter three (3) values' ) 410 DO 422 I=1,NATOMS WRITE(COMAND,'('' ATOM '',I4,'' VALUES X, Y, Z: '')') I CALL UPROMP( COMAND( :INDEX(COMAND,':')+1) ) READ (*,'(A)', END=400) COMAND CALL LCLEAN( COMAND, COMAND, .TRUE.) IF ( COMAND(1:1) .EQ. '*') THEN XDIST(I)=XDIST(I-1) YDIST(I)=YDIST(I-1) ZDIST(I)=ZDIST(I-1) ELSE IF ( COMAND(1:1) .EQ. '"') THEN XDIST(I) = XDIST( I-1) ELSE XDIST(I) = READA( COMAND, 1, ERROR) ENDIF CALL POPARG( COMAND, COMAND) IF ( COMAND(1:1) .EQ. '"') THEN YDIST(I) = YDIST( I-1) ELSE YDIST(I) = READA( COMAND, 1, ERROR) ENDIF CALL POPARG( COMAND, COMAND) IF ( COMAND(1:1) .EQ. '"') THEN ZDIST(I) = ZDIST( I-1) ELSE ZDIST(I) = READA( COMAND, 1, ERROR) ENDIF CALL POPARG( COMAND, COMAND) c? XDIST(I)=XDIST(I)*SCALEM c? YDIST(I)=YDIST(I)*SCALEM c? ZDIST(I)=ZDIST(I)*SCALEM XDIST(I)=XDIST(I) YDIST(I)=YDIST(I) ZDIST(I)=ZDIST(I) ENDIF 422 CONTINUE ELSEIF( COMAND(1:1).EQ.'N' .OR. COMAND(1:1).EQ.'V')THEN CALL UPROMP( 'WHICH EIGENVECTOR NUMBER? [DEFAULT IS 1] ') READ ( *, '(A)', END=400) COMAND CALL LCLEAN( COMAND, COMAND, .TRUE.) IF ( COMAND(:1) .EQ. ' ') THEN IDVECT = 1 ELSE IDVECT = READA( COMAND, 1, ERROR) ENDIF CALL UPROMP( 'Enter a multiplier [ 1.000] ') READ ( *, '( A )' ) COMAND CALL LCLEAN( COMAND, COMAND, .TRUE.) IF ( COMAND(:1) .EQ. ' ') THEN SCALEM = 1.0D0 ELSE SCALEM=READA( COMAND,1,ERROR) IF(ERROR)SCALEM=1.0 ENDIF ITEMP = 0 DO 404 I= 1, NATOMS IF ( IE(I) .NE. 99) THEN XDIST( I) = VIBVEC( ITEMP+1, IDVECT ) * SCALEM YDIST( I) = VIBVEC( ITEMP+2, IDVECT ) * SCALEM ZDIST( I) = VIBVEC( ITEMP+3, IDVECT ) * SCALEM ITEMP = ITEMP + 3 ELSE XDIST( I) = 0.0D0 YDIST( I) = 0.0D0 ZDIST( I) = 0.0D0 ENDIF 404 CONTINUE ELSE CALL DEBUGR( 'I wish you would use one of my options.') GOTO 400 ENDIF CALL XYZMOV(XDIST,YDIST,ZDIST,0,IGROUP) CALL XYZMND( NATOMS, CO, NA, NB, NC, XNDOGM ) REDRAW = .TRUE. GO TO 400 ENDIF ELSEIF (COMAND(:1) .EQ. 'I') THEN CALL DEBUGR( 'INTERNAL GEOMETRY MOVEMENT.') CALL UPROMP( 'INPUT SCALE MULTIPLIER (DEFAULT IS 1.000) ') READ ( *, '(A)', END=400 ) COMAND CALL LCLEAN( COMAND, COMAND, .TRUE.) IF ( COMAND(:1) .EQ. ' ') THEN SCALEM = 1.0D0 ELSE SCALEM = READA( COMAND, 1, ERROR) IF (ERROR) SCALEM = 1.0D0 ENDIF IF (SCALEM.EQ.0)SCALEM=1.0D0 WRITE (*,*) 'MANUAL IS THE ONLY MODE.' 505 WRITE (6,454)NATOMS IUNIT=5 510 DO 522 I=1,NATOMS 518 WRITE (6,*) ' ATOM ',I, . ' VALUES OF LENGTH, BOND ANGLE, DIHED' READ (5,*) XDIST(I),YDIST(I),ZDIST(I) 520 XDIST(I)=XDIST(I)*SCALEM YDIST(I)=YDIST(I)*SCALEM ZDIST(I)=ZDIST(I)*SCALEM 522 CONTINUE CALL MNDMOV(XDIST,YDIST,ZDIST,0,IGROUP) CALL GMETRY(NUATOM,NATOMS,NN,A,NA,NB,NC,COORD,ERROR) REDRAW = .TRUE. ELSEIF (COMAND(:1) .EQ. 'Q' ) THEN RETURN ELSE WRITE (*,*) 'I don''t understand, try Help.' GO TO 400 ENDIF RETURN END