SUBROUTINE DSPLAY 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) CHARACTER*80 COMAND, DUMMY CHARACTER*80 FILEIN, FILOUT, FILPLT, LLEGND CHARACTER*6 ATSYMB DIMENSION EVEC( 3, 3), DISPL( 3), ANGLES( 3) INTEGER AUDIN, AUDOUT INTEGER*2 ATBOND REAL DENMAT, BONDS REAL VFREQ, VIBVEC LOGICAL ERROR, MODATA, REDRAW, ZOOM1 LOGICAL DEBUG, DEBUGL, DEBUGN, DEBUGO, DEBUGP, DEBUGI COMMON /DEBCOM/ DEBUG, DEBUGL, DEBUGN, DEBUGO, DEBUGP, DEBUGI REAL VDIST, XBOUND, YBOUND, BORDER, RETRAC, XCENTR, YCENTR REAL SCOR1, SCOR2, REDUCT, BTHICK, XTITLE, YTITLE, THEIT COMMON /CORTEP/ VDIST, XBOUND, YBOUND, BORDER, RETRAC, . IN600, XCENTR, YCENTR, SCOR1, SCOR2, REDUCT, . NORATM, NORBON, NRBOND, BTHICK, XTITLE, YTITLE, THEIT * VDIST :== VIEWING DISTANCE (INST 301) * XBOUND :== X-BOUNDARY (INST 301) * YBOUND :== Y-BOUNDARY (INST 301) * BORDER :== SIZE OF BORDER (INST 301) * RETRAC :== DIPLACEMENT FOR RETRACE (INST 303) * IN600 :== TYPE OF 600 COMMAND (INST 60X) * XCENTR :== X-COORD CENTER OF PLOT (INST 60X) * YCENTR :== Y-COORD CENTER OF PLOT (INST 60X) * SCOR1 :== OVER ALL SCALING (INST 60X) * SCOR2 :== SUBSIDIARY SCALING (INST 60X) * REDUCT :== OVERALL REDUCTION (INST 611) * NORATM :== ATOM SYMBOL SHAPE (INST 7XX) * NORBON :== TYPE OF BONDS (INST 80X) * NRBOND :== NUMBER OF LINES IN BOND (INST 80X) * BTHICK :== BOND THICKNESS (INST 80X) * XTITLE :== X-RESET FOR TITLE (INST 902) * YTITLE :== Y-RESET FOR TITLE (INST 902) * THEIT :== TITLE HEIGHT (INST 902) COMMON /AUDIT/ AUDIN, AUDOUT 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 /COLORS/ ICOLAT( 200) COMMON /DISPLY/ IREM(200), BSCALE, ATBOND( NUMATM, NUMATM), . ISTYPE, LATYPE, IMASK( NUMATM), ISCOLO COMMON /DEVICE/ ITYPE, ISCRN, KOROFF COMMON /OUTPUT/ IPAPER,IPAGE COMMON /FORCE/ VFREQ(3*NUMATM), VIBVEC(3*NUMATM,3*NUMATM), IDVECT COMMON /FORGEO/ FORORE( 3, NUMATM), IEFOR( NUMATM) COMMON /ORBITS/ EVAL(100),ORBS(100,100) COMMON /DENSTY/ DENMAT( MPACK ), BONDS( MPACK ) COMMON /COMM/ COMAND COMMON /LEGEND/ FILEIN, FILOUT, FILPLT, LLEGND COMMON /EDIT/ MODATA, REDRAW COMMON /ALLROT/ ROTPRD( 3, 3) COMMON /ATMASS/ ATMASS( NUMATM) C? COMMON /EXMASS/ XMASS(200) COMMON /PLOTS/ XMIN,XMAX,YMIN,YMAX,ZMIN,ZMAX,CMIN,CMAX,SCALE COMMON /HCPY/ JHDEV INTEGER PIXROW, PIXCOL, PIXEL COMMON /TERM/ IMAXR, IMAXC, PIXROW, PIXCOL, PIXEL, LCOUNT, INGRAF, . IXL, IXR, IYT, IYB, NCOLOR, MCOLOR( 64 ), ITTRM, . MARGX, MARGY * VARIABLES IN COMMON TERM: * IMAXR = MAX NUMBER OF ROWS * IMAXC = MAX NUMBER OF COLUMNS * PIXROW = NUMBER OF PIXELS PER ROW * PIXCOL = NUMBER OF PIXELS PER COLUMN * PIXEL = LESSER OF PIXROW OR PIXCOL * LCOUNT = NUMBER OF LINES CURRENTLY WRITTEN TO DIALOG AREA * INGRAF = 0=> HOST TEXT GOES TO MONITOR SPACE\\ 1=> TEXT TO GRAPHICS * IXL = LEFT MOST VALUE OF X * IXR = RIGHT MOST VALUE OF X * IYT = VALUE OF Y AT TOP OF SCREEN * IYB = VALUE OF Y AT BOTTOM OF SCREEN * NCOLOR = NUMBER OF COLORS IN MCOLOR MAP * MCOLOR = MAP OF COLORS * ITTRM = UNIQUE MODEL NUMBER OF GENERAL TERMINAL TYPE * MARGX = NUMBER OF PIXELS PADDED TO X-COORDINATE * MARGY = NUMBER OF PIXELS PADDED TO Y-COORDINATE * * DATA ZOOM1 /.TRUE./ *************************************************** * HERE IS STUFF WE MUST RE-INITIALIZE FOR RE-ENTRY * *************************************************** 10 CONTINUE IF ( COMAND(1:1) .EQ. ' ' ) THEN IF ( AUDIN .EQ. 0 ) THEN CALL UPROMP( 'Draw:DISPLAY> ') READ ( *, '(A)', END=9000) COMAND CALL LCLEAN( COMAND, COMAND, .TRUE.) IF ( AUDOUT .GT. 0 ) WRITE ( AUDOUT, '(A)') COMAND ELSE READ( AUDIN, '(A)', END=9000) COMAND ENDIF ENDIF ITS1 = MOD(ISTYPE,10) IF (COMAND(1:1) .EQ.'H' .OR. COMAND(1:1) .EQ. '?') THEN COMAND = 'DRAW DISPLAY' CALL HELP( COMAND ) COMAND = ' ' ELSEIF (COMAND(1:1) .EQ. 'Q' ) THEN CALL POPARG( COMAND, COMAND) RETURN ELSEIF (COMAND(:1) .EQ. '-' ) THEN COMAND = COMAND( 2:) CALL LCLEAN( COMAND, COMAND, .TRUE.) IF ( COMAND( 1: 1 ) .EQ. '-' ) THEN CALL POPARG( COMAND, COMAND) DO 30 I=1,NUMATM 30 IMASK(I) = I REDRAW = .TRUE. CALL DEBUGR( 'All atoms turned off.') ELSEIF (COMAND( 1: 1 ).GE.'A' .AND. COMAND( 1: 1).LE.'Z' ) THEN I = 1 IF (COMAND( 2: 2) .NE. ' ') I=2 JJ = I J = NUMELE( COMAND( 1: I) ) IF ( J .GT. 0 ) THEN IF ( IREM(J) .EQ. 0 ) THEN CALL DEBUGR( 'Ok.') IREM(J) = J DO 501 KK = 1, NATOMS IF ( IE( KK) .EQ. J ) REDRAW = .TRUE. 501 CONTINUE ELSE WRITE (*,*) 'It was.' ENDIF ELSE WRITE (*, '( '' No match for symbol '', A )' ) . COMAND(1:I) ENDIF CALL POPARG( COMAND, COMAND) GO TO 10 ELSEIF (COMAND(1:1).GE.'0' .AND. COMAND( 1:1) .LE. '9') THEN NNN = READA(COMAND, 1, ERROR) IF (ERROR) THEN WRITE (*,*) 'READA error on',COMAND(2:) COMAND = ' ' GO TO 10 ENDIF IF (IMASK(NNN) .NE. 0 ) THEN CALL DEBUGR( 'It was.') ELSE CALL DEBUGR( 'Ok.') IMASK(NNN) = NNN REDRAW = .TRUE. ENDIF CALL POPARG( COMAND, COMAND) GO TO 10 ELSE WRITE (*,*) 'INV)lID CHARACTER',COMAND(2:2) COMAND = ' ' ENDIF ELSEIF (COMAND(1:1) .EQ. '+' ) THEN COMAND = COMAND(2:) CALL LCLEAN( COMAND, COMAND, .TRUE.) IF (COMAND( 1: 1 ) .EQ. '+' ) THEN CALL POPARG( COMAND, COMAND) DO 40 I = 1, NUMATM 40 IMASK(I) = 0 REDRAW = .TRUE. CALL DEBUGR( 'All atom numbers allowed.' ) ELSEIF (COMAND(1:1 ).GE.'A' .AND. COMAND( 1:1) .LE. 'Z' ) THEN I = 1 IF (COMAND( 2: 2 ) .NE. ' ') I=2 JJ = I J = NUMELE( COMAND( 1: I) ) IF ( J .GT. 0 ) THEN IF (IREM(J) .NE. 0 ) THEN CALL DEBUGR( 'Ok.') IREM(J) = 0 DO 500 KK = 1, NATOMS IF ( IE( KK) .EQ. J ) REDRAW = .TRUE. 500 CONTINUE CALL SETLAB ELSE WRITE (*,*) 'It was.' ENDIF ELSE WRITE (*, '( '' No match for symbol '', A )' ) . COMAND(1:I) ENDIF CALL POPARG( COMAND, COMAND) GO TO 10 ELSEIF (COMAND( 1:1 ).GE.'0' .AND. COMAND( 1:1).LE.'9') THEN NNN = READA( COMAND, 1, ERROR) IF (ERROR) THEN WRITE (*,*) 'READA error on',COMAND(2:) COMAND = ' ' GO TO 10 ENDIF IF (IMASK(NNN) .EQ. 0 ) THEN WRITE (*,*) 'It was.' CALL POPARG( COMAND, COMAND) GO TO 10 ELSE CALL DEBUGR( 'Ok.') IMASK(NNN) = 0 REDRAW = .TRUE. CALL SETLAB CALL POPARG( COMAND, COMAND) GO TO 10 ENDIF ELSE WRITE (*,*) 'INVALID CHARACTER',COMAND(2:2) ENDIF ELSEIF ( COMAND(1:1) .EQ. 'Z' ) THEN * ZOOM-IN COMMAND CALL POPARG( COMAND, COMAND) IF ( COMAND(1:1) .EQ. ' ') THEN IF ( AUDIN .EQ. 0 ) THEN CALL UPROMP( . 'Show by MANUAL, OPTIMIZED, SURFACE, or QUIT? ') COMAND = ' ' READ ( *, '(A)', END=10) COMAND CALL LCLEAN( COMAND, COMAND, .TRUE.) IF ( AUDOUT .GT. 0 ) WRITE ( AUDOUT, '(A)') COMAND ELSE READ( AUDIN, '(A)', END=10) COMAND ENDIF ENDIF IF ( COMAND(1:1) .EQ. 'Q' ) THEN CALL POPARG( COMAND, COMAND) ZOOM1 = .TRUE. REDRAW = .TRUE. DO 238 I= 1, NATOMS IMASK( I) = 0 238 CONTINUE CALL DEBUGR( 'Revert to display entire molecule.') XMIN = -1.0 XMAX = 1.0 CALL MINMAX ELSEIF ( COMAND(1:1) .EQ. 'M' ) THEN DO 240 I = 1, NATOMS IMASK( I) = I 240 CONTINUE REDRAW = .TRUE. 241 CONTINUE CALL POPARG( COMAND, COMAND) CALL LCLEAN( COMAND, COMAND, .TRUE.) IF ( AUDIN .EQ. 0 ) THEN IF(COMAND(1:1).EQ.' ') THEN CALL UPROMP( . 'What atoms to zoom-in on? (NONE to stop) ') READ ( *, '(A)', END=10) COMAND CALL LCLEAN( COMAND, COMAND, .TRUE.) IF ( AUDOUT .GT. 0 ) WRITE ( AUDOUT, '(A)') COMAND ENDIF ELSE READ( AUDIN, '(A)', END=10) COMAND ENDIF IF( COMAND(1:1) .EQ. ' ') GOTO 10 IF( COMAND(1:1) .EQ. 'N') GOTO 10 C? 241 CONTINUE ITEMP = READA( COMAND, 1, ERROR) IF (ERROR .OR. COMAND(1:1) .EQ. ' ') THEN CALL UPROMP( 'ZOOM is set.' ) COMAND = ' ' GOTO 10 ELSE IF (ITEMP .LT. NATOMS) THEN IMASK( ITEMP) = 0 JTEMP = MAX( INDEX( COMAND, ' '), 1) KTEMP = MAX( INDEX( COMAND, '-'), 1) LTEMP = MAX( INDEX( COMAND, ','), 1) MTEMP = MIN( KTEMP, JTEMP) MTEMP = MIN( MTEMP, LTEMP) COMAND = COMAND( MTEMP: ) CALL LCLEAN( COMAND, COMAND, .TRUE.) IF ( COMAND(1:1) .EQ. '-') THEN COMAND(1:1) = ' ' CALL LCLEAN( COMAND, COMAND, .TRUE.) JTEMP = READA( COMAND, 1, ERROR) CALL POPARG( COMAND, COMAND) IF ( ERROR) THEN CALL DEBUGR( 'ERROR IN RANGE OF ZOOM.') GOTO 241 ELSE DO 244 I=MIN( ITEMP, JTEMP), MAX( ITEMP, JTEMP) IMASK( I) = I 244 CONTINUE REDRAW = .TRUE. ENDIF ELSE CALL LCLEAN( COMAND, COMAND, .TRUE.) ENDIF GOTO 241 ELSE WRITE ( COMAND, '('' ERROR IN ATOM NUMBER '',I4)') . ITEMP CALL DEBUGR( COMAND ) COMAND = ' ' GOTO 10 ENDIF ENDIF ELSEIF( COMAND(1:1) .EQ. 'O') THEN CALL POPARG( COMAND, COMAND) IFIRST = 0 ILAST = 0 * AUTOMATIC SELECTION OF OPTIMIZED ATOMS DO 245 I = 1, NATOMS IMASK( I ) = I IF ( INTFRE( 1, I) .NE. 0 ) IMASK( I ) = 0 IF ( INTFRE( 2, I) .NE. 0 ) IMASK( I ) = 0 IF ( INTFRE( 3, I) .NE. 0 ) IMASK( I ) = 0 IF ( IMASK( I) .EQ. 0) THEN IF ( IFIRST .EQ. 0 ) IFIRST = I ILAST = I ELSEIF ( IFIRST .GT. 0 ) THEN WRITE (*,'('' Selecting '',I4,'' through '',I4)') . IFIRST, ILAST IFIRST = 0 ILAST = 0 ENDIF 245 CONTINUE REDRAW = .TRUE. ELSEIF( COMAND(1:1) .EQ. 'S') THEN * WANTS TO SELECT A SURFACE (ONLY A RELATIVE X-Y SURFACE IS ALLOWED) IF ( ZOOM1 ) THEN * we will lock the scale for now CALL MINMAX XMIN = -XMIN XMAX = -XMAX ZOOM1 = .FALSE. ENDIF CALL POPARG( COMAND, COMAND) ZTOP = CO( 3, 1) ZBOT = CO( 3, 1) IZTOP = 1 IZBOT = 1 DO 3300 I= 1, NATOMS IF ( CO( 3, I ) .GT. ZTOP ) THEN ZTOP = CO( 3, I) IZTOP = I ELSEIF ( CO( 3, I) .LT. ZBOT ) THEN ZBOT = CO( 3, I) IZBOT = I ENDIF 3300 CONTINUE ZRANGE = ZTOP - ZBOT IF ( ZRANGE .LE. 1.5 ) THEN CALL DEBUGR( 'This molecule is nearly flat.') ZRANGE = 1.5 ELSE WRITE (*,'('' Maximum Z: '',F11.4,'' Minimum Z: '', . F11.4)') ZTOP, ZBOT WRITE (*,'('' Slices will be '',F8.2, . '' Angstroms thick.'')')ZRANGE ENDIF IF ( COMAND(1:1) .EQ. ' ') THEN IF ( AUDIN .EQ. 0 ) THEN IF ( IZTOP .LT. 1 ) THEN CALL UPROMP . (' Enter Z-value, TOP, BOTTOM, or Atom ##: ') ELSE CALL UPROMP . (' Enter Z-value, TOP, BOTTOM, Atom ##, +, or -: ') ENDIF READ ( *, '(A)', END=10) COMAND CALL LCLEAN( COMAND, COMAND, .TRUE.) IF ( AUDOUT .GT. 0 ) WRITE ( AUDOUT, '(A)') COMAND ELSE READ( AUDIN, '(A)', END=10) COMAND ENDIF ENDIF IF ( COMAND( 1: 1) .EQ. ' ') THEN GOTO 10 ELSEIF( COMAND( 1: 1) .EQ. 'T' ) THEN * WANTS TOP OF MOLECULE ZMIDD = ZTOP ELSEIF( COMAND( 1: 1) .EQ. 'B') THEN * WANTS BOTTOM OF MOLCULES ZMIDD = ZBOT ELSEIF( COMAND( 1: 1) .EQ. 'A') THEN * WANTS SURFACE CONTAINING ATOM ## IZATOM = READA( COMAND, 2, ERROR) IF ( ERROR ) THEN CALL DEBUGR( 'I could not understand that atom.') CALL DEBUGR( COMAND(1:10) ) IZATOM = 1 ENDIF ZMIDD = CO( 3, IZATOM) ELSEIF ( COMAND( 1: 1) .EQ. '+') THEN * WANTS TO MOVE UP RELATIVE ZMIDD = ZMIDD + ZRANGE / 10.0 ELSEIF ( COMAND( 1: 1) .EQ. '-') THEN * WANTS TO MOVE DOWN RELATIVE ZMIDD = ZMIDD - ZRANGE / 10.0 ELSE ZMIDD = READA( COMAND, 1, ERROR) IF ( ERROR ) THEN COMAND = ' ' GOTO 10 ENDIF ENDIF IF ( ZMIDD .GE. ZTOP ) THEN ZMIDD = ZTOP CALL DEBUGR( 'At the top; Maximum Positive Z.') ELSEIF ( ZMIDD .LE. ZBOT) THEN ZMIDD = ZBOT CALL DEBUGR( 'At the bottom; Minimum Z.') ENDIF ZSTART = ZMIDD + ZRANGE / 10.0 ZEND = ZMIDD - ZRANGE / 10.0 WRITE ( *, '('' Secting atoms in the range: '',F11.4, . '' down to'',F11.4,'' Angstroms.'')') ZSTART, ZEND CALL UPROMP( ' ATOMS: ' ) DO 3304 I= 1, NATOMS ZTEMP = CO( 3, I) IF ( ZTEMP .LE. ZSTART .AND. ZTEMP .GE. ZEND) THEN IMASK( I) = 0 WRITE ( DUMMY, '(''+'',I5)') I CALL UPROMP( DUMMY( 1: 7) ) ELSE IMASK( I) = I ENDIF 3304 CONTINUE CALL POPARG( COMAND, COMAND) REDRAW = .TRUE. ELSE CALL DEBUGR( 'That was not one of the choices.' ) CALL POPARG( COMAND, COMAND) GOTO 10 ENDIF ELSEIF (COMAND(:1) .EQ. 'A' ) THEN WRITE ( *, *) 'USE +## or -## to UNMASK or MASK types of atoms.' CALL POPARG( COMAND, COMAND) ELSEIF (COMAND(:1) .EQ. 'B' ) THEN * ADJUSTMENT TO BONDING CALL SETBON( .TRUE. ) REDRAW = .TRUE. ELSEIF (COMAND(:1) .EQ. 'P') THEN * SELECTION OF PLOTTING DEVICE CALL POPARG( COMAND, COMAND) JTEMP = ABS(JHDEV) IF (JTEMP .EQ. 1 ) THEN WRITE (*,*) 'PLOTS SET FOR IDS PAPER TIGER PRINTER.' ELSEIF (JTEMP .EQ. 2 ) THEN WRITE (*,*) 'PLOTS SET FOR EPSON FX-80 PRINTER.' ELSEIF (JTEMP .EQ. 3 ) THEN WRITE (*,*) 'PLOTS SET FOR DEC LA50 PRINTER.' ELSEIF (JTEMP .EQ. 4 ) THEN WRITE (*,*) 'PLOTS SET FOR MPI-99 PRINTER.' ELSEIF (JTEMP .EQ. 5) THEN WRITE (*,*) 'PLOTTING FOR HP9872 STYLE PLOTTER.' ELSEIF (JTEMP .EQ. 6) THEN WRITE (*,*) 'PLOTTING FOR CALCOMP M84 PLOTTER.' ELSEIF (JTEMP .EQ. 7) THEN WRITE (*,*) 'PLOTTING FOR XEROX 2700 II LASER PRINTER.' ELSE WRITE (*,*) 'PLOTS ARE SET FOR AN UNKNOWN DEVICE' WRITE (*,*) 'JHDEV =',JTEMP ENDIF IF ( AUDIN .EQ. 0 ) THEN CALL UPROMP( 'WHAT TYPE OF DEVICE TO PLOT ON ' ) COMAND = ' ' READ ( *, '(A)', END= 3000) COMAND CALL LCLEAN( COMAND, COMAND,.TRUE.) IF ( AUDOUT .GT. 0 ) WRITE ( AUDOUT, '(A)') COMAND ELSE READ( AUDIN, '(A)', END= 3000) COMAND ENDIF IF (COMAND(1:2) .EQ. 'HE' .OR. COMAND(1:1) .EQ. '?') THEN COMAND = 'DRAW DISPLAY PLOT' CALL HELP( COMAND ) ELSEIF (COMAND(1:1) .EQ. 'T' ) THEN JHDEV = -1 CALL DEBUGR( 'OK NOW SET FOR IDS PAPER TIGER') ELSEIF (COMAND(1:1) .EQ. 'E' ) THEN JHDEV = -2 CALL DEBUGR( 'OK NOW SET FOR EPSON FX-80') ELSEIF (COMAND(1:1) .EQ. 'L' ) THEN JHDEV = -3 CALL DEBUGR( 'OK NOW SET FOR DEC LA50 PRINTER') ELSEIF (COMAND(1:1) .EQ. 'M' ) THEN JHDEV = -4 CALL DEBUGR( 'OK NOW SET FOR MPI-99 PRINTER') ELSEIF (COMAND(1:2) .EQ. 'HP' ) THEN JHDEV = -5 CALL DEBUGR( 'OK, I''M SET FOR HP9872 STYLE PLOT.') ELSEIF (COMAND(1:1) .EQ. 'C' ) THEN JHDEV = -6 CALL DEBUGR( 'OK, I''M SET FOR CALCOMP M84 PLOTTER.') ELSEIF (COMAND(1:1) .EQ. 'X' ) THEN JHDEV = -7 CALL DEBUGR( 'OK, I''M SET FOR XEROX 2700 II PRINTER.') ELSEIF (COMAND(1:1) .EQ. ' ' ) THEN CONTINUE ELSE CALL DEBUGR('I DO NOT RECOGNIZE THAT, TRY MORE CHARACTERS') CALL DEBUGR(' or get HELP for available printers.') CALL DEBUGR('CURRENT PLOTTER NOT CHANGED') ENDIF 3000 CONTINUE COMAND = ' ' ELSEIF (COMAND(:1) .EQ. 'D') THEN IF ( ABS(DENMAT( 1 )) .LT. 1.0D-5) THEN CALL DEBUGR(' NO DENSITY MATRIX AVAILABLE.') COMAND = ' ' GOTO 10 ENDIF IF ( ITS1 .EQ. 2 ) THEN CALL DEBUGR('DENSITY DISPLAY NOT AVAILABLE FOR NAMODI.') ELSEIF ( ITS1 .EQ. 4) THEN CALL DEBUGR('DENSITY DISPLAY NOT AVAILALBE FOR ORTEP.') ELSEIF ( ITS1 .EQ. 1) THEN CALL DEBUGR('DENSITY DISPLAY NOT AVAILABLE FOR STICKS.') ENDIF ISTYPE = (ISTYPE - (ISTYPE/10)*10) + 10 ELSEIF (COMAND(:2) .EQ. 'NA') THEN ISTYPE = ISTYPE - MOD( ISTYPE,10) + 2 CALL DEBUGR('NAMOD') IF ( LLEGND.EQ.' ') LLEGND = FILEIN REDRAW = .TRUE. CALL POPARG( COMAND, COMAND) ELSEIF (COMAND(:2) .EQ. 'SC' .OR. COMAND(:2) .EQ. 'SI') THEN IF( XMAX-XMIN .GT. 0.0 ) THEN CALL DEBUGR( 'Scaling is AUTOMATIC.') ELSE CALL DEBUGR( 'Scaling is FIXED.') ENDIF WRITE (*,1060) 'Current size of display: CRT=',IPAGE,'%' WRITE (*,1060) ' HARD COPY=',IPAPER,'%' 1060 FORMAT ( 1X, A, I3, A ) COMAND = ' ' IF ( AUDIN .EQ. 0 ) THEN CALL UPROMP( 'Enter C= or H= and a number from 1 to 100 : ') COMAND = ' ' READ ( *, '(A)', END=10) COMAND CALL LCLEAN( COMAND, COMAND,.TRUE.) IF ( AUDOUT .GT. 0 ) WRITE ( AUDOUT, '(A)') COMAND ELSE READ( AUDIN, '(A)', END=10) COMAND ENDIF IF (COMAND(:1) .EQ. 'H') THEN ITEMP=READA(COMAND,INDEX(COMAND,'=')+1,ERROR) CALL POPARG( COMAND, COMAND) IF (ERROR) THEN CALL DEBUGR( 'Input conversion error, no change.') ELSE IPAPER=ITEMP WRITE (*,*) 'Current HARD COPY scaling is',IPAPER ENDIF ELSEIF (COMAND( 1: 1) .EQ. 'C') THEN ITEMP = READA( COMAND, INDEX( COMAND, '=')+1, ERROR) CALL POPARG( COMAND, COMAND) IF (ERROR) THEN CALL DEBUGR( 'Input conversion error, no change.') ELSE IPAGE=ITEMP REDRAW = .TRUE. WRITE (*,*) 'Current CRT scaling is', IPAGE ENDIF ELSEIF (COMAND( 1: 1) .EQ. 'A') THEN CALL DEBUGR( 'Now using AUTOMATIC Scaling.') XMIN = 0.0 XMAX = 1.0 CALL MINMAX CALL POPARG( COMAND, COMAND) ELSEIF (COMAND( 1: 1) .EQ. 'F') THEN CALL DEBUGR( 'Scaling now FIXED at current scale.') CALL MINMAX XMIN = -XMIN XMAX = -XMAX CALL POPARG( COMAND, COMAND) ENDIF ELSEIF (COMAND(:2) .EQ. 'ST') THEN ISTYPE = ISTYPE - MOD( ISTYPE,10) + 1 WRITE ( *, *) 'STICK FIGURES' REDRAW = .TRUE. CALL POPARG( COMAND, COMAND) ELSEIF (COMAND(:2) .EQ. 'OR') THEN * ASK TO DISPLAY ORTEP VIEW CALL POPARG( COMAND, COMAND) IF ( NATOMS .LT. 2) THEN CALL DEBUGR( 'YOU HAVE TOO FEW ATOMS.') GOTO 10 ENDIF ISTYPE = ISTYPE - MOD( ISTYPE,10) + 4 CALL DEBUGR( 'ORTEP') IF ( LLEGND.EQ.' ') LLEGND = FILEIN REDRAW = .TRUE. ELSEIF ( COMAND(1:2) .EQ. 'OP') THEN * ALTER ORTEP PARAMETERS CALL MINMAX WRITE (*,'( '' Minimums: X='',F8.4,'', Y='',F8.4,'', Z='', . F8.4,'', OVERALL='',F8.4)') XMIN, YMIN, ZMIN, CMIN WRITE (*,'( '' MAXIMUMS: X='',F8.4,'', Y='',F8.4,'', Z='', . F8.4,'', OVERALL='',F8.4,'', SCALE='',F8.4)') . XMAX, YMAX, ZMAX, CMAX, SCALE CALL POPARG( COMAND, COMAND) CALL DEBUGR( 'ORTEP Parameters...' ) WRITE (*,'( '' XBOUND,YBOUND:'',2F6.2,'' VDIST:'',F5.2, . '' BORDER '',F5.2)') XBOUND,YBOUND, VDIST, BORDER WRITE (*,'( '' IN600='',I3,'' XCENTR,YCENTR '',2F6.2, . '' SCOR1,2='',2F6.3)') IN600, XCENTR, YCENTR, SCOR1, SCOR2 WRITE (*, '('' ATOM TYPES:'',I2,'' RETRACE:'',F5.4)') . NORATM, RETRAC WRITE (*, '( '' BOND TYPE:'',I3,'' USING '',I3,'' LINES'', . '' WITH TOTAL THICKNESS '',F5.4)') NORBON, NRBOND, BTHICK IF ( AUDIN .EQ. 0 ) THEN IF ( COMAND(1:1) .EQ. ' ') CALL UPROMP( . 'Which parameter to change? ') READ ( *, '(A)', END=10) COMAND CALL LCLEAN( COMAND, COMAND,.TRUE.) IF ( AUDOUT .GT. 0 ) WRITE ( AUDOUT, '(A)') COMAND ELSE READ( AUDIN, '(A)', END=10) COMAND ENDIF IF ( COMAND(1:3) .EQ. 'XBO') THEN CALL POPARG( COMAND, COMAND) TEMP = READA( COMAND, 1, ERROR) XBOUND = TEMP CALL POPARG( COMAND, COMAND) ELSEIF ( COMAND(1:3) .EQ. 'YBO') THEN CALL POPARG( COMAND, COMAND) TEMP = READA( COMAND, 1, ERROR) YBOUND = TEMP CALL POPARG( COMAND, COMAND) ELSEIF ( COMAND(1:1) .EQ. 'B') THEN CALL POPARG( COMAND, COMAND) TEMP = READA( COMAND, 1, ERROR) BORDER = TEMP CALL POPARG( COMAND, COMAND) ELSEIF ( COMAND(1:1) .EQ. 'V') THEN CALL POPARG( COMAND, COMAND) TEMP = READA( COMAND, 1, ERROR) VDIST = TEMP CALL POPARG( COMAND, COMAND) ELSEIF ( COMAND(1:3) .EQ. 'IN6') THEN CALL POPARG( COMAND, COMAND) TEMP = READA( COMAND, 1, ERROR) IN600 = INT( TEMP) CALL POPARG( COMAND, COMAND) ELSEIF ( COMAND(1:2) .EQ. 'XC') THEN CALL POPARG( COMAND, COMAND) TEMP = READA( COMAND, 1, ERROR) XCENTR = TEMP CALL POPARG( COMAND, COMAND) ELSEIF ( COMAND(1:2) .EQ. 'YC') THEN CALL POPARG( COMAND, COMAND) TEMP = READA( COMAND, 1, ERROR) YCENTR = TEMP CALL POPARG( COMAND, COMAND) ELSEIF ( COMAND(1:5) .EQ. 'SCOR1') THEN CALL POPARG( COMAND, COMAND) TEMP = READA( COMAND, 1, ERROR) SCOR1 = TEMP CALL POPARG( COMAND, COMAND) ELSEIF ( COMAND(1:5) .EQ. 'SCOR2') THEN CALL POPARG( COMAND, COMAND) TEMP = READA( COMAND, 1, ERROR) SCOR2 = TEMP ELSE COMAND = ' ' ENDIF ELSEIF (COMAND(:1) .EQ. 'L') THEN * REQUEST TO SET LABEL TYPE CALL POPARG( COMAND, COMAND) IF ( COMAND(1:1) .EQ. ' ' ) THEN IF (LATYPE .EQ. 0) THEN CALL DEBUGR( 'Labels are currently MASKED.') ELSEIF (LATYPE .EQ. 1) THEN CALL DEBUGR( 'Current labels are ATOM NUMBERS.') ELSEIF ( LATYPE .EQ. 2 ) THEN CALL DEBUGR( 'I am using ATOMIC SYMBOLS as labels.') ELSEIF ( LATYPE .EQ. 3 ) THEN CALL DEBUGR( 'Labels are SYMBOLS and ATOM NUMBERS.') ELSEIF ( LATYPE .EQ. 4 ) THEN CALL DEBUGR( 'Labels are USER DEFINED.') ELSE WRITE (*,*) 'UNKNOWN LABEL TYPE, LATYPE=',LATYPE ENDIF IF ( AUDIN .EQ. 0 ) THEN IF ( COMAND(1:1) .EQ. ' ') CALL UPROMP( . 'What do you want: Mask, Numbers, Symbols,'// . ' Both, User-defined ') READ ( *, '(A)', END=10) COMAND CALL LCLEAN( COMAND, COMAND,.TRUE.) IF ( AUDOUT .GT. 0 ) WRITE ( AUDOUT, '(A)') COMAND ELSE READ( AUDIN, '(A)', END=10) COMAND ENDIF ENDIF IF (COMAND(:1) .EQ. 'M') THEN IF ( LATYPE .NE. 0 ) THEN LATYPE = 0 REDRAW = .TRUE. ENDIF ELSEIF (COMAND(:1) .EQ. 'N') THEN IF ( LATYPE .NE. 1 ) THEN LATYPE = +1 REDRAW = .TRUE. ENDIF ELSEIF (COMAND(:1) .EQ. 'S') THEN IF ( LATYPE .NE. -1 ) THEN LATYPE = 2 REDRAW = .TRUE. ENDIF ELSEIF (COMAND(:1) .EQ. 'B') THEN IF ( LATYPE .NE. -1 ) THEN LATYPE = 3 REDRAW = .TRUE. ENDIF ELSEIF (COMAND(:1) .EQ. 'U') THEN IF ( LATYPE .NE. -1 ) THEN LATYPE = 4 REDRAW = .TRUE. ENDIF ELSE WRITE (*,*) 'NO CHANGE.' ENDIF CALL POPARG( COMAND, COMAND) IF ( REDRAW ) CALL SETLAB ELSEIF (COMAND( 1: 2) .EQ. 'MO') THEN IF ( ABS( EVAL(1)) .LT. 1.0D-2) THEN WRITE (*,'('' NO MOLECULAR ORBITALS AVAILABLE.'')') COMAND = ' ' GOTO 10 ENDIF IF ( ITS1 .EQ. 2 ) THEN WRITE (*,*) 'MO DISPLAY NOT AVAILABLE FOR NAMOD.' ELSEIF ( ITS1 .EQ. 4) THEN WRITE (*,*) 'MO DISPLAY NOT AVAILALBE FOR ORTEP.' ELSEIF ( ITS1 .EQ. 1) THEN WRITE (*,*) 'MO DISPLAY NOT AVAILABLE FOR STICKS.' ENDIF ISTYPE = (ISTYPE - (ISTYPE/10)*10) + 20 IF ( AUDIN .EQ. 0 ) THEN CALL UPROMP( 'Which MO number (default is HOMO) ') COMAND = ' ' READ ( *, '(A)', END=10) COMAND CALL LCLEAN( COMAND, COMAND,.TRUE.) IF ( AUDOUT .GT. 0 ) WRITE ( AUDOUT, '(A)') COMAND ELSE READ( AUDIN, '(A)', END=10) COMAND ENDIF IF ( COMAND(:4) .EQ. 'HOMO') THEN MO = 6 ELSEIF ( COMAND(:4) .EQ. 'LUMO') THEN MO = 7 ELSE MO = READA( COMAND, 1, ERROR) ENDIF WRITE (*,*) 'SORRY, MO CODE IS NOT DONE YET.' ELSEIF (COMAND(1:1) .EQ. 'V') THEN * TO DISPLAY VIBRATIONS FROM FILE CALL POPARG( COMAND, COMAND) IF ( ABS( VFREQ(1) ) .LT. 1.0D-2) THEN CALL DEBUGR( 'NO VIBRATION INFORMATION AVAILABLE.') COMAND = ' ' GOTO 10 ENDIF IF ( ITS1 .EQ. 2 ) THEN CALL DEBUGR('N.MODE DISPLAY NOT AVAILABLE FOR NAMODI.') CALL POPARG( COMAND, COMAND) GOTO 10 ELSEIF ( ITS1 .EQ. 4) THEN CALL DEBUGR( 'N.MODE DISPLAY NOT AVAILALBE FOR ORTEP.') CALL POPARG( COMAND, COMAND) GOTO 10 ENDIF REDRAW = .TRUE. NATOM1 = 0 DO 14 I= 1, NATOMS IF ( IE( I) .LT. 99 ) NATOM1 = NATOM1 + 1 14 CONTINUE IF ( AUDIN .EQ. 0 ) THEN IF ( COMAND( :1).EQ.' ') THEN CALL UPROMP('Which Normal mode '// . '( [+1], 0 stops, -# reverses phase) ? ' ) READ ( *, '(A)', END=10) COMAND CALL LCLEAN( COMAND, COMAND,.TRUE.) IF ( AUDOUT .GT. 0 ) WRITE ( AUDOUT, '(A)') COMAND ENDIF ELSE READ( AUDIN, '(A)', END=10) COMAND ENDIF IDVECT = READA( COMAND, 1, ERROR) CALL POPARG( COMAND, COMAND) IPHASE = 1 IF ( IDVECT .LT. 0 ) THEN IPHASE = -1 IDVECT = -IDVECT ENDIF IF (ERROR) THEN IDVECT = 1 ELSEIF (IDVECT .EQ. 0) THEN * TURN OFF THE NORMAL MODE DISPLAY ISTYPE = ITS1 ITEMP = 0 DO 70 I=1, NATOMS IF ( IE( I) .EQ. 200 ) GOTO 70 ITEMP = ITEMP + 1 70 CONTINUE NATOMS = ITEMP CALL DEBUGR( ' Stop NORMAL MODE display.' ) GOTO 10 ELSEIF ( IDVECT .GT. 3* NATOM1 ) THEN WRITE (*, '( 1X, ''MAXIMUM EIGENFUNCTION NUMBER IS '',I5)') . 3*NATOM1 GOTO 10 ENDIF ISTYPE = (ISTYPE - (ISTYPE/10)*10) + 40 IREM( 99) = 99 IREM( 200) = 200 IB = 0 NATOM1 = NATOMS NATOMS = 0 * LOOP THRU ATOMS TO SET WEIGHTS AND RESET NUMBER OF ATOMS DO 416 IA=1,NATOM1 IB = IB + 1 IF ( IE( IA) .LT. 200 ) NATOMS = NATOMS + 1 416 CONTINUE CALL XYZMND( NATOMS, CO, NA, NB, NC, XNDOGM) CALL GMETRY( NUATOM, NATOMS, IE, XNDOGM, NA, NB, NC, CO, ERROR) CALL ORIENT( CO, IE, FORORE, IEFOR, DISPL, ANGLES ) WRITE ( DUMMY, '('' MODE '', I5,'' WITH PHASE '',I2 )') . IDVECT, IPHASE CALL DEBUGR( DUMMY( 1: 26) ) VSCALE = 0.5D0 * IPHASE ITEMP = 0 NATOM1 = NATOMS DO 400 I= 1, NATOMS IF ( IE( I) .LT. 99 ) THEN IF ( DEBUG ) THEN WRITE ( DUMMY, '('' COORDS: '',3F9.6, . ''; COMPTS: '',3F9.6)') (CO( J,I), J= 1,3), . ( VIBVEC( ITEMP+J, IDVECT), J=1,3) CALL DEBUGR( DUMMY(1: 79) ) ENDIF NATOM1 = NATOM1 + 1 DO 401 J= 1, 3 401 CO( J, NATOM1 ) = CO( J,I)+VIBVEC( ITEMP+J, IDVECT)*VSCALE IE( NATOM1) = 200 NA( NATOM1) = I NB( NATOM1) = NA( I) NC( NATOM1) = NB( I) C? IF ( I .GT. 1) THEN C? NB( NATOM1 ) = NA( I) C? IF ( I .GT. 2) THEN C? NC( NATOM1) = NB( I) C? ELSEIF( NATOM1.GT.3) THEN C? NC( NATOM1) = 3 C? ENDIF C? ENDIF IF( I.EQ.1) THEN IF( NATOM1.EQ.3) THEN NB( NATOM1) = 2 ELSEIF( NATOM1.GT.3) THEN NB( NATOM1) = 2 NC( NATOM1) = 3 ENDIF ELSEIF( I.EQ.2) THEN IF( NATOM1.GT.3) NC( NATOM1) = 3 ENDIF LOOPER = 0 402 CONTINUE ITMP1 = NA( NATOM1) ITMP2 = NB( NATOM1) ITMP3 = NC( NATOM1) IF ( ITMP3 .LT. 1 ) ITMP3 = ITMP1 CALL BANGLE( ITMP1, ITMP2, ITMP3, ANGLE, CO) IF ( ABS( ANGLE-180.0D0) .LT. 1.0D-2) THEN LOOPER = LOOPER + 1 IF ( ITMP1.NE.1 .AND. ITMP2.NE.1 .AND. ITMP3.NE.1) THEN NC( NATOM1) = 1 GOTO 402 ELSEIF(ITMP1.NE.1 .AND. ITMP2.NE.1 .AND. ITMP3.NE.1) THEN NB( NATOM1) = 2 GOTO 402 ENDIF WRITE ( DUMMY, '('' DISPLAY: Could not rectify dihedral'', . '' on atom '', I4, ''.'')' ) NATOM1 CALL DEBUGR( DUMMY(1:60) ) ENDIF IMASK( NATOM1) = 1 ITEMP = ITEMP + 3 ENDIF 400 CONTINUE NATOMS = NATOM1 * NOW RE-CAST TRASNFORM GEOM WITH VIBRATIONS BACK TO "NORMAL" INTERNALS c? CALL XYZMND( NATOMS, CO, NA, NB, NC, XNDOGM) c? CALL GMETRY( NUATOM, NATOMS, IE, XNDOGM, NA, NB, NC, CO, ERROR) ELSEIF ( COMAND( 1: 1) .EQ. 'T' ) THEN * SETTING TITLE FOR DRAWING CALL POPARG( COMAND, COMAND) IF ( AUDIN .EQ. 0 ) THEN IF ( COMAND( 1:1) .EQ. ' ') THEN IF(LLEGND.EQ.' ') THEN WRITE ( *, *) ' What TITLE do you want? ' ELSE WRITE(*,*) ' What TITLE do you want? The default is:' ENDIF WRITE ( *, *) LLEGND( 1: MAX( 1, LLENG( LLEGND) ) ) CALL UPROMP( ' New title: ') COMAND = ' ' READ ( *, '(A)', END= 450) COMAND IF ( AUDOUT .GT. 0 ) WRITE ( AUDOUT, '(A)') COMAND ENDIF ELSE READ( AUDIN, '(A)', END= 450) COMAND ENDIF 450 IF ( LLENG( COMAND ) .LT. 1 ) THEN CALL UPROMP( 'Do you want to remove the title ? ') READ ( *, '(A)', END=450) COMAND CALL LCLEAN( COMAND, COMAND, .TRUE.) IF( COMAND( 1: 1) .EQ. 'Y') THEN LLEGND = ' ' CALL DEBUGR( 'Title removed.' ) ELSE CALL DEBUGR( 'Title unchanged.' ) ENDIF ELSE LLEGND = COMAND ENDIF COMAND = ' ' ELSEIF (COMAND( 1: 1) .EQ. 'C') THEN * TO SET NUMBER OF COORDINATES ON SCREEN CALL POPARG( COMAND, COMAND) IF ( AUDIN .EQ. 0 ) THEN IF ( COMAND( 1:1 ) .EQ. ' ') THEN WRITE ( *, '( 1X, ''Displaying '', I3, '' cartesian '', . ''coordinates starting with atom '',I4,''.'')') . ISCRN, KOROFF CALL UPROMP( 'How many lines do you want ? ' ) COMAND = ' ' READ ( *, '(A)', END=10) COMAND CALL LCLEAN( COMAND, COMAND,.TRUE.) IF ( AUDOUT .GT. 0 ) WRITE ( AUDOUT, '(A)') COMAND ENDIF ELSE READ( AUDIN, '(A)', END=10) COMAND ENDIF ITEMP1 = READA( COMAND, 1, ERROR) CALL POPARG( COMAND, COMAND) IF ( ERROR ) ITEMP1 = -1 IF ( AUDIN .EQ. 0 ) THEN IF ( COMAND( 1:1 ) .EQ. ' ') THEN WRITE( DUMMY, 1 '('' Which coordinate should I start with ['',I3,'' ]'')') 1 KOROFF CALL UPROMP( DUMMY(1: INDEX( DUMMY, ']')+1 ) ) READ ( *, '(A)', END=10) COMAND CALL LCLEAN( COMAND, COMAND,.TRUE.) IF ( AUDOUT .GT. 0 ) WRITE ( AUDOUT, '(A)') COMAND ENDIF ELSE READ( AUDIN, '(A)', END=10) COMAND ENDIF ITEMP2 = READA( COMAND, 1, ERROR) CALL POPARG( COMAND, COMAND) IF ( ERROR ) ITEMP2 = -1 IF ( ITEMP1 .GE. 0) THEN ISCRN = ITEMP1 REDRAW = .TRUE. ENDIF IF ( ITEMP2 .GE. 1) THEN KOROFF = ITEMP2 REDRAW = .TRUE. ENDIF ELSEIF( COMAND( 1: 2) .EQ. 'MA') THEN * SET COLOR MAP * NUMBER COLOR * * 1 WHITE * 2 RED * 3 GREEN * 4 BLUE * 5 CYAN * 6 MAGENTA * 7 YELLOW * 8 ORANGE * 9 GREEN-YELLOW * 10 GREEN-CYAN * 11 BLUE-CYAN * 12 BLUE-MAGENTA * 13 RED-MAGENTA * 14 DARK GRAY * 15 LIGHT GRAY * CALL POPARG( COMAND, COMAND) C? IF(COMAND(1:1) .EQ. 'T' .OR. COMAND(1:1).EQ.'C') THEN C? ELSEIF( COMAND(1;1) .EQ. 'P' .OR. COMAND(1:1).EQ. 'H') THEN C" ELSE C? WRITE (*,*) 'Do you want the color map for the' c? WRITE (*,*) ' Terminal or the Plotter?') C? ENDIF CALL DEBUGR( 'CURRENT TERMINAL COLOR USE') DUMMY = ' ' K = 1 DO 2030 I= 1, 200 DO 2020 J= 1, NATOMS IF ( IE( J) .EQ. I ) THEN ITEMP = ICOLAT( I) IF ( NCOLOR .LT. 1) THEN WRITE( DUMMY( K: ), '( A6, 1X, I3,'' '' )') ATSYMB( I), . ICOLAT( I ) ELSE IF( ITEMP.NE. MOD(ITEMP, 1+NCOLOR))THEN WRITE( DUMMY( K: ), '( A6, 1X, I3,''*'' )') ATSYMB( I), . MOD(ICOLAT( I ), NCOLOR) ELSE WRITE( DUMMY( K: ), '( A6, 1X, I3,'' '' )') ATSYMB( I), . MCOLOR( ICOLAT( I ) ) ENDIF ENDIF K = K + 15 IF( K.GE.65)THEN WRITE(*,*) DUMMY( 1:K) K = 1 ENDIF GOTO 2030 ENDIF 2020 CONTINUE 2030 CONTINUE IF( K.GT.1) CALL DEBUGR( DUMMY( 1: K ) ) CALL DEBUGR( '* means the result of modulo calculation.' ) IF ( ISCOLO .GT. 0 ) THEN WRITE (*,'('' This terminal recognizes '',I3, . '' colors.'')' ) NCOLOR WRITE (*,*) .' Nr. 1 2 3 4 5 6 7 8 9 10 11 12'// .' 13 14 15' WRITE (*,*) .' Whi. Red Grn. Blu Cyan Mag. Yel. Orn. G-Y G-C B-C B-M'// .' R-M DkGra LtGra' IF ( AUDIN .EQ. 0 ) THEN CALL UPROMP('Shall I KEEP or REMOVE colors? ') READ ( *, '(A)', END=10) COMAND CALL LCLEAN( COMAND, COMAND, .TRUE.) IF ( AUDOUT .GT. 0 ) WRITE ( AUDOUT, '(A)') COMAND ELSE READ( AUDIN, '(A)', END=10) COMAND ENDIF IF ( COMAND( 1: 1) .EQ. 'R' ) THEN CALL POPARG( COMAND, COMAND) ISCOLO = 0 CALL DEBUGR( 'Ok, no colors.' ) REDRAW = .TRUE. GOTO 10 ELSEIF ( COMAND(1:1) .EQ. 'K' .OR. COMAND(1:1) .EQ. ' ') THEN CALL POPARG( COMAND, COMAND) CALL DEBUGR( 'Ok, we keep.' ) ENDIF ELSE CALL DEBUGR( 'THIS TERMINAL DOES NOT CURRENTLY USE COLOR.' ) CALL UPROMP( 'How many colors would you like to use? ') READ( *, '(A)', END=10) COMAND CALL LCLEAN( COMAND, COMAND, .TRUE.) J = READA( COMAND, 1, ERROR) IF(ERROR)THEN CALL DEBUGR( 'I could not understand that.' ) GOTO 10 ELSE ISCOLO = J NCOLOR = J ENDIF ENDIF IF ( AUDIN .EQ. 0 ) THEN CALL UPROMP('Shall I CHANGE, KEEP, or REMOVE colors? ') READ ( *, '(A)', END=10) COMAND CALL LCLEAN( COMAND, COMAND, .TRUE.) IF ( AUDOUT .GT. 0 ) WRITE ( AUDOUT, '(A)') COMAND ELSE READ( AUDIN, '(A)', END=10) COMAND ENDIF IF ( COMAND( 1: 1) .EQ. 'R' ) THEN CALL POPARG( COMAND, COMAND) ISCOLO = 0 CALL DEBUGR( 'Ok, no colors.' ) REDRAW = .TRUE. GOTO 10 ELSEIF ( COMAND(1:1) .EQ. 'K' .OR. COMAND(1:1) .EQ. ' ') THEN CALL POPARG( COMAND, COMAND) CALL DEBUGR( 'Ok, we keep.' ) ELSEIF( COMAND(1:1) .EQ. 'C') THEN CALL DEBUGR( 'Changing Colors.' ) CALL POPARG( COMAND, COMAND) 4000 IF( COMAND(1:1) .EQ. ' ')THEN CALL UPROMP( . ' Enter an Atomic Symbol or Number and a Color number: ') READ(*, '(A)', END=10) COMAND CALL LCLEAN( COMAND, COMAND, .TRUE.) ENDIF IF ( COMAND(1:1).GE.'A' .AND. COMAND(1:1).LE.'Z')THEN I = INDEX( COMAND, ' ') J = NUMELE( COMAND( 1: I) ) ELSEIF( COMAND(1:1) .EQ. ' ')THEN GOTO 10 ELSE J = READA( COMAND, 1, ERROR) ENDIF CALL POPARG( COMAND, COMAND) IF( COMAND(1:1) .EQ. ' ')THEN CALL UPROMP( 'What COLOR for this atom? ') READ(*, '(A)', END=10) COMAND CALL LCLEAN( COMAND, COMAND, .TRUE.) ENDIF K = READA( COMAND, 1, ERROR) CALL POPARG( COMAND, COMAND) IF( ERROR )THEN CALL DEBUGR( 'I couldn''t understand the color.' ) ELSEIF( K.LE.0 .OR. K.GT.NCOLOR) THEN WRITE (*,*) 'Invalid color, ',NCOLOR,' is maximum.' ELSE ICOLAT( J) = K REDRAW = .TRUE. GOTO 4000 ENDIF ENDIF ELSE CALL DEBUGR( 'I didn''t recognize that...try Help.' ) COMAND = ' ' ENDIF GO TO 10 9000 RETURN END