C slightly modified dyn88.f by Wei Cai
C 
C changed utils/utils.f   subroutine scale -> scale_sub
C remove contin, lastconf from dyn88.f dyn88a.f
c move common/mea/ to dyn.inc

C from original main.f

        subroutine freevel
        return
        end
        subroutine frnewton(contin)
        logical contin
        return
        end
        subroutine freepot
        return
        end
        subroutine froutput
        return
        end
        subroutine xforce
        return
        end

c   dyn88.f
c$Author: baskes $
c$Date: 2004/09/29 19:26:24 $
c$Source: /home/baskes/programs/MEAM/v88/RCS/dyn88.f,v $
c$Revision: 1.30 $
c$Log: dyn88.f,v $
cRevision 1.30  2004/09/29 19:26:24  baskes
cfixed B1 + NN
c
cRevision 1.29  2004/02/24 16:10:32  baskes
cadded ialloy
c
cRevision 1.28  2003/12/09 21:17:58  baskes
cmerged with dyn96
c
cRevision 1.27  2003/12/09 17:04:25  baskes
cupdating dyn96 compatability
c
cRevision 1.26  2003/12/06 04:20:22  baskes
cupdating
c
cRevision 1.25  2003/01/18 18:02:13  baskes
cfixed initialization of 2NN MEAM with iscr=1
c
cRevision 1.24  2002/11/04 18:28:39  baskes
cchanged print
c
cRevision 1.23  2002/04/26 20:55:35  baskes
cadded vcm
c
cRevision 1.22  2002/04/07 01:24:36  baskes
cmoved restart stuff to utils
cadded constant velocity of periodic vector
c
cRevision 1.21  2002/02/22 19:48:29  baskes
cfixed header in output
c
cRevision 1.20  2002/01/04 23:15:14  baskes
cmodified averaging
c
cRevision 1.19  2001/12/04 22:40:36  baskes
cCM fixed
c
cRevision 1.18  2001/12/04 18:52:25  baskes
cadd icm zero CM velocity
c
cRevision 1.17  2001/09/17 16:25:04  baskes
cfixed NN
cadded ipscree
c
cRevision 1.16  2001/09/09 14:28:43  baskes
cadded SiO2
c
cRevision 1.15  2001/06/12 15:35:01  baskes
cadded acf
c
cRevision 1.14  2001/05/16 21:04:56  baskes
cfix arg for hcp
covercome z inconsistency
c
cRevision 1.13  2001/05/15 21:33:45  baskes
cremoved default repuls
caddeed 2NN MEAM
cadded table
c
cRevision 1.12  2001/02/27 18:29:37  baskes
cfixed lattces
c
cRevision 1.11  2001/01/17 01:02:30  baskes
cfull slocal
c
cRevision 1.10  2001/01/08 23:31:18  baskes
cfixed real seconds
c
cRevision 1.9  2001/01/08 22:59:47  baskes
cfixed header
c
c**********************************************************************
c
c               dynamic code version 8.7 (unix) msd/smf  8/30/99
c      (temperature control: tmpcard & tmprgn added to input namelist)
c	meafile added to read meacard 3/20/97
c	fixed hcp initialization 4/15/97
c	8/8/97 added legendre correction
c	10/4/97 added repulsive term to Rose function
c	3/26/98 added attrac to erose
c	11/13/98 added iconf=4 (energy output)
c       monoclinic structure added 8/9/99
c	CM velocity fixed  1/21/00
c	change in fix for negative rho^2 3/11/00
c
c*******************************************************************
c               conventions
c       9000+ reserved for format statement #'s
c*******************************************************************
c
	block data
      include 'param.inc'
      include 'dyn.inc'
      include 'meam.inc'
c      logical contin,lastconf
c      character*80 printf,rstrtf,conff,meamf,forcef,meafile
c      character*24 timestr
c      common/mea/ meamf, meafile
      data eqtim/0.0/
	data itable/0/,nn/.false./
      data rscrmax /0.0/,ipscree/0/
      data dt,tol,iaccur,inte,accbnd/0.001,0.001,0,1,1000.,400./
      data ipinter/0/,ipatoms/3/,ipitera/-1/,irstrt/0/,iconf/0/,
     1    iconst/0/
c      data contin/.false./,lastconf/.true./
      data xminp,yminp,zminp/3*-1.e6/,xmaxp,ymaxp,zmaxp/3*1.e6/
        data nminp,nmaxp/1,10000/
      data typep/0/,sortp/.false./
        data legend /0.0/
	data ialloy/0/
	end
      subroutine dyn88
      include 'param.inc'
      include 'dyn.inc'
      include 'meam.inc'
      logical contin,lastconf
c      character*80 printf,rstrtf,conff,meamf,forcef,statf,meafile
c      character*24 timestr
c	common/mea/ meamf, meafile
	common/free/ ifree
	common/print1/iustat
      namelist /prntcard/ ipinter,ipatoms,ipitera,printf,rstrtf,conff,
     1    iconst,xminp,yminp,zminp,xmaxp,ymaxp,zmaxp,nminp,nmaxp,
     2    typep,sortp,iconf,meamf,forcef,ipscree,iout,statf
      namelist /continue/ contin,lastconf
      data rstrtf,conff,forcef/3*'none'/,printf/'dynprint'/
c
c  determine the initial timing values
c
      call initsec()
c
c  read the parameters controlling output
c
      read(5,prntcard)
c
c  determine which output files are desired and open them
c
      open(unit=6,file=printf,form='FORMATTED',status='UNKNOWN')
c
	if(ifree.eq.0) then
      write(6,9100)
9100  format(' *******  dynamo version 8.7 (unix) *******'/,
     1   '$Revision: 1.30 $',/'$Date: 2004/09/29 19:26:24 $')
	else
      if (iout.eq.1) then
         iustat=6
      else
         iustat=23
