      SUBROUTINE WRITMO(TIME0,FUNCT)
      implicit double precision (A-H,O-Z)
      include 'SIZES'
      include 'MOP6FILE'
      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(MPACK*4), SEC(MPACK*2), VEC(MPACK*2),
     1                ALBAND(MPACK*14)
      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, XYZ, STILL
      character TYPE(3)*11, IDATE*28, CALCN(2)*5, GTYPE*13, GRTYPE*14,
     1          FLEPO(16)*58, ITER(2)*58, NUMBRS(11)*1, GETNAM*80
      character*2 ELEMNT, IELEMT(20), SPNTYP*7, 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)
      PI=3.141592653589D0
      if (ICALCN.EQ.0) NAMFIL='**NULL**'     ! ????? moze to i sensowne
      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
      XYZ=(INDEX(KEYWRD,' XYZ') .NE. 0)
      SINGLT=(INDEX(KEYWRD,' SING') .NE. 0)
      TRIPLT=(INDEX(KEYWRD,' TRIP') .NE. 0)
      EXCITD=(INDEX(KEYWRD,' EXCI') .NE. 0)
      SPNTYP='GROUND '
      if (SINGLT) SPNTYP='SINGLET'
      if (TRIPLT) SPNTYP='TRIPLET'
      if (EXCITD) SPNTYP='EXCITED'
      CI=(INDEX(KEYWRD,' C.I.') .NE. 0)
      if (INDEX(KEYWRD,' MINDO') .NE. 0) then
         CALTYP='MINDO/3'
      else if (INDEX(KEYWRD,' AM1') .NE. 0) then
         CALTYP='  AM1  '
      else if (INDEX(KEYWRD,' PM3') .NE. 0) then
         CALTYP='  PM3  '
      else
         CALTYP=' MNDO  '
      end if
      UHF=(IUHF.EQ.2)
      call DATE(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'
      end if
      GNORM=0.D0
      if (NVAR.NE.0)  GNORM=SQRT(DOT(GRAD,GRAD,NVAR))
      write(MIOB,'(/,'' ----'',15(''-----''))')
      call WRTTXT(MIOB)
      write(MIOB,'(//4X,A58)') FLEPO(IFLEPO)
      IITER=MAX(1,IITER)
      write(MIOB,'(4X,A58)') ITER(IITER)
      write(MIOB,'(//30X,A7,''  CALCULATION'')') CALTYP
      write(MIOB,'(/25X,''Version of MOPAC used ='',F5.2)') VERSON
      write(MIOB,'(/25X,A28)') IDATE
      if (IITER.EQ.2) then
C
C   RESULTS ARE MEANINGLESS. DON'T PRINT ANYTHING!
C
         write(MIOB,
     %     '(//,'' FOR SOME REASON THE SCF CALCULATION FAILED.''/
     %          '' THE RESULTS WOULD BE MEANINGLESS,'',
     %          '' SO WILL NOT BE PRINTED.'')')
         write(MIOB,
     %     '('' TRY TO FIND THE REASON FOR THE FAILURE BY USING '',
     %       ''"PL".''/
     %       '' CHECK YOUR GEOMETRY AND ALSO TRY USING SHIFT '',
     %       ''OR PULAY. '')')
         call GEOUT(1)
c
         call filclo  ! J/M
         stop ' in WRITMO - SCF failed, no results printed'
c
      end if
      write(MIOB,'(////10X,''FINAL HEAT OF FORMATION ='',F17.5,
     %                     '' KCAL'')')  FUNCT
      if (LATOM.EQ.0) write(MIOB,'(/)')
      write(MIOB,'(    10X,''TOTAL ENERGY            ='',F17.5,
     %                     '' EV'' )')   ELECT+ENUCLR
      write(MIOB,'(    10X,''ELECTRONIC ENERGY       ='',F17.5,
     1                     '' EV'' )')   ELECT
      write(MIOB,'(    10X,''CORE-CORE REPULSION     ='',F17.5,
     1                     '' EV'' )')   ENUCLR
      if (LATOM.EQ.0) write(MIOB,'(1X)')
      PRTGRA=(PRTGRA .OR. GNORM .GT. 2.D0)
      if (PRTGRA)
     1   write(MIOB,
     2   '(    10X,''GRADIENT NORM           ='',F17.5)')  GNORM
      STILL=.TRUE.
      if (LATOM.EQ.0) then
      if (INDEX(KEYWRD,' AIDER').NE.0) go to 45
      if (INDEX(KEYWRD,'1SCF').NE.0.AND.INDEX(KEYWRD,'GRAD').EQ.0)
     1             go to 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(MIOB,'(A)')
     %           ' WARNING -- GEOMETRY IS NOT AT A STATIONARY POINT'
               STILL=.FALSE.
            end if
  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(MIOB,'(    10X,''FOR REACTION COORDINATE ='',F17.5
     %                          ,'' ANGSTROMS'')')  XREACT
         else
            if (NA(1).NE.99) GRTYPE=' KCAL/RADIAN  '
            write(MIOB,'(    10X,''FOR REACTION COORDINATE ='',F17.5
     %                          ,'' DEGREES'')')  XREACT*DEGREE
         end if
         write(MIOB,'(    10X,''REACTION GRADIENT       ='',F17.5,A14
     %                )')                         GCOORD,GRTYPE
      end if
      if (NALPHA.GT.0) then
         EIONIS=-MAX(EIGS(NALPHA), EIGB(NBETA))
      else if (NELECS.EQ.1) then
         EIONIS=-EIGS(1)
      else if (NELECS.GT.1) then
         EIONIS=-MAX(EIGS(NCLOSE), EIGS(NOPEN))
      else
         EIONIS=0.D0
      end if
      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)
      end if
      if (ABS(EIONIS).GT.1.D-5)
     1  write(MIOB,
     2    '(       10X,''IONIZATION POTENTIAL    ='',F17.5)')  EIONIS
      if ( UHF ) then
         write(MIOB,
     %     '(      10X,''NO. OF ALPHA ELECTRONS  ='',I11)')    NALPHA
         write(MIOB,
     %     '(      10X,''NO. OF BETA  ELECTRONS  ='',I11)')    NBETA
      else
         write(MIOB,
     %     '(      10X,''NO. OF FILLED LEVELS    ='',I11)')    NCLOSE
         if (NOPN.NE.0) then
            write(MIOB,
     %        '(   10X,''AND NO. OF OPEN LEVELS  ='',I11)')    NOPN
         end if
      end if
      SUMW=0
      do 10 I=1,NUMAT
   10 SUMW=SUMW+ATMASS(I)
      if (SUMW.GT.0.1D0)
     1  write(MIOB,
     2    '(    10X,''MOLECULAR WEIGHT        ='',F11.3)')     SUMW
      if (LATOM.EQ.0) write(MIOB,'(/)')
      write(MIOB,'(10X,''SCF CALCULATIONS  =   '',I14 )')      NSCF
      TIM=SECOND()-TIME0
      I=TIM*0.000001D0
      TIM=TIM-I*1000000
      call TIMOUT(MIOB,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(MIOB,'(///7X,''FINAL  POINT  AND  DERIVATIVES'',/)')
         write(MIOB,'(''   PARAMETER     ATOM    TYPE  ''
     %               ,''          VALUE       GRADIENT'')')
      end if
      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  '
            end if
   40    write(MIOB,'(I7,I11,1X,A2,4X,A11,F13.6,F13.6,2X,A13)')
     %              I,K,ELEMNT(L),TYPE(J),XI,GRAD(I),GTYPE
      end if
C
C     WRITE OUT THE GEOMETRY
C
      write(MIOB,'(///)')
      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(MIOB,'(//10X,''  INTERATOMIC DISTANCES'')')
         call VECPRT(RXYZ,NUMAT)
      end if
      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 LINE IS NON-STANDARD.  IF THIS CAUSES DIFFICULTY
C  REPLACE IT WITH
c
       open(unit=MIOI,status='unknown',file=GETNAM('FOR016'),ERR=190)
c
               ! it had to be done J/M
C
*            open(unit=MIOI,status='NEW',CARRIAGECONTROL='LIST',
*     1     file=GETNAM('FOR016'),ERR=190)
      end if
      if (NORBS.GT.0) then
         if (INDEX(KEYWRD,' VECT') .NE. 0) then
            write(MIOB,'(//10X,A5,'' EIGENVECTORS  '')')  CALCN(IUHF)
            call MATOUT (C,EIGS,NORBS,NORBS,NORBS)
            if (UHF) then
               write(MIOB,'(//10X,'' BETA EIGENVECTORS  '')')
               call MATOUT (CBETA,EIGB,NORBS,NORBS,NORBS)
            end if
         else
            write(MIOB,'(//10X,A5,''   EIGENVALUES'',/)')  CALCN(IUHF)
            write(MIOB,'(8F10.5)')  (EIGS(I),I=1,NORBS)
            if (UHF) then
               write(MIOB,'(//10X,'' BETA EIGENVALUES '')')
               write(MIOB,'(8F10.5)')  (EIGB(I),I=1,NORBS)
            end if
         end if
      end if
      write(MIOB,'(//13X,'' NET ATOMIC CHARGES AND DIPOLE '',
     %                   ''CONTRIBUTIONS'',/)')
      write(MIOB,'(8X,'' ATOM NO.   TYPE          CHARGE        ATOM''
     %               ,''  ELECTRON DENSITY'')')
      call CHRGE(P,Q)
      do 80 I=1,NUMAT
         L=NAT(I)
         Q2(I)=CORE(L) - Q(I)
   80 write(MIOB,'(I12,9X,A2,4X,F13.4,F16.4)')
     %           I,ELEMNT(L),Q2(I),Q(I)
      DIP= DIPOLE(P,Q2,COORD,DUMY,1)
      if (INDEX(KEYWRD,' NOXYZ') .EQ. 0) then
         write(MIOB,'(//10X,''CARTESIAN COORDINATES '',/)')
         write(MIOB,'(4X,''NO.'',7X,''ATOM'',15X,''X'',
     %                9X,''Y'',9X,''Z'',/)')
         write(MIOB,'(I6,8X,A2,14X,3F10.4)')
     %              (I,ELEMNT(NAT(I)),(COORD(J,I),J=1,3),I=1,NUMAT)
      end if
      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(MIOB,'(A)')  '  ALPHA BANDS'
            call BRLZON(F, FMAT2D, NORBS, SEC, VEC, ALBAND,MONO3,STEP,2)
         if (UHF) then
         write(MIOB,'(A)')  '  BETA BANDS'
         call BRLZON(FB, FMAT2D, NORBS, SEC, VEC, ALBAND,MONO3,STEP,2)
         end if
         end if
         if (ISYBYL.EQ.1) then
            NFILLD=MAX(NCLOSE,NALPHA,NBETA)
            call MPCSYB(NUMAT,COORD,Q2,1,EIGS,NFILLD,FUNCT,EIONIS
     1                 ,KCHRGE,DIP)
         end if
         if (INDEX(KEYWRD,' FOCK') .NE. 0) then
            write(MIOB,'('' FOCK MATRIX IS '')')
            call VECPRT(F,NORBS)
         end if
         if (INDEX(KEYWRD,' DENS') .NE. 0) then
            write(MIOB,'(//,20X,'' DENSITY MATRIX IS '')')
            call VECPRT(P,NORBS)
         else
            write(MIOB,
     %        '(//10X,''ATOMIC ORBITAL ELECTRON POPULATIONS'',/)')
            write(MIOB,'(8F10.5)')  (P((I*(I+1))/2),I=1,NORBS)
         end if
         if (INDEX(KEYWRD,' PI') .NE. 0) then
            write(MIOB,'(//10X,''SIGMA-PI BOND-ORDER MATRIX'')')
            call DENROT
         end if
         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(MIOB,'(//20X,''(SZ)    ='',F10.6)')  SZ
            write(MIOB,'(  20X,''(S**2)  ='',F10.6)')  SS2
            if (INDEX(KEYWRD,' SPIN') .NE. 0) then
               write(MIOB,'(//10X,''SPIN DENSITY MATRIX'')')
               call VECPRT(PA,NORBS)
            else
               write(MIOB,
     %           '(//10X,''ATOMIC ORBITAL SPIN POPULATIONS'',/)')
               write(MIOB,'(8F10.5)')  (PA((I*(I+1))/2),I=1,NORBS)
            end if
            if (INDEX(KEYWRD,' HYPERFINE') .NE. 0) then
C
C  WORK OUT THE HYPERFINE COUPLING CONSTANTS.
C
               write(MIOB,
     %           '(//10X,''    HYPERFINE COUPLING COEFFICIENTS''/)')
               J=(NALPHA-1)*NORBS
               do 110 K=1,NUMAT
                  I=NFIRST(K)
C#          write(MIOB,'('' 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(MIOB,'(5(2X,A2,I2,F9.5,1X))')
     %                    (ELEMNT(NAT(I)),I,Q(I),I=1,NUMAT)
            end if
            do 120 I=1,LINEAR
  120       PA(I)=P(I)-PB(I)
         end if
         if (INDEX(KEYWRD,' BONDS') .NE. 0) then
            if (NBETA.EQ.0) then
               write(MIOB,
     %           '(/10X,''BONDING CONTRIBUTION OF EACH M.O.'',/)')
               call MOLVAL(C,P,NORBS,2.D0)
            else
               write(MIOB,
     %           '(/10X,''BONDING CONTRIBUTION OF EACH ALPHA M.O.''/)')
               call MOLVAL(C,P,NORBS,1.D0)
               write(MIOB,
     %           '(/10X,''BONDING CONTRIBUTION OF EACH BETA  M.O.''/)')
               call MOLVAL(C,P,NORBS,1.D0)
            end if
            call BONDS(P)
         end if
         I=NCLOSE+NALPHA
         if (INDEX(KEYWRD,' LOCAL') .NE. 0) then
            call LOCAL(C,NORBS,I,EIGS)
            if (NBETA.NE.0) then
               write(MIOB,
     %           '(//10X,'' LOCALIZED BETA MOLECULAR ORBITALS'')')
               call LOCAL(CBETA,NORBS,NBETA,EIGB)
            end if
         end if
         if (INDEX(KEYWRD,' 1ELE') .NE. 0) then
            write(MIOB,'('' FINAL ONE-ELECTRON MATRIX '')')
            call VECPRT(H,NORBS)
         end if
         if (INDEX(KEYWRD,' ENPART') .NE. 0)
     1                  call ENPART(UHF,H,PA,PB,P,Q,COORD)
      end if
      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
         end if
         IEL2(1)=11
      else
         KFRST=NZS/10
         KSEC=NZS-(10*KFRST)
         IEL1(1)=KFRST+1
         IEL2(1)=KSEC+1
      end if
  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
            end if
            IEL2(ICHFOR)=11
         else
            KFRST=NZS/10
            KSEC=NZS-(10*KFRST)
            IEL1(ICHFOR)=KFRST+1
            IEL2(ICHFOR)=KSEC+1
         end if
  160 continue
      if (INDEX(KEYWRD,' DENOUT') .NE. 0) then
         open(unit=MIOD,file=GETNAM('FOR010'),
     +status='UNKNOWN',form='UNFORMATTED')
         rewind MIOD
         write(MIOD) (PA(I),I=1,LINEAR)
         if (UHF) write(MIOD) (PB(I),I=1,LINEAR)
         close (unit=MIOD)
      end if
      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(MIOB,'(//10X,
     %   ''MULTI-ELECTRON CONFIGURATION INTERACTION CALCULATION'',//)')
         LAST=3
         X=MECI(EIGS,C)
      end if
      if (INDEX(KEYWRD,' MULLIK') +INDEX(KEYWRD,' GRAPH') .NE. 0) then
         if (INDEX(KEYWRD,' MULLIK') .NE. 0)
     1   write(MIOB,'(/10X,'' MULLIKEN POPULATION ANALYSIS'')')
         call MULLIK(C,H,F,NORBS,P,RXYZ)
         if (INDEX(KEYWRD,' GRAPH') .NE. 0)
     1   write(MIOB,'(/10X,'' DATA FOR GRAPH WRITTEN TO DISK'')')
      end if
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)
         end if
         close (unit=MIOI)
      end if
      if (ICALCN.NE.NUMCAL) then
         if (NAMFIL.EQ.'**NULL**') then
         NAMFIL=GETNAM('FOR012')
         INAM=ICHAR('a')
         JNAM=INAM
         JEND=INDEX(NAMFIL,' ')
         Iend=JEND+1
         end if
  162    close (unit=MIOF)
         open(unit=MIOF,file=NAMFIL,status='NEW',ERR=163)
         go to 164
  163    NAMFIL(Iend:IEND)=CHAR(INAM)
         NAMFIL(JEND:JEND)=CHAR(JNAM)
         if (INAM.EQ.ICHAR('z')) then
         INAM=INAM-26
         JNAM=JNAM+1
         end if
         INAM=INAM+1
         go to 162
  164    rewind MIOF
         ICALCN=NUMCAL
      end if
      IWRITE=MIOF
  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,'(51X,A28)') 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
         end if
         write(IWRITE,'(    10X,''REACTION GRADIENT       ='',F17.6,A14
     1                                         )') GCOORD,GRTYPE
      end if
      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)
     1     write(IWRITE,'(  10X,''AND NO. OF OPEN LEVELS  ='',I10)')
     2                                      NOPN
      end if
      if (CI)
     1  write(IWRITE,'(  10X,''CONFIGURATION INTERACTION WAS USED'')')
      if (KCHRGE.NE.0)
     1  write(IWRITE,'(  10X,''CHARGE ON SYSTEM        ='',I10)')
     2                                      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)
      end if
      if (IWRITE.NE.MIOE.AND.INDEX(KEYWRD,' NOLOG').EQ.0) then
         IWRITE=MIOE
         go to 170
      end if
      NSCF=0
      return
  190 write(MIOB,'(A)') 'Error opening SYBYL MOPAC output'
      return
      end
