      subroutine input_data
*
      parameter (n_dim = 3, nss = 24, no_mat = 1000 ) !added WML 91109
      integer, parameter :: nume   = 40000
	  common /wblock1/ iplotDirxy, x_area, yield_stress !iplotDirxy=1 for x, 2=y
      common/wblock2/  g_source, g_immob, g_minter, g_recov, b_v,
     1                             b_vvec(87),nmo,nim
      common/wblock3/  density_ms, density_ims,thermalEnthalpy(1000)
      common /wblock5/ enthalpy_coef, thermal_coef, temp
      common /wblock7/ slip_n0(1000,nss,3), slip_s0(1000,nss,3)!Changed to accomodate multiple slip WML 91109
      common /wblock9/ slip_n0_t(1000,nss,3),slip_s0_t(1000,nss,3)
      common /wblock10/ng,grain_mo(1000,3),bv(no_mat,87),nssmat(1000)  !added WML 91109
     >        ,nssimmat(1000)
      common /wblock11/ pd_counter,rhoim0(1000,nss),rhomo0(1000,nss)
!!!!!!!      common/WMLthermal/thermalflag
!!!!!!!      integer thermalflag
	  common /nab/ gn_bcc(3,43,43), n_bcc(3,43,43), np(43)
	  common /nab1/ gn_fcc(3,18,18), n_fcc(3,18,18), np1(18)
	  common /nab2/ gn_hcpt(3,86,86), n_hcpt(3,86,86), np2(86)
	  common /nab3/gn_hcp(3,87,87), n_hcp(3,87,87), den_im2(87),
     > np3(87)
	  common /aij/ aijhcp(24,87), aijfcc(12,18), aijbcc(24,43),
     >          aijhcpt(24,86)
!!!	  common /stressflag/ ElemFractCode(nume),ElemDecayCount(nume)
!!!!	  common /gbblock/ gbvec(nume,3), gbflag(nume,3)
	  common/bk00/
     1 k01,k02,k03,k04,k05,k06,k07,k08,k09,k10,k11,k12,
     2 k13,k14,k15,k16,k17,k18,k19,k20,k21,k22,k23,k24,
     3 k25,k26,k27,k28,k29,k30,k31,k32,k33,k34,k35,k36,
     4 k37,k38,k39,k40,k41,k42,k43,k44,k45,k46,k47,k48,
     5 k49,k50,k51,k52,k53,k54,k55,k56,k57,k58,k59,k60,
     6 k61,k62,k63,k64,k65,k66,k67,k68,k69,k70,k71,k72,
     7 k73,k74,k75,k76,k77,k78,k79,k80,k81,k82,k83,k84,
     8 k85,k86,k87,k88,k89,k90,k91,k92,k93,k94,k95,k96
	  common /main_block/ a(1)
	  common /cleavage_plane/ cleave_n(1000,3,3)
	  common /cleavage_plane0/ cleave_n0(3,3)
	  common /sigfrac/ sigmacrit0, sigmacrit1,sigmacrit2, sigmacrit3,
     >      DecayCount, f_decay, penalty,fractFlag
	  common /precrack/ npc, elepc(100)
!!      common /elas_energ/ inie(nume), ecount(nume)
!!!	  common /energbox/ gbco
	  common /cracktipcircle/ ndcircle
!!!!	  common /fractureplane/ planeflag(nume), planeflag0(nume)
!!	  common /precrack2/ rlflag

      character *80 txt
	  real dum, b_v, inie,  gbco!!, gbvec
!!!	  integer ElemFractCode, ElemDecayCount !!, gbflag
	  integer var_no(1000), ngbctr, DecayCount ,fractFlag
	  real slip_s00(4,24,3), slip_n00(4,24,3)
	  real cleave_n, cleave_n0, sigmacrit0, sigmacrit1, sigmacrit2,
     > 	  sigmacrit3, f_decay, penalty
	  integer npc, elepc, ecount, ndcircle
!!!      integer  planeflag,planeflag0
	  integer  rlflag

      data (((slip_n00(i,j,k), k = 1, 3), j = 1, 24), i = 1, 4)
     >      / 1 , 1 , 1,  1, 1, 1,  1, 1, 1,
     >       -1 ,-1 , 1, -1,-1, 1, -1,-1, 1,
     >       -1 , 1 , 1, -1, 1, 1, -1, 1, 1,
     >        1 ,-1 , 1,  1,-1, 1,  1,-1, 1,
     >        0 , 0 , 0,  0, 0, 0,  0, 0, 0,
     >        0 , 0 , 0,  0, 0, 0,  0, 0, 0,
     >        0 , 0 , 0,  0, 0, 0,  0, 0, 0,
     >        0 , 0 , 0,  0, 0, 0,  0, 0, 0,
     >       -1 , 1 , 0, -1, 0, 1,  0,-1, 1,
     >        1 , 1 ,-2,  1,-2, 1, -2, 1, 1,
     >        1 , 1 , 0,  1, 0, 1,  0,-1, 1,
     >        2 , 1 , 1,  1,-1, 2,  1, 2,-1,
     >        1 , 1 , 0,  0, 1, 1, -1, 0, 1,
     >        1 , 2 , 1, -1, 1, 2,  2, 1,-1,
     >        1 , 0 , 1,  0, 1, 1, -1, 1, 0,
     >        1 , 1 , 2,  2,-1, 1, -1, 2, 1,
     >        0,0 ,-1.594,0,0 ,-1.594,0,0 ,-1.594,
     >         1,1.232,1.594, -2,0.134,-1.594,1,-1.366,0,
     >        1,1.232,0,-2,0.134,-3.188,1,-1.366,-1.594,
     >        -1,-1.232,-3.188,2,-0.134,0,-1,1.366,-1.594,
     >         1,1.232,0,1,1.232,0,-2,0.134,-3.188,
     >         -2,0.134,-3.188,1,-1.366,-1.594,1,-1.366,-1.594,
     >        -1,-1.232,-3.188,-1,-1.232,-3.188,2,-0.134,0,
     >        2,-0.134,0, -1,1.366,-1.594,-1,1.366,-1.594,
     >        0,0,0.3137,0,0,0.3137,0,0,0.3137,
     >        1,1.1547,0, -0.5,-1.4434,0,-0.5,0.2887,0,
     >      1,1.1547,0.3137,-0.5,-1.4434,0.3137,-0.5,0.2887,0.3137,
     >      -1,-1.1547,0.3137,0.5,1.4434,0.3137,0.5,-0.2887,0.3137,
     >       1,1.1547,0.3137, 1,1.1547,0.3137,-0.5,-1.4434,0.3137,
     >   -0.5,-1.4434,0.3137,-0.5,0.2887,0.3137,-0.5,0.2887,0.3137,
     >       -1,-1.1547,0.3137,-1,-1.1547,0.3137,0.5,1.4434,0.3137,
     >     0.5,1.4434,0.3137,0.5,-0.2887,0.3137,0.5,-0.2887,0.3137/

      data (((slip_s00(i,j,k), k = 1, 3), j = 1, 24), i = 1, 4)
     >      /-1 , 0 , 1, -1, 1, 0,  0,-1, 1,
     >		  0 , 1 , 1, -1, 1, 0,  1, 0, 1,
     >		  1 , 0 , 1,  1, 1, 0,  0,-1, 1,
     >		  0 , 1 , 1,  1, 1, 0, -1, 0, 1,
     >        0 , 0 , 0,  0, 0, 0,  0, 0, 0,
     >        0 , 0 , 0,  0, 0, 0,  0, 0, 0,
     >        0 , 0 , 0,  0, 0, 0,  0, 0, 0,
     >        0 , 0 , 0,  0, 0, 0,  0, 0, 0,
     >        1 , 1 , 1,  1, 1, 1,  1, 1, 1,
     >        1 , 1 , 1,  1, 1, 1,  1, 1, 1,
     >       -1 , 1 , 1, -1, 1, 1, -1, 1, 1,
     >       -1 , 1 , 1, -1, 1, 1, -1, 1, 1,
     >        1 ,-1 , 1,  1,-1, 1,  1,-1, 1,
     >        1 ,-1 , 1,  1,-1, 1,  1,-1, 1,
     >        1 , 1 ,-1,  1, 1,-1,  1, 1,-1,
     >        1 , 1 ,-1,  1, 1,-1,  1, 1,-1,
     >         0,0.866,0,1,-0.5,0,-1,-0.366,0,
     >          1,-0.5,0,0,0.866,0,-1,-0.366,0,
     >         1,-0.5,0,0,0.866,0,-1,-0.366,0,
     >         1,-0.5,0,0,0.866,0,1,0.366,0,
     >          0,0,-0.531,1,-0.5,-1.594,2,0.732,-1.594,
     >         2,-0.134,-0.531,1,0.4106,-0.5313, 0 ,0.866,-1.594,
     >         1,0.4106,-0.5313,2,0.732,-1.594,0,0,-0.5313,
     >          0,0.866,-1.594,1,-0.5,-1.594,2,-0.0446,-0.5313,
     >		   1,0,0,-0.5,0.866,0,-0.5,-0.866,0,
     >		  -0.5,0.866,0,1,0,0,-0.5,-0.866,0,
     >        -0.5,0.866,0,1,0,0,-0.5,-0.866,0,
     >		  -0.5,0.866,0,1,0,0,0.5,0.866,0,
     >        -0.5,-0.866,1.594,-1,0,-1.594,0.5,0.866,1.594,
     >        -0.5,0.866,1.594,1,0,1.594,0.5,-0.866,1.594,
     >         1,0 ,1.594,0.5,0.866,1.594,-0.5,-0.866,1.594,
     >         0.5,-0.866,1.594,-1, 0,-1.594,-0.5,0.866,1.594 /

      write(*,*) 'beginning of input data'
      open(60,file = 'data.in', status = 'unknown')

	  open(61,file = 'a.txt', status = 'unknown')
	  open(62,file = 'b.txt', status = 'unknown')
	  open(63,file = 'c.txt', status = 'unknown')
	  open(85,file = 'd.txt', status = 'unknown')

	  open(64,file = 'a1.txt', status = 'unknown')
	  open(65,file = 'b1.txt', status = 'unknown')
	  open(66,file = 'c1.txt', status = 'unknown')
	  open(86,file = 'd1.txt', status = 'unknown')

	  open(67,file = 'a3.txt', status = 'unknown')
	  open(68,file = 'b3.txt', status = 'unknown')
	  open(69,file = 'c3.txt', status = 'unknown')
	  open(87,file = 'd3.txt', status = 'unknown')

	  open(82,file = 'a4.txt', status = 'unknown')
	  open(83,file = 'b4.txt', status = 'unknown')
	  open(84,file = 'c4.txt', status = 'unknown')
	  open(88,file = 'd4.txt', status = 'unknown')