c         open(unit=23,file=statf,form='FORMATTED',status='UNKNOWN')
      endif
      write(6,9107)
9107  format(' *******  dynamo version 9.6 (unix) *******'/,
     1   '$Revision: 1.30 $',/'$Date: 2004/09/29 19:26:24 $')
	endif
c
      write(6,9005)printf
9005  format(/,/,1x,'opened print file named ',a)
c
c  print out the  real time for the beginning of the job
c
      call mytime(timestr)
      write(6,9101) timestr
9101  format(/,/,1x,'begin run:',a24)
c
c	open restart and configuration files
c
      if (.not.(rstrtf(1:4).eq.'NONE'.or.rstrtf(1:4).eq.'none')) then
         irstrt = 1
         open(unit=21,file=rstrtf,form='FORMATTED',status='UNKNOWN')
         write(6,9006)rstrtf
9006     format(1x,'opened restart file named ',a)
      end if
      if (.not.(conff(1:4).eq.'NONE'.or.conff(1:4).eq.'none')) then
         if (iconf.eq.0) iconf = 1
         open(unit=20,file=conff,form='UNFORMATTED',status='UNKNOWN')
         write(6,9007)conff,iconf
9007     format(1x,'opened configuration file named ',a,/
     $             ' configuration file type:',i2)
       else
         iconf = 0
       end if
      if (.not.(forcef.eq.'NONE'.or.forcef.eq.'none')) then
         iforce = 1
         open(unit=30,file=forcef,form='FORMATTED',status='UNKNOWN')
         write(6,9008) forcef
9008     format(1x,'opened force file named ',a)
        else
        iforce=0
      end if
c
c  call dynamo to perform the computation
c
1000  continue
      call dynamo(contin,lastconf)
      contin = .false.
      read(5,continue,end=9000,err=9000)
      if (.not.contin) goto 9000
c
c  mark the output file
c
      write(6,9201)
9201  format(1x,/,1x,'******  continuation run  *******',/,1x)
c
c  close and reopen the configuration file and restart file
c
      if (irstrt.eq.1) then
         close(21)
         open(unit=21,file=rstrtf,form='FORMATTED',status='UNKNOWN')
         write(6,9006)rstrtf
      end if
      if (iconf.ne.0) then
         close(20)
         open(unit=20,file=conff,form='FORMATTED',status='UNKNOWN')
         write(6,9007)conff
      end if
      goto 1000
9000  continue
c
c  compute final timing information
c
      t2tot = seconds()
      t2cpu = 0.
      t2io = 0.
      t2sys = 0.
c
      write(6,9010) t2tot,t2cpu,t2io,t2sys
9010  format(/,/,1x,'timing:',7x,'total',9x,'cpu',10x,'io',6x,'system',
     1  /,8x,4f12.3)
      call mytime(timestr)
      write(6,9102) timestr
9102  format(1x,'end of run:',a24)
c
      if (inte.ne.-1.or.mnterm.eq.0) then
         stop ''
       else if (mnterm.eq.1) then
         stop '*nfmax*'
       else
         stop '*timeup*'
       endif
      end
c************************************************************************
c
c
c       this is the main routine
c
      subroutine dynamo(contin,lastconf)
      include 'param.inc'
      include 'dyn.inc'
      include 'meam.inc'
        common /err/  ibarer,ibare
	common/head/ header
	common/free/ifree
      common /average1/  potbar,potrms,vcm(3),potrefbar,potrefrms,nfree
      logical contin,lastconf
      character*80 header
      data header /'        '/
      data nmeth/2/,dradn/-1.0/
	data zero/0.0001/
	data ncalcacf/1/
      namelist /headcard/ header
      namelist /neicard/ nmeth,dradn
      namelist /avecard/ eqtim,nbuff,nval,nlimitacf,ncalcacf
c
c
c  clear the force statistics variables
c
	sqrtz=sqrt(zero)
      nforce = 0
      ngtlst = 0
      nneimx = 0
      mxlstu = 0
      mxnnei = 0
      frctmx = -1.e5
      frctmn = 1.e5
      gnetmx = -1.e5
      gnetmn = 1.e5
c
c  read and print the descriptive header for this run
c
      if (.not.contin) read(5,headcard)
      write(6,9110) header
9110  format(' ****************************************** ',//,
     11x,a,//,
     1' ******************************************  ')
c
c describe the output control in effect
c
      if(.not.contin)write(6,9120)ipinter,ipatoms,ipitera,iconst
9120  format(/,/,'  print control:  ',/,
     1'    print interaction functions: ',i4,/,
     2'    print atom positions: ',i4,/,
     3'    print iteration info: ',i4,/,
     4'    print full constraint list: ',i4)
c
c  print the units convention
c
      if(.not.contin)write(6,9130)
 9130 format(/,/,' explanation of units',/,' positions in angstroms',/,
     1' time in picoseconds',/,' velocities in angstroms/picosecond',/,
     2' energies in ev',/,' temperature in degrees kelvin',/,
     3' pressure in bars ',/,
     4' mass in ev-psec^2/angstroms^2',/,/)
c
c       set up interactions
c
      if (.not.contin) then
         call inter
c         call modint
       end if
	if(ipinter.eq.1) call prphi
c
c  determine the initial positions and velocities
c
      call initlat(contin,lastconf)
c
c  read in the type of boundaries to be used
c
	call getbnd
c
c  determine the type of neighbor finding method to be used
c
      if (.not.contin) read(5,neicard)
      write(6,9611) nmeth
9611  format(1x,/,'****** using neighbor method: ',i2)
c
c  if nmeth=2, set up the storage required by the neighbor list,
c  initialize the values of the neighbor list index and compute the
c  cut off radii for the neighbor list using the default
c  expression for dradn if it is not specified
c
c  nmeth=2
      if (abs(nmeth).eq.2) then
         nnstrt = 0
         nnindx(0) = nnstrt
         nnindx(1) = nnstrt
         newlst = 1
         if (dradn.lt.0.0) dradn = 0.1*sqrt(rcutsq)
