PROGRAM DRAWII 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 C MAIN ROUTINE OF DRAWING PROGRAM C C NOTICE: This program contains segments of code C extracted in total from the packages: C NAMOD - a perspective plotting program C ORTEP - Oak Ridge Thermal Elipsoid Plotter C The only "new" code consists of front-end and C back-end logic to provide interactive operation C along with various user services such as C EDIT, INFORMATION, DISPLAY MODIFICATION, C STICK FIGURES, etc. C C With the exception of the NAMODI and ORTEP segments, C this program and associated subroutines lies TOTALLY C within the area of PUBLIC DOMAIN. C C MAJOR DONN M. STORCH, USAF C 1986 C C IMPLICIT REAL (A-H,O-Z) INCLUDE 'SIZES' REAL XMASS CHARACTER*80 FILEC,VNAME,FILEIN,FILOUT,FILPLT,FILMMI CHARACTER*80 KEYWRD,KOMENT,TITLE,COMAND, STRTMP, SUBCOM, LLEGND CHARACTER*80 DUMMY CHARACTER*3 FTYPE CHARACTER*4 EXTIN, EXTOUT, EXTPLT CHARACTER*1 ANSWER, ASCII, BELL CHARACTER*6 ATSYMB, ATLABS LOGICAL OPNERR, MODATA, ERROR, REDRAW, . RBELL, DOSUB, RESET, FIRST INTEGER FLAGS, DEVTYP, LINWID, LINSPP, AUDIN, AUDOUT INTEGER*2 ATBOND DIMENSION COBAK(3, NUMATM),EVEC(3,3), INVERT( 3) DIMENSION TEMCO(3,NUMATM) DIMENSION DISPL( 3), ANGLES( 3) 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 /FINFO/ DELTAH,RC,GRAD,RCGRAD,VIP,DIPOLE, ICHARG COMMON /FINFOC/ FTYPE COMMON /SYMTRY/ ISYM(10,NUMATM) COMMON /ASCIIC/ ASCII( 0: 255 ) COMMON /ATMASS/ ATMASS ( NUMATM ) COMMON /EXMASS/ XMASS( 200) COMMON /INTCOR/ XNDOGM(3, NUMATM), INTFRE(3, NUMATM) COMMON /KEYS/ KEYWRD,KOMENT,TITLE COMMON /COMM/ COMAND COMMON /FIRST/ FIRST COMMON /DEVICE/ ITYPE, ISCRN, KOROFF COMMON /ATSYMB/ ATSYMB( 200) COMMON /COLORS/ ICOLAT( 200) COMMON /LABELS/ ATLABS(NUMATM) COMMON /NAINTE/ NO,NUBOND,ITABLE,INDCL COMMON /ATOMS/ CO(3, NUMATM),IE( NUMATM),NATOMS, ATCHG( NUMATM) COMMON /GEOM/ COOLD(3, NUMATM),NA( NUMATM),NB( NUMATM),NC( NUMATM) COMMON /DISPLY/ IREM(200), BSCALE, ATBOND( NUMATM, NUMATM), . ISTYPE, LATYPE, IMASK( NUMATM), ISCOLO COMMON /HCPY/ JHDEV COMMON /LEGEND/ FILEIN,FILOUT,FILPLT, LLEGND C? COMMON /VANRAD/ VANRAD(200) C? COMMON /ATMRAD/ ATMRAD(200) LOGICAL DEBUG, DEBUGL, DEBUGN, DEBUGO, DEBUGP, DEBUGI COMMON /DEBCOM/ DEBUG, DEBUGL, DEBUGN, DEBUGO, DEBUGP, DEBUGI C DEBUGGING NOTES C DEBUG - GENERAL DEBUG LOGICAL * DEBUGL - DEBUG FOR LINE DRAWING * DEBUGN - DEBUG FOR NAGOYA * DEBUGO - DEBUG FOR ORTEP C DEBUGP - DEBUG FLAG FOR PLOTTING SUBROUTINES COMMON /EDIT/ MODATA, REDRAW COMMON /VALNCE/ MAXVAL(200) COMMON /OUTPUT/ IPAPER,IPAGE COMMON /ALLROT/ ROTPRD(3,3) EQUIVALENCE ( BELL, ASCII(7)) DATA FIRST /.TRUE./ C C## DATA ATSYMB/ C## . 'H', 'HE', 'LI', 'BE', 'B', 'C', 'N', 'O', 'F', 'NE', C## 1 'NA', 'MG', 'AL', 'SI', 'P', 'S', 'CL', 'AR', 'K', 'CA', C## 2 'SC', 'TI', 'V', 'CR', 'MN', 'FE', 'CO', 'NI', 'CU', 'ZN', C## 3 'GA', 'GE', 'AS', 'SE', 'BR', 'KR', 'RB', 'SR', 'Y', 'ZR', C## 4 'NB', 'MO', 'TC', 'RU', 'RH', 'PD', 'AG', 'CD', 'IN', 'SN', C## 5 'SB', 'TE', 'I', 'XE', 'CS', 'BA', 'LA', 'CE', 'PR', 'ND', C## 6 'PM', 'SM', 'EU', 'GD', 'TB', 'DY', 'HO', 'ER', 'TM', 'YB', C## 7 'LU', 'HF', 'TA', 'W', 'RE', 'OS', 'IR', 'PT', 'AU', 'HG', C## 8 'TL', 'PB', 'BI', 'PO', 'AT', 'RN', 'FR', 'RA', 'AC', 'TH', C## 9 'PA', 'U', 'NP', 'PU', 'AM', 'CM', 'BK', 'CF', 'XX', 'D', C## . '00', 'X', 'Z', 'DP', 'LP', '+', '-', '++', '--', 'ME', C## 1 'ET','IPR','BUT', 'PH', 'CH','CH2','CH3', 'OH','GLY','ALA', C## 2 'VAL','LEU','ILE','PHE','PRO','SER','THR','MET','CYS','TRP', C## 3 'ASN','GLN','ASP','GLU','TYR','LYS','ARG','HIS', 'TV', 'R', C## 4 'DD', 'CB','H2O','HOH', 6*' ', C## 5 '..', 49*' '/ C C## DATA VANRAD/ C## . 0.37, 0.93, 1.34, 0.90, 0.82, 0.77, 0.75, 0.73, 0.72, 1.31, C## 1 1.54, 1.30, 1.18, 1.11, 1.06, 1.02, 0.99, 1.74, 1.96, 1.74, C## 2 1.44, 1.36, 1.34, 1.27, 1.26, 1.26, 1.25, 1.24, 1.38, 1.31, C## 3 1.26, 1.22, 1.19, 1.16, 1.14, 1.89, 2.11, 1.92, 1.62, 1.48, C## 4 1.46, 1.39, 1.36, 1.34, 1.34, 1.37, 1.53, 1.48, 1.44, 1.41, C## 5 1.38, 1.35, 1.33, 2.09, 2.25, 1.98, 1.69, 1.65, 1.65, 1.64, C## 6 1.63, 1.66, 1.85, 1.61, 1.59, 1.59, 1.58, 1.57, 1.56, 1.70, C## 7 1.56, 1.58, 1.46, 1.39, 1.37, 1.35, 1.36, 1.38, 1.50, 1.49, C## 8 1.48, 1.47, 1.46, 1.46, 1.45, 2.14, 2.40, 2.40, 2.40, 1.65, C## 9 1.65, 7*1.42, 2*-10.0, C## . 9*-10.00, 0.77, C## H 8*0.75, 1.37, 1.50, C## I 10*1.50, C## J 8*1.50, -10., 0.77, C## L -10.,1.0,-10.,-10., 6*-10.0, C## Z 50*-10.00 / C C## DATA ATMRAD/ C## . 0.37, 0.93, 1.34, 0.90, 0.82, 0.77, 0.75, 0.73, 0.72, 1.31, C## 1 1.54, 1.30, 1.18, 1.11, 1.06, 1.02, 0.99, 1.74, 1.96, 1.74, C## 2 1.44, 1.36, 1.34, 1.27, 1.26, 1.26, 1.25, 1.24, 1.38, 1.31, C## 3 1.26, 1.22, 1.19, 1.16, 1.14, 1.89, 2.11, 1.92, 1.62, 1.48, C## 4 1.46, 1.39, 1.36, 1.34, 1.34, 1.37, 1.53, 1.48, 1.44, 1.41, C## 5 1.38, 1.35, 1.33, 2.09, 2.25, 1.98, 1.69, 1.65, 1.65, 1.64, C## 6 1.63, 1.66, 1.85, 1.61, 1.59, 1.59, 1.58, 1.57, 1.56, 1.70, C## 7 1.56, 1.58, 1.46, 1.39, 1.37, 1.35, 1.36, 1.38, 1.50, 1.49, C## 8 1.48, 1.47, 1.46, 1.46, 1.45, 2.14, 2.40, 2.40, 2.40, 1.65, C## 9 1.65, 7*1.42, 2*0.30, C## . 9*0.30, 0.77, C## H 8*0.75, 2*1.60, C## I 10*1.60, C## J 8*1.60, 0.30,0.77, C## L 0.30,1.0,0.30,0.30, 6*0.30, C## Z 50*0.30 / C C## DATA MAXVAL / C## . 1, 0, 1, 2, 3, 4, 3, 2, 1, 0, C## . 1, 2, 3, 4, 3, 2, 1, 0, 1, 2, C## . 10*6, C## . 6, 3, 4, 3, 2, 1, 0, 499, 499, 499, C## . 60*499, C## . 10*499, C## H 8*499, 2*2, C## I 10*2, C## J 8*2, 2*499, C## L 10*499, C## Z 50*499 / * C## DATA XMASS / 1.0078250D0, 4.0026D0, 6.939D0, 9.0122D0, C## . 10.811D0, 12.0D0, 14.067D0, 15.9994D0, 18.9984D0, 20.183D0, C## 3 22.9898D0, 24.312D0, 26.9815D0, 28.086D0, C## . 30.9738D0, 32.064D0, 35.453D0, 39.948D0, C## 4 39.102D0, 40.08D0, 44.956D0, 47.90D0, 50.942D0, C## . 51.996D0, 54.938D0, 55.847D0, 58.933D0, 58.71D0, C## . 63.54D0, 65.37D0, C## . 69.72D0, 72.59D0, 74.922D0, 78.96D0, 79.909D0, C## . 83.80D0, 85.47D0, 87.62D0, 88.905D0, 91.22D0, C## . 92.906D0, 95.94D0, C## . 98.00D0, 101.07D0, 102.905D0, 106.4D0, 107.870D0, C## . 112.40D0, 114.82D0, 118.69D0, 121.75D0, 127.60D0, C## . 126.904D0, 131.30D0, C## 6 132.905D0, 137.34D0, 138.91D0, 140.12D0, 140.907D0, C## . 144.24D0, 147.00D0, 150.35D0, 151.96D0, 157.25D0, C## . 158.924D0, 162.50D0, 164.930D0, 167.26D0, 168.934D0, C## . 173.04D0, 174.97D0, 178.49D0, 180.948D0, 183.85D0, C## . 186.2D0, 190.2D0, 192.2D0, 195.09D0, 196.967D0, C## . 200.59D0, 204.37D0, 207.19D0, 208.980D0, 210.00D0, C## . 210.00D0, 222.00D0, 114*0.000D0 / * * 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 * C## DATA ICOLAT C## . /15, 13, C## . 13,13, 13, 1, 4, 2, 3,13, C## . 13,13, 13, 4,13, 7, 3,13, C## . 13,13,13,13,13,13,13,13,13,13,13,13,13,13,13,13, 3,13, C## . 13,13,13,13,13,13,13,13,13,13,13,13,13,13,13,13, 3,13, C## . 13,13, C## . 13,13,13,13,13,13,13,13,13,13,13,13,13,13, C## . 13,13,13,13,13,13,13,13,13,13,13,13,13,13, 3,13, C## . 13,13, C## . 13,13,13,13,13,13,13,13,13,13,13,13,13,13, C## . 13,13,13,13,13,13,13,13,13,13,13,13,13,13, 3,13, C## . 3, 1, 1, 1, 1, 1, 1, 3, 3, 7, 7, 1, 3, 3, 2, 2, 3, 4, 4, 4, C## . 4*13, 58*13 / * C * HERE WE SET THE TYPE OF OFF-LINE HARDCOPY GRAPHICS * THE VALUES OF JHDEV ARE: * 1 => IDS PAPER TIGER * 2 => EPSON FX-80 * 3 => DEC LA50 * 4 => ZENITH MPI-99 * 5 => Hewlet-Packard STYLE PEN PLOTTER * * C C LETS SET THE SCALE INFORMATION TO DEFAULT C CALL MINMAX C JHDEV = 5 FTYPE = ' ' KEYWRD = ' ' TITLE = ' ' KOMENT = ' ' VDIST = 20.0 XBOUND = 12.0 YBOUND = 12.0 C? BORDER = 4.0 BORDER = 2.0 RETRAC = 0.000 C? IN600 = 4 IN600 = 3 XCENTR = 0.00 YCENTR = 0.00 C? SCOR1 = 0.00 SCOR1 = 2.00 SCOR2 = 1.54 REDUCT = 0.90 NORATM = 2 NORBON = 1 NRBOND = 4 BTHICK = 0.06 XTITLE = -0.15 YTITLE = -1.30 THEIT = 0.35 DO 3000 I= 0, 255 ASCII( I ) = CHAR( I ) 3000 CONTINUE IFIRST=0 ITABLE=1 ITYPE = 0 KOROFF = 1 IPAPER=100 IPAGE=100 OPNERR = .FALSE. MODATA = .FALSE. REDRAW = .FALSE. DOSUB = .FALSE. SUBCOM = ' ' FILEIN = ' ' JHDEV = -ABS(JHDEV) * C CALL SETTRM * * * SET ISTYPE FOR STICK DRAWING ISTYPE = 1 * SET LATYPE FOR ATOM NUMBERING LABELS LATYPE = +1 BSCALE = 1.4 RESET = .TRUE. DEBUG = .FALSE. DEBUGL = .FALSE. DEBUGN = .FALSE. DEBUGO = .FALSE. DEBUGP = .FALSE. MODATA = .FALSE. COMAND = ' ' EXTIN = '.OUT' EXTOUT = '.DAT' EXTPLT = '.PLT' * FIRST ALLOW EACH INDIVIDUAL ATOM AND ALL TYPES * EXCEPT DUMMIES (TYPE=XX) AND EDITED ATOMS (TYPE=DD) * AND HIDDEN-DUMMIES (TYPE=..) DO 2 I= 1, 200 IF ( ATSYMB(I)(1:2) .EQ. 'XX') THEN IREM(I) = I ELSEIF( ATSYMB(I)(1:2) .EQ. 'DD') THEN IREM(I) = I ELSEIF( ATSYMB(I)(1:2) .EQ. '..') THEN IREM(I) = I ELSE IREM(I) = 0 ENDIF 2 CONTINUE DO 3 I= 1, NUMATM IMASK(I)=0 3 CONTINUE CALL PLOT(0,0,1) CALL PLOT (0,0,6) CALL PLOT (0,0,8) ICLR=ISCRN IF (ITYPE .EQ. 1) ICLR = 1 IF ( ICLR .LT. 1) ICLR = 1 CALL DEBUGR( ' DRAW: VERSION 2.00' ) IR = 20 C? OPEN(UNIT=20, STATUS='UNKNOWN', IOSTAT = ITEMP) C? INQUIRE( UNIT=IR, NAME= STRTMP, IOSTAT = ITEMP, EXIST = OPNERR ) C? WRITE (*,*) STRTMP C? CLOSE( UNIT=20) C? IF( OPNERR ) GOTO 3002 CALL DEBUGR( ' ') CALL DEBUGR( ' by Maj. Donn Storch, USAF' ) CALL DEBUGR( ' ' ) CALL DEBUGR( ' Department of Chemistry' ) CALL DEBUGR( 'United States Air Force Academy, CO 80840-5700' ) CALL DEBUGR( ' ' ) CALL DEBUGR( ' For HELP enter ? at any time.' ) * ********* HERE FOR NEW INPUT FILE *************** 1 CONTINUE ISTYPE = MOD( ISTYPE, 10) CALL UPROMP( 'What is name of file ['//EXTIN//'] ') READ(5,'(A80)', END=4000) STRTMP 3002 CONTINUE ISEMI = INDEX( STRTMP, ';') IF ( ISEMI .GT. 0) STRTMP( ISEMI:ISEMI) = '@' 3001 ISLASH = INDEX( STRTMP, '/') IF ( ISLASH .GT. 0) THEN STRTMP( ISLASH: ISLASH) = '\\' GOTO 3001 ENDIF CALL LCLEAN( STRTMP, STRTMP, .TRUE.) ISEMI = INDEX( STRTMP, '@') IF ( ISEMI .GT. 0) STRTMP( ISEMI:ISEMI) = ';' * CHECK FOR HELP IF ( STRTMP(:1) .EQ. '?' ) THEN COMAND = 'DRAW' CALL HELP( COMAND ) COMAND = ' ' GOTO 1 ENDIF * CHECK FOR PRELIMINARY COMMANDS 2222 IZZ = INDEX( STRTMP, '\\') IF (IZZ .GT. 0) THEN IF (STRTMP(IZZ+1:IZZ+3) .EQ. '-H') THEN IREM(1)=1 STRTMP=STRTMP(:IZZ-1)//STRTMP(IZZ+3:) GOTO 2222 ELSEIF (STRTMP(IZZ+1:IZZ+4) .EQ. '+XX') THEN IREM(99)=0 STRTMP=STRTMP(:IZZ-1)//STRTMP(IZZ+4:) GOTO 2222 ELSEIF ( STRTMP( IZZ+1:IZZ+6) .EQ. 'ORTEP') THEN ISTYPE = 4 STRTMP = STRTMP( :IZZ-1)// STRTMP( IZZ+6: ) GOTO 2222 ELSEIF ( STRTMP( IZZ+1:IZZ+7) .EQ. 'NAMODI') THEN ISTYPE = 2 STRTMP = STRTMP( :IZZ-1)// STRTMP( IZZ+7: ) GOTO 2222 ELSEIF ( STRTMP( IZZ+1: IZZ+7) .EQ. 'DEBUGI') THEN DEBUGI = .TRUE. STRTMP = STRTMP( :IZZ-1)//STRTMP( IZZ+7:) GOTO 2222 ELSEIF ( STRTMP( IZZ+1:IZZ+6) .EQ. 'DEBUG') THEN DEBUG = .TRUE. STRTMP = STRTMP( :IZZ-1)//STRTMP( IZZ+6:) GOTO 2222 ELSEIF ( STRTMP( IZZ+1:IZZ+6) .EQ. 'RETRO') THEN ITYPE = 7 ISCRN = 20 STRTMP = STRTMP( :IZZ-1)//STRTMP(IZZ+6:) GOTO 2222 ENDIF ENDIF IF ( STRTMP(:1) .EQ. '*' ) THEN IF ( FILEIN(1:1) .EQ. ' ') THEN CALL DEBUGR('YOU WILL HAVE TO PROVIDE A FILE NAME FOR') CALL DEBUGR('SUBSEQUENT OPERATIONS.') ENDIF GOTO 6 ENDIF FILEIN = STRTMP DO 1000 I=1, 80 C CHECK FOR DIRECTORY/SUB DIRECTORY JUNK IF (STRTMP(I:I).EQ.']') INDIR=0 IF (STRTMP(I:I).EQ.'[') INDIR=1 IF (INDIR.EQ.1) GOTO 1000 IF (STRTMP(I:I).EQ.'.') GOTO 1010 IF (STRTMP(I:I).EQ.' ') GOTO 1005 1000 CONTINUE CALL DEBUGR( ' ERROR IN HANDLING FILE NAMES.') C APPLY DEFAULT EXTENSIONS C FIRST IS .ARC C?1005 IF ( I .LT. 2 ) CALL QUIT 1005 IF ( I .LT. 2 ) GOTO 4000 STRTMP(I:) = EXTIN IFILE = I + 4 FILEIN=STRTMP C NOW .PLT FOR PLOT 1010 IFILE = I + 4 STRTMP(I:) = EXTPLT FILPLT=STRTMP C NOW FOR THE OUTPUT FILE .DAT STRTMP(I:) = EXTOUT FILOUT=STRTMP C NOW FOR THE MOLECULAR MECHANICS FILE .MMI STRTMP(I+1:)= 'MMI' FILMMI=STRTMP C 6 IF ( RESET ) THEN CALL ROTCLR RESET = .FALSE. ENDIF NATOMS = 0 STRTMP = FILEIN C? LLEGND = FILEIN LLEGND = ' ' IR = 20 CALL GPRDR( IR, FILEIN, FTYPE, XNDOGM, IE, NATOMS, . NA, NB, NC, .TRUE. ) IF ( FTYPE .NE. 'TEC' ) THEN * RESET STRUCTURE TYPE IF IT IS SET FOR TEC FILE IF ( ISTYPE.EQ.9) ISTYPE = 1 IF (NATOMS.LT.0) THEN CLOSE (UNIT= IR) IF (NATOMS .EQ. -100) THEN FILEIN = STRTMP CALL DEBUGR( 'END OF FILE' ) GOTO 1 ELSEIF (OPNERR) THEN OPNERR = .FALSE. GOTO 1 ELSEIF (NATOMS .EQ. -1000) THEN CALL DEBUGR( 'NEW FILE' ) FILEIN = STRTMP OPNERR = .TRUE. GOTO 111 ELSE WRITE (*,*) 'DRAW: ERROR, NATOMS=',NATOMS ENDIF ENDIF 8 CONTINUE IF ( FTYPE .NE. 'PDB' .AND. FTYPE .NE. 'GIP') THEN CALL GMETRY( NUATOM, NATOMS, IE, XNDOGM, . NA, NB, NC, CO, ERROR) TEMPXX=CO(1,1) TEMPYY=CO(2,1) TEMPZZ=CO(3,1) CALL TOTROT(TEMPXX,TEMPYY,TEMPZZ) ENDIF IF ( IE( 1) .LE. NUMELE( 'GLY') ) CALL SETBON( .FALSE. ) CALL SETLAB CALL PLOT(0,0,9) 90 DO 10 IA=1,NATOMS DO 10 J=1,3 COBAK(J,IA)=CO(J,IA) COOLD(J,IA)=CO(J,IA) TEMCO(J,IA)=CO(J,IA) 10 CONTINUE C? IF ( AUDIN .EQ. 0) CALL PICTUR CALL PICTUR DOSUB = .TRUE. ENDIF 111 CALL PLOT(0,0,8) IF (RBELL ) WRITE (*,'(1X,A)') BELL REDRAW = .FALSE. IF ( DOSUB ) THEN COMAND = SUBCOM DOSUB = .FALSE. ENDIF IF ( COMAND(:1) .NE. ' ') GOTO 300 IF ( AUDIN .EQ. 0 ) THEN CALL UPROMP( 'DRAW> ' ) READ (5, '(A)', END=4000) COMAND ELSE READ( AUDIN, '(A)', END=4000) COMAND WRITE ( *, '(A)') 'AUDIT-IN> '//COMAND(1:60) ENDIF CALL LCLEAN ( COMAND, COMAND, .TRUE.) IF ( AUDOUT .GT. 0 ) WRITE( AUDOUT, '(A80)') COMAND 300 IF (COMAND(:1) .EQ. 'H' .OR. COMAND(:1) .EQ. '?') THEN COMAND = 'DRAW' CALL HELP( COMAND ) COMAND = ' ' ELSEIF( COMAND( 1:3) .EQ. 'ORI') THEN * TO ORIENT CALL ORIENT( TEMCO, IE, CO, IE, DISPL, ANGLES) ELSEIF (COMAND(:4) .EQ. 'BELL' ) THEN IF (RBELL ) THEN RBELL = .FALSE. ELSE RBELL = .TRUE. ENDIF ELSEIF (COMAND(:1) .EQ. 'B') THEN WRITE (*,'(1X,A)') BELL ELSEIF ( COMAND(:1) .EQ. 'C') THEN CALL POPARG( COMAND, COMAND) IF ( COMAND(:1) .EQ. ' ') THEN IF ( SUBCOM(:1) .EQ. ' ') THEN CALL DEBUGR( 'THERE IS NO COMMAND STORED.' ) ELSE WRITE ( *, *) SUBCOM(:79) ENDIF CALL UPROMP( 'Draw: COMMAND> ') READ (*, '( A )' ) COMAND CALL LCLEAN( COMAND, COMAND, .TRUE.) IF ( COMAND(:1) .EQ. 'Q') THEN SUBCOM = ' ' CALL DEBUGR( 'COMMAND ERASED.' ) ELSE SUBCOM = COMAND ENDIF ELSEIF ( COMAND(:1) .EQ. 'Q' ) THEN SUBCOM = ' ' CALL DEBUGR( 'COMMAND ERASED.' ) ELSE SUBCOM = COMAND ENDIF DOSUB = .TRUE. COMAND = ' ' ELSEIF ( COMAND(:3) .EQ. 'REF' ) THEN CALL POPARG( COMAND, COMAND) CALL LCLEAN( COMAND, COMAND, .TRUE.) IF ( NATOMS .LT. 1 ) THEN CALL DEBUGR( 'No atoms present, option not premitted.' ) ELSE * REFLECTION * CHECK FOR REFLECTION TYPE REDRAW = .FALSE. INVERT( 1) = 1 INVERT( 2) = 1 INVERT( 3) = 1 IF ( COMAND( :1) .EQ. ' ') THEN CALL UPROMP( . 'Specify reflection plane: XY, YZ, XZ, or INV: ') READ ( *, '( A )' ) COMAND ENDIF IF ( COMAND( :2).EQ.'XY' .OR. COMAND( :2).EQ.'YX' ) THEN INVERT( 3) = -1 REDRAW = .TRUE. ELSEIF (COMAND(:2).EQ.'YZ'.OR.COMAND(:2).EQ.'ZY') THEN INVERT( 1) = -1 REDRAW = .TRUE. ELSEIF (COMAND(:2).EQ.'XZ'.OR.COMAND(:2).EQ.'ZX') THEN INVERT( 2) = -1 REDRAW = .TRUE. ELSEIF ( COMAND( :2) .EQ. 'IN') THEN INVERT( 1) = -1 INVERT( 2) = -1 INVERT( 3) = -1 REDRAW = .TRUE. ELSE WRITE (*, *) 'NO REFLECTION SPECIFIED USE XY, YZ, OR XZ.' ENDIF IF ( REDRAW ) THEN CALL ROTSUM( dble(INVERT(1)), 0.0D0, 0.0D0, 0.0D0, . dble(INVERT(2)), 0.0D0,0.0D0, 0.0D0, dble(INVERT(3)) ) DO 41 IA = 1, NATOMS DO 41 J = 1, 3 COBAK( J, IA) = CO( J, IA) CO( J, IA) = CO( J, IA) * INVERT( J) 41 CONTINUE CALL PICTUR REDRAW = .FALSE. ENDIF ENDIF ELSEIF ( COMAND(:3) .EQ. 'RES' ) THEN CALL POPARG( COMAND, COMAND) IF ( NATOMS.LT.1 ) THEN CALL DEBUGR( 'No atoms present.' ) GOTO 111 ENDIF IF ( ISTYPE .LT. 10 ) THEN CALL ROTCLR CALL XYZMND( NATOMS, CO, NA, NB, NC, XNDOGM) CALL GMETRY( NUATOM, NATOMS, IE, XNDOGM, . NA, NB, NC, CO, ERROR) CALL SETBON( .FALSE. ) CALL PICTUR ELSE CALL DEBUGR( 'RESET NOT PERMITTED IN THIS SITUATION.') ENDIF ELSEIF (COMAND(:1) .EQ. 'G') THEN * Make GIP file FILEC = ' ' CALL POPARG( COMAND, COMAND) ISTART = 0 5050 CONTINUE ITEMP = INDEX( COMAND, ' ')-1 IF ((COMAND(1:1).GE.'0' .AND. COMAND(1:1).LE.'9') .AND. . ( COMAND(ITEMP:ITEMP).GE.'0' .AND. . COMAND(ITEMP:ITEMP).LE.'9')) THEN ISTART = READA( COMAND, 1, ERROR) IF( ERROR ) ISTART = 0 CALL POPARG( COMAND, COMAND) GOTO 5050 ELSEIF( COMAND(1:1) .NE. ' ') THEN FILEC = COMAND( 1: ITEMP) CALL POPARG( COMAND, COMAND) GOTO 5050 ENDIF CALL GIPOUT( ISTART, FILEC ) ELSEIF (COMAND(:2) .EQ. 'RO' .AND. NATOMS.GT.0 ) THEN REDRAW = .FALSE. DO 13 IA=1,NATOMS DO 13 J=1,3 COOLD(J,IA)=CO(J,IA) COBAK(J,IA)=CO(J,IA) 13 CONTINUE CALL POPARG( COMAND, COMAND) CALL ROTATE IF ( REDRAW ) THEN DO 14 IA=1,NATOMS DO 14 J=1,3 COOLD(J,IA)=CO(J,IA) 14 CONTINUE CALL SETBON( .FALSE. ) CALL PICTUR REDRAW = .FALSE. ENDIF ELSEIF (COMAND(:1) .EQ. 'S' .AND. NATOMS.GT.0 ) THEN * CALL AXIS AND PLACE MOLECULE BY SYMMETRY AXES CALL POPARG( COMAND, COMAND) IF (COMAND(:1) .EQ. ' ') THEN MASS = 2 ELSE MASS = READA( COMAND, 1, ERROR) CALL POPARG( COMAND, COMAND) ENDIF IF(MASS.LE.1) MASS=2 CALL XYZMND( NATOMS, CO, NA, NB, NC, XNDOGM) CALL GMETRY( NUATOM, NATOMS, IE, XNDOGM, . NA, NB, NC, CO, ERROR) IB = 0 DO 16 IA=1,NATOMS IB = IB + 1 ATMASS( IB ) = XMASS( IE( IA ) ) DO 15 J=1,3 COOLD(J,IA)=CO(J,IA) COBAK(J,IA)=CO(J,IA) 15 CONTINUE 16 CONTINUE CALL ROTCLR CALL AXIS(CO, IB, CMOM, BMOM, AMOM, SUMW, MASS, EVEC) CALL ROTSUM( EVEC(1,1), EVEC(1,2), EVEC(1,3), . EVEC(2,1), EVEC(2,2), EVEC(2,3), . EVEC(3,1), EVEC(3,2), EVEC(3,3) ) DO 17 IA=1,NATOMS DO 17 J=1,3 COOLD(J,IA)=CO(J,IA) 17 CONTINUE CALL SETBON( .FALSE. ) TEMPXX=CO(1,1) TEMPYY=CO(2,1) TEMPZZ=CO(3,1) CALL TOTROT(TEMPXX,TEMPYY,TEMPZZ) CALL PICTUR C? WRITE (*,7000) AMOM,BMOM,CMOM C? 7000 FORMAT (1X, 'MOMENTS OF INERTIA: A=',F10.6,', B=',F10.6, C? . '; C=',F10.6 ) ELSEIF (COMAND(1:6) .EQ. 'AUTHOR') THEN CALL DEBUGR( .'This program was written by Major D.M. STORCH, at USAF Academy') CALL POPARG( COMAND, COMAND) ELSEIF ( COMAND( 1:1) .EQ. 'A' ) THEN * REQUESTING AUDITING CALL POPARG( COMAND, COMAND) IF (COMAND( 1:1) .EQ. ' ') THEN CALL UPROMP(' Do you want INPUT or OUTPUT ? ') READ (*,'(A)', END=10) COMAND CALL LCLEAN( COMAND, COMAND, .TRUE.) ENDIF IF ( COMAND( 1:1) .EQ. 'I' ) THEN IF ( AUDIN .NE. 0 ) THEN CALL DEBUGR(' AUDIT input in progress.' ) GOTO 111 ENDIF CALL POPARG( COMAND, COMAND) IF (COMAND( 1:1) .NE. ' ') THEN CALL UPROMP(' What INPUT file [.AUD] ? ') READ(*, '(A)', END=10) DUMMY ELSE DUMMY = COMAND( 1: INDEX( COMAND, ' ') ) CALL POPARG( COMAND, COMAND) ENDIF CALL LCLEAN( DUMMY, DUMMY, .TRUE.) IDOT = INDEX( DUMMY, '.') IF ( IDOT .LT. 1) DUMMY = DUMMY(1:LLENG(DUMMY))//'.AUD' OPEN( UNIT=2, FILE=DUMMY, STATUS='OLD', ERR= 4321) REWIND 2 WRITE( DUMMY, '('' AUDIT INPUT FROM FILE '',A)') DUMMY CALL DEBUGR( DUMMY(1: LLENG( DUMMY) ) ) AUDIN = 2 GOTO 111 4321 CONTINUE CALL DEBUGR(' I can''t open that file.') GOTO 111 ELSEIF( COMAND( 1:1) .EQ. 'O') THEN IF ( AUDOUT .NE. 0 ) THEN CALL DEBUGR(' AUDIT output in progress.' ) CALL UPROMP(' Shall I stop auditing ? ') READ( *, '(A)', END=10) DUMMY CALL LCLEAN( DUMMY, DUMMY, .TRUE.) IF ( DUMMY(1:1) .EQ. 'Y') THEN CLOSE( AUDOUT ) AUDOUT = 0 CALL DEBUGR(' AUDIT output is ended, file closed.') ENDIF GOTO 111 ENDIF IF (COMAND(:1) .NE. ' ') THEN CALL UPROMP(' What OUTPUT file [.AUD] ? ') READ(*, '(A)', END=10) DUMMY ELSE DUMMY = COMAND( 1: INDEX( COMAND, ' ') ) CALL POPARG( COMAND, COMAND) ENDIF CALL LCLEAN( DUMMY, DUMMY, .TRUE.) IDOT = INDEX( DUMMY, '.') IF ( IDOT .LT. 1) DUMMY = DUMMY(1:LLENG(DUMMY))//'.AUD' OPEN( UNIT=3, FILE=DUMMY, STATUS='NEW', ERR= 4341) REWIND 3 WRITE( DUMMY, '('' AUDIT OUTPUT TO FILE '',A)') DUMMY CALL DEBUGR( DUMMY(1: LLENG( DUMMY) ) ) AUDOUT = 3 GOTO 111 4341 CONTINUE CALL DEBUGR(' I cannot open that output file.') GOTO 111 ENDIF ELSEIF (COMAND(1:1) .EQ. 'T') THEN * TERMINAL COMMAND CALL POPARG( COMAND, COMAND) IF (COMAND(:1) .EQ. ' ') THEN IF (ITYPE .EQ. 0) THEN WRITE (*,501) 'NON-GRAPHIC' ELSEIF (ITYPE .EQ. 1) THEN WRITE (*,501) '4025 (TEKTRONIX)' ELSEIF (ITYPE .EQ. 2) THEN WRITE (*,501) 'PRO350' ELSEIF (ITYPE .EQ. 3) THEN C? WRITE (*,501) 'USAFA TERAK 8600' ELSEIF (ITYPE .EQ. 4) THEN WRITE (*,501) 'USAFA VT10X' ELSEIF (ITYPE .EQ. 5) THEN WRITE (*,501) '41xx (TEKTRONIX)' ELSEIF (ITYPE .EQ. 6) THEN WRITE (*,501) 'DEC GIGI' ELSEIF (ITYPE .EQ. 7) THEN WRITE (*,501) 'RETRO-GRAPHICS ON VT-102' ELSEIF (ITYPE .EQ. 8) THEN WRITE (*,501) 'DEC 240' ELSEIF (ITYPE .EQ. 9) THEN WRITE (*,501) '4010 (TEKTRONIX)' ELSEIF (ITYPE .EQ. 10) THEN WRITE (*,501) 'HP GRAPHIC LANGUAGE' ELSEIF (ITYPE .EQ. 11) THEN WRITE (*,501) 'APOLLO COLOR WORKSTATION' ELSEIF (ITYPE .EQ. 12) THEN WRITE (*,501) 'APOLLO MONO WORKSTATION' ELSEIF (ITYPE .EQ. 15) THEN WRITE (*,501) 'X11 WORKSTATION' ELSEIF (ITYPE .EQ. 16) THEN WRITE (*,501) 'X11 WORKSTATION' ELSE WRITE (*,*) 'ERROR: Bad terminal type, ITYPE=',ITYPE ENDIF 501 FORMAT (' Current terminal type is ',A,'.' ) 510 CALL UPROMP( 'Draw:TERMINAL> ') READ (5, '(A80)', END=502) COMAND CALL LCLEAN( COMAND, COMAND, .TRUE.) ENDIF NTYPE = ITYPE IF (COMAND(:1) .EQ. 'N' ) THEN NTYPE = 0 ISCRN = 20 ELSEIF (COMAND(:4) .EQ. '4025') THEN NTYPE = 1 ISCRN = 26 ELSEIF (COMAND(:3) .EQ. 'PRO') THEN NTYPE = 2 ISCRN = 0 ELSEIF (COMAND(:3) .EQ. 'TER') THEN C? NTYPE = 3 C? ISCRN = 26 ISCRN = 0 CALL DEBUGR('That type is no longer available.') ELSEIF (COMAND(:2).EQ.'41') THEN NTYPE = 5 ISCRN = 26 ELSEIF (COMAND(:4) .EQ. 'GIGI') THEN NTYPE = 6 ELSEIF (COMAND(:4) .EQ. 'RETR') THEN NTYPE = 7 ISCRN = 24 ELSEIF (COMAND(:3) .EQ. '240' .OR. . COMAND(:3) .EQ. '241' .OR. . COMAND(:6) .EQ. 'DEC240' .OR. . COMAND(:6) .EQ. 'DEC241' .OR. . COMAND(:5) .EQ. 'VT240' .OR. . COMAND(:5) .EQ. 'VT241' ) THEN NTYPE = 8 ISCRN = 20 ELSEIF (COMAND(:3) .EQ. '401' ) THEN NTYPE = 9 ISCRN = 24 ELSEIF (COMAND(:2) .EQ. 'HP' ) THEN NTYPE = 10 ISCRN = 24 ELSEIF (COMAND(:5) .EQ. 'APCOL') THEN NTYPE = 11 ISCRN = 24 ELSEIF (COMAND(:5) .EQ. 'APMON') THEN NTYPE = 12 ISCRN = 24 ELSEIF (COMAND(:9) .EQ. 'BIG-COLOR') THEN NTYPE = 13 ISCRN = 40 ELSEIF (COMAND(:8) .EQ. 'BIG-MONO') THEN NTYPE = 14 ISCRN = 40 ELSEIF (COMAND(:4) .EQ. 'XCOL' ) THEN NTYPE = 15 ISCRN = 24 ELSEIF (COMAND(:4) .EQ. 'XMON' ) THEN NTYPE = 16 ISCRN = 24 ELSEIF ( COMAND(:1) .EQ. 'H' .OR. COMAND(:1) .EQ. '?' ) THEN COMAND = 'DRAW TERMINAL' CALL HELP ( COMAND ) COMAND = ' ' GOTO 510 ENDIF 502 IF ( NTYPE .NE. ITYPE) THEN CALL PLOT( 0, 0, 0) ITYPE = NTYPE CALL PLOT(0,0,1) CALL PLOT(0,0,6) CALL PLOT(0,0,8) CALL POPARG( COMAND, COMAND) GOTO 90 ENDIF CALL POPARG( COMAND, COMAND) ELSEIF (COMAND(:5) .EQ. 'DEBUG') THEN 333 CONTINUE CALL POPARG( COMAND, COMAND) IF ( COMAND( :1) .NE. ' ') GOTO 334 WRITE ( *, *) 'DEBUG: L N O P I' WRITE ( *, '( 6X, 6( 2X, L1) )' ) DEBUG, DEBUGL, DEBUGN, . DEBUGO, DEBUGP, DEBUGI CALL UPROMP( 'Draw: DEBUG> ') READ ( *, '( A )' ) COMAND CALL LCLEAN( COMAND, COMAND, .TRUE.) 334 IF ( COMAND( :1) .EQ. ' ' .OR. COMAND(:1) .EQ. 'Q' ) THEN CONTINUE ELSE IF ( COMAND(:6) .EQ. 'DEBUG ') THEN DEBUG = .NOT. DEBUG ELSEIF (COMAND(:6).EQ.'DEBUGL'.OR.COMAND(:1).EQ.'L') THEN DEBUGL = .NOT. DEBUGL ELSEIF (COMAND(:6).EQ.'DEBUGN'.OR.COMAND(:1).EQ.'N') THEN DEBUGN = .NOT. DEBUGN ELSEIF (COMAND(:6).EQ.'DEBUGO'.OR.COMAND(:1).EQ.'O') THEN DEBUGO = .NOT. DEBUGO ELSEIF (COMAND(:6).EQ.'DEBUGP'.OR.COMAND(:1).EQ.'P') THEN DEBUGP = .NOT. DEBUGP ELSEIF (COMAND(:6).EQ.'DEBUGI'.OR.COMAND(:1).EQ.'I') THEN DEBUGI = .NOT. DEBUGI ENDIF GOTO 333 ENDIF ELSEIF (COMAND(:1) .EQ. 'D') THEN CALL POPARG( COMAND, COMAND) CALL DSPLAY IF ( REDRAW ) THEN CALL SETBON( .FALSE. ) CALL PICTUR REDRAW = .FALSE. ENDIF ELSEIF (COMAND(:2) .EQ. 'MM' .AND. NATOMS.GT.0 ) THEN * MOLECULAR MECHANICS FILE GENERATION CALL POPARG( COMAND, COMAND) IF (COMAND(:1) .NE. '*' .AND. COMAND(:1) .NE. ' ') THEN IDOT=INDEX(COMAND,'.') IF (IDOT .LT. 1) . COMAND=COMAND(:INDEX(COMAND,' ')-1)//'.MMI' FILMMI=COMAND ELSEIF (COMAND(:1) .EQ. '*') THEN IBRAK=INDEX(FILMMI,']') IF (IBRAK .GT. 2) FILMMI=FILMMI(IBRAK+1:) CALL POPARG( COMAND, COMAND) ENDIF CALL MMIOUT( FILMMI ) ELSEIF (COMAND(:2) .EQ. 'MO' ) THEN IF ( NATOMS.LT.1 ) THEN CALL DEBUGR( 'No atoms present.' ) ELSE * MOVE THE GEOMETRY DO 18 IA=1,NATOMS DO 18 J=1,3 COBAK(J,IA)=CO(J,IA) 18 CONTINUE CALL MOVE IF ( REDRAW ) THEN DO 19 IA=1,NATOMS DO 19 J=1,3 COOLD(J,IA)=CO(J,IA) 19 CONTINUE CALL SETBON( .FALSE. ) CALL PICTUR MODATA = .TRUE. REDRAW = .FALSE. ENDIF ENDIF ELSEIF (COMAND(:1) .EQ. 'Q') THEN GOTO 4000 ELSEIF (COMAND(:1) .EQ. 'I') THEN * REQUEST FOR INFORMATION CALL POPARG( COMAND, COMAND) CALL INFO DOSUB = .FALSE. GOTO 111 ELSEIF (COMAND(:1) .EQ. 'P') THEN * PRODUCE PLOTTER FILE IPAP2=IPAPER CALL POPARG( COMAND, COMAND) 40 CONTINUE ITEMP = INDEX( COMAND, ' ')-1 IF (( COMAND(:1) .GE. '0' .AND. COMAND(:1) .LE. '9') .AND. . (COMAND(ITEMP:ITEMP).GE.'0' .AND. . COMAND(ITEMP:ITEMP).LE.'9')) THEN ITEMP=READA(COMAND,1,ERROR) IF (ERROR) THEN WRITE (*,*) 'ERROR, PLOT SCALE IS ',IPAPER ELSE IPAPER=ITEMP ENDIF ELSEIF (COMAND(:1) .NE. '*' .AND. COMAND(:1) .NE. ' ') THEN IDOT=INDEX(COMAND,'.') IF (IDOT .LT. 1) . COMAND=COMAND(:INDEX(COMAND,' ')-1)//EXTPLT FILPLT=COMAND ELSEIF (COMAND .EQ. '*') THEN IBRAK=INDEX(FILPLT,']') IF (IBRAK .GT. 2) FILPLT=FILPLT(IBRAK+1:) CALL POPARG( COMAND, COMAND) ENDIF CALL POPARG( COMAND, COMAND) IF (COMAND(:1) .NE. ' ') GOTO 40 IF (IPAPER .LT. 10) IPAPER = 100 / IPAPER CALL OUTPLT IPAPER=IPAP2 ITEMP=INDEX(FILPLT,' ') ELSEIF (COMAND(:1) .EQ. 'L' .AND. NATOMS.GT.0 ) THEN DO 50 IA=1,NATOMS DO 50 J=1,3 CO(J,IA) = COBAK(J,IA) 50 CONTINUE CALL POPARG( COMAND, COMAND) GOTO 90 ELSEIF( COMAND(1:3) .EQ. 'NEW') THEN COMAND = ' ' CALL DEBUGR( ' Quitting current file...') IR = -IR CALL GPRDR( IR, FILEIN, FTYPE, XNDOGM, IE, NATOMS, . NA, NB, NC, .TRUE. ) GOTO 1 ELSEIF (COMAND(1:1) .EQ. 'N') THEN * NEXT GEOMETRY DESCRIPTION IF ( COMAND(2:2) .EQ. '+') COMAND(2: ) = ' '//COMAND(2:) KPOINT = 0 55 CONTINUE CALL POPARG( COMAND, COMAND) RESET = .FALSE. IF (COMAND(:1) .EQ. 'R') THEN RESET = .TRUE. GOTO 55 ELSEIF ( COMAND(1:1) .EQ. '+') THEN KPOINT = READA( COMAND, 2, ERROR) IF( ERROR ) THEN CALL DEBUGR( 'I don''t understand the point number.') GOTO 111 ENDIF KPOINT = KPOINT + ICHARG * NOTE: ICHARG IS USED AS NUMBER OF CURRENT POINT FOR DRC'S GOTO 55 ELSEIF ( COMAND(1:1) .GE. '0' .AND. COMAND(1:1) .LE. '9' ) THEN KPOINT = READA( COMAND, 1, ERROR) GOTO 55 ENDIF IF ( (FTYPE.EQ.'DRC' .OR. FTYPE.EQ.'IRC') . .AND. KPOINT.GT.0 ) THEN 3111 CALL GPRDR( IR, FILEIN, FTYPE, XNDOGM, IE, NATOMS, . NA, NB, NC, .TRUE. ) IF ( NATOMS .LT. 0 ) THEN WRITE(*,'('' END OF DRC/IRC FILE...LAST POINT IS '',I8)') . ICHARG ELSE IF ( KPOINT .GT. ICHARG) GOTO 3111 IF ( KPOINT .LT. ICHARG) . WRITE (*,'('' Closest following point is '',I8)') . ICHARG ENDIF GOTO 8 ELSE DO 56 I = 1, KPOINT CALL GPRDR( IR, FILEIN, FTYPE, XNDOGM, IE, NATOMS, . NA, NB, NC, .TRUE. ) IF ( NATOMS .LT. 0 ) THEN WRITE(*, '('' END OF INPUT FILE...LAST POINT IS '', . I8)') ICHARG GOTO 8 ENDIF 56 CONTINUE ENDIF GOTO 6 ELSEIF( COMAND(1:3) .EQ. 'EXT') THEN * EXTRACT FROM IRC/DRC FILE IF( FTYPE .NE. 'DRC' .AND. FTYPE.NE.'IRC')THEN CALL DEBUGR( 'Sorry, this is the wrong file type.') ELSE CALL DRCEXT ENDIF ELSEIF (COMAND(1:1) .EQ. 'E') THEN * SET UP FOR EDIT COMMAND DO 20 IA=1,NATOMS DO 20 J=1,3 COOLD(J,IA)=CO(J,IA) COBAK(J,IA)=CO(J,IA) 20 CONTINUE CALL POPARG( COMAND, COMAND) CALL EDITOR IF ( REDRAW ) THEN DO 21 IA=1,NATOMS DO 21 J=1,3 COOLD(J,IA)=CO(J,IA) COBAK(J,IA)=CO(J,IA) 21 CONTINUE CALL SETBON( .FALSE. ) CALL PICTUR REDRAW = .FALSE. ENDIF ELSEIF (COMAND(:1) .EQ. 'O') THEN * OUTPUT COMMAND TO MAKE A DATA FILE CALL POPARG( COMAND, COMAND) IF (COMAND(:1) .NE. '*' .AND. COMAND(:1) .NE. ' ') THEN IDOT=INDEX(COMAND,'.') IF (IDOT .LT. 1) . COMAND=COMAND(:INDEX(COMAND,' ')-1)//EXTOUT FILOUT=COMAND ELSEIF (COMAND .EQ. '*') THEN IBRAK=INDEX(FILOUT,']') IF (IBRAK .GT. 2) FILOUT=FILOUT(IBRAK+1:) ENDIF CALL POPARG( COMAND, COMAND) IF( NATOMS .LT. 1 ) THEN CALL DEBUGR( 'OUTPUT forbidden because there are no atoms.') GOTO 111 ENDIF OPEN (UNIT=7,FILE=FILOUT,STATUS='NEW', ERR=92) REWIND 7 CALL XYZMND( NATOMS, CO, NA, NB, NC, XNDOGM) CALL MNDOUT CLOSE (UNIT=7) ITEMP=INDEX(FILOUT,' ') WRITE (*,*) 'Internal coordinates written to '//FILOUT(:ITEMP) MODATA = .FALSE. GOTO 111 92 WRITE (*,*) 'ERROR OPENING: '//FILOUT(:ITEMP)//' ABORTED.' ELSE CALL DEBUGR( 'I don''t understand') COMAND = ' ' ENDIF CALL POPARG( COMAND, COMAND) DOSUB = .FALSE. GOTO 111 4000 CONTINUE IF ( AUDIN .GT. 0 ) THEN CLOSE( AUDIN) AUDIN = 0 CALL DEBUGR( 'End of AUDIT INPUT, reverting to manual input.') GOTO 111 ENDIF IF (MODATA ) THEN CALL DEBUGR( 'You have not saved your modified geometry.') CALL DEBUGR( 'Use OUTPUT command to save new geometry or') CALL DEBUGR( 'repeat the command to quit without save.') MODATA = .FALSE. CALL POPARG( COMAND, COMAND) GOTO 111 ELSE C? CALL QUIT CALL PLOT( 0, 0, 0) STOP ' ' ENDIF END