!!!!	  open(89,file = 'gb.f', status = 'unknown')

	  cleave_n0(1,1) = 1.
	  cleave_n0(1,2) = 0.
	  cleave_n0(1,3) = 0.
	  cleave_n0(2,1) = 0.
	  cleave_n0(2,2) = 1.
	  cleave_n0(2,3) = 0.
	  cleave_n0(3,1) = 0.
	  cleave_n0(3,2) = 0.
	  cleave_n0(3,3) = 1.

!!!	  do i = 1, nume
!!!!!!!!!	  planeflag(i)=0
!!!!!!!!!	  planeflag0(i)=0
!!!!!	  ElemFractCode(i) = 0
!!!!!	  ElemDecayCount(i) = 1
!!!!!!!!!	  gbvec(i,1) = 0.0
!!!!!!!!!	  gbvec(i,2) = 0.0
!!!!!!!!!	  gbvec(i,3) = 0.0
!!!!!!!!!	  gbflag(i,1) = 0
!!!!!!!!!	  gbflag(i,2) = 0
!!!!!!!!!	  gbflag(i,2) = 0
!!!	  inie(i)=0.0
!!!	  ecount(i)=0
!!!	  end do

!!!	  read(89,*) ngbctr
!!!	  write(999,*) ngbctr
!!!	  do i = 1,ngbctr
!!!	  read(89,*) j1,j2,j3,j4
!!!	  write(999,*) j1,j2,j3,j4
!!!	  gbflag(j1,1)=j2
!!!	  gbflag(j1,2)=j3
!!!	  gbflag(j1,3)=j4
!!!	  gbflag(j2,1)=j1
!!!	  gbflag(j2,2)=j3
!!!	  gbflag(j2,3)=j4
!!!	  end do

!!!!!	  call edge(a(k03),a(k04),a(k08))

	  do i = 1, 43
	  do j = 1, 43
	  do k = 1, 3
		  read(61,*) gn_bcc(k,j,i)
		  read(62,*) n_bcc(k,j,i)
	  end do
	  end do
	  read(63,*) np(i)
	  end do

	  do i = 1, 18
	  do j = 1, 18
	  do k = 1, 3
		  read(64,*) gn_fcc(k,j,i)
		  read(65,*) n_fcc(k,j,i)
	  end do
	  end do
	  read(66,*) np1(i)
	  end do

	  do i = 1, 86
	  do j = 1, 86
	  do k = 1, 3
		  read(67,*) gn_hcpt(k,j,i)
		  read(68,*) n_hcpt(k,j,i)
	  end do
	  end do
	  read(69,*) np2(i)
	  end do

	  do i = 1, 87
	  do j = 1, 87
	  do k = 1, 3
		  read(82,*) gn_hcp(k,j,i)
		  read(83,*) n_hcp(k,j,i)
	  end do
	  end do
	  read(84,*) np3(i)
	  end do

	  do i = 1, 43
	  do j = 1, 24
		  read(85,*) dum
		  aijbcc(j,i) = sqrt(dum)
	  end do
	  end do

	  do i = 1, 18
	  do j = 1, 12
		  read(86,*) dum
		  aijfcc(j,i) = sqrt(dum)
	  end do
	  end do

	  do i = 1, 86
	  do j = 1, 24
		  read(87,*) dum
		  aijhcpt(j,i) = sqrt(dum)
	  end do
	  end do

	  do i = 1, 87
	  do j = 1, 24
		  read(88,*) dum
		  aijhcp(j,i) = sqrt(dum)
	  end do
	  end do

!!!!      read (60,*) sigmacrit0
!!!!	  read (60,*) sigmacrit1
!!!!      read (60,*) sigmacrit2
!!!!	  read (60,*) sigmacrit3
	  read (60,*) fractFlag
	  read (60,*) DecayCount
	  read (60,*) f_decay
	  read (60,*) ndcircle
	  read (60,*) iplotDirxy
      read (60,*) x_area
      read (60,*) yield_stress
      read (60,*) b_v
      read (60,*) g_source
      read (60,*) g_immob
      read (60,*) g_minter
      read (60,*) g_recov
      read (60,*) density_ms
      read (60,*) density_ims
      !read (60,*) enthalpy_coef