c         if (dradn.lt.0.0) dradn = 0.35*sqrt(float(natoms)/500.0)
         rctsqn = (sqrt(rcutsq) + dradn)**2
         write(6,9612) rctsqn,dradn
9612  format(1x,/,'    rctsqn:',g13.5,'  dradn:',g13.5)
       end if
c
c  nmeth = 3
c
      if (nmeth.eq.3) then
         newlst = 1
         natsav = natoms
         if (dradn.lt.0.0) dradn = 0.35
         rctsqn = (sqrt(rcutsq) + dradn)**2
         write(6,9612) rctsqn,dradn
       endif
c
c       calculate energy of initial lattice without defects
c
      call calce(ekin1,eperf,etot1,temper,press,1,t0)
c
c       read in defects
c
      write(6,9140)
 9140 format(/,/' ******  reading in defects ')
      call readef(ndef)
c
c  if defects have been created, force the determination of a
c  new neighbor list
c
      if (ndef.ne.0) newlst = 1
      write(6,9150)ndef
 9150 format('  finished reading in ',i5,' defects ')
c
c  delete vacancies
c
      call delvac
c
c  check that all types used have been defined
c
      call chktyp
c
c  make sure 0.lt.natoms.le.natmax
c
      if(natoms.le.0)then
         write(6,*) ' there are no atoms'
         stop
      endif
      if(natoms.gt.natmax)then
         write(6,9160)natoms,natmax
 9160    format(' natoms=',i10,' is greater than natmax=',i10)
         stop
      endif
c
c  read in the fixcard constraints
c
      call setfix(contin,lastconf,nfixcard)
c
c
c  read in and set up the temperature control
c
      call settmp(contin)
c
c  initiaze the averaging variables
c
      if (.not.contin) read(5,avecard)
      if (.not.contin) write(6,avecard)
c       calculate initial state
c
      if(nfixcard.ne.0.or.ndef.ne.0)then
          call calce(ekin1,pot1,etot1,temper,press,1,t0)
      else
          pot1 = eperf
      endif
      volint = perlen(1)*perlen(2)*perlen(3)/natoms
      write(6,9205)ekin1,pot1,etot1,temper,press,volint
 9205 format(' ******   initial state: ',/,
     1'  kinetic, potential and total energies ',3e17.9,/,
     2'  temperature:',g13.6,'  pressure:',g13.6,'  volume:',g13.6)
	if(ifree.ne.0) call freevel
c
c       print out types, positions, velocities, electron densities,
c       forces and energies on particles
c
      write(6,9170)natoms
 9170 format(/,/1x,i5,' particles ')
      if(abs(ipatoms).eq.1.or.abs(ipatoms).eq.3) call patoms
c
c  write the job parameters to the output file 20 for use by the
c  analysis programs
c
      if (iconf.ne.0) then
        write(20) header
        write(20) natoms,iconf
        write(20) (perub(i),i=1,3),(perlb(i),i=1,3)
       end if
c
c  call newton to integrate the equations of motion
c               or to minimize the potential
c
	nskipd=0
	nfree=0
	call average(-1,t)
	call average(0,t)
	if(ifree.eq.0) then
      call newton(contin)
	else
      call frnewton(contin)
	endif
c
c  if a minimization, put the final positions in a configuration file
c  if there is one
c
      if (iconf.ne.0.and.inte.eq.-1) then
c
      if (iconf.eq.1) then
         write(20) t,temp,press,(perlen(i),i=1,3)
         write(20) ((rv(i,j),i=1,3),itype(j),j=1,natoms)
       end if
      if (iconf.eq.2) then
         write(20) t,temp,press,(perlen(i),i=1,3)
         write(20) ((rv(i,j),i=1,6),itype(j),j=1,natoms)
       end if
      if (abs(iconf).eq.3) then
         write(20) t,temp,press,(perlen(i),i=1,3)
         write(20) ((rv(i,j),i=1,3),itype(j),j=1,natoms)
	if(iconf.gt.0) then
         write(20) (((slocal(i,j,k),i=1,j),j=1,3),k=1,natoms)
	else
         write(20) (((slocal(i,j,k),i=1,3),j=1,3),k=1,natoms)
	endif
       end if
      if (iconf.eq.4) then
         write(20) t,temp,press,(perlen(i),i=1,3)
         write(20) ((rv(i,j),i=1,6),itype(j),e(j),j=1,natoms)
       end if
c
      endif
c  write the force file
        if(iforce.eq.1) then
        write(30,9777) ((f(i,j),i=1,3),j=1,natoms)
9777    format(3e20.8)
        endif
c
c  if this run is just to calculate energy (inte=2), skip down to
c  timing information
c
c      if(inte.eq.2)goto 5000
c
c  print out the final position, velocities, and forces as well as
c  the final energies, temerature, and pressure
c
	if(ifree.ne.0) volintot=volint*natoms
	call finalpr(ekin1,pot1,etot1,eperf,volint)
c
c  compute and output the average values.
c
        if(inte.eq.1)  call average(3,t)
c
      if (nfree.gt.0) call freepot
c
c  create the restart file (21)
c
c       use format compatible with vax/creator capability
      if (irstrt.eq.1) then
	rewind(21)
      write(21,9501) header
9501  format(a)
      write(21,9502) natoms,ntypes,tend,beta
9502  format(2i10,e15.8,f10.5)
      write(21,9503) (perub(i),i=1,3),(perlb(i),i=1,3)
9503  format(3e25.16)
      write(21,9504) (amass(i),ielement(i),i=1,ntypes)
9504  format(e25.16,i10)
      write(21,9505) ((rv(i,j),i=1,6),itype(j),j=1,natoms)
