program sortDQQ implicit none integer*4 i,n,j,i1,i2,i3,i4 integer*4,allocatable::ijk(:,:),istack(:) real*8,allocatable:: c(:) real*8 idum character*80 fn c write(6,*)'sorting anharmonic quartic constants from DQQ.SCR.TXT' n=0 open(8,file='DQQ.SCR.TXT') 101 read(8,*,end=99,err=99)idum,idum,idum,idum,idum n=n+1 goto 101 99 rewind 8 write(6,*)n,' constants' allocate(c(n),ijk(n,5),istack(n)) do 102 i=1,n 102 read(8,*)(ijk(i,j),j=1,3),c(i),c(i) close(8) do 1 i=1,n ijk(i,4)=ijk(i,1) ijk(i,5)=1 if(c(i).lt.0.0d0)ijk(i,5)=-1 1 c(i)=dabs(c(i)) open(8,file='uddia.lst') do 5 i=1,n i1=ijk(i,1) i2=ijk(i,2) i3=ijk(i,3) i4=ijk(i,4) 5 if(i1.eq.i2.and.i2.eq.i3.and.i3.eq.i4) 1write(8,6000)(ijk(i,j),j=1,4),c(i)*dble(ijk(i,5)) close(8) write(6,*)'unsorted diagonals written into uddia.lst' write(6,*)(ijk(1,i),i=1,5) write(6,*)(ijk(n,i),i=1,5) call sort2(n,n,c,ijk,istack) write(6,*)(ijk(1,i),i=1,5) write(6,*)(ijk(n,i),i=1,5) write(6,*)'sorted' open(8,file='ddia.lst') do 2 i=1,n i1=ijk(i,1) i2=ijk(i,2) i3=ijk(i,3) i4=ijk(i,4) 2 if(i1.eq.i2.and.i2.eq.i3.and.i3.eq.i4) 1write(8,6000)(ijk(i,j),j=1,4),c(i)*dble(ijk(i,5)) 6000 format(4i3,f12.4) close(8) write(6,*)'diagonals written into ddia.lst' open(8,file='d2.lst') do 3 i=1,n i1=ijk(i,1) i2=ijk(i,2) i3=ijk(i,3) i4=ijk(i,4) c iijj ijij ijji 3 if((i1.eq.i2.and.i3.eq.i4.and.i2.ne.i3).or. 1 (i1.eq.i3.and.i2.eq.i4.and.i2.ne.i3).or. 1 (i1.eq.i4.and.i2.eq.i3.and.i1.ne.i3)) 3write(8,6000)(ijk(i,j),j=1,4),c(i)*dble(ijk(i,5)) close(8) write(6,*)'2-center written into d2.lst' open(8,file='d3.lst') do 4 i=1,n i1=ijk(i,1) i2=ijk(i,2) i3=ijk(i,3) i4=ijk(i,4) c iijk ijik ijki jiik jiki jkii 4 if((i1.eq.i2.and.i2.ne.i3.and.i2.ne.i4.and.i3.ne.i4).or. 1 (i1.eq.i3.and.i1.ne.i2.and.i1.ne.i4.and.i2.ne.i4).or. 1 (i1.eq.i4.and.i1.ne.i2.and.i1.ne.i3.and.i2.ne.i3).or. 1 (i2.eq.i3.and.i1.ne.i2.and.i2.ne.i4.and.i1.ne.i4).or. 1 (i2.eq.i4.and.i1.ne.i2.and.i2.ne.i3.and.i1.ne.i3).or. 1 (i3.eq.i4.and.i3.ne.i2.and.i3.ne.i1.and.i1.ne.i2)) 1write(8,6000)(ijk(i,j),j=1,4),c(i)*dble(ijk(i,5)) close(8) write(6,*)'3-center written into d3.lst' open(8,file='d4.lst') do 6 i=1,n i1=ijk(i,1) i2=ijk(i,2) i3=ijk(i,3) i4=ijk(i,4) 6 if(i1.ne.i2.and.i1.ne.i3.and.i1.ne.i4.and. 1 i2.eq.i3.and.i2.ne.i4.and.i3.ne.i4) 2write(8,6000)(ijk(i,j),j=1,4),c(i)*dble(ijk(i,5)) close(8) write(6,*)'4-center written into d4.lst' stop end c ========================================================= subroutine sort2(n0,n,arr,brr,istack) c Sorts an array arr(1:n) into ascending order while c making rearangement of the array brr(1:n) c M ... when buble sort is switched on c implicit none integer*4 n,M,n0,n3 parameter (M=10,n3=5) real*8 arr(*),a,temp integer*4 brr(n0,n3),b(n3),itemp integer*4 i,ir,j,jstack,k,l,istack(n0),i3 jstack=0 l=1 ir=n 1 if(ir-l.lt.M)then c insertion sort for small Ms: do j=l+1,ir a=arr(j) do i3=1,n3 b(i3)=brr(j,i3) enddo do i=j-1,l,-1 if(arr(i).le.a)goto 2 arr(i+1)=arr(i) do i3=1,n3 brr(i+1,i3)=brr(i,i3) enddo enddo i=l-1 2 arr(i+1)=a do i3=1,n3 brr(i+1,i3)=b(i3) enddo enddo if(jstack.eq.0)return c pop stack and begind new round of partitioning ir=istack(jstack) l=istack(jstack-1) jstack=jstack-2 else c choose median of left, center and right elements as partitioning c element a. Also rearrange so that a(l)<=a(l+1)<=a(ir) k=(l+ir)/2 temp=arr(k) arr(k)=arr(l+1) arr(l+1)=temp do i3=1,n3 itemp=brr(k,i3) brr(k,i3)=brr(l+1,i3) brr(l+1,i3)=itemp enddo if(arr(l).gt.arr(ir))then temp=arr(l) arr(l)=arr(ir) arr(ir)=temp do i3=1,n3 itemp=brr(l,i3) brr(l,i3)=brr(ir,i3) brr(ir,i3)=itemp enddo endif if(arr(l+1).gt.arr(ir))then temp=arr(l+1) arr(l+1)=arr(ir) arr(ir)=temp do i3=1,n3 itemp=brr(l+1,i3) brr(l+1,i3)=brr(ir,i3) brr(ir,i3)=itemp enddo endif if(arr(l).gt.arr(l+1))then temp=arr(l) arr(l)=arr(l+1) arr(l+1)=temp do i3=1,n3 itemp=brr(l,i3) brr(l,i3)=brr(l+1,i3) brr(l+1,i3)=itemp enddo endif c initialize pointers for partitioning i=l+1 j=ir c partitioning element a=arr(l+1) do i3=1,n3 b(i3)=brr(l+1,i3) enddo c beginninf of innermost loop 3 continue c scan up to find element >a i=i+1 if(arr(i).lt.a)goto 3 4 continue c scan down to find element