!!!c     Elements for pre-existing crack
	  read(60,*) npc
	  do i=1, npc
	      read(60,*) elepc(i)
	  end do
      !-- the following two numbers are not used any more
	  read(60,*) rlflag     ! pre-existing crack at left or right edge, 0 left, 1 right
	  read(60,*) gbco

      read (60,*) ng
      do i = 1, ng
	  read (60,*) var_no(i),grain_mo(i,1), grain_mo(i,2),
     >  grain_mo(i,3)
	  if (var_no(i) .lt. 1) then   !fcc
	  nssmat(i) = 12
	  nssimmat(i) = 18
	  else if ((var_no(i) .ge. 1) .and. (var_no(i) .le. 24)) then   !bcc
	  nssmat(i) = 24
	  nssimmat(i) = 43
	  else if ((var_no(i) .ge. 25) .and. (var_no(i) .le. 60)) then
	  nssmat(i) = 12
	  nssimmat(i) = 18
	  else if (var_no(i) == 61) then    !hcpt
	  nssmat(i) = 24
	  nssimmat(i) = 86
	  else if (var_no(i) == 62) then   !hcp
	  nssmat(i) = 24
	  nssimmat(i) = 87

	  end if
	  write(*,*) 'input_data', nssimmat(i)
!c	  if (thermalflag.eq.0) then
!c	  read (60,*) ecin(i)!enthalpy coefficent
!c	  read (60,*) etain(i)!nondim fractionofworktoheat/rhocp
!c	  endif
      end do
!c	  write(*,*) 'in input_data' !WMLWRITE51210
!c	  write(*,*) nssmat(1)

	  do i = 1, ng
	  do j = 1, nssimmat(i)

	  bv(i,j) = b_v
	  end do
	  end do
      write(*,*) bv(1,1),'bv'
      do i = 1, ng
	  if (var_no(i) .lt. 1) then
         do j = 1, nssmat(i)
		 do k = 1, 3
               slip_n0(i,j,k) = slip_n00(1,j,k)
			   slip_s0(i,j,k) = slip_s00(1,j,k)
         end do
		 end do
	 else if ((var_no(i) .ge. 1) .and. (var_no(i) .le. 24)) then
		 do j = 1, nssmat(i)
		 do k = 1, 3
               slip_n0(i,j,k) = slip_n00(2,j,k)
			   slip_s0(i,j,k) = slip_s00(2,j,k)
         end do
		 end do
	  else if ((var_no(i) .ge. 25) .and. (var_no(i) .le. 60)) then
         do j = 1, nssmat(i)
		 do k = 1, 3
               slip_n0(i,j,k) = slip_n00(1,j,k)
			   slip_s0(i,j,k) = slip_s00(1,j,k)
         end do
		 end do

		 else if (var_no(i) == 61) then
		 do j = 1, nssmat(i)
		 do k = 1, 3
               slip_n0(i,j,k) = slip_n00(3,j,k)
			   slip_s0(i,j,k) = slip_s00(3,j,k)
         end do
		 end do
		 else if (var_no(i) == 62) then
		 do j = 1, nssmat(i)
		 do k = 1, 3
               slip_n0(i,j,k) = slip_n00(4,j,k)
			   slip_s0(i,j,k) = slip_s00(4,j,k)
         end do
		 end do

	  end if
      end do

	  do i=1,ng
		    do j=1,nssmat(i)
			      rhoim0(i,j) = density_ims
			      rhomo0(i,j) = density_ms
			  end do
	  end do

      call transform(nss,slip_n0,slip_s0,slip_n0_t,slip_s0_t, var_no)
      ! #####################################################
      !      read the multiple time step specs ....dtimesteps.in
            call ReaddtimestepsSpecs()

! #####################################################
! #####################################################
!      to read the GB data, normals, element map
            call GBReadInput()
! #####################################################
! #####################################################
!C      to read precracked elements and apply proper cleavage planes
!       call FractReadApplyPreCrackCleavagePlanes()!a(k03),a(k04),a(k02))
!!!!      call FractReadApplyPreCrackCleavagePlanes(y,z,ix)
! #####################################################

      return
      end


      SUBROUTINE WRITMO(TIME0,FUNCT)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      INCLUDE 'SIZES'
      CHARACTER KEYWRD*241
      DOUBLE PRECISION MECI
      COMMON /KEYWRD/ KEYWRD
      COMMON /ELEMTS/ ELEMNT(107)
      COMMON /GEOM  / GEO(3,NUMATM)
      COMMON /GEOKST/ NATOMS,LABELS(NUMATM),
     1                NA(NUMATM),NB(NUMATM),NC(NUMATM)
      COMMON /HMATRX/ H(MPACK)
      COMMON /FOKMAT/ F(MPACK), FB(MPACK)
      COMMON /VECTOR/ C(MORB2),EIGS(MAXORB),CBETA(MORB2),EIGB(MAXORB)
      COMMON /DENSTY/ P(MPACK),PA(MPACK),PB(MPACK)
      COMMON /GEOSYM/ NDEP, LOCPAR(MAXPAR), IDEPFN(MAXPAR),
     1                    LOCDEP(MAXPAR)
      COMMON / EULER/ TVEC(3,3), ID
      COMMON /RJKS  / RJKAB(NMECI,NMECI), RJKAA(NMECI,NMECI)
      COMMON /ERRFN / ERRFN(MAXPAR), AICORR(MAXPAR)
      COMMON /WORK1 /  FMAT2D(NPULAY*4), SEC(NPULAY*2), VEC(NPULAY*2),
     1                ALBAND(NPULAY*13)
      COMMON /PATH  / LATOM,LPARAM,REACT(200)
      COMMON /NUMCAL/ NUMCAL
      COMMON /NUMSCF/ NSCF
      COMMON /WMATRX/ WJ(N2ELEC), WK(N2ELEC)
      COMMON /ATHEAT/ ATHEAT
      COMMON /CORE  / CORE(107)
      COMMON /LAST  / LAST
      COMMON /SCRACH/ RXYZ(MPACK), XDUMY(MAXPAR**2-MPACK)
      COMMON /CIMATS/ ENGYCI(3),VECTCI(9),ECI(6)
      COMMON /MESAGE/ IFLEPO,IITER
      COMMON /ATMASS/ ATMASS(NUMATM)
      COMMON /ENUCLR/ ENUCLR
      COMMON /ELECT / ELECT
      COMMON /XYZGRA/ DXYZ(9*NUMATM)
      COMMON /GRADNT/ GRAD(MAXPAR), GNORM
      COMMON /MOLKST/ NUMAT,NAT(NUMATM),NFIRST(NUMATM),NMIDLE(NUMATM),
     1                NLAST(NUMATM), NORBS, NELECS,NALPHA,NBETA,
     2                NCLOSE,NOPEN,NDUMY,FRACT
      COMMON /GEOVAR/ NVAR, LOC(2,MAXPAR), IDUMY, XPARAM(MAXPAR)