9505  format(3e25.16/3e25.16/i10)
      write(21,9503) (bndvel(i),i=1,3)
      end if
c
c  output the statistics on call to force
c
c  branch to here if only calculated energy once (inte=2)
5000  continue
      write(6,9401)
9401  format(/,/,1x,'****** statistics on FORCE and GNEIGH')
      write(6,9402)nforce
9402  format(1x,'total number of calls to FORCE:',i5)
      if (abs(nmeth).eq.2) write(6,9403) ngtlst
9403  format(1x,'total number of neighbor list updates:',i5)
	if(natoms.gt.2) then
      mxtmp = 2*int(1.+float(mxlstu)/float(natoms-2))
      mxnnei = max0(mxnnei,mxtmp)
      write(6,9404) nneimx,mxnnei
9404  format(1x,'maximum number of actual neighbors found:',i5,/,
     1       1x,'maximum number of possible neighbors found:',i5)
	endif
      write(6,9405)frctmx,frctmn
9405  format(1x,'maximum and minimum times for calls to FORCE:',/,
     1       5x,2g15.5)
      write(6,9406)gnetmx,gnetmn
9406  format(1x,'maximum and minimum times for calls to GNEIGH:',/,
     1       5x,2g15.5)
	write(6,9407) rscrmax
9407	format(1x,'maximum distance between partially',
     1	' unscreened atoms: ',f10.5)
	write(6,9408) ibarer,ibare
9408	format(1x,'number of negative square root calls',i5/
     1   'number in last call to force',i5)
      return
      end
c
c
c***************************************************************
c	prints out phi
c
	subroutine prphi
      include 'param.inc'
      include 'dyn.inc'
      dimension p(3,3)
	ntype=min(ntypes,3)
	write(6,9000) ((it,jt,jt=it,ntype),it=1,ntype)
9000	format('  pair potentials'/5x,'r',4x,6(4x,2i1,4x))
	do 9809 i=1,100
        r=.05*i
	do 1 it=1,ntype
	do 1 jt=it,ntype
1	p(it,jt)=phif(r,it,jt)
        write(6,9808) r,((p(it,jt),jt=it,ntype),it=1,ntype)
9808    format(7f10.4)
9809    continue         
	return
	end
c***************************************************************
c
c  patoms prints out the atom positions etc.
c
      subroutine patoms
      include 'param.inc'
      include 'dyn.inc'
      include 'meam.inc'
      include 'wrkspc.inc'
      dimension rmult(natmax),dum1(natmax),idum1(natmax),idum2(natmax)
        naver=0
        ave=0.
c
c  sort the output list if requested
c
      do 1000 i = 1,natoms
      idum1(i) = i
1000  idum2(i) = i
      if (.not.sortp) goto 2000
      permax = max(perlen(1),perlen(2),perlen(3))
      if(permax.ge.1000.)then
         xbot = 1.e6
         ybot = 1.e6
         zbot = 1.e6
         do 1005 i = 1,natoms
         xbot = min(xbot,rv(1,i))
         ybot = min(ybot,rv(2,i))
         zbot = min(zbot,rv(3,i))
1005     continue
         call m01aaf(perlen,1,3,idum1,idum2,ifail)
         rmult(1) = 10**(4*idum1(1)-3)
         rmult(2) = 10**(4*idum1(2)-3)
         rmult(3) = 10**(4*idum1(3)-3)
         do 1010 i=1,natoms
         dum1(i) = rmult(1)*(rv(1,i)-xbot)
     1           + rmult(2)*(rv(2,i)-ybot)
     2           + rmult(3)*(rv(3,i)-zbot)
1010     continue
      else
         do 1020 i=1,natoms
         dum1(i) = rv(1,i)**2 + rv(2,i)**2 + rv(3,i)**2
1020     continue
      endif
      call m01aaf(dum1,1,natoms,idum1,idum2,ifail)
      do 1030 i = 1,natoms
1030  idum2(idum1(i)) = i
      if(ifail.ne.0)write(6,9020)ifail
 9020 format('    trouble in sorting routine   ',i5)
2000  continue
c
c
c  now print out the atoms in the specified region and/or type
c
      write(6,9180)
 9180 format(1x,'atomic data:',
     1       'number, type, positions, energy')
      if (ipatoms.gt.0) write(6,9181)
9181  format(13x,'velocities, kinetic energy (if not minimization)',/,
     2   13x,'forces',/,
     3   13x,'el. density, f(rho), phi(r)',/,
     4   13x,'rho0, rho1^2, rho2^2, rho3^2'/)
	nmaxp=min(nmaxp,natoms)
      do 2100 i = nminp,nmaxp
      j = idum2(i)
      if (rv(1,j).lt.xminp.or.rv(1,j).gt.xmaxp) goto 2100
      if (rv(2,j).lt.yminp.or.rv(2,j).gt.ymaxp) goto 2100
      if (rv(3,j).lt.zminp.or.rv(3,j).gt.zmaxp) goto 2100
      if (typep.ne.0.and.itype(j).ne.typep) goto 2100
      write(6,9190) j,itype(j),rv(1,j),rv(2,j),rv(3,j),e(j)
9190  format(1x,i5,1x,i2,4g15.7)
        naver=naver+1
        ave=ave+e(j)
      if (ipatoms.lt.0) goto 2100
      if (inte.ne.-1) then
         akin = 0.5*amass(itype(j))*(rv(4,j)**2+rv(5,j)**2+rv(6,j)**2)
         write(6,9191) rv(4,j),rv(5,j),rv(6,j),akin
9191     format(9x,4g15.5)
       endif
      write(6,9192) (f(kk,j),kk=1,3)
9192  format(9x,3g15.5)
      ity = itype(j)
      write(6,9193) rho(j),plocal(j),fp(j)
