PROGRAM NEW10 C THIS PROGRAM READS .XYZ FILE (CARTESIAN COORDINATES OF A MOLECUL C IN THE PMODEL FORMAT) AND MAKES THE UMATIN INPUT FILES FOR THE C VCD PROGRAMS IMPLICIT REAL*8 (A-H,O-Z) IMPLICIT INTEGER*4 (I-N) CHARACTER*1 MOLNAM(80) CHARACTER*2 ATOMT CHARACTER*5 PGROUP PARAMETER (NA0=31000,MENDELEV=89) DIMENSION ATOMT(NA0),KATOM(NA0) 1,X(NA0),Y(NA0),Z(NA0),il(NA0,2) COMMON /ICOORD/IDUM(NA0,8),ICON(NA0,8), 1ISTRE,IBEND,ITOR,IST(NA0),JST(NA0),IBD(NA0),JBD(NA0), 2KBD(NA0),NITOR(NA0),NLTOR(NA0),JTOR(NA0),KTOR(NA0), 3IBUF(NA0,4),JBUF(NA0,4),N,IBOND(NA0) INTEGER*4 BT(NA0,7) COMMON/DUMMY/RAD0,RAD CHARACTER*2 atsy(MENDELEV) data atsy/' H','He','Li','Be',' B',' C',' N',' O',' F','Ne', 3'Na','Mg','Al','Si',' P',' S','Cl','Ar', 4' K','Ca','Sc','Ti',' V','Cr','Mn','Fe','Co','Ni','Cu','Zn', 4 'Ga','Ge','As','Se','Br','Kr', 5'Rb','Sr',' Y','Zr','Nb','Mo','Tc','Ru','Rh','Pd','Ag','Cd', 5 'In','Sn','Sb','Te',' I','Xe', 6'Cs','Ba','La', 6 'Ce','Pr','Nd','Pm','Sm','Eu','Gd','Tb','Dy','Ho', 6 'Er','Tm','Yb','Lu', 6'Hf','Ta',' W','Re','Os','Ir','Pt','Au','Hg', 6 'Tl','Pb','Bi','Po','At','Rn', 7'Fr','Ra','Ac'/ c dimension amas(MENDELEV) c data amas/1.008,4.003, c 2 6.941, 9.012, 10.810,12.011,14.007,15.999,18.998,20.179, c 3 22.990,24.305, 26.981,28.086,30.974,32.060,35.453,39.948, c 4 39.098,40.080,44.956,47.900,50.941,51.996,54.938,55.847, c 4 58.933,58.700,63.546,65.380, c 4 69.720,72.590,74.922,78.960,79.904,83.800, c 5 85.468,87.620,88.906,91.220,92.906,95.940,98.906,101.070, c 5 102.906,106.400,107.868,112.410, c 5 114.82,118.69,121.75,127.600,126.905,131.300, c 6 132.905,137.330,138.906, c 6 140.120,140.908,144.240,145.000,150.400, c 6 151.960,157.250,158.925,162.500,164.930,167.260,168.934, c 6 173.040,174.970, c 6 178.490,180.948,183.850,186.207,190.200,192.220,195.090, c 6 196.967,207.590,204.370,207.200,208.980,210.000,210.001, c 6 222.02, c 7 223.000,226.025,227.028/ C WRITE(*,*) WRITE(*,*)' VIBRATIONAL PROGRAM PACKAGE INPUT FILE GENERATION ' WRITE(*,*) WRITE(*,*)' PETR BOUR, UOCHB CSAV 1992-10' WRITE(*,*) WRITE(*,*)' FILE X --> FILE UMAT' WRITE(*,*) OPEN(55,FILE='FILE.X',STATUS='OLD') READ(55,888)MOLNAM 888 format(80a1) read(55,*)N if(N.gt.NA0)then write(6,*)'too many atoms' stop endif nb=0 do 11 I=1,N IBOND(I)=0 DO 1116 J=1,7 1116 BT(I,J)=0 do 11 J=1,8 11 ICON(I,J)=0 do 1 I=1,N READ(55,*)KT,X(I),Y(I),Z(I),(BT(I,J),J=1,7) KATOM(I)=KT ATOMT(I)=ATSY(KT) do 1 J=1,7 K=BT(I,J) if(K.gt.0)then c c find, if bound I-K already in the list: ilist=0 do 34 ii=1,nb 34 if((il(ii,1).eq.I.and.il(ii,2).eq.K).or. 1 (il(ii,2).eq.I.and.il(ii,1).eq.K))ilist=1 if(ilist.eq.0)then if(nb.gt.NA0)then write(6,*)'too many bonds' stop endif nb=nb+1 il(nb,1)=I il(nb,2)=K IBOND(I)=IBOND(I)+1 IBOND(K)=IBOND(K)+1 ICON(I,IBOND(I))=K ICON(K,IBOND(K))=I endif endif 1 continue CLOSE(55) WRITE(*,888)MOLNAM WRITE(*,*)N,' atoms' WRITE(*,*)nb,' bonds' WRITE(*,*)'INPUT OK' WRITE(*,*)'BOND TABLE TAKEN FROM INPUT' C ************************** COORDINATE DEFINITION: ************** CALL INCO(IERR) C ************************************************************ IF(IERR.EQ.1)THEN WRITE(*,*)' Internal coordinates cannot be used' NTOT=3*N GOTO 1001 ENDIF WRITE(*,*) ISTRE,' OF STRETCHES' WRITE(*,*) IBEND,' OF VALENCE BENDS' WRITE(*,*) ITOR,' OF TORSIONS' WRITE(*,*)' -------------------------' NTOT=ISTRE+IBEND+ITOR WRITE(*,*)NTOT,' - TOTAL ; 3N-6 = ',3*N-6 IF(NTOT.NE.3*N-6)THEN WRITE(*,*)' ** NUMBER OF FOUND COORDINATES IS NOT 3N-6 !! **' WRITE(*,*)' ** Manual redefinition required **' ENDIF WRITE(*,*) C **************************** OUTPUT: *********************** 1001 WRITE(*,*)'FILE.UMA - IS THE OUPTUT FILE' IPNCH=-1 PGROUP='C1 ' OPEN(7,FILE='FILE.UMA',STATUS='UNKNOWN') WRITE(7,888)MOLNAM WRITE(7,888)MOLNAM NFCS=((3*N-6)*((3*N-6)+1))/2 WRITE(7,222)N,3*N-6,NFCS,IPNCH,PGROUP 222 FORMAT(4I6,A5) DO 100 I=1,N 100 WRITE(7,333)X(I),Y(I),Z(I),I,KATOM(I),ATOMT(I) 333 FORMAT(3F12.6,2I4,A2) IF(IERR.EQ.1)GOTO 1002 IIT=0 I1=1 A1=1.0d0 I0=0 DO 101 I=1,ISTRE IIT=IIT+1 101 WRITE(7,444)I1,IST(I),JST(I),I0,I0,I0,I0,A1 1,ATOMT(IST(I)),IST(I), 2ATOMT(JST(I)),JST(I),IIT 444 FORMAT(7I4,F12.6,' STRETCH ',A2,I3,' - ',A2,I3,I4) I2=2 DO 102 I=1,IBEND IIT=IIT+1 102 WRITE(7,555)I2,IBD(I),JBD(I),KBD(I),I0,I0,I0,A1, 1ATOMT(IBD(I)),IBD(I),ATOMT(JBD(I)),JBD(I), 2ATOMT(KBD(I)),KBD(I),IIT 555 FORMAT(7I4,F12.6,' BEND ',A2,I3, 1' - ',A2,I3,' - ',A2,I3,I4) I4=4 DO 103 I=1,ITOR IIT=IIT+1 WRITE(7,666)I4,NITOR(I),JTOR(I),KTOR(I),NLTOR(I), 1I0,I0,A1, 2ATOMT(JTOR(I)),JTOR(I),ATOMT(KTOR(I)),KTOR(I),IIT WRITE(7,666)(IBUF(I,J),J=1,NITOR(I)) 103 WRITE(7,666)(JBUF(I,J),J=1,NLTOR(I)) 666 FORMAT(7I4,F12.6,' TORSION ',A2,I3,' - ',A2,I3,I4) WRITE(7,*)' 0' A=1.0d0 DO 771 I=1,3*N-6 771 WRITE(7,777)I,A 777 FORMAT(' 1',/,I3,F5.1) 1002 CLOSE(7) WRITE(*,*)' PROGRAM TERMINATED' END SUBROUTINE INCO(IERR) IMPLICIT REAL*8(A-H,O-Z) IMPLICIT INTEGER*4(I-N) PARAMETER (NA0=31000) DIMENSION IAA(8,NA0),ICON(NA0,8),IDT(NA0),IDB(NA0) COMMON /ICOORD/IDUM(NA0,8),IBOND(NA0,8), 1ISTRE,IBEND,ITOR,IST(NA0),JST(NA0),IBD(NA0),JBD(NA0), 2KBD(NA0),NITOR(NA0),NLTOR(NA0),JTOR(NA0),KTOR(NA0), 3IBUF(NA0,4),JBUF(NA0,4),N,IE(NA0) COMMON /IB/IBM2,IBM1,IB0,IBACK(NA0) IBM1=0 IBM2=0 IB0=0 IERR=0 NAT=N DO 1 I=1,N DO 1 J=1,8 1 ICON(I,J)=IBOND(I,J) DO 2 I=N+1,N+2 DO 2 J=1,8 IBOND(I,J)=0 2 ICON(I,J)=0 DO 14 I=1,NA0 14 IBACK(I)=0 IBACK(1)=NAT+1 c climb on the network and define atom dependencies 24 ICO=0 DO 1111 L2=1,NAT IF (IBACK(L2).NE.0)THEN c (this atoms is dependent, network can be further propagated) DO 2222 K3=1,8 L=L2 K=K3 IA=IBOND(L,K) IF (IA.NE.0)THEN ICO=1 IBOND(L,K)=0 5555 CONTINUE IF (IBACK(IA).EQ.0)IBACK(IA)=L DO 33 KK=1,8 33 IF (IBOND(IA,KK).EQ.L) IBOND(IA,KK)=0 DO 44 KK=1,8 IF (IBOND(IA,KK).NE.0)THEN L=IA IA=IBOND(IA,KK) IBOND(L,KK)=0 GOTO 5555 ENDIF 44 CONTINUE ENDIF 2222 CONTINUE endif 1111 CONTINUE IF (ICO.EQ.1)GOTO 24 IBACK(NAT+1)=NAT+2 IB=0 DO 5 I=2,NAT IB=IB+1 IAA(4,IB)=I IAA(3,IB)=IBACK(IAA(4,IB)) IAA(2,IB)=IBACK(IAA(3,IB)) 5 IAA(1,IB)=IBACK(IAA(2,IB)) WRITE(*,999) 999 FORMAT(1X,' BOND 1 - 2 - 3 -> (4) (IB) WAS DEFINED') C C IF AN ATOM IA1 OF THE BOND IB IS NOT YET DEFINED, THE BOND IS PU C TO THE BACK OF THE LIST OF BONDS: icontr=0 47 IC=0 IB0=IB DO 45 I=2,IB-1 DO 46 J=1,I-1 46 IF (IAA(3,I).EQ.IAA(4,J).OR.IAA(3,I).EQ.1)GOTO 45 IC=1 DO 51 J=1,4 I0=IAA(J,I) IAA(J,I)=IAA(J,I+1) 51 IAA(J,I+1)=I0 45 CONTINUE icontr=icontr+1 if (icontr.gt.5000) then WRITE(*,*)'INFINITE LOOP' IERR=1 RETURN endif IF (IC.EQ.1)GOTO 47 WRITE(*,*)' BONDS ARRANGED' ISTRE=0 IBEND=0 ITOR=0 DO 3 I=1,N IDB(I)=0 3 IDT(I)=0 DO 54 IB=1,IB0 ISTRE=ISTRE+1 IST(ISTRE)=IAA(4,IB) JST(ISTRE)=IAA(3,IB) IBEND=IBEND+1 IBD(IBEND)=IAA(4,IB) JBD(IBEND)=IAA(3,IB) KBD(IBEND)=IAA(2,IB) IDB(IBD(IBEND))=KBD(IBEND) IF (KBD(IBEND).GT.NAT) THEN IW=0 DO 55 I=1,8 IR=ICON(JBD(IBEND),I) IF (IR.EQ.IBD(IBEND))GOTO 55 IF (IR.NE.0) IW=IR 55 CONTINUE IF (IW.EQ.0)IBEND=IBEND-1 IF (IW.NE.0)THEN KBD(IBEND)=IW IDB(IBD(IBEND))=IW IF (IDB(IW).EQ.IBD(IBEND))IBEND=IBEND-1 ENDIF ENDIF ITOR=ITOR+1 NITOR(ITOR)=1 NLTOR(ITOR)=1 JTOR(ITOR)=IAA(2,IB) KTOR(ITOR)=IAA(3,IB) IBUF(ITOR,1)=IAA(1,IB) JBUF(ITOR,1)=IAA(4,IB) IDT(JBUF(ITOR,1))=IBUF(ITOR,1) IF (IBUF(ITOR,1).EQ.NAT+1)THEN IW=0 DO 56 I=1,8 IR=ICON(JTOR(ITOR),I) IF (IR.EQ.KTOR(ITOR))GOTO 56 IF (IR.NE.0) IW=IR 56 CONTINUE IF (IW.EQ.0)ITOR=ITOR-1 IF (IW.NE.0)THEN IDT(JBUF(ITOR,1))=IW IBUF(ITOR,1)=IW ENDIF IF ((IW.EQ.0).AND.(IE(KTOR(ITOR+1)).GT.2)) THEN DO 59 I=1,IE(KTOR(ITOR+1)) IT=ICON(KTOR(ITOR+1),I) IF (IT.EQ.JTOR(ITOR+1).OR.IT.EQ.JBUF(ITOR+1,1))GOTO 59 IF (IDB(IT).NE.JBUF(ITOR+1,1))THEN IBEND=IBEND+1 IBD(IBEND)=IT JBD(IBEND)=KTOR(ITOR+1) KBD(IBEND)=JBUF(ITOR+1,1) IDB(JBUF(ITOR+1,1))=IT ENDIF GOTO 60 59 CONTINUE ENDIF 60 CONTINUE ENDIF IF (IBUF(ITOR,1).EQ.NAT+2)THEN K=KTOR(ITOR) IW=0 DO 57 I=1,8 IR=ICON(KTOR(ITOR),I) IF (IR.EQ.JBUF(ITOR,1))GOTO 57 IF (IR.NE.0) IW=IR 57 CONTINUE IF (IW.EQ.0)ITOR=ITOR-1 IF (IW.EQ.0)GOTO 54 IC=0 DO 58 I=1,8 IR=ICON(JBUF(ITOR,1),I) IF (IR.EQ.KTOR(ITOR)) GOTO 58 IF (IR.NE.0)IC=IR 58 CONTINUE IF ((IDT(IW).LE.N).AND.(IDT(IC).GE.1))IC=0 IF (IC.EQ.0)ITOR=ITOR-1 IF (IC.EQ.0)GOTO 54 JTOR(ITOR)=KTOR(ITOR) KTOR(ITOR)=JBUF(ITOR,1) JBUF(ITOR,1)=IC IBUF(ITOR,1)=IW IDT(IW)=IC ENDIF 54 CONTINUE RETURN END