************************************************************************
*
*   WRITE PRINTS OUT MOST OF THE RESULTS.
*         IT SHOULD NOT ALTER ANY PARAMETERS, SO THAT IT CAN BE CALLED
*         AT ANY CONVENIENT TIME.
*
************************************************************************
      DIMENSION Q(MAXORB), Q2(MAXORB), COORD(3,NUMATM)
     1,IEL1(107), NELEMT(107), IEL2(107)
      DIMENSION W(N2ELEC), DUMY(3)
      LOGICAL UHF, CI, SINGLT, TRIPLT, EXCITD, PRTGRA, STILL
      CHARACTER TYPE(3)*11, IDATE*24, CALCN(2)*5, GTYPE*13, GRTYPE*14,
     1          FLEPO(16)*58, ITER(2)*58, NUMBRS(11)*1, GETNAM*80
      CHARACTER*2 ELEMNT, IELEMT(20), CALTYP*7, NAMFIL*80
      SAVE ICALCN, NUMBRS, CALCN, TYPE, FLEPO, ITER
      EQUIVALENCE (W,WJ)
      DOUBLE PRECISION WJ, WK
      DATA ICALCN/0/
      DATA TYPE/'BOND       ','ANGLE      ','DIHEDRAL   '/
      DATA CALCN /'     ','ALPHA'/
      DATA NUMBRS /'0','1','2','3','4','5','6','7','8','9',' '/
      DATA FLEPO(1),FLEPO(2),FLEPO(3)/
     1' 1SCF WAS SPECIFIED, SO BFGS WAS NOT USED                 ',
     2' GRADIENTS WERE INITIALLY ACCEPTABLY SMALL                ',
     3' HERBERTS TEST WAS SATISFIED IN BFGS                      '/
      DATA FLEPO(4),FLEPO(5),FLEPO(6)/
     1' THE LINE MINIMIZATION FAILED TWICE IN A ROW.   TAKE CARE!',
     2' BFGS FAILED DUE TO COUNTS EXCEEDED. TAKE CARE!           ',
     3' PETERS TEST WAS SATISFIED IN BFGS OPTIMIZATION           '/
      DATA FLEPO(7),FLEPO(8),FLEPO(9)/
     1' THIS MESSAGE SHOULD NEVER APPEAR, CONSULT A PROGRAMMER!! ',
     2' GRADIENT TEST NOT PASSED, BUT FURTHER WORK NOT JUSTIFIED ',
     3' A FAILURE HAS OCCURRED, TREAT RESULTS WITH CAUTION!!     '/
      DATA FLEPO(10),FLEPO(11),FLEPO(12)/
     1' GEOMETRY OPTIMIZED USING NLLSQ. GRADIENT NORM MINIMIZED  ',
     2' GEOMETRY OPTIMIZED USING POWSQ. GRADIENT NORM MINIMIZED  ',
     3' CYCLES EXCEEDED, GRADIENT NOT FULLY MINIMIZED IN NLLSQ   '/
      DATA FLEPO(13),FLEPO(14),FLEPO(15)/
     1' 1SCF RUN AFTER RESTART.  GEOMETRY MIGHT NOT BE OPTIMIZED ',
     2' HEAT OF FORMATION MINIMIZED IN ONE LINE SEARCH           ',
     3' GEOMETRY OPTIMISED USING EIGENVECTOR FOLLOWING (EF).     '/
      DATA FLEPO(16)/
     1' EF-OPTIMIZED GEOMETRY.  NUMBER OF -VE ROOTS INCORRECT    '/
      DATA ITER/
     1' SCF FIELD WAS ACHIEVED                                   ',
     2'  ++++----**** FAILED TO ACHIEVE SCF. ****----++++        '/
C
C SUMMARY OF RESULTS (NOTE: THIS IS IN A SUBROUTINE SO IT
C          CAN BE USED BY THE PATH OPTION)
      IF(ICALCN.EQ.0)NAMFIL='**NULL**'
      IDATE=' '
      IF(IFLEPO.EQ.0) IFLEPO=7
      IUHF=MIN(INDEX(KEYWRD,' UHF'),1)+1
      PRTGRA=(INDEX(KEYWRD,' GRAD').NE.0.AND.NVAR.GT.0)
      LINEAR=(NORBS*(NORBS+1))/2
      SINGLT=(INDEX(KEYWRD,' SING') .NE. 0)
      TRIPLT=(INDEX(KEYWRD,' TRIP') .NE. 0)
      EXCITD=(INDEX(KEYWRD,' EXCI') .NE. 0)
      CI=(INDEX(KEYWRD,' C.I.') .NE. 0)
      IF(INDEX(KEYWRD,' MINDO') .NE. 0) THEN
         CALTYP='MINDO/3'
      ELSEIF(INDEX(KEYWRD,' AM1') .NE. 0) THEN
         CALTYP='  AM1  '
      ELSEIF(INDEX(KEYWRD,' PM3') .NE. 0) THEN
         CALTYP='  PM3  '
      ELSE
         CALTYP=' MNDO  '
      ENDIF
      UHF=(IUHF.EQ.2)
      CALL FDATE(IDATE)
      DEGREE=57.29577951D0
      IF(NA(1).EQ.99)THEN
         DEGREE=1.D0
         TYPE(1)='CARTESIAN X'
         TYPE(2)='CARTESIAN Y'
         TYPE(3)='CARTESIAN Z'
      ENDIF
      GNORM=0.D0
      IF(NVAR.NE.0)GNORM=SQRT(DOT(GRAD,GRAD,NVAR))
      WRITE(6,'(/,'' ----'',15(''-----''))')
      CALL WRTTXT(6)
      WRITE(6,'(//4X,A58)')FLEPO(IFLEPO)
      IITER=MAX(1,IITER)
      WRITE(6,'(4X,A58)')ITER(IITER)
      WRITE(6,'(//30X,A7,''  CALCULATION'')')CALTYP
      WRITE(6,'(55X,''VERSION '',F5.2)')VERSON
      WRITE(6,'(55X,A24)')IDATE
      IF(IITER.EQ.2)THEN
C
C   RESULTS ARE MEANINGLESS. DON'T PRINT ANYTHING!
C
         WRITE(6,'(//,'' FOR SOME REASON THE SCF CALCULATION FAILED.'',/
     1,'' THE RESULTS WOULD BE MEANINGLESS, SO WILL NOT BE PRINTED.'')')
         WRITE(6,'('' TRY TO FIND THE REASON FOR THE FAILURE BY USING ''
     1,''"PL".'',/,
     2'' CHECK YOUR GEOMETRY AND ALSO TRY USING SHIFT OR PULAY. '')')
         CALL GEOUT(1)
         STOP
      ENDIF
      WRITE(6,'(////10X,''FINAL HEAT OF FORMATION ='',F17.5,'' KCAL''
     1)')FUNCT
      IF(LATOM.EQ.0) WRITE(6,'(/)')
      WRITE(6,'(    10X,''TOTAL ENERGY            ='',F17.5,'' EV''
     1)')ELECT+ENUCLR
      WRITE(6,'(    10X,''ELECTRONIC ENERGY       ='',F17.5,'' EV''
     1)')ELECT
      WRITE(6,'(    10X,''CORE-CORE REPULSION     ='',F17.5,'' EV''
     1)')ENUCLR
      IF(LATOM.EQ.0) WRITE(6,'(1X)')
      PRTGRA=(PRTGRA .OR. GNORM .GT. 2.D0)
      IF(PRTGRA)
     1WRITE(6,'(    10X,''GRADIENT NORM           ='',F17.5)')GNORM
      STILL=.TRUE.
      IF(LATOM.EQ.0) THEN
      IF(INDEX(KEYWRD,' AIDER').NE.0) GOTO 45
      IF(INDEX(KEYWRD,'1SCF').NE.0.AND.INDEX(KEYWRD,'GRAD').EQ.0)GOTO 45
C
C   CHECK THAT THE CARTESIAN COORDINATE GRADIENT IS ALSO SMALL
C
            IF(DOT(DXYZ,DXYZ,3*NUMAT).GT.MAX(16.D0,4*GNORM**2)
     1.AND.GNORM.LT.2.D0.AND.NCLOSE.EQ.NOPEN.AND.ID.EQ.0) THEN
               WRITE(6,'(A)')' WARNING -- GEOMETRY IS NOT AT A STATIONAR
     1Y POINT'
               STILL=.FALSE.
            ENDIF
  45  CONTINUE
      ELSE