9193  format(9x,3g15.5)
	write(6,9191) c(j),rhsq(1,j),rhsq(2,j),rhsq(3,j)
2100  continue
c
c  print out the periodic lengths
c
      write(6,9200) (perlen(i),i=1,3)
 9200 format(1x,'perlen:',3g15.7)
        if(naver.gt.0) ave=ave/naver
        write(6,9201) ave
9201    format(' average energy ',e20.12)
      return
      end
c***************************************************************
c
c  this routine sets the parameters defining the interactions
c
      subroutine inter
      include 'param.inc'
      include 'dyn.inc'
      include 'meam.inc'
       common /fr/ frcut,xncut,xmcut
	common /alloy/ all(nelmax,nelmax)
c	common/mea/ meamf,meafile
	common /scre/ noscr
        common /czbl/ xzbl,xzbl0
c      character*80 header,meamf,meafile
      character*4 name,all,lattce
      character*7 kodes(nelmax)
	data xncut,xmcut/2.,4./
      data conmas/1.0365e-4/
      data rz0/1.0/,alpha0/1.0/
        data xzbl,xzbl0/-3.,-1./
c	data meamf/'meamf'/
c	data meafile/'none'/
	data noscr/0/
c	data hartre/27.2/,bohr/0.529/
	data frcut/0.9/
      namelist /meacard/ ntypes,lattces,enames,esubs,alats,alphas,asubs,
     1                   betas,ts,deltas,zs,rozros,kderiv,kodes,rcut,
     2                   rz0,alpha0,all,res,cmin,cmax,itable,nn,ialloy,
     3                   noscr,meafile,legend,repuls,attrac,xzbl,xzbl0,
     4			frcut,xncut,xmcut
      common /kodes/kodes
      integer kmeamf
c
c     subroutine to read in meam data and compute some parameters
c
c
c	write(*,*) 'call inter...'
c      fid=24
      kmeamf=13
      open (unit=kmeamf,file=meamf,status='old',form='formatted')
c
 105  format(a)
 110  format(a)
	do 777 n=1,nelmax
	rozros(n)=0.
	do 777 m=1,nelmax
	alphas(m,n)=0.
	repuls(m,n)=0.
	attrac(m,n)=0.
	res(m,n)=0.
	do 777 l=1,nelmax
	cmin(l,m,n)=2.0
	cmax(l,m,n)=2.8
777	continue
c	write(*,*) ' inter... (2) kodes=',kodes(1)
C      read  (5,meacard)
c	write(*,*) ' inter... (3)'
	if(meafile.ne.'none') then
	kmeaf=55
        open (unit=kmeaf,file=meafile,status='old',form='formatted')
	read(kmeaf,meacard)
        close(unit=kmeaf)
	endif
      rcutsq=rcut**2
