SUBROUTINE GPRDR( IR, FNAME, FTYPE, COOUT, IEOUT, NATOUT, . NAOUT, NBOUT, NCOUT, UPDATE) IMPLICIT REAL (A-H,O-Z) INCLUDE 'SIZES' DIMENSION COOUT( 3, NUMATM), IEOUT( NUMATM) DIMENSION NAOUT( NUMATM ), NBOUT( NUMATM), NCOUT( NUMATM) CHARACTER*80 KEYWRD, KOMENT, TITLE, COMAND, LINE, FNAME CHARACTER*5 SYMBL(100) CHARACTER FTYPE*3 LOGICAL OPNERR, ERROR, UPDATE LOGICAL FIRST REAL DENMAT, BONDS REAL VFREQ, VIBVEC REAL FVECT REAL CVECT, CBETA COMMON /FILEST/ FIRST COMMON /SYMTRY/ ISYM(10,NUMATM) COMMON /ATMASS / ATMASS ( NUMATM ) COMMON /INTCOR/ XNDOGM(3, NUMATM), INTFRE(3, NUMATM) COMMON /KEYS/ KEYWRD,KOMENT,TITLE COMMON /ATOMS/ CO(3, NUMATM),IE( NUMATM),NATOMS, ATCHG( NUMATM) COMMON /GEOM/ COOLD(3, NUMATM),NA( NUMATM),NB( NUMATM),NC( NUMATM) DIMENSION IA(NUMATM), IB(NUMATM), IC(NUMATM) LOGICAL DEBUG, DEBUGL, DEBUGN, DEBUGO, DEBUGP, DEBUGI COMMON /DEBCOM/ DEBUG, DEBUGL, DEBUGN, DEBUGO, DEBUGP, DEBUGI COMMON /DENSTY/ DENMAT( MPACK ), BONDS( MPACK ) C 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 * LOGICAL LR, LF, LV, LC, LCB, LB COMMON /FORCE/ VFREQ(3*NUMATM), VIBVEC(3*NUMATM,3*NUMATM), IDVECT DIMENSION RIJ(1000), FVECT(3*NUMATM, 3*NUMATM), C(1000) * RIJ == INTERATOMIC DISTANCES * FVECT == FORCE VECTORS * VIBVEC == NORMAL MODE VIBRATIONS DIMENSION CBETA(1000) COMMON /DATUMS/ NVAR, NUMAT, NORBS, NELECS, NALPHA, NBETA, . NCLOSE, NOPEN, NNATOM COMMON /ARRAYS/ EIGS(MAXORB), EIGB(MAXORB), LOC(2,MAXPAR), . NFIRST(MAXORB), NLAST(MAXORB), . EVIBS(MAXPAR*3), COORD(3,NUMATM), FEIGS(3*MAXPAR), . Q(NUMATM), AMS(NUMATM) DIMENSION X(NUMATM), Y(NUMATM), Z(NUMATM), ZLINER(NUMATM*3) EQUIVALENCE (COOLD(1,1),ZLINER(1)) EQUIVALENCE (ZLINER(1), X(1)) EQUIVALENCE (ZLINER(NUMATM), Y(1)) EQUIVALENCE (ZLINER(NUMATM*2), Z(1)) * IF (DEBUGI) CALL DEBUGR( 'IN GPRDR: FTYPE='//FTYPE ) IF ( IR.LT.0)THEN CLOSE( UNIT=ABS(IR) ) FIRST = .TRUE. FTYPE = ' ' RETURN ENDIF IF ( FTYPE(:1) .EQ. ' ') THEN IF (DEBUGI) CALL DEBUGR( 'IN GPRDR: OPENING '// . FNAME(:INDEX(FNAME, ' ')) ) IRROR = 0 IOERR = 0 * changed from readonly OPEN( UNIT= IR, FILE= FNAME, STATUS= 'OLD', IOSTAT= IRROR) IF ( IRROR .NE. 0) GOTO 9000 REWIND (UNIT=IR, ERR=9000) FIRST = .TRUE. C? DO 10 NZZ= 1, 20 DO 10 NZZ= 1, 60 READ( IR, '( A )', ERR=9100, END= 11 ) LINE IF( INDEX( LINE, 'GIP/DRAW') .GT. 0) THEN FTYPE = 'GIP' GOTO 12 ELSEIF(INDEX(LINE,'ATOMS WITH A CHARGE OF').NE.0) THEN FTYPE='COR' GOTO 12 ELSEIF ( INDEX( LINE, ' SUMMARY OF ').GT. 0) THEN FTYPE='ARC' GOTO 12 ELSEIF (LINE(:6) .EQ. 'HEADER') THEN FTYPE='PDB' GOTO 12 ELSEIF ( INDEX(LINE,'NUMBER OF CONTOURS') .GT. 0) THEN FTYPE='TEC' GOTO 12 ELSEIF ( INDEX( LINE, ' CALCULATION RESULTS') .GT. 0) THEN FTYPE='OUT' ELSEIF ( INDEX( LINE, 'INTRINSIC REACTION C') .GT. 0) THEN FTYPE='IRC' c?? keep looking for DRC GOTO 12 ELSEIF ( INDEX( LINE, 'DYNAMIC REACTION COO') .GT. 0) THEN FTYPE='DRC' GOTO 12 ELSEIF( INDEX( LINE, 'HALF-LIFE FOR KINETIC EN').GT. 0) THEN FTYPE='DRC' GOTO 12 ENDIF 10 CONTINUE * ASSUME DATA TYPE IF END OF FILE 11 IF (FTYPE .EQ. ' ') FTYPE='GEO' 12 CONTINUE REWIND (UNIT=IR, ERR=9000) ENDIF IF ( FTYPE(:1) .EQ. ' ') THEN FTYPE='GEO' ENDIF 50 IF (DEBUGI) CALL DEBUGR( 'IN GPRDR: FTYPE='//FTYPE ) IF ( FTYPE .EQ. 'COR') THEN CALL CORRD( IR, NATOUT, KHARGE, TITLE, SYMBL, X,Y,Z, + IBONDS, IOERR ) IF (IOERR.NE.0) GO TO 9100 DO 20 I= 1, NATOUT COOUT(1,I) = X(I) COOUT(2,I) = Y(I) COOUT(3,I) = Z(I) 20 CONTINUE RETURN ELSEIF ( FTYPE.EQ.'GEO') THEN CALL GEORD( IR, NATOUT,IEOUT,COOUT,NAOUT,NBOUT,NCOUT, + IA, IB, IC, ISYM, IOERR ) IF (IOERR.NE.0) GO TO 9100 ELSEIF ( FTYPE.EQ.'ARC') THEN CALL ARCRD( IR, NATOUT,IEOUT,COOUT,NAOUT,NBOUT,NCOUT, + IA, IB, IC, ISYM, IOERR ) IF (IOERR.NE.0) GO TO 9100 ELSEIF ( FTYPE.EQ.'GIP') THEN CALL GIPRD( IR, NATOUT,IEOUT,COORD,NAOUT,NBOUT,NCOUT, . IOERR ) IF (IOERR.NE.0) THEN IF ( NATOUT .LT. 1 ) GOTO 9100 CALL UPROMP( 'I had an ERROR reading the file.' ) WRITE (*, '('' I found '', I4,'' atoms.'')' ) NATOUT CALL UPROMP( 'Do you want me to use them [YES/no] ? ') READ (*, '(A)', END=9100) COMAND CALL LCLEAN( COMAND, COMAND, .TRUE. ) IF ( COMAND(1:1) .EQ. 'N' ) GOTO 9100 ENDIF DO 48 I=2,NATOUT IA(I)=1 IF (I.GT.2) IB(I)=1 IF (I.GT.3) IC(I)=1 48 CONTINUE DO 49 I=1,NATOUT CO( 1, I) = COORD( 1, I) CO( 2, I) = COORD( 2, I) CO( 3, I) = COORD( 3, I) INTFRE(1,I)=IA(I) INTFRE(2,I)=IB(I) INTFRE(3,I)=IC(I) 49 CONTINUE GOTO 120 ELSEIF ( FTYPE .EQ. 'PDB') THEN CALL BPDBRD( IR, NATOUT,IEOUT,COORD,NAOUT,NBOUT,NCOUT, . KEYWRD, KOMENT, TITLE, IOERR ) IF (IOERR.NE.0) GOTO 9100 DO 80 I=1,NATOUT CO( 1, I) = COORD( 1, I) CO( 2, I) = COORD( 2, I) CO( 3, I) = COORD( 3, I) IF ( I .GT. 1) INTFRE(1,I)=1 IF ( I .GT. 2) INTFRE(2,I)=1 IF ( I .GT. 3) INTFRE(3,I)=1 80 CONTINUE RETURN ELSEIF ( FTYPE .EQ. 'TEC' ) THEN CALL CONTUR( IR, IOERR ) IF (IOERR.NE.0) GO TO 9100 RETURN ELSEIF ( FTYPE.EQ.'DRC' .OR. FTYPE.EQ.'IRC') THEN CALL DRCRD( IR, NATOUT,IEOUT,COOUT,NAOUT,NBOUT,NCOUT, + IA, IB, IC, ISYM, KEYWRD, KOMENT, TITLE, IOERR ) IF (IOERR.NE.0) GO TO 9100 ELSEIF ( FTYPE .EQ. 'OUT') THEN CALL READER(COOUT, IEOUT, NAOUT, NBOUT, NCOUT, INTFRE, . LR, FVECT, LF, VIBVEC, LV, CVECT, LC, . CBETA, LCB, BONDS, LB, IR, IOERR) IF (IOERR.NE.0) GOTO 9100 NATOUT = NNATOM DO 60 I= 1, NATOUT IA( I ) = INTFRE( 1, I) IB( I ) = INTFRE( 2, I) IC( I ) = INTFRE( 3, I) DO 60 J= 1, 3 VFREQ( (I-1)*3 + J) = EVIBS( (I-1)*3 + J) 60 CONTINUE ENDIF C WRITE ( COMAND, '(''GPRDR: NATOUT='',I4)' ) NATOUT IF (DEBUGI) CALL DEBUGR( COMAND ) * IF ( ISYM(1,1) .NE. 0 ) THEN CALL DEBUGR( 'GPRDR: SYMMETRY INFORMATION PRESENT.' ) ENDIF C? CALL GMETRY(NUMAT,NATOUT,IEOUT,COOUT,NA,NB,NC,COORD,ERROR) C 120 DO 150 I=1,NATOUT IF ( UPDATE ) THEN C CO( 1, I) = COORD( 1, I) C CO( 2, I) = COORD( 2, I) C CO( 3, I) = COORD( 3, I) INTFRE(1,I)=IA(I) INTFRE(2,I)=IB(I) INTFRE(3,I)=IC(I) C ELSE ENDIF C? COOUT(1,I) = COORD(1,I) C? COOUT(2,I) = COORD(2,I) C? COOUT(3,I) = COORD(3,I) C ENDIF 150 CONTINUE C IF ( UPDATE ) NATOMS = NATOUT C C END GEO-COR CALCULATION RETURN 9000 IFILE=INDEX( FNAME,' ') WRITE(*,'('' ERROR IN OPENING '', A )') FNAME(:IFILE) NATOUT = -1000 FNAME=' ' FTYPE = ' ' RETURN 9100 IFILE = INDEX( FNAME, ' ') WRITE (*,'('' ERROR IN READING '', A)') FNAME(:IFILE) FNAME=' ' FTYPE = ' ' NATOUT = -100 RETURN END