C
C   WE NEED TO CALCULATE THE REACTION COORDINATE GRADIENT.
C
         MVAR=NVAR
         LOC11=LOC(1,1)
         LOC21=LOC(2,1)
         NVAR=1
         LOC(1,1)=LATOM
         LOC(2,1)=LPARAM
         XREACT=GEO(LPARAM,LATOM)
         CALL DERIV(GEO,GCOORD)
         NVAR=MVAR
         LOC(1,1)=LOC11
         LOC(2,1)=LOC21
         GRTYPE=' KCAL/ANGSTROM'
         IF(LPARAM.EQ.1)THEN
            WRITE(6,'(    10X,''FOR REACTION COORDINATE ='',F17.5
     1        ,'' ANGSTROMS'')')XREACT
         ELSE
            IF(NA(1).NE.99)GRTYPE=' KCAL/RADIAN  '
            WRITE(6,'(    10X,''FOR REACTION COORDINATE ='',F17.5
     1        ,'' DEGREES'')')XREACT*DEGREE
         ENDIF
         WRITE(6,'(    10X,''REACTION GRADIENT       ='',F17.5,A14
     1    )')GCOORD,GRTYPE
      ENDIF
      IF(NALPHA.GT.0)THEN
         EIONIS=-MAX(EIGS(NALPHA), EIGB(NBETA))
      ELSEIF(NELECS.EQ.1)THEN
         EIONIS=-EIGS(1)
      ELSEIF(NELECS.GT.1) THEN
         EIONIS=-MAX(EIGS(NCLOSE), EIGS(NOPEN))
      ELSE
         EIONIS=0.D0
      ENDIF
      NOPN=NOPEN-NCLOSE
C   CORRECTION TO I.P. OF DOUBLETS
      IF(NOPN.EQ.1)THEN
         I=NCLOSE*NORBS+1
         EIONIS=EIONIS+0.5D0*RJKAB(1,1)
      ENDIF
      IF(ABS(EIONIS).GT.1.D-5)
     1WRITE(6,'(       10X,''IONIZATION POTENTIAL    ='',F17.5)')EIONIS
      IF( UHF ) THEN
         WRITE(6,'(      10X,''NO. OF ALPHA ELECTRONS  ='',I11)')NALPHA
         WRITE(6,'(      10X,''NO. OF BETA  ELECTRONS  ='',I11)')NBETA
      ELSE
         WRITE(6,'(      10X,''NO. OF FILLED LEVELS    ='',I11)')NCLOSE
         IF(NOPN.NE.0) THEN
            WRITE(6,'(   10X,''AND NO. OF OPEN LEVELS  ='',I11)')NOPN
         ENDIF
      ENDIF
      SUMW=0
      DO 10 I=1,NUMAT
   10 SUMW=SUMW+ATMASS(I)
      IF(SUMW.GT.0.1D0)
     1WRITE(6,'(    10X,''MOLECULAR WEIGHT        ='',F11.3)')SUMW
      IF(LATOM.EQ.0) WRITE(6,'(/)')
      WRITE(6,'(10X,''SCF CALCULATIONS  =   '',I14 )') NSCF
      TIM=SECOND()-TIME0
      I=TIM*0.000001D0
      TIM=TIM-I*1000000
      CALL TIMOUT(6,TIM)
      IF( NDEP .NE. 0 )CALL SYMTRY
      DO 20 I=1,NVAR
   20 XPARAM(I)=GEO(LOC(2,I),LOC(1,I))
      CALL GMETRY(GEO,COORD)
      IF(PRTGRA)THEN
         WRITE(6,'(///7X,''FINAL  POINT  AND  DERIVATIVES'',/)')
         WRITE(6,'(''   PARAMETER     ATOM    TYPE  ''
     1    ,''          VALUE       GRADIENT'')')
      ENDIF
      SUM=0.5D0
      DO 30 I=1,NUMAT
   30 SUM=SUM+CORE(NAT(I))
      I=SUM
      KCHRGE=I-NCLOSE-NOPEN-NALPHA-NBETA
C
C    WRITE OUT THE GEOMETRIC VARIABLES
C
      IF(PRTGRA) THEN
         DO 40 I=1,NVAR
            J=LOC(2,I)
            K=LOC(1,I)
            L=LABELS(K)
            XI=XPARAM(I)
            IF(J.NE.1) XI=XI*DEGREE
            IF(J.EQ.1.OR.NA(1).EQ.99)THEN
               GTYPE='KCAL/ANGSTROM'
            ELSE
               GTYPE='KCAL/RADIAN  '
            ENDIF
   40    WRITE(6,'(I7,I11,1X,A2,4X,A11,F13.6,F13.6,2X,A13)')
     1I,K,ELEMNT(L),TYPE(J),XI,GRAD(I),GTYPE
      ENDIF
C
C     WRITE OUT THE GEOMETRY
C
      WRITE(6,'(///)')
      CALL GEOUT(1)
      IF (INDEX(KEYWRD,' NOINTER') .EQ. 0) THEN
C
C   WRITE OUT THE INTERATOMIC DISTANCES
C
         L=0
         DO 50 I=1,NUMAT
            DO 50 J=1,I
               L=L+1
   50    RXYZ(L)=SQRT((COORD(1,I)-COORD(1,J))**2+
     1                         (COORD(2,I)-COORD(2,J))**2+
     2                         (COORD(3,I)-COORD(3,J))**2)
         WRITE(6,'(//10X,''  INTERATOMIC DISTANCES'')')
         CALL VECPRT(RXYZ,NUMAT)
      ENDIF
      DO 60 I=1,NORBS
   60 IF(EIGS(I).LT.-999.D0.OR.EIGS(I).GT.1000.D0)EIGS(I)=0.D0
      DO 70 I=1,NORBS
   70 IF(EIGB(I).LT.-999.D0.OR.EIGB(I).GT.1000.D0)EIGS(I)=0.D0
      IF(ISYBYL.EQ.1) THEN