c	write(*,*) ' inter... (4)'
      write (fid,100) legend
 100  format(//,1x,' ******  MEAM data',/' legendre ', f10.5)
      write (fid,101) xzbl,xzbl0
 101  format(//,1x,'  ZBL limits ', 2f10.5)
      write (fid,115) ntypes,kderiv,rcut,frcut,xncut,xmcut
 115  format(/,1x,'ntypes=',i3,' kderiv=',i3,/' rcut=',f8.4,
     1    ' frcut=',f8.4,' ncut=',f8.4,' mcut=',f8.4)
	write (fid,116) noscr
116	format(' noscr=  ',i1)
	write (fid,117) ialloy
117	format(' ialloy=  ',i1)
c
c     take data from namelist or from library if kodes(i)='library'.
c     note that kderiv,deltas and rcut must be defined in namelist data.
c
      do 460 i=1,ntypes
         write (fid,*) 'kodes(',i,')=',kodes(i)
         if (kodes(i) .ne. 'library') go to 460
c         write(*,*) ' inter... (5) kodes=',kodes(i)
         rewind kmeamf
         read  (kmeamf,105) header
         write (fid,110) header
         read  (kmeamf,105) header
         write (fid,110) header
         read  (kmeamf,105) header
         write (fid,110) header
         read  (kmeamf,105) header
         write (fid,110) header
c
c       this is the only place where the mass is in amu
c       here we convert to eV-psec**2/angstrom**2
c       this is the unit used throughout the program
c       restart assumes this mass unit
c
c         write(*,*) ' inter... (6) kodes=',kodes(i)

 410     read  (kmeamf,*) name,lattces(i),zs(i),ielement(i),amamu

c         enames(1) = 'Si'
c         write(*,*) ' inter... (7) name=',name,' enames=',enames(1)

         read  (kmeamf,*)   alphas(i,i),(betas(l,i),l=1,4),alats(i),
     1        esubs(i,i),asubs(i)
         read  (kmeamf,*) (ts(k,i),k=1,4),tempr0,ibarr(i)
         if (name .eq. enames(i)) go to 430
         if (name .ne. 'zz') go to 410

         write (fid,420) i,enames(i)
 420     format(1x,'error in meamdat, could not find, i=',i4,2x,a4)
         stop 'error in meamdat, could not find element in library'    
 430     write (fid,440)    enames(i),lattces(i),zs(i),ielement(i),amamu
 440     format(1x,a,2x,a,2x,f5.2,i5,f10.4)
         write (fid,450) alphas(i,i),(betas(l,i),l=1,4),alats(i),
     1        esubs(i,i),asubs(i)
 450     format(1x,8f8.4)
         if(rozros(i).eq.0) rozros(i)=tempr0
         write (fid,451) (ts(k,i),k=1,4),rozros(i),ibarr(i)
 451     format(1x,5f8.4,i5)
         if (ibarr(i).ge.10) then
            irhos(i)=1
            ibarr(i)=ibarr(i)-10
         elseif(ibarr(i).le.-10) then
            irhos(i)=1
            ibarr(i)=ibarr(i)+10
         else
            irhos(i)=0
         endif
         if(irhos(i).gt.0) print *,'powers of r in density for atom ',i
         amass(i) = conmas*amamu
c     write (fid,441) i,amass(i)
c     441  format(1x,'i=',i3,' amass(i)=',e25.16)
 460  continue
      close(unit=kmeamf)

      write (fid,120)
 120  format(/,5x,'i',3x,'lattice',6x,'name',5x,'kodes')
      do 130 i=1,ntypes
      write (fid,125) i,lattces(i),enames(i),kodes(i)
 125  format(1x,i5,7x,a,8x,a,3x,a)
 130  continue
c
      write (fid,150) 
 150  format(/,2x,'i',5x,'esubs(i,j)')
      do 160 i=1,ntypes
      write (fid,155) i,(esubs(i,j),j=1,ntypes)
 155  format(1x,i2,5x,4f10.5)
 160  continue
c
      write (fid,165) 
 165  format(/,2x,'i',5x,'alphas(i,j)')
      do 175 i=1,ntypes
	if(ibarr(i).eq.0.or. abs(ibarr(i)).eq.4) then
	all(i,i)='sq root'
	elseif(abs(ibarr(i)).eq.1) then
	all(i,i)='ex1'
	elseif(abs(ibarr(i)).eq.2) then
	all(i,i)='ex2'
	elseif(abs(ibarr(i)).eq.3) then
	all(i,i)='ex3'
	else
	write(fid,*) 'unknown ibar', ibarr(i), ' for element ',i
	stop
	endif
      write (fid,170) i,(alphas(i,j),j=1,ntypes)
 170  format(1x,i2,5x,4f10.5)
 175  continue
c
      write (fid,180) 
 180  format(/,2x,'i',4x,'betas(i,j)')
      do 190 i=1,4
      write (fid,185) i,(betas(i,j),j=1,ntypes)
 185  format(1x,i2,5x,4f10.5)
 190  continue
c
      write (fid,195) 
 195  format(/,2x,'i',8x,'ts(i,j)')
      do 205 i=1,4
      write (fid,200) i,(ts(i,j),j=1,ntypes)
 200  format(1x,i2,5x,4f10.5)
 205  continue
c
      write (fid,210) 
 210  format(/,2x,'i',4x,'deltas(i,j)')
      do 220 i=1,ntypes
      write (fid,215) i,(deltas(i,j),j=1,ntypes)
 215  format(1x,i2,5x,4f10.5)
 220  continue
c
      write (fid,297) 
 297  format(/,2x,'i',7x,'repuls(i,j)')
      do 313 i=1,ntypes
      write (fid,300) i,(repuls(i,j),j=1,ntypes)
 313  continue
      write (fid,298) 
 298  format(/,2x,'i',7x,'attrac(i,j)')
      do 314 i=1,ntypes
      write (fid,300) i,(attrac(i,j),j=1,ntypes)
 314  continue
c
	if(nn) itable=1
c	write(*,*) '2NN: itable =',itable
c
      write (fid,135)
 135  format(/,3x,'i',5x,'alats',5x,'asubs',5x,'zs',7x,'z0s',8x,
     1     'rozros')
      do 250 i=1,ntypes
      lattce=lattces(i)
        cmx=cmax(i,i,i)
        cmn=cmin(i,i,i)
c     fcc
         if (lattce .eq. 'fcc') then
	if(zs(i).ne.12) then
	zs(i)=12
	print *,' neighbor inconsistency - neighbors set to ',zs(i)
	endif
	omegas(i)=alats(i)**3/4
	res(i,i)=alats(i)/sqrt(2.)
	a2nn(i)=sqrt(2.)
	if(noscr.eq.0) then
	  arg=1.
          fac=(cmx-arg)/(cmx-cmn)
	  if(fac.ge.1) then
	   xfac=0.
	  elseif (fac.le.0.) then
	   xfac=1.
	  else
	   xfac=xcut(fac)
	  endif
	else
	  xfac=1.
	endif
        b2nn(i)=-xfac**4*6./12.
	if (ibarr(i).lt.0) then
	rho0=zs(1)*(1-b2nn(i)*exp(-betas(1,i)*(a2nn(i)-1)))
        arg=0.
	z0s(i)=bar(rho0,arg,ibarr(i),zs(i)*rozros(i),temp1,temp2)
	endif
c
c     bcc
         elseif (lattce .eq. 'bcc') then
	if(zs(i).ne.8) then
	zs(i)=8
	print *,' neighbor inconsistency - neighbors set to ',zs(i)
	endif
c   alats(i)  : the lattice constant of element i    
c   omegas(i) : the atomic volume of element i
c   res(i,i)  : the nearest element distance 
c   a2nn : the ratio between the 2nd and 1st 
c          nearest neighbor distances
c   b2nn : the screening const. on the 2nd nearest neighbors
	omegas(i)=alats(i)**3/2
	res(i,i)=alats(i)*sqrt(3.)/2
	a2nn(i)=2/sqrt(3.)
        if(noscr.eq.0) then
          arg=2.
          fac=(cmx-arg)/(cmx-cmn)
          if(fac.ge.1) then
           xfac=0.
          elseif (fac.le.0.) then
           xfac=1.
          else
           xfac=xcut(fac)
          endif
        else
          xfac=1.
        endif
        b2nn(i)=-xfac**4*6./8.
        if (ibarr(i).lt.0) then
	rho0=zs(1)*(1-b2nn(i)*exp(-betas(1,i)*(a2nn(i)-1)))
        arg=0.
	z0s(i)=bar(rho0,arg,ibarr(i),zs(i)*rozros(i),temp1,temp2)
	endif
c
c     dia
        elseif (lattce .eq. 'dia') then
        if(zs(i).ne.4) then
        zs(i)=4
        print *,' neighbor inconsistency - neighbors set to ',zs(i)
        endif
	omegas(i)=alats(i)**3/8
	res(i,i)=alats(i)*sqrt(3.)/4
	a2nn(i)=sqrt(8./3.)
	b2nn(i)=0.
	if(nn.and.cmin(i,i,i).lt.0.500001) then
	write(fid,*) 'can not do 2NN MEAM for dia'
	stop
	endif
c
c     hcp (ideal c/a)
        elseif (lattce .eq. 'hcp') then
        if(zs(i).ne.12) then
        zs(i)=12
        print *,' neighbor inconsistency - neighbors set to ',zs(i)
        endif
	if(nn .and. ntypes.gt.1 .and. ibarr(i).lt.0) then
	print *,' can not do 2NN MEAM for alloys and hcp',
     1     '  reference structure'
	stop
	endif
        omegas(i)=alats(i)**3*sqrt(2.)
        res(i,i)=alats(i)
	a2nn(i)=sqrt(2.)
        if(noscr.eq.0) then
          arg=1.
          fac=(cmx-arg)/(cmx-cmn)
          if(fac.ge.1) then
           xfac=0.
          elseif (fac.le.0.) then
           xfac=1.
          else
           xfac=xcut(fac)
          endif
        else
          xfac=1.
        endif
        b2nn(i)=-xfac**4*6./12.
        if (ibarr(i).lt.0) then
	rho0=zs(1)*(1-b2nn(i)*exp(-betas(1,i)*(a2nn(i)-1)))
	rh3=exp(-betas(1,i)*(a2nn(i)-1))
        arg=(1.0/3.0)*ts(4,i)*rh3**2
	z0s(i)=bar(rho0,arg,ibarr(i),zs(i)*rozros(i),temp1,temp2)
	endif
c
c     dimer
        elseif (lattce .eq. 'dim') then
        if(zs(i).ne.1) then
        zs(i)=1
        print *,' neighbor inconsistency - neighbors set to ',zs(i)
        endif
        omegas(i)=alats(i)**3
        res(i,i)=alats(i)
	b2nn(i)=0.
	a2nn(i)=1.
c
c     error 
	else
 235  write (fid,240) lattce
 240  format(1x,'Error in subroutine meamdat, lattce=',a3)
         stop 135
	endif
	if(.not.nn .or. ibarr(i).ge.0) then
        z0s(i)=zbar(ibarr(i),zs(i),lattces(i),ts(2,i),ts(3,i),ts(4,i),
     1    nn,1.)
	endif
        write (fid,140) i,alats(i),asubs(i),zs(i),z0s(i),rozros(i)
 140  format(1x,i3,5f10.5)
 250  continue
c
c     compute off diagonal elements
c
	do 310 j=1,ntypes
	do 310 i=2,ntypes
	do 310 k=1,i-1
	cmin(i,j,k)=cmin(k,j,i)
	cmax(i,j,k)=cmax(k,j,i)
 310	continue
      do 260 i=1,ntypes
      do 255 j=1,ntypes
       if(i.eq.j) then
	go to 255
       elseif(i.gt.j) then
	esubs(i,j)=esubs(j,i)
	all(i,j)=all(j,i)
	res(i,j)=res(j,i)
	alphas(i,j)=alphas(j,i)
	repuls(i,j)=repuls(j,i)
	attrac(i,j)=attrac(j,i)
       else
          if(all(i,j).eq.'L12') then
	i1=min(i,j)
	i2=max(i,j)
	if(esubs(i,j).eq.0.) then
	esubs(i,j)=(3*esubs(i1,i1)+esubs(i2,i2))/4. - deltas(i,j)
	endif
        if(alphas(i,j).eq.0.) then
	alphas(i,j)=(3*alphas(i1,i1)+alphas(i2,i2))/4.
	endif
        if(res(i,j).eq.0.) then
	res(i,j)=(res(i,i)+res(j,j))/2.
	endif
          else
	if(esubs(i,j).eq.0.) then
	esubs(i,j)=(esubs(i,i)+esubs(j,j))/2. - deltas(i,j)
	endif
        if(alphas(i,j).eq.0.) then
        alphas(i,j)=(alphas(i,i)+alphas(j,j))/2.
	endif
        if(res(i,j).eq.0.) then
        res(i,j)=(res(i,i)+res(j,j))/2.
	endif
	 endif
         if (rz0.ne.1.0) then
           res(i,j)=rz0*res(i,j)
         endif
         if (alpha0.ne.1.0) then
           alphas(i,j)=alpha0*alphas(i,j)
         endif
        endif
 255  continue
 260  continue
c	compute default repulsive term
cdo 1311 i=1,ntypes
cdo 1311 j=1,ntypes
cif(repuls(i,j).lt.0.) then
crepuls(i,j)=hartre*bohr*ielement(i)*ielement(j)/alphas(i,j)**3
c    1   /esubs(i,j)/res(i,j)*exp(-alphas(i,j))*(zs(i)+zs(j))/4
cendif
c311	continue
c
c     edit complete arrays
c
      write (fid,261)
 261  format(1x,'Computed arrays')
      write (fid,265) 
 265  format(/,2x,'i',5x,'esubs(i,j)')
      do 275 i=1,ntypes
      write (fid,270) i,(esubs(i,j),j=1,ntypes)
 270  format(1x,i2,5x,4f10.5)
 275  continue
c
      write (fid,280) 
 280  format(/,2x,'i',5x,'alphas(i,j)')
      do 290 i=1,ntypes
      write (fid,285) i,(alphas(i,j),j=1,ntypes)
 285  format(1x,i2,5x,4f10.5)
 290  continue
c
      write (fid,295) 
 295  format(/,2x,'i',7x,'res(i,j)')
      do 305 i=1,ntypes
      write (fid,300) i,(res(i,j),j=1,ntypes)
 300  format(1x,i2,5x,4f10.5)
 305  continue
c
      write (fid,297) 
      do 311 i=1,ntypes
      write (fid,300) i,(repuls(i,j),j=1,ntypes)
 311  continue
      write (fid,298) 
      do 312 i=1,ntypes
      write (fid,300) i,(attrac(i,j),j=1,ntypes)
 312  continue
c
      write (fid,296)
 296  format(/,2x,'i',7x,'all(i,j)')
      do 306 i=1,ntypes
      write (fid,301) i,(all(i,j),j=1,ntypes)
 301  format(1x,i2,5x,4a10)
 306  continue 
c
      alat=alats(1)
c
	write(fid,*) ' For screening:'
	do 307 i=1,ntypes
	write(fid,*) ' type ',i
	write(fid,*) ' cmax'
	do 308 j=1,ntypes
	write(fid,9331) (cmax(j,i,k),k=1,ntypes)
  308	continue
	write(fid,*) ' cmin'
	do 309 j=1,ntypes
	write(fid,9331) (cmin(j,i,k),k=1,ntypes)
  309	continue
9331	format(10f8.2)
  307	continue
400	continue
      write (fid,330)
 330  format(/,1x,'End of MEAM data')
c
	if(itable.gt.0) then
	write(fid,*) 'setting up table for phi'
	do 407 i=1,ntypes
	if(nn) then
	nmax=10
        write(fid,*) 'calc. 2NN MEAM with a2nn,b2nn=',a2nn(i),b2nn(i)
	else
	nmax=0
	endif
	do 407 k=1,ntable
	r=k*rcut/ntable
	phitab(k,i,i)=phif(r,i,i)
	do 408 n=1,nmax
cprint *,' phi ',r,phitab(k,i,i),n
	phitab(k,i,i)=phitab(k,i,i)+b2nn(i)**n*phif(r*a2nn(i)**n,i,i)
408	continue
407	continue
	itable=-1
	do 406 i=1,ntypes
	do 406 j=i+1,ntypes
	print *, 'calculating mixed phi',i,j
        do 406 k=1,ntable
        r=k*rcut/ntable
	phitab(k,i,j)=phif(r,i,j)
	phitab(k,j,i)=phitab(k,i,j)
406	continue
	itable=-2
	endif
      return
	end
c************************************************************************
c
c  this routine outputs the current configuration to file 20
c  as well as the instantaneous values of the temperature and
c  stress tensor.
c
      subroutine output(t,iclfor)
      include 'param.inc'
      include 'dyn.inc'
      include 'meam.inc'
      include 'wrkspc.inc'
	common/head/ header
	character *80 header
      data de/0.0/,eold/0.0/,ifirst/0/,ipcnt/-1/
c
c
c  compute the physical (unscaled) coordinates
c
	call uscale
c
c  compute the energy, temperature and pressure
c
      call calce(ekin,pot,etot,temp,press,iclfor,t)
c
c  determine the maximun change in total energy
c
      if(ifirst.eq.0)then
        ifirst=1
        eold=etot
        detops = 0.0
      else
        de=abs(etot-eold)
        detops = max(detops,de)
        eold=etot
      endif
c
c  print out energy, temperature and pressure
c
      ipcnt = mod(ipcnt + 1,ipitera)
      if(ipcnt.eq.0)then
c   write the restart file each output
      rewind(21)
      write(21,9501) header
9501  format(a)
      write(21,9502) natoms,ntypes,t,beta
9502  format(2i10,e15.8,f10.5)
      write(21,9503) (perub(i),i=1,3),(perlb(i),i=1,3)
9503  format(3e25.16)
      write(21,9504) (amass(i),ielement(i),i=1,ntypes)
9504  format(e25.16,i10)
      write(21,9505) ((rv(i,j),i=1,6),itype(j),j=1,natoms)
9505  format(3e25.16/3e25.16/i10)
      write(21,9503) (bndvel(i),i=1,3)
c output the averages over the output period
	call average(2,t)
	endif
      call flush(21)
      call flush(6)
c
c  write to file 20
c
      if (iconf.eq.1) then
         write(20) t,temp,press,(perlen(i),i=1,3)
         write(20) ((rv(i,j),i=1,3),itype(j),j=1,natoms)
      elseif (iconf.eq.2) then
         write(20) t,temp,press,(perlen(i),i=1,3)
         write(20) ((rv(i,j),i=1,6),itype(j),j=1,natoms)
      elseif (abs(iconf).eq.3) then
         write(20) t,temp,press,(perlen(i),i=1,3)
         write(20) ((rv(i,j),i=1,3),itype(j),j=1,natoms)
         if(iconf.gt.0) then
	  write(20) (((avslocal(i,j,k),i=1,j),j=1,3),k=1,natoms)
	 else
          write(20) (((avslocal(i,j,k),i=1,3),j=1,3),k=1,natoms)
	 endif
      elseif (iconf.eq.4) then
         write(20) t,temp,press,(perlen(i),i=1,3)
         write(20) ((rv(i,j),i=1,6),itype(j),e(j),j=1,natoms)
      elseif (iconf.eq.5) then
         write(20) t,temp,press,(perlen(i),i=1,3)
         write(20) ((rv(i,j),i=1,3),itype(j),j=1,natoms)
         write(20) (rho(k),c(k),(rhsq(j,k),j=1,3),k=1,natoms)
      elseif (abs(iconf).eq.6) then
         write(20) t,temp,press,(perlen(i),i=1,3)
         write(20) ((rv(i,j),i=1,6),itype(j),j=1,natoms)
         if(iconf.gt.0) then
          write(20) (((avslocal(i,j,k),i=1,j),j=1,3),k=1,natoms)
         else
          write(20) (((avslocal(i,j,k),i=1,3),j=1,3),k=1,natoms)
         endif
       end if
c reinitialize averages
	call average(0,t)
      return
      end
