PROGRAM GAR PARAMETER (NT0=500,MX3=3*NT0) DIMENSION F(MX3,MX3),P(NT0,3,3),X(3,NT0) CHARACTER*80 filename CHARACTER*1 BUFF(140),NUMBER(80),L,LS,AT(NT0) CHARACTER*5 SSTR CHARACTER*2 LG COMMON/LINE/I LOGICAL LABS,LVCD,LGEO OPEN(8,FILE='scr',FORM='FORMATTED') WRITE(*,*)' How many atoms ?' READ(*,*)NAT N=3*NAT NB=70 LABS=.FALSE. LGEO=.FALSE. LS='\\' LE='=' LG='%%' WRITE(*,*) 1' Geometry looked for after string ',LG,' (only for G94)' WRITE(*,*)' Filename ? ' READ(*,'(A)')filename OPEN(7,FILE=FILENAME,STATUS='OLD',FORM='FORMATTED') C 5444 READ(7,7000,END=8888)(BUFF(I),I=1,NB) READ(7,7000,END=8888)(BUFF(I),I=NB+1,2*NB) 7000 FORMAT(1X,70A1) BACKSPACE 7 DO 51 I=1,2*NB-5 DO 52 J=1,5 52 SSTR(J:J)=BUFF(I+J-1) IF(SSTR.EQ.'leDer')THEN WRITE(*,*)' Dipole Derivatives found' LABS=.TRUE. GOTO 6555 ENDIF C NImag for g94, NIMAG for g92 IF(SSTR.EQ.'NImag'.OR.SSTR.EQ.'NIMAG')THEN WRITE(*,*)' Second derivatives found' GOTO 5555 ENDIF IF((.NOT.LGEO).AND.SSTR(1:2).EQ.LG)THEN WRITE(*,*)' Geometry found' LGEO=.TRUE. GOTO 7555 ENDIF 51 CONTINUE GOTO 5444 C 7555 I=I+1 C I .. index of the letter to be gotten IF(I.GT.NB)THEN DO 74 K=1,NB 74 BUFF(K)=BUFF(K+NB) I=I-NB READ(7,*) ENDIF DO 73 IA=1,NAT C C Get element: I=I+1 CALL GETLET(L,BUFF,NB) AT(IA)=L I=I+1 CALL GETLET(L,BUFF,NB) C DO 773 IX=1,3 C READ X(IX,IA): DO 75 J=1,20 75 NUMBER(J)=' ' IN=0 7558 IN=IN+1 I=I+1 CALL GETLET(L,BUFF,NB) NUMBER(IN)=L IF(L.NE.','.AND.L.NE.LS)GOTO 7558 NUMBER(IN)=' ' REWIND 8 WRITE(8,*)(NUMBER(J),J=1,20) REWIND 8 READ(8,*)FU X(IX,IA)=FU 773 CONTINUE 73 CONTINUE OPEN(15,FILE='FILE.XYZ') WRITE(15,*)' FILE.XYZ from Gaussian output' DO 77 IA=1,NAT K=0 IF(AT(IA).EQ.'C')K=1 IF(AT(IA).EQ.'O')K=2 IF(AT(IA).EQ.'N')K=3 IF(AT(IA).EQ.'H')K=4 IF(AT(IA).EQ.'S')K=5 IF(AT(IA).EQ.'P')K=9 IF(K.EQ.0)WRITE(*,*)' Unknown atom ',AT(IA) 77 WRITE(15,1500)K,(X(IX,IA),IX=1,3),0,0,0,0,0.0 1500 FORMAT(I4,3F15.8,4I2,F4.1) WRITE(15,1500)9999,0.0,0.0,0.0,0,0,0,0,0.0 CLOSE(15) WRITE(*,*)' X written into FILE.XYZ' BACKSPACE 7 GOTO 5444 C 6555 I=I+J C I .. index of the letter to be gotten IF(I.GT.NB)THEN DO 54 K=1,NB 54 BUFF(K)=BUFF(K+NB) I=I-NB READ(7,*) ENDIF 6556 I=I+1 CALL GETLET(L,BUFF,NB) IF(L.NE.LE)GOTO 6556 DO 53 IA=1,NAT DO 53 IX=1,3 DO 53 IY=1,3 C C READ P(IA,IX,IY): DO 55 J=1,20 55 NUMBER(J)=' ' IN=0 6558 IN=IN+1 I=I+1 CALL GETLET(L,BUFF,NB) NUMBER(IN)=L IF(L.NE.','.AND.L.NE.'\\')GOTO 6558 NUMBER(IN)=' ' REWIND 8 WRITE(8,*)(NUMBER(J),J=1,20) REWIND 8 READ(8,*)FU 53 P(IA,IX,IY)=FU OPEN(15,FILE='FILE.TEN') LABS=.TRUE. LVCD=.FALSE. CALL WRITETEN(NT0,P,P,LABS,LVCD,X,NAT) CLOSE(15) WRITE(*,*)' P written into FILE.TEN' BACKSPACE 7 GOTO 5444 C C Force Field: 5555 I=I+J C I .. index of the letter to be gotten IF(I.GT.70)THEN DO 4 K=1,70 4 BUFF(K)=BUFF(K+70) I=I-70 READ(7,*) ENDIF C NB .. line length 5556 I=I+1 CALL GETLET(L,BUFF,NB) IF(L.NE.LS)GOTO 5556 5557 I=I+1 CALL GETLET(L,BUFF,NB) IF(L.NE.LS)GOTO 5557 DO 3 IX=1,N DO 3 IY=1,IX C C READ F(IX,IY): DO 5 J=1,20 5 NUMBER(J)=' ' IN=0 5558 IN=IN+1 I=I+1 CALL GETLET(L,BUFF,NB) NUMBER(IN)=L IF(L.NE.','.AND.L.NE.'\\')GOTO 5558 NUMBER(IN)=' ' REWIND 8 WRITE(8,*)(NUMBER(J),J=1,20) REWIND 8 READ(8,*)FU C WRITE(9,*)IX,IY,FU F(IX,IY)=FU 3 F(IY,IX)=FU OPEN(20,FILE='FILE.FC') CALL WRITEFF(MX3,N,F) CLOSE(20) WRITE(*,*)' FF written into FILE.FC' BACKSPACE 7 GOTO 5444 C C 8888 CLOSE(7) STOP END SUBROUTINE WRITEFF(MX3,N,FCAR) DIMENSION FCAR(MX3,N) C CONST=4.359828/0.5291772**2 CONST=1.0 DO 6 I=1,N DO 6 J=1,N 6 FCAR(I,J)=FCAR(I,J)/CONST N1=1 1 N3=N1+4 IF(N3.GT.N)N3=N DO 130 LN=N1,N 130 WRITE(20,17)LN,(FCAR(LN,J),J=N1,MIN(LN,N3)) N1=N1+5 IF(N3.LT.N)GOTO 1 17 FORMAT(I4,5D14.6) RETURN END SUBROUTINE GETLET(L,BUFF,NB) CHARACTER*1 BUFF(140) CHARACTER*1 L COMMON/LINE/I IF(I.GT.NB)THEN IF(I.GT.NB+1)THEN WRITE(*,*)' Cannot read letter ',I STOP ENDIF I=1 READ(7,7000)(BUFF(J),J=1,70) 7000 FORMAT(1X,70A1) ENDIF L=BUFF(I) RETURN END SUBROUTINE WRITETEN(N0,P,A,LABS,LVCD,X,NAT) PARAMETER (NT0=500) DIMENSION P(N0,3,3),A(N0,3,3),R(3,NT0),X(3,NAT) LOGICAL LABS,LVCD BOHR=0.52917705993 Z0=0.0 GOTO 8888 DO 3 L=1,NAT DO 3 I=1,3 3 R(I,L)=X(I,L)/BOHR C Axial tensor in the common origin system: DO 2201 L=1,NAT DO 2201 J=1,3 DO 2201 I=1,3 SUM=0.0 DO 2202 ID=1,3 DO 2202 IG=1,3 2202 SUM=SUM+0.25*EPS(I,IG,ID)*R(IG,L)*P(L,J,ID) 2201 A(L,J,I)=A(L,J,I)+SUM 8888 CONTINUE OPEN(15,FILE='FILE.TEN') WRITE(15,1500) NAT,NAT-6,0 1500 FORMAT(3I5) DO 10 L=1,NAT DO 10 J=1,3 10 WRITE(15,1501) (P(L,J,I),I=1,3),L 1501 FORMAT(3F14.8,I5) DO 220 L=1,NAT DO 220 J=1,3 220 WRITE(15,1501) (Z0,I=1,3),L DO 230 L=1,NAT DO 230 J=1,3 230 WRITE(15,1501) (Z0,I=1,3),L DO 100 L=1,NAT DO 100 J=1,3 100 WRITE(15,1501) (P(L,J,I),I=1,3),L CLOSE(15) RETURN END C FUNCTION EPS(I,J,K) REAL*8 EPS INTEGER*4 I,J,K EPS=0.0 IF (I.EQ.1.AND.J.EQ.2.AND.K.EQ.3)EPS= 1.0 IF (I.EQ.1.AND.J.EQ.3.AND.K.EQ.2)EPS=-1.0 IF (I.EQ.2.AND.J.EQ.3.AND.K.EQ.1)EPS= 1.0 IF (I.EQ.2.AND.J.EQ.1.AND.K.EQ.3)EPS=-1.0 IF (I.EQ.3.AND.J.EQ.1.AND.K.EQ.2)EPS= 1.0 IF (I.EQ.3.AND.J.EQ.2.AND.K.EQ.1)EPS=-1.0 RETURN END C SUBROUTINE VCDD0(VCD,VEL,DIP,C,NAT) C STOLEN FROM CADPAC, INDICES ARE DIFFERENT !!, VEL WITH NUCLEI IMPLICIT REAL*8(A-H,O-Z) IMPLICIT INTEGER*4 (I-N) INTEGER*4 ALPHA,BETA,GAMMA,DELTA,LAMBDA PARAMETER (MX=100) DIMENSION VCD(MX,3,3),VEL(MX,3,3),DIP(MX,3,3), 1C(3,NAT) DO 90 BETA =1,3 DO 90 GAMMA=1,3 DO 90 DELTA=1,3 SKEW=0.25D0*EPS(BETA,GAMMA,DELTA) IF (DABS(SKEW).GT.1.0D-10)THEN DO 80 ALPHA=1,3 DO 80 LAMBDA=1,NAT 80 VCD(LAMBDA,ALPHA,BETA)=VCD(LAMBDA,ALPHA,BETA) 1 -SKEW*C(GAMMA,LAMBDA) 2 *(VEL(LAMBDA,ALPHA,DELTA)-DIP(LAMBDA,ALPHA,DELTA)) ENDIF 90 CONTINUE RETURN END C C\Version=SGI-G94RevB.3\HF=-966.6745649\RMSD=0.000e+00\RMSF=1.196e-01\D Cipole=0.,0.,0.\PG=C01 [X(C38H52N16O24P4)]\NImag=84\\0.76752455,0.00053 C432,0.03734306,0.23733561,0.00042079,0.13291623,-0.70920516,0.00065060 C,-0.21702343,1.33224819,0.00170226,-0.03103517,0.00051274,0.02526703,1 C.09059550,-0.21867837,0.00010553,-0.09804719,0.00890088,-0.02513206,1.