C
C  THE FOLLOWING OPEN STATEMENTS ARE NON-STANDARD.  IF THIS CAUSES
C  DIFFICULTY REPLACE THEM WITH
C#      OPEN(UNIT=16,FILE=GETNAM('FOR016'),STATUS='NEW',ERR=31)
C#      GOTO 32
C#  31  OPEN(UNIT=16,FILE=GETNAM('FOR016'),STATUS='OLD')
C#      WRITE(6,'(A)') 'Error opening SYBYL MOPAC output'
C#  32  CONTINUE
      OPEN(UNIT=16,FILE=GETNAM('FOR016'),CARRIAGECONTROL='LIST',
     +STATUS='NEW',ERR=31)
      GOTO 32
  31  OPEN(UNIT=16,FILE=GETNAM('FOR016'),CARRIAGECONTROL='LIST',
     +STATUS='OLD')
      WRITE(6,'(A)') 'Error opening SYBYL MOPAC output'
  32  CONTINUE
      ENDIF
      IF(NORBS.GT.0)THEN
         IF (INDEX(KEYWRD,' VECT') .NE. 0) THEN
            WRITE(6,'(//10X,A5,'' EIGENVECTORS  '')')CALCN(IUHF)
            CALL MATOUT (C,EIGS,NORBS,NORBS,NORBS)
            IF(UHF) THEN
               WRITE(6,'(//10X,'' BETA EIGENVECTORS  '')')
               CALL MATOUT (CBETA,EIGB,NORBS,NORBS,NORBS)
            ENDIF
         ELSE
            WRITE(6,'(//10X,A5,''   EIGENVALUES'',/)')CALCN(IUHF)
            WRITE(6,'(8F10.5)')(EIGS(I),I=1,NORBS)
            IF(UHF) THEN
               WRITE(6,'(//10X,'' BETA EIGENVALUES '')')
               WRITE(6,'(8F10.5)')(EIGB(I),I=1,NORBS)
            ENDIF
         ENDIF
      ENDIF
      WRITE(6,'(//13X,'' NET ATOMIC CHARGES AND DIPOLE '',
     1''CONTRIBUTIONS'',/)')
      WRITE(6,'(8X,'' ATOM NO.   TYPE          CHARGE        ATOM''
     1,''  ELECTRON DENSITY'')')
      CALL CHRGE(P,Q)
      DO 80 I=1,NUMAT
         L=NAT(I)
         Q2(I)=CORE(L) - Q(I)
   80 WRITE(6,'(I12,9X,A2,4X,F13.4,F16.4)')
     1I,ELEMNT(L),Q2(I),Q(I)
      DIP= DIPOLE(P,Q2,COORD,DUMY,1)
      IF (INDEX(KEYWRD,' NOXYZ') .EQ. 0) THEN
         WRITE(6,'(//10X,''CARTESIAN COORDINATES '',/)')
         WRITE(6,'(4X,''NO.'',7X,''ATOM'',15X,''X'',
     1  9X,''Y'',9X,''Z'',/)')
         WRITE(6,'(I6,8X,A2,14X,3F10.4)')
     1  (I,ELEMNT(NAT(I)),(COORD(J,I),J=1,3),I=1,NUMAT)
      ENDIF
      IF(NORBS.GT.0) THEN
         IF (INDEX(KEYWRD,' K=') .NE. 0)THEN
C
C  GO INTO BRILLOUIN ZONE MODE
C
            I=INDEX(KEYWRD,' K=')
            STEP=READA(KEYWRD,I)
            MONO3=NLAST(NINT(READA(KEYWRD(I:),INDEX(KEYWRD(I:),','))))
         IF(UHF)WRITE(6,'(A)')'  ALPHA BANDS'
            CALL BRLZON(F, FMAT2D, NORBS, SEC, VEC, ALBAND,MONO3,STEP,2)
         IF(UHF)THEN
         WRITE(6,'(A)')'  BETA BANDS'
         CALL BRLZON(FB, FMAT2D, NORBS, SEC, VEC, ALBAND,MONO3,STEP,2)
         ENDIF
         ENDIF
         IF(ISYBYL.EQ.1)THEN
            NFILLD=MAX(NCLOSE,NALPHA,NBETA)
            CALL MPCSYB(NUMAT,COORD,Q2,1,EIGS,NFILLD,FUNCT,EIONIS
     1                 ,KCHRGE,DIP)
         ENDIF
         IF (INDEX(KEYWRD,' FOCK') .NE. 0) THEN
            WRITE(6,'('' FOCK MATRIX IS '')')
            CALL VECPRT(F,NORBS)
         ENDIF
         IF (INDEX(KEYWRD,' DENS') .NE. 0) THEN
            WRITE(6,'(//,20X,'' DENSITY MATRIX IS '')')
            CALL VECPRT(P,NORBS)
         ELSE
            WRITE(6,'(//10X,''ATOMIC ORBITAL ELECTRON POPULATIONS'',/)')
            WRITE(6,'(8F10.5)')(P((I*(I+1))/2),I=1,NORBS)
         ENDIF
         IF(INDEX(KEYWRD,' PI') .NE. 0) THEN
            WRITE(6,'(//10X,''SIGMA-PI BOND-ORDER MATRIX'')')
            CALL DENROT
         ENDIF
         IF(UHF) THEN
            SZ=ABS(NALPHA-NBETA)*0.5D0
            SS2=SZ*SZ
            L=0
            DO 100 I=1,NORBS
               DO 90 J=1,I
                  L=L+1
                  PA(L)=PA(L)-PB(L)
   90          SS2=SS2+PA(L)**2
  100       SS2=SS2-0.5D0*PA(L)**2
            WRITE(6,'(//20X,''(SZ)    ='',F10.6)')SZ
            WRITE(6,'(  20X,''(S**2)  ='',F10.6)')SS2
            IF(INDEX(KEYWRD,' SPIN') .NE. 0) THEN
               WRITE(6,'(//10X,''SPIN DENSITY MATRIX'')')
               CALL VECPRT(PA,NORBS)
            ELSE
               WRITE(6,'(//10X,''ATOMIC ORBITAL SPIN POPULATIONS'',/)')
               WRITE(6,'(8F10.5)')(PA((I*(I+1))/2),I=1,NORBS)
            ENDIF
            IF(INDEX(KEYWRD,' HYPERFINE') .NE. 0) THEN
C
C  WORK OUT THE HYPERFINE COUPLING CONSTANTS.
C
               WRITE(6,'(//10X,''    HYPERFINE COUPLING COEFFICIENTS'',/
     1)')
               J=(NALPHA-1)*NORBS
               DO 110 K=1,NUMAT
                  I=NFIRST(K)
