program rcc implicit none integer*4 nq,nat,J,II,I,NPE,IMAX,K,KK,nc,il,iq,n,ic real*8 AMAX,an real*8,allocatable:: s(:,:),w(:),B(:,:),ir(:,:),str(:),AMODE(:), 1PE(:) integer*4,allocatable::MODE(:),IPE(:) character*2,allocatable::A1(:),A2(:),A3(:),A4(:) character*1,allocatable::bt(:),ty(:) logical deloc write(6,6000) 6000 format(/,' Relative coordinate changes under vibrations',/, 1 /,' Input: B.MAT Cartesian-Internal ', 1 /,' transformation matrix', 1 /,' F.INP S-matrix',/, 1 /,' Output: POT_all.LST PED - all', 1 /,' POT.EN PED - selected', 1 /,' POT.TXT brief summary',/,/) call setd(nq,nat,nc,n) allocate(s(n,nq),w(nq),B(nc,n),A1(nc),A2(nc),A3(nc),A4(nc), 1ty(nc),bt(nc),ir(nq,nc),str(nc),AMODE(nc),MODE(nc),PE(nc), 1IPE(nc)) call reads(nq,nat,s,w) call rb(B,nc,n) call rfu(nc,A1,A2,A3,A4,ty,bt,str) ir=0.0d0 do 1 ic=1,nc do 1 iq=1,nq do 2 il=1,n 2 ir(iq,ic)=ir(iq,ic)+B(ic,il)*s(il,iq) 1 ir(iq,ic)=dabs(ir(iq,ic)/str(ic)) do 3 iq=1,nq an=0.0d0 do 4 ic=1,nc 4 an=an+ir(iq,ic) do 3 ic=1,nc 3 ir(iq,ic)=ir(iq,ic)/an call wrall(nq,nc,w,ir) OPEN(20,FILE='POT.TXT') OPEN(19,FILE='POT.EN') WRITE(19,1921) WRITE(20,1921) 1921 format(' Relative coordinate change [in %]',/, 1 ' MODE coordinate(change) (for change > 5%)',/, 180(1H-)) AMODE=0.0D0 MODE=0 c c Loop over normal modes: DO 451 J=1,nq NPE=0 c c Loop over coordinates DO 453 II=1,nc AMAX=ir(J,1) IMAX=1 c c Second loop over coordinates - find maximum and zero after DO 452 I=2,nc IF(ir(J,I).GT.AMAX)THEN AMAX=ir(J,I) IMAX=I ENDIF 452 CONTINUE ir(J,IMAX)=0.0D0 AMAX=AMAX*100.0D0 c NPE=NPE+1 PE(NPE)=AMAX IPE(NPE)=IMAX c c record the absolute maximum:(mode J, coord IMAX) IF(AMODE(IMAX).LT.AMAX)THEN MODE(IMAX)=J AMODE(IMAX)=AMAX ENDIF 453 CONTINUE NPE=MIN(NPE,5) deloc=PE(1).lt.5.0d0 if(PE(1).gt.99.9d0)PE(1)=99.9d0 WRITE(19,1923)nq-J+1,w(J) 1923 FORMAT(I5,F9.1,$) WRITE(20,1924)J,nint(w(J)) 1924 FORMAT(I5,I8,' ',$) do 9 I=1,NPE if(I.eq.1.or.PE(I).gt.5.0d0)then K=IPE(I) c is this type already recorded?: do 11 II=1,I-1 KK=IPE(II) 11 if(ty(K).eq.ty(KK).and.A1(K).eq.A1(KK).and.A2(K).eq.A2(KK).and. 1 A3(K).eq.A3(KK).and.A4(K).eq.A4(KK).and.bt(K).eq.bt(KK))goto 9 if(I.ne.1)write(20,1929) 1929 FORMAT(', ',$) write(20,1926)ty(K) 1926 FORMAT(a1,$) if(ty(K).eq.'v')then write(20,1927) 1927 FORMAT('(',$) if(A1(K).eq.' H')then call wr1(A2(K)) call wr1(A1(K)) else call wr1(A1(K)) call wr1(' '//bt(K)) call wr1(A2(K)) endif write(20,1928) 1928 FORMAT(')',$) endif if(ty(K).eq.'d')then write(20,1927) call wr1(A1(K)) call wr1(A2(K)) call wr1(A3(K)) write(20,1928) endif if(ty(K).eq.'o')then write(20,19271) 19271 FORMAT('op(',$) call wr1(A1(K)) call wr1(A2(K)) call wr1(A3(K)) call wr1(A4(K)) write(20,1928) endif if(ty(K).eq.'t')then write(20,1927) call wr1(A1(K)) call wr1(A2(K)) write(20,1928) endif WRITE(19,1925)K,PE(i) 1925 FORMAT(I5,'(',F4.1,')',$) endif 9 continue if(deloc)write(20,1930) 1930 format(', deloc.',$) WRITE(19,*) WRITE(20,*) 451 CONTINUE WRITE(19,1920) 1920 format(80(1H-)) DO 455 I=1,nc 455 WRITE(19,1919)I,nq+1-MODE(I),w(MODE(I)),AMODE(I) 1919 FORMAT(' Coordinate',I4,' is most present in mode',I4, 1f10.2, 'cm-1 (by',F5.1,'%).') WRITE(19,1920) CLOSE(19) CLOSE(20) end subroutine wr1(A) character*2 A if(A(1:1).eq.' ')then write(20,201)A(2:2) 201 FORMAT(a1,$) else write(20,202)A 202 FORMAT(a2,$) endif return end subroutine rfu(nc,A1,A2,A3,A4,ty,bt,str) integer*4 nat,nc,J,itype real*8 str(nc),pi character*2 A1(nc),A2(nc),A3(nc),A4(nc) character*1 ty(nc),bt(nc) character*120 s120 pi=4.0d0*atan(1.0d0) open(8,file='FILE.UMA') read(8,*) read(8,*) read(8,*)nat,nc ty='?' bt='?' A1=' X' A2=' X' A3=' X' A4=' X' str=pi/4.0d0 do 7 J=1,nat 7 read(8,*) do 8 J=1,nc read(8,800)s120 800 format(a120) read(s120,*)itype if(itype.eq.1)then ty(J)='v' A1(J)=s120(65:66) A2(J)=s120(74:75) bt(J)=s120(72:72) read(s120(86:93),*)str(J) else if(itype.eq.2)then ty(J)='d' A1(J)=s120(63:64) A2(J)=s120(72:73) A3(J)=s120(81:82) str(J)=pi/2.0d0 else if(itype.eq.3)then ty(J)='o' A1(J)=s120(63:64) A2(J)=s120(72:73) A3(J)=s120(81:82) A4(J)=s120(90:91) str(J)=1.0d0 else if(itype.eq.4)then ty(J)='t' A1(J)=s120(66:67) A2(J)=s120(77:78) read(8,*) read(8,*) else goto 444 endif endif endif endif 8 continue 444 close(8) return end subroutine setd(nq,nat,nc,n) implicit none integer*4 nq,nat,nc,n OPEN(17,FILE='F.INP',STATUS='OLD') READ(17,*)nq,n,nat close(17) open(9,file='B.MAT') read(9,*)nc close(9) return end subroutine reads(NQ,NOAT,SV,FRQ) implicit none integer*4 NQ,NOAT,K,I,J real*8 SV(3*NOAT,NQ),FRQ(*) OPEN(17,FILE='F.INP',STATUS='OLD') READ(17,*)NQ,NOAT,NOAT DO 3 K=1,NOAT 3 READ(17,*) READ(17,*) DO 4 K=1,NOAT DO 4 I=1,NQ 4 READ (17,*)(SV(J+3*(K-1),I),J=1,2),(SV(J+3*(K-1),I),J=1,3) READ(17,*) READ(17,*)(FRQ(I),I=1,NQ) write(6,*)'F.INP read' close(17) return end subroutine rb(B,nc,n) implicit none integer*4 nc,n,i,nn,ii,ia,ix real*8 B(nc,n) B=0.0d0 open(9,file='B.MAT') read(9,*) read(9,*) read(9,*) do 13 i=1,nc read(9,*) read(9,*)nn do 13 ii=1,nn 13 read(9,*)ia,ix,b(i,ix+3*(ia-1)) close(9) write(6,*)'B.MAT read' return end subroutine wrall(nq,nc,w,ir) implicit none integer*4 nq,nc,i,J real*8 w(*),ir(nq,nc) OPEN(17,FILE='POT_all.LST') do 1 i=1,nq write(17,1717)i,w(i) 1717 format(i6,f10.2,$) do 2 J=1,nc 2 write(17,17171)ir(i,J) 17171 format(f10.6,$) 1 write(17,*) close(17) return end