*******************************************************************************

	program elastic_xyz 

*******************************************************************************
c
c       This program allows the user to create input car files with
c       expanded or compressed coordinates along all unit cell vectors
c       The application is to test the energy vs unit cell dimension
c       This is a test of the structure and bulk modulus that are calculated
c       by DFT methods
c
c	To compile non-graphics programs use : 
c        f77 $(OPT) elastic_xyz.f -o elastic_xyz
c
        real rx(300), ry(300), rz(300)
        real ucell ,cx,cy,cz
        real rnx(300), rny(300), rnz(300)
        real cnx,cny,cnz
        character*80    record(300)
        character*80    rec
        character*80    aform
        character*80    bform
        character*40	fname
        character*10	gname
        character*20    right 
        character*20    r1
        character*5     left 
        character*5     l1
        character*4     root 
        integer         i,ia,id,ih
	integer	        natom
	integer	        ndisp ,nfrag
	integer	        j,itime 
	integer	        ifrag(20) 
c
c 
	 print *,'Enter car file name: '
	 read(5,'(a40)') fname
c
         print *,'Input the number of atoms:'
         read(5,*) natom 
c
c       
         open(unit=7,file=fname,form='formatted',
     $                            status='old',err=990)
c
         aform = "(a5,3(2x,f13.9),a29)"
         bform = "(a5,3(f10.5),a29)"
c
         read(7,'(a80)',end=997,err=995) record(1)
         read(7,'(a80)',end=997,err=995) record(2)
         read(7,'(a80)',end=997,err=995) record(3)
         read(7,'(a80)',end=997,err=995) record(4)
         read(7,'(a80)',end=997,err=995) record(5)
         write(6,'(a80)') record(5)

         read (record(5),bform,err=996) l1,cx,cy,cz,r1 
         print *,'The unit cell and all coordinates along X, Y and Z' 
         print *,'will be multiplied by a factor.'
         print *,'Input the factor to multiply the unit cell vector:'
         read(5,*) ucell 
c
         do 200 i=1,natom
           read(7,'(a80)',end=997,err=995) record(i+5)
           write(6,'(a80)') record(i+5)
           read (record(i+5),aform,err=996) left,rx(i),
     $                       ry(i),rz(i),right
200      continue
c
         close(7)
c
c
	 print *,'Enter output file root name: '
	 read(5,'(a4)') root
c
         gname=root//'_x.car'
         do 110 i = 1,natom
           rnx(i)=rx(i)*ucell
           rny(i)=ry(i)
           rnz(i)=rz(i)
110       continue
         cnx=cx*ucell
         cny=cy
         cnz=cz
c
         call wf(rnx,rny,rnz,cnx,cny,cnz,ucell,natom,
     $gname,record)
c
         gname=root//'_z.car'
c
         do 120 i = 1,natom
           rnx(i)=rx(i)
           rny(i)=ry(i)
           rnz(i)=rz(i)*ucell
120       continue
         cnx=cx
         cny=cy
         cnz=cz*ucell
c
         call wf(rnx,rny,rnz,cnx,cny,cnz,ucell,natom,
     $gname,record)
c
         gname=root//'_y.car'
         do 130 i = 1,natom
           rnx(i)=rx(i)
           rny(i)=ry(i)*ucell
           rnz(i)=rz(i)
130       continue
         cnx=cx
         cny=cy*ucell
         cnz=cz
c
         call wf(rnx,rny,rnz,cnx,cny,cnz,ucell,natom,
     $gname,record)
c
         goto 999
990      continue
         print *,'Error in input file'
         goto 999
995      continue
         print *,'Error in format'
         print *, record
         goto 999
996      continue
         print *,'Error parsing format'
         print *, record
         print *,left, rx(i), ry(i), rz(i),right 
         goto 999
997      continue
         print *,'End of file detected'
999      continue
c
         end
c
***************************************************************************
       Subroutine wf(rx,ry,rz,cx,cy,cz,ucell,na,gname,recd)
***************************************************************************
        real rx(300), ry(300), rz(300)
        real ucell ,cx,cy,cz
        character*11 gname
        character*80    recd(300)
        integer na

        integer j,junit,ierror
        character*80    rec

         open(unit=7,file=gname,form='formatted',
     $                           status='new',err=2990)
         ierror=0
        junit=7
        do 50 j=1,4
          write(junit,'(a80)') recd(j)
50      continue 
        rec=recd(5)
        write (junit,10) rec(1:5),cx,cy,cz,rec(36:80)
        do 100 j = 1,na
          rec=recd(j+5)
       write (junit,20) rec(1:8),rx(j),ry(j),rz(j),rec(51:80)
100     continue
          do 150 j = 1,2
	    write(junit,'(a3)') 'end'
150       continue 
        close(7)
c
10       format(a5,3(f10.5),a45)
20       format(a8,f12.9,3x,f12.9,3x,f12.9,a30)

         goto 3000 
2990     continue
         print *,'Error in input file'
3000     continue
         return
         end