SUBROUTINE INFO 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) INTEGER*2 ATBOND CHARACTER*80 COMAND,VNAME,FILEIN,FILOUT,FILPLT, LLEGND CHARACTER*80 KEYWRD, KOMENT, TITLE, STEMP, DUMMY CHARACTER*6 ATSYMB CHARACTER*3 FTYPE LOGICAL ERROR, VALMSG REAL DENMAT, BONDS REAL VFREQ, VIBVEC COMMON /SYMTRY/ ISYM(10,NUMATM) COMMON /KEYS/ KEYWRD, KOMENT, TITLE LOGICAL DEBUG, DEBUGL, DEBUGN, DEBUGO, DEBUGP, DEBUGI COMMON /DEBCOM/ DEBUG, DEBUGL, DEBUGN, DEBUGO, DEBUGP, DEBUGI COMMON /ATSYMB/ ATSYMB( 200) COMMON /COLORS/ ICOLAT( 200) COMMON /ATOMS/ CO(3, NUMATM),IE( NUMATM),NATOMS, ATCHG( NUMATM) C? COMMON /VANRAD/ VANRAD(200) COMMON /INTCOR/ XNDOGM(3, NUMATM), INTFRE(3, NUMATM) COMMON /DISPLY/ IREM(200), BSCALE, ATBOND( NUMATM, NUMATM), . ISTYPE, LATYPE, IMASK( NUMATM), ISCOLO COMMON /VALNCE/ MAXVAL(200) COMMON /LEGEND/ FILEIN,FILOUT,FILPLT, LLEGND COMMON /FINFO/ DELTAH,RC,GRAD,RCGRAD,VIP,DIPOLE, ICHARG COMMON /FINFOC/ FTYPE COMMON /DENSTY/ DENMAT( MPACK ), BONDS( MPACK ) COMMON /FORCE/ VFREQ(3*NUMATM), VIBVEC(3*NUMATM,3*NUMATM), IDVECT COMMON /COMM/ COMAND COMMON / PATH / ICPATH, NPATH, PATH( 30) 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 * * DIMENSION ICOUNT( 200),IELEC(200) DIMENSION IRADUS( NUMATM), TRADUS( NUMATM) C DATA IELEC/1,2,1,2,3,4,5,6,7,8,1,2,3,4,5,6,7,8, . 1,2,10*0,3,4,5,6,7,8,1,2,10*0,3,4,5,6,7,8, . 46*0, Z 100*0 / ** ** LOCAL FUNCTION FOR 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 10 CALL LCLEAN( COMAND, COMAND, .TRUE.) IF ( COMAND(1:1) .NE. ' ') GOTO 11 CALL UPROMP( 'Draw:INFO> ') READ (5,2000,END=4000) COMAND 11 CALL LCLEAN( COMAND, COMAND, .TRUE.) 2000 FORMAT (A80) IF (COMAND(:1) .GE. '0' .AND. COMAND(:1) .LE. '9') THEN IPT1 = READA( COMAND, 1, ERROR) CALL POPARG( COMAND, COMAND) IF (ERROR) THEN CALL DEBUGR( 'READA ERROR.') GOTO 10 ENDIF IF (IPT1 .GT. NATOMS .OR. IPT1.LT.1) THEN WRITE (*,*) 'INVALID NUMBER',IPT1 GOTO 10 ENDIF IF (COMAND(:1).LT.'0' .OR. COMAND(:1).GT.'9') THEN WRITE (*,1005) IPT1,ATSYMB(IE(IPT1)),(CO(IZ,IPT1),IZ=1,3) 1005 FORMAT (' Atom Nr. ',I3,', is ',A5,' at:',3F8.4,'; BONDS:') IIT = 1 DO 26 J=1,NATOMS IF (J .EQ. IPT1) GOTO 26 IF ( ATBOND( IPT1,J) .GT. 0 ) THEN DIST=ATDIST(IPT1,J) WRITE (STEMP( IIT:),1006) J,DIST 1006 FORMAT ( 1X,' To: ',I3,' by ', F7.4,';' ) IIT = INDEX( STEMP( IIT:), ';') + IIT IF ( IIT .GT. 59 ) THEN WRITE ( *, '( A )' ) STEMP(:IIT-2)//'.' STEMP = ' ' IIT = 1 ENDIF ENDIF 26 CONTINUE IF ( IIT .GT. 3 ) WRITE ( *, '( A ) ' ) STEMP(:IIT-2)//'.' GOTO 10 ENDIF IPT2 = READA( COMAND, 1, ERROR) CALL POPARG( COMAND, COMAND) IF (IPT2 .GT. NATOMS .OR. IPT2.LT.0) THEN WRITE ( DUMMY, '('' INVALID NUMBER'',I8)') IPT2 CALL DEBUGR( DUMMY( 1: 24) ) GOTO 10 ENDIF IF (COMAND(:1).LT.'0' .OR. COMAND(:1).GT.'9') THEN DIST=ATDIST(IPT1,IPT2) WRITE (*,1015) IPT1,IPT2,DIST 1015 FORMAT (1X,'Atoms',I4,' and',I4,' separated by',F12.6, 1 ' Angstroms.') GOTO 10 ENDIF IPT3 = READA( COMAND, 1, ERROR) CALL POPARG( COMAND, COMAND) IF (IPT3 .GT. NATOMS) THEN WRITE (*,*) 'INVALID NUMBER',IPT3 GOTO 10 ENDIF IF (COMAND(:1).LT.'0' .OR. COMAND(:1).GT.'9') THEN CALL BANGLE(IPT1,IPT2,IPT3,ANGLE, CO) WRITE (*,1025) IPT1,IPT2,IPT3,ANGLE 1025 FORMAT (1X,'Angle',2(I4,','),I4,' is ',F10.6, 1 ' degrees.') GOTO 10 ELSE IPT4 = READA( COMAND, 1, ERROR) CALL POPARG( COMAND, COMAND) IF (IPT4 .GT. NATOMS) THEN WRITE (*,*) 'INVALID NUMBER',IPT4 GOTO 10 ENDIF CALL DIHED(IPT1,IPT2,IPT3,IPT4,ANGLE, CO) WRITE (*,1035) IPT1,IPT2,IPT3,IPT4,ANGLE 1035 FORMAT (1X,'Atoms',3(I4,','),I4,' describe a', 1 ' dihedral of ', F11.6,' degrees.') GOTO 10 ENDIF ELSEIF( COMAND(1:3) .EQ. 'DOF') THEN * FIND SPECIFIC DEGREE OF FREEDOM CALL POPARG( COMAND, COMAND) IF ( COMAND(1:1) .EQ. ' ') THEN CALL UPROMP('Which Degree of Freedom (DOF)do you want? ') READ( *, '(A)', END=10) COMAND ENDIF IFREE = READA( COMAND, 1, ERROR) CALL POPARG( COMAND, COMAND) IF (ERROR) THEN CALL DEBUGR('I do not understand that request.') GOTO 10 ENDIF KCOUNT = 0 DO 210 I= 1, NATOMS DO 210 J= 1, 3 IF ( INTFRE( J, I) .EQ. 1 ) THEN KCOUNT = KCOUNT + 1 IF ( KCOUNT .EQ. IFREE) THEN WRITE( DUMMY, '('' D.O.F. '',I4,'' IS FOR THE DISTANCE'', . '' OF ATOM '',I4)') IFREE, I IF( J .EQ. 2) THEN DUMMY( 25:32) = 'ANGLE' ELSEIF( J.EQ. 3) THEN DUMMY( 25:32) = 'DIHEDRAL' ENDIF CALL DEBUGR( DUMMY(1:50) ) GOTO 10 ENDIF ENDIF 210 CONTINUE WRITE( DUMMY, '('' SORRY, '',I4,'' IS THE MAXIMUM D.O.F.'')') . KCOUNT CALL DEBUGR( DUMMY(1:30) ) ELSEIF (COMAND(:1) .EQ. 'R' ) THEN * search of atoms in a radius * Radius ## [RADIUS] [SS] * where ## is atom number * RADIUS is radius of search * SS is type of atom to look for CALL POPARG( COMAND, COMAND) IMATCH = 0 IF ( COMAND( 1:1) .EQ. ' ') THEN CALL UPROMP( 'Search around what atom number? ') READ ( *, '(A)', END=10) COMAND CALL LCLEAN( COMAND, COMAND, .TRUE.) ENDIF ICTR = READA( COMAND, 1, ERROR) CALL POPARG( COMAND, COMAND) IF ( ICTR .LT. 1 .OR. ICTR .GT. NATOMS .OR. ERROR ) THEN CALL DEBUGR( 'Error on your atom number.') GOTO 10 ENDIF IF ( COMAND( 1:1) .GE. '0' .AND. COMAND(1:1) .LE. '9' ) THEN RADIUS = READA( COMAND, 1, ERROR) CALL POPARG( COMAND, COMAND) IF ( RADIUS .LT. 5.0D-2 .OR. ERROR ) THEN CALL DEBUGR( 'I don''t understand the RADIUS.') GOTO 10 ENDIF ELSE RADIUS = 5.0 ENDIF IF ( COMAND( 1:1) .GE. 'A' .AND. COMAND( 1:1) .LE. 'Z') THEN I = INDEX( COMAND, ' ') - 1 IMATCH = NUMELE( COMAND(1: I) ) CALL POPARG( COMAND, COMAND) IF ( IMATCH .LT. 1 ) THEN CALL DEBUGR( 'I do not recognize that atomic symbol.') GOTO 10 ENDIF ENDIF WRITE (*,'('' Search radius '', F8.2,'' about atom'', I4)') . RADIUS, ICTR IF ( IMATCH .GT. 0 ) . WRITE (*, *) 'Matching only '//ATSYMB(IMATCH) IIIRAD = 0 DO 1220 I= 1, NATOMS IF ( I .EQ. ICTR) GOTO 1220 IF ( IMATCH .GT. 0 .AND. IMATCH .NE. IE( I ) ) GOTO 1220 DIST=ATDIST(I, ICTR) IF ( DIST .LT. RADIUS ) THEN IIIRAD = IIIRAD + 1 IRADUS( IIIRAD) = I TRADUS( IIIRAD) = DIST ENDIF 1220 CONTINUE DO 1222 I= 1, IIIRAD-1 DO 1222 J= I+1, IIIRAD IF ( TRADUS( I) .GT. TRADUS( J) ) THEN TEMP = TRADUS( I) TRADUS( I) = TRADUS( J) TRADUS( J) = TEMP ITEMP = IRADUS( I) IRADUS( I) = IRADUS( J) IRADUS( J) = ITEMP ENDIF 1222 CONTINUE IIT = 1 STEMP = ' ' DO 1200 I= 1, IIIRAD WRITE (STEMP( IIT:), 1007) IRADUS( I), TRADUS( I) IIT = INDEX( STEMP( IIT:), ';') + IIT IF ( IIT .GT. 59 ) THEN WRITE ( *, '( A )' ) STEMP(:IIT-2)//',' STEMP = ' ' IIT = 1 ENDIF 1200 CONTINUE 1007 FORMAT ( 1X,' Atom ',I3,' at ', F7.4,';' ) IF ( IIT .GT. 3 ) THEN WRITE ( *, '( A )' ) STEMP(:IIT-2)//'.' ENDIF ELSEIF ( COMAND(1:1) .EQ. 'E' ) THEN * user wants to know the Euler equivalent rotation CALL POPARG( COMAND, COMAND) CALL PREULR( THETA, PHI, PSI ) WRITE ( DUMMY, . '('' EULERIAN EQUIVALENT: THETA='', F12.6,'' PHI='', . F12.6, '' PSI='', F12.6)') THETA, PHI, PSI CALL DEBUGR( DUMMY( 1: 79) ) ELSEIF (COMAND(1:1) .EQ. 'B' ) THEN * user wants bond order information CALL POPARG( COMAND, COMAND) IF ( BONDS( 1 ) .LT. 1.0D-4 ) THEN CALL DEBUGR( 'No BONDORDER information present.') ELSE K = 0 DO 4100 I = 1, NATOMS STEMP = ' ' IL = 0 DO 4200 J = 1, I K = K + 1 WRITE ( STEMP(6*IL+1:), '(F5.3)') BONDS(K) IL = IL + 1 IF ( IL .GE. 10 ) THEN WRITE (*,*) STEMP(1:6*IL) IL = 0 ENDIF 4200 CONTINUE IF ( IL .GT. 0 ) WRITE (*,*) STEMP(1:6*IL) 4100 CONTINUE ENDIF ELSEIF (COMAND(:1) .EQ. 'I') THEN * USER ASKED FOR INFORMATION WRITE ( *, '( A )' ) ' FILE TYPE IS '//FTYPE IF ( FTYPE .EQ. 'ARC' .OR. FTYPE .EQ. 'OUT') THEN WRITE ( *, '( A79 )' ) KEYWRD WRITE ( *, '( A79 )' ) KOMENT WRITE ( *, '( A79 )' ) TITLE WRITE (*,3000) DELTAH, VIP WRITE (*,3020) GRAD, ICHARG IF (RCGRAD.NE.0.0 .OR. RC.NE.0.0) . WRITE (*,3010) RC, ICPATH, RCGRAD IF (DIPOLE .GT. 0.0D0) WRITE (*,3030) DIPOLE 3000 FORMAT (1X, 'HEAT OF FORMATION = ',F12.5, . ' IONISATION POTENTIAL = ',F12.5) 3010 FORMAT (1X, 'REACTION COORDINATE ',F12.5, . ' on atom ',I4,' GRADIENT ',F12.5) 3020 FORMAT (1X, 'GRADIENT NORM = ',F12.5, . ' CHARGE ON SYSTEM ', I3) 3030 FORMAT (1X, ' MOLECULAR DIPOLE = ',F12.5) ELSEIF( FTYPE .EQ. 'GEO') THEN WRITE ( *, '( A79 )' ) KEYWRD WRITE ( *, '( A79 )' ) KOMENT WRITE ( *, '( A79 )' ) TITLE ELSEIF( FTYPE .EQ. 'TEC') THEN WRITE (*, '(A79)' ) KEYWRD WRITE (*, '(A79)' ) KOMENT WRITE (*, '(A79)' ) TITLE ELSEIF( FTYPE.EQ.'DRC' ) THEN WRITE ( *, '( A79 )' ) KEYWRD WRITE ( *, '( A79 )' ) KOMENT WRITE ( *, '( A79 )' ) TITLE ETIME = DELTAH EXKIN = RC ENERR = GRAD EPOT = RCGRAD EKINET = VIP IREFNR = INT(DIPOLE) IPOINT = ICHARG WRITE ( *, 4010 ) WRITE ( *, 4011 ) ETIME, IPOINT, EPOT, EKINET, EPOT+EKINET, . ENERR, IREFNR 4010 FORMAT( ' ', . ' FEMTOSEC POINT POTENTIAL + KINETIC = TOTAL ', . ' ERROR REF') 4011 FORMAT( ' ', . F10.5, 3X,I4, 1X,F10.5, 2X,F10.5, 2X,F10.5, 2X,F10.5, 2X,I4 ) ELSEIF( FTYPE.EQ.'IRC') THEN WRITE ( *, '( A79 )' ) KEYWRD WRITE ( *, '( A79 )' ) KOMENT WRITE ( *, '( A79 )' ) TITLE ETIME = DELTAH EXKIN = RC ENERR = GRAD EPOT = RCGRAD EKINET = VIP IREFNR = INT(DIPOLE) IPOINT = ICHARG WRITE ( *, 4020 ) WRITE ( *, 4021 ) IPOINT, EPOT, EKINET, EPOT+EKINET, . ENERR, IREFNR 4020 FORMAT( ' ', . ' POINT POTENTIAL + E. LOST = TOTAL ', . ' ERROR REF') 4021 FORMAT( ' ', . 5X,I4, 2X,F10.5, 2X,F10.5, 2X,F10.5, 2X,F10.5, 2X,I4 ) ENDIF CALL POPARG( COMAND, COMAND) ELSEIF (COMAND(:1) .EQ. 'D' ) THEN WRITE ( *, 8000 ) MAXHEV, MAXLIT, NUMATM 8000 FORMAT(' Dimensioned: ',I4,' heavy + ',I4,' light =',I5,' total.') CALL POPARG( COMAND, COMAND) ELSEIF (COMAND(:1) .EQ. 'T' ) THEN * CHECK TYPE OF TERMINAL WRITE ( *, '( '' ITTRM='', I4 )' ) ITTRM CALL POPARG( COMAND, COMAND) ELSEIF (COMAND(:1) .EQ. 'Q' ) THEN * USER WISHES TO LEAVE OUR HAPPY ROUTINE CALL POPARG( COMAND, COMAND) RETURN ELSEIF (COMAND(:1) .EQ. 'N' ) THEN * SEARCH FOR NEAREST NEIGHBORS DMIN = 10000.0 HMIN = 10000.0 IHA = 0 DO 51 IA = 1, NATOMS-1 IF ( IE( IA) .LT. 1 .OR. IE(IA) .GT. 200 ) GOTO 51 IF ( ATSYMB( IE( IA)) .EQ. 'XX') GOTO 51 IF ( ATSYMB( IE( IA)) .EQ. 'DD') GOTO 51 IF ( ATSYMB( IE( IA)) .EQ. 'LP') GOTO 51 DO 50 IB = 1+IA, NATOMS IF ( IE( IB) .LT. 1 .OR. IE(IB) .GT. 200 ) GOTO 50 IF ( ATSYMB( IE( IB)) .EQ. 'XX') GOTO 50 IF ( ATSYMB( IE( IB)) .EQ. 'DD') GOTO 50 IF ( ATSYMB( IE( IB)) .EQ. 'LP') GOTO 50 DIST=ATDIST(IA,IB) IF (DMIN .GT. DIST ) THEN DMIN = DIST IIA = IA IIB = IB IF ( IE(IA).NE.1 .AND. IE(IB).NE.1) THEN IHA = IA IHB = IB HMIN = DIST ENDIF ENDIF 50 CONTINUE 51 CONTINUE WRITE (*,1050) IIA,IIB,DMIN 1050 FORMAT (1X,'Nearest neighbors are ',I4,' and',I4,' at ', 1 F10.6,' Angstroms.') IF ( IHA.GT.0 .AND. IHA.NE.IIA) . WRITE (*, '('' Nearest HEAVY neighbors are '', I4, . '' and '',I4,'' by '', F10.6,'' Angstroms.'' )' ) . IHA, IHB, HMIN CALL POPARG( COMAND, COMAND) ELSEIF( COMAND( 1:2) .EQ. 'VI' ) THEN * SHOW NORMAL MODES OF VIBRATION IREAL = 0 DO 3500 ICCC=1, NATOMS IF( IE(ICCC).LT.99 ) IREAL = IREAL + 1 3500 CONTINUE CALL POPARG( COMAND, COMAND) IF ( ABS( VFREQ(1)) .LT. 1.0D-4) THEN CALL DEBUGR( 'NO VIBRATION INFORMATION AVAILABLE.') ELSE IF ( COMAND( 1:1) .GE. '0' .AND. COMAND(1:1) .LE. '9') THEN ITEMP = READA( COMAND, 1, ERROR) CALL POPARG( COMAND, COMAND) ELSE ITEMP = 0 ENDIF MAXMOD = NATOMS*3 IF ( FTYPE.EQ. 'DRC') MAXMOD = 1 IF ( FTYPE.EQ. 'IRC') MAXMOD = 1 IF ( ITEMP .GT. 0 ) THEN IF( ITEMP.LE.MAXMOD) THEN WRITE ( *, '('' VIBRATION MODE '', I4)') ITEMP DO 1100 I= 0, IREAL-1 WRITE ( *, '('' ATM. '', I4, '': '', 3F10.5)') . I+1, ( VIBVEC( I*3+J, ITEMP), J= 1, 3) 1100 CONTINUE ELSE WRITE( *,'('' TOO BIG, THE MAXIMUM IS '',I5)') MAXMOD ENDIF ELSE DO 1110 K= 1, MAXMOD WRITE ( *, '('' VIBRATION MODE '', I4)') K DO 1120 I= 0, IREAL-1 WRITE ( *, '('' ATM. '', I4, '': '', 3F10.5)') . I+1, ( VIBVEC( I*3+J, K), J=1, 3) 1120 CONTINUE 1110 CONTINUE ENDIF ENDIF ELSEIF (COMAND(1:2) .EQ. 'VA' ) THEN * CHECK FOR ANY ATOMS WHICH EXCEED "NORMAL" VALENCE" VALMSG = .FALSE. DO 68 I=1,NATOMS IF ( IE( I) .GT. 98 ) GOTO 68 NBOND=0 IIT = 0 DO 62 J=1,NATOMS IF ( IE( J) .GT. 98) GOTO 62 IF ( I .EQ. J ) GOTO 62 IF ( ATBOND( I, J) .NE. 0 ) NBOND = NBOND + 1 62 CONTINUE IF ( NBOND .GT. MAXVAL(IE(I)) ) THEN VALMSG = .TRUE. WRITE ( *,1060) ATSYMB(IE(I)),I,NBOND 1060 FORMAT (' Atom ',A4,I4,' has',I3, 1 ' bonding neighbors.') IIT = 1 STEMP = ' ' DO 65 J=1,NATOMS IF ( I .EQ. J ) GOTO 65 IF ( ATBOND( I, J) .NE. 0 ) THEN DIST=ATDIST(I,J) WRITE (STEMP( IIT:),1006) J,DIST IIT = INDEX( STEMP( IIT:), ';') + IIT IF ( IIT .GT. 59 ) THEN VALMSG = .TRUE. WRITE ( *, '( A )' ) STEMP(:IIT-2)//',' STEMP = ' ' IIT = 1 ENDIF ENDIF 65 CONTINUE ELSEIF ( MAXVAL(IE(I))-NBOND .GT. 0) THEN IF ( IE( I) .EQ. 1 ) THEN VALMSG = .TRUE. WRITE (*, '('' HYDROGEN '',I4,'' has ZERO BONDS.'')') I ELSE NBOND = 0 DO 66 J= 1, NATOMS IF ( ATBOND( I, J) .NE. 0) THEN IF( IE( J) .EQ. 6) NBOND = NBOND + 3 IF( IE( J) .EQ. 7) NBOND = NBOND + 3 IF( IE( J) .EQ. 8) NBOND = NBOND + 2 IF( IE( J) .EQ. 16) NBOND = NBOND + 2 ENDIF 66 CONTINUE IF ( NBOND .LT. MAXVAL( IE( I)) ) THEN VALMSG = .TRUE. WRITE ( *, '( 1X, A6, '' NUMBER '', I4, . '' MAY HAVE TOO FEW BONDS.'')') ATSYMB( IE( I)), I ENDIF ENDIF ENDIF 68 CONTINUE IF ( IIT .GT. 3 ) WRITE ( *, '( A )' ) STEMP(:IIT-2)//'.' IF ( .NOT. VALMSG) CALL DEBUGR( 'All Valences seem OK.') CALL POPARG( COMAND, COMAND) ELSEIF (COMAND(:1) .EQ. 'C') THEN * A COUNT OF ATOMS, FORMULA, ORBITALS, ETC. IHEAVY=0 ILIGHT=0 NELEC=-ICHARG DO 6 I=1, 200 6 ICOUNT(I)=0 IDUMMY=0 DO 8 I=1,NATOMS ICOUNT(IE(I))=ICOUNT(IE(I))+1 NELEC=NELEC+IELEC(IE(I)) IF ( IE(I) .EQ. 1 ) THEN ILIGHT=ILIGHT+1 ELSEIF ( IE(I) .EQ. 99 ) THEN IDUMMY=IDUMMY+1 ELSE IHEAVY=IHEAVY+1 ENDIF 8 CONTINUE WRITE (*,1070) IHEAVY,ILIGHT,IDUMMY,ILIGHT+4*IHEAVY,NELEC 1070 FORMAT (1X, I4,' heavy, ',I4,' light', . ' (',I3,' dummy) atoms with ',I4,' orbs', . ' and ',I4,' elns.' ) IF (NELEC/2*2 .NE. NELEC) WRITE (*,*) '* * * * * * * THIS', . ' SYSTEM IS A RADICAL * * * * * * *' STEMP = ' Formula: ' IIT = INDEX( STEMP, ':') + 1 IF ( ICOUNT(6) .GT. 0) THEN IT=ICOUNT(6) STEMP( IIT:) = 'C' IIT = IIT + 1 IF ( IT .GT. 1 .AND. IT .LT. 10 ) THEN WRITE ( STEMP(IIT:), '( I1 )') IT IIT = IIT + 2 ELSEIF ( IT.GT.9 .AND. IT.LT.100) THEN WRITE ( STEMP(IIT:), '( I2 )') IT IIT = IIT + 3 ELSEIF ( IT.GT.99 .AND. IT.LT.1000) THEN WRITE ( STEMP(IIT:), '( I3 )') IT IIT = IIT + 4 ELSE IIT = IIT + 1 ENDIF ICOUNT(6)=0 ENDIF IF ( ICOUNT(1) .GT. 0) THEN IT=ICOUNT(1) STEMP( IIT: ) = 'H' IIT = IIT + 1 IF ( IT .GT. 1 .AND. IT.LT.10) THEN WRITE ( STEMP(IIT:), '(I1)') IT IIT = IIT + 2 ELSEIF( IT.GT.9 .AND. IT.LT. 100) THEN WRITE ( STEMP(IIT:), '(I2)') IT IIT = IIT + 3 ELSEIF( IT.GT.99 .AND. IT.LT.1000) THEN WRITE ( STEMP(IIT:), '(I3)') IT IIT = IIT + 4 ELSE IIT = IIT + 1 ENDIF ICOUNT(1)=0 ENDIF DO 9 I= 1, 200 IF ( ICOUNT(I) .GT. 0) THEN IT=ICOUNT(I) STEMP( IIT: ) = ATSYMB( I ) IIT = INDEX( STEMP( IIT:), ' ') + IIT - 1 IF ( IT .GT. 1 .AND. IT.LT.10) THEN WRITE ( STEMP(IIT:), '(I1)' ) IT IIT = IIT + 2 ELSEIF ( IT.GT.9 .AND. IT.LT.100) THEN WRITE ( STEMP(IIT:), '(I2)') IT IIT = IIT + 3 ELSEIF ( IT.GT.99 .AND. IT.LT.1000) THEN WRITE ( STEMP(IIT:), '(I3)') IT IIT = IIT + 4 ELSE IIT = IIT + 1 ENDIF ICOUNT(I)=0 IF ( IIT .GT. 70 ) THEN WRITE (*, '(A)') STEMP( 1: IIT) STEMP = ' Formula (cont):' IIT = INDEX( STEMP, ':')+1 ENDIF ENDIF 9 CONTINUE IF ( IIT .GT. INDEX(STEMP, ':')+2 ) . WRITE (*, '( A )' ) STEMP(:IIT) CALL POPARG( COMAND, COMAND) ELSEIF (COMAND(:1) .EQ. 'F') THEN IFILE = MAX( 1, INDEX(FILEIN,' ')-1 ) WRITE (*,*) 'Input file: '//FILEIN(:IFILE) CALL POPARG( COMAND, COMAND) ELSEIF (COMAND(:1) .EQ. 'H' .OR. COMAND(:1) .EQ. '?' ) THEN COMAND = 'DRAW INFORMATION' CALL HELP( COMAND ) COMAND = ' ' ELSEIF (COMAND(:2) .EQ. 'AU' ) THEN CALL DEBUGR( 'Program written by Maj Donn M. Storch, USAFA') CALL POPARG( COMAND, COMAND) ELSEIF ( COMAND(:1) .EQ. 'S' ) THEN * user wants summary of symmetry information CALL POPARG( COMAND, COMAND) IF ( ISYM(1,1) .EQ. 0 ) THEN CALL DEBUGR( 'NO SYMMETRY INFORMATION.') ELSE CALL DEBUGR( ' SYMMETRY INFORMATION:' ) DO 73 I= 1, NUMATM DO 74 J= 10, 1, -1 IF ( ISYM( J, I ) .NE. 0 ) GOTO 75 74 CONTINUE 75 IF ( J .GT. 0 ) THEN WRITE (*, '('' REF:'',I4,'' FTN:'',I4,'' TO '', . 8I4 )' ) (ISYM(K,I),K=1,J) ELSE GOTO 76 ENDIF 73 CONTINUE 76 CONTINUE ENDIF ELSE CALL DEBUGR( 'You have lost me... try Help.') COMAND = ' ' ENDIF GOTO 10 4000 CONTINUE RETURN END