C#          WRITE(6,'('' PA:'',F13.6,'' C('',I2,''+'',I3,''):'',
C#     +F13.5)')PA((I*(I+1))/2),I,J,C(I+J)
  110          Q(K)=PA((I*(I+1))/2)*0.3333333D0+C(I+J)**2*0.66666666D0
               WRITE(6,'(5(2X,A2,I2,F9.5,1X))')
     1    (ELEMNT(NAT(I)),I,Q(I),I=1,NUMAT)
            ENDIF
            DO 120 I=1,LINEAR
  120       PA(I)=P(I)-PB(I)
         ENDIF
         IF (INDEX(KEYWRD,' BONDS') .NE. 0) THEN
            IF(NBETA.EQ.0)THEN
               WRITE(6,'(/10X,''BONDING CONTRIBUTION OF EACH M.O.'',/)')
               CALL MOLVAL(C,P,NORBS,2.D0)
            ELSE
               WRITE(6,'(/10X,''BONDING CONTRIBUTION OF EACH ALPHA M.O.'
     1',/)')
               CALL MOLVAL(C,P,NORBS,1.D0)
               WRITE(6,'(/10X,''BONDING CONTRIBUTION OF EACH BETA  M.O.'
     1',/)')
               CALL MOLVAL(C,P,NORBS,1.D0)
            ENDIF
            CALL BONDS(P)
         ENDIF
         I=NCLOSE+NALPHA
         IF (INDEX(KEYWRD,' LOCAL') .NE. 0) THEN
            CALL LOCAL(C,NORBS,I,EIGS)
            IF(NBETA.NE.0)THEN
               WRITE(6,'(//10X,'' LOCALIZED BETA MOLECULAR ORBITALS'')')
               CALL LOCAL(CBETA,NORBS,NBETA,EIGB)
            ENDIF
         ENDIF
         IF (INDEX(KEYWRD,' 1ELE') .NE. 0) THEN
            WRITE(6,'('' FINAL ONE-ELECTRON MATRIX '')')
            CALL VECPRT(H,NORBS)
         ENDIF
         IF(INDEX(KEYWRD,' ENPART') .NE. 0)
     1CALL ENPART(UHF,H,PA,PB,P,Q,COORD)
      ENDIF
      DO 130 I=1,107
  130 NELEMT(I)=0
      DO 140 I=1,NUMAT
         IGO=NAT(I)
         IF (IGO.GT.107) GO TO 140
         NELEMT(IGO)=NELEMT(IGO)+1
  140 CONTINUE
      ICHFOR=0
      IF (NELEMT(6).EQ.0) GO TO 150
      ICHFOR=1
      IELEMT(1)=ELEMNT(6)
      NZS=NELEMT(6)
      IF (NZS.LT.10) THEN
         IF (NZS.EQ.1) THEN
            IEL1(1)=11
         ELSE
            IEL1(1)=NZS+1
         ENDIF
         IEL2(1)=11
      ELSE
         KFRST=NZS/10
         KSEC=NZS-(10*KFRST)
         IEL1(1)=KFRST+1
         IEL2(1)=KSEC+1
      ENDIF
  150 NELEMT(6)=0
      DO 160 I=1,107
         IF (NELEMT(I).EQ.0) GO TO 160
         ICHFOR=ICHFOR+1
         IELEMT(ICHFOR)=ELEMNT(I)
         NZS=NELEMT(I)
         IF (NZS.LT.10) THEN
            IF (NZS.EQ.1) THEN
               IEL1(ICHFOR)=11
            ELSE
               IEL1(ICHFOR)=NZS+1
            ENDIF
            IEL2(ICHFOR)=11
         ELSE
            KFRST=NZS/10
            KSEC=NZS-(10*KFRST)
            IEL1(ICHFOR)=KFRST+1
            IEL2(ICHFOR)=KSEC+1
         ENDIF
  160 CONTINUE
      IF(INDEX(KEYWRD,' DENOUT') .NE. 0) THEN
         OPEN(UNIT=10,FILE=GETNAM('FOR010'),
     +STATUS='UNKNOWN',FORM='UNFORMATTED')
         REWIND 10
         WRITE(10)(PA(I),I=1,LINEAR)
         IF(UHF)WRITE(10)(PB(I),I=1,LINEAR)
         CLOSE (10)
      ENDIF
      IF((CI.OR.NOPEN.NE.NCLOSE.AND.FRACT.NE.2.D0.AND.FRACT.NE.0.D0
     1 .OR.INDEX(KEYWRD,' SIZE').NE.0)
     2 .AND. INDEX(KEYWRD,' MECI')+INDEX(KEYWRD,' ESR').NE.0)THEN
         WRITE(6,'(//10X,
     1''MULTI-ELECTRON CONFIGURATION INTERACTION CALCULATION'',//)')
         LAST=3
         X=MECI(EIGS,C)
      ENDIF
      IF (INDEX(KEYWRD,' MULLIK') +INDEX(KEYWRD,' GRAPH') .NE. 0) THEN
         IF (INDEX(KEYWRD,' MULLIK') .NE. 0)
     1   WRITE(6,'(/10X,'' MULLIKEN POPULATION ANALYSIS'')')
         CALL MULLIK(C,H,F,NORBS,P,RXYZ)
         IF (INDEX(KEYWRD,' GRAPH') .NE. 0)
     1   WRITE(6,'(/10X,'' DATA FOR GRAPH WRITTEN TO DISK'')')
      ENDIF
C
C  NOTE THAT THE DENSITY, H AND F MATRICES ARE CORRUPTED BY A
C  CALL TO MULLIK.
      IF(ISYBYL.EQ.1) THEN
         IF (INDEX(KEYWRD,'MULLIK').EQ.0) THEN
            CALL MPCPOP(C,0)
         ELSE
            CALL MPCPOP(C,1)
         ENDIF
         CLOSE(16)
      ENDIF
      IF(ICALCN.NE.NUMCAL)THEN
         IF(NAMFIL.EQ.'**NULL**') THEN
         NAMFIL=GETNAM('FOR012')
         INAM=ICHAR('a')
         JNAM=INAM
         JEND=INDEX(NAMFIL,' ')
         IEND=JEND+1
         ENDIF
  162    CLOSE (12)
         OPEN(UNIT=12,FILE=NAMFIL,STATUS='NEW',ERR=163)
         GOTO 164
  163    NAMFIL(IEND:IEND)=CHAR(INAM)
         NAMFIL(JEND:JEND)=CHAR(JNAM)
         IF(INAM.EQ.ICHAR('z'))THEN
         INAM=INAM-26
         JNAM=JNAM+1
         ENDIF
         INAM=INAM+1
         GOTO 162
  164    REWIND 12
         ICALCN=NUMCAL
      ENDIF
      IWRITE=12
  170 WRITE(IWRITE,'(//20X,'' SUMMARY OF '',A7,
     1'' CALCULATION'',/)')CALTYP
      WRITE(IWRITE,'(60X,''VERSION '',F5.2)')VERSON
      WRITE (IWRITE,180) (IELEMT(I),NUMBRS(IEL1(I)),NUMBRS(IEL2(I))
     1,I=1,ICHFOR)
  180 FORMAT (//,1X,17(A2,A1,A1))
      WRITE(IWRITE,'(55X,A24)')IDATE
      CALL WRTTXT(IWRITE)
      WRITE(IWRITE,'(//4X,A58)')FLEPO(IFLEPO)
      WRITE(IWRITE,'(4X,A58)')ITER(IITER)
      WRITE(IWRITE,'(//10X,''HEAT OF FORMATION       =''
     1,F17.6,'' KCAL'')')FUNCT
      WRITE(IWRITE,'(  10X,''ELECTRONIC ENERGY       =''
     1,F17.6,'' EV'')')ELECT
      WRITE(IWRITE,'(  10X,''CORE-CORE REPULSION     =''
     1,F17.6,'' EV'')')ENUCLR
      IF(PRTGRA)
     1WRITE(IWRITE,'(  10X,''GRADIENT NORM           =''
     2,F17.6)')GNORM
      IF(LATOM.EQ.0) THEN
         IF(.NOT.STILL) WRITE(IWRITE,'(A)')
     1' WARNING -- GEOMETRY IS NOT AT A STATIONARY POINT'
      ELSE
         GRTYPE=' KCAL/ANGSTROM'
         IF(LPARAM.EQ.1)THEN
            WRITE(IWRITE,'(    10X,''FOR REACTION COORDINATE ='',F17.4
     1        ,'' ANGSTROMS'')')XREACT
         ELSE
            IF(NA(1).NE.99)GRTYPE=' KCAL/RADIAN  '
            WRITE(IWRITE,'(    10X,''FOR REACTION COORDINATE ='',F17.4
     1        ,'' DEGREES'')')XREACT*DEGREE
         ENDIF
         WRITE(IWRITE,'(    10X,''REACTION GRADIENT       ='',F17.6,A14
     1    )')GCOORD,GRTYPE
      ENDIF
      WRITE(IWRITE,'(  10X,''DIPOLE                  =''
     1,F16.5, '' DEBYE'')')DIP
      IF(UHF) THEN
         WRITE(IWRITE,'(  10X,''(SZ)                    ='',F17.6)')SZ
         WRITE(IWRITE,'(  10X,''(S**2)                  ='',F17.6)')SS2
         WRITE(IWRITE,'(  10X,''NO. OF ALPHA ELECTRONS  ='',I10)')NALPHA
         WRITE(IWRITE,'(  10X,''NO. OF BETA  ELECTRONS  ='',I10)')NBETA
      ELSE
         WRITE(IWRITE,'(  10X,''NO. OF FILLED LEVELS    ='',I10)')NCLOSE
         NOPN=NOPEN-NCLOSE
         IF(NOPN.NE.0)
     1WRITE(IWRITE,'(  10X,''AND NO. OF OPEN LEVELS  ='',I10)')NOPN
      ENDIF
      IF(CI)
     1WRITE(IWRITE,'(  10X,''CONFIGURATION INTERACTION WAS USED'')')
      IF(KCHRGE.NE.0)
     1WRITE(IWRITE,'(  10X,''CHARGE ON SYSTEM        ='',I10)')KCHRGE
      WRITE(IWRITE,'(  10X,''IONIZATION POTENTIAL    =''
     1,F17.6,'' EV'')')EIONIS
      WRITE(IWRITE,'(  10X,''MOLECULAR WEIGHT        ='',F14.3)')SUMW
      WRITE(IWRITE,'(  10X,''SCF CALCULATIONS        =''
     1,I10)') NSCF
      TIM=SECOND()-TIME0
      CALL TIMOUT(IWRITE,TIM)
      WRITE(IWRITE,'(//10X,''FINAL GEOMETRY OBTAINED'',36X,''CHARGE'')')
      CALL GEOUT(IWRITE)
      IF(INDEX(KEYWRD,' AIGOUT').NE.0)THEN
         WRITE(IWRITE,'(//,A)')'  GEOMETRY IN GAUSSIAN Z-MATRIX STYLE'
         CALL WRTTXT(IWRITE)
         CALL GEOUTG(IWRITE)
      ENDIF
      IF(IWRITE.NE.11.AND.INDEX(KEYWRD,' NOLOG').EQ.0)THEN
         IWRITE=11
         GOTO 170
      ENDIF
      NSCF=0
      RETURN
      END
      SUBROUTINE TIMOUT(NOUT,TIM)
C
C     CONVERT THE TIME FROM SECONDS TO DAYS, HOURS, MINUTES, AND SECONDS
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      DOUBLE PRECISION MINS, MINPHR
C
C
      DATA HRSPD /24.0D0/,    MINPHR /60.0D0/
      DATA SECPD /86400.0D0/, SECPMI /60.0D0/
C
      DAYS = TIM / SECPD
      IDAYS = INT(DAYS)
      HOURS = (DAYS - FLOAT(IDAYS)) * HRSPD
      IHOURS = INT(HOURS)
      MINS = (HOURS - FLOAT(IHOURS)) * MINPHR
      IMINS = INT(MINS)
      SECS = (MINS - FLOAT(IMINS)) * SECPMI
C
      IF (IDAYS .GT. 1) THEN
         WRITE (NOUT,10) IDAYS,IHOURS,IMINS,SECS
      ELSE IF (IDAYS .EQ. 1) THEN
         WRITE (NOUT,20) IDAYS,IHOURS,IMINS,SECS
      ELSE IF (IHOURS .GT. 0) THEN
         WRITE (NOUT,30) IHOURS,IMINS,SECS
      ELSE IF (IMINS .GT. 0) THEN
         WRITE (NOUT,40) IMINS,SECS
      ELSE
         WRITE (NOUT,50) SECS
      END IF
C
   10 FORMAT (10X,'COMPUTATION TIME = ',I2,1X,'DAYS',2X,I2,1X,'HOURS',
     1        1X,I2,1X,'MINUTES AND',1X,F7.3,1X,'SECONDS')
   20 FORMAT (10X,'COMPUTATION TIME = ',I2,1X,'DAY',2X,I2,1X,'HOURS',
     1        1X,I2,1X,'MINUTES AND',1X,F7.3,1X,'SECONDS')
   30 FORMAT (10X,'COMPUTATION TIME = 'I2,1X,'HOURS',
     1        1X,I2,1X,'MINUTES AND',1X,F7.3,1X,'SECONDS')
   40 FORMAT (10X,'COMPUTATION TIME = ',I2,1X,'MINUTES AND',
     1        1X,F7.3,1X,'SECONDS')
   50 FORMAT (10X,'COMPUTATION TIME = ',F7.3,1X,'SECONDS')
      END
      SUBROUTINE MPCPOP(C,ICOK)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      INCLUDE 'SIZES'
C
C This subroutine calculates the total Mulliken populations on the
C   atoms by summing the diagonal elements from the  Mulliken
C   population analysis.
C
      COMMON / MOLKST/ NUMAT,NAT(NUMATM),NFIRST(NUMATM),NMIDLE(NUMATM),
     1                NLAST(NUMATM), NORBS, NELECS,NALPHA,NBETA,
     2                NCLOSE,NOPEN,NDUMY,FRACT
      COMMON /CORE/ CORE(107)
      DIMENSION C(MORB2),POP(NUMATM),CHRG(NUMATM)
      WRITE(16,'(I4,5X'' MULLIKEN POPULATION AND CHARGE'')',ERR=40)ICOK
C
C ICOK = 1 ==> PRINT POPULATIONS
C ICOK = 0 ==> KEYWORD mulliken = .f.
C         NO POPULATION ANALYSIS PERFORMED
C
      IF (ICOK.NE.0) THEN
         DO 20 I = 1,NUMAT
            IF = NFIRST(I)
            IL = NLAST(I)
            SUM = 0.0
            POP(I) = 0.0
            CHRG(I) = 0.0
            DO 10 J = IF,IL
C
C    Diagonal element of mulliken matrix
C
               SUM = SUM + C((J*(J+1))/2)
   10       CONTINUE
            K = NAT(I)
C
C    Mulliken population for i'th atom
C
            POP(I) = SUM
            CHRG(I) = CORE(K) - POP(I)
   20    CONTINUE
         WRITE(6,'(///10X,''MULLIKEN POPULATIONS AND CHARGES'')')
         DO 30 J = 1,NUMAT
            WRITE(6,60) J, POP(J), CHRG(J)
            WRITE(16,70,ERR=40) POP(J), CHRG(J)
   30    CONTINUE
      ENDIF
      RETURN
   40 WRITE(6,'(A)') 'Error writing SYBYL Mulliken population output'
      RETURN
   50 FORMAT(//,5X,'ATOM',8X,'POPULATION',6X,'CHARGE')
   60 FORMAT(5X,I4,4X,F11.6,6X,F11.6)
   70 FORMAT(2F12.6)
      END
C
C This subroutine writes out the optimized geometry and atomic charges
C   for a MOPAC run.
C
      SUBROUTINE MPCSYB(NUMAT,COORD,CHR,ICOK,EIGS,NCLOSE,FUNCT
     1                       ,EIONIS,KCHRGE,DIP)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      INCLUDE 'SIZES'
      DIMENSION COORD(3, NUMAT), CHR(NUMAT),EIGS(MAXORB)
C  Write out the charge flag and number of atoms
      WRITE(16,'(2I4)', ERR=30) ICOK,NUMAT
C  Write out the coordinates and charges
      DO 10 I=1, NUMAT
         WRITE(16,'(4F12.6)', ERR=30) (COORD(J, I), J=1, 3), CHR(I)
   10 CONTINUE
      I1 = MAX(1,NCLOSE - 1)
      I2 = MIN(MAXORB,NCLOSE + 2)
C
C  Write out the 2 highest and 2 lowest orbital energies
C
      WRITE(16,20,ERR=30)(EIGS(J),J=I1,I2),NCLOSE
   20 FORMAT(4F12.6,2X,I4,2X,'HOMOs,LUMOs,# of occupied MOs')
C
C  Write out the Heat of Formation and Ionisation Potential
C
      WRITE(16,'(2F12.6,4X,''HF and IP'')',ERR=30) FUNCT,EIONIS
C
C  Write out the Dipole Moment
C
      IF(KCHRGE.NE.0) DIP = 0.0
      WRITE(16, '(I4,F10.3,''  Charge,Dipole Moment'')', ERR=30)
     1KCHRGE, DIP
      RETURN
   30 WRITE(6,'(A)') 'Error writing SYBYL MOPAC output'
      RETURN
      END