      SUBROUTINE DFPSAV(TOTIME,XPARAM,GD,XLAST,FUNCT1,MDFP,XDFP)
      implicit double precision (A-H,O-Z)
      include 'SIZES'
      include 'MOP6FILE'
      dimension XPARAM(*), GD(*), XLAST(*), MDFP(9),XDFP(9)
**********************************************************************
*
* DFPSAV STORES AND RESTORES DATA USED IN THE D-F-P GEOMETRY
*        OPTIMISATION.
*
*  ON INPUT TOTIME = TOTAL CPU TIME ELAPSED DURING THE CALCULATION.
*           XPARAM = CURRENT VALUE OF PARAMETERS.
*           GD     = OLD GRADIENT.
*           XLAST  = OLD VALUE OF PARAMETERS.
*           FUNCT1 = CURRENT VALUE OF HEAT OF FORMATION.
*           MDFP   = INTEGER CONSTANTS USED IN D-F-P.
*           XDFP   = REAL CONSTANTS USED IN D-F-P.
*           MDFP(9)= 1 FOR DUMP, 0 FOR RESTORE.
**********************************************************************
      common /KEYWRD/ KEYWRD
      common /GRADNT/ GRAD(MAXPAR),GNORM
      common /GEOVAR/ NVAR,LOC(2,MAXPAR), IDUMY, DUMY(MAXPAR)
      common /DENSTY/ P(MPACK), PA(MPACK), PB(MPACK)
      common /ALPARM/ ALPARM(3,MAXPAR),X0, X1, X2, ILOOP
      common /PPARAM/ CURRT
      common /GPARAM/ CURRT1,CURRT2
      common /PROFIL/ PROFIL
      common /SURF  / SURF
      common /KLOOP / KLOOP
      common /IJLP  / IJLP, ILP, JLP, JLP1, IONE
      common /REACTN/ STEP, GEOA(3,NUMATM), GEOVEC(3,NUMATM),CALCST
      common /GEOM  / GEO(3,NUMATM)
      common /GEOKST/ NATOMS,LABELS(NUMATM),
     1                NA(NUMATM),NB(NUMATM),NC(NUMATM)
      common /ELEMTS/ ELEMNT(107)
      character KOMENT*81, TITLE*81
      common /TITLES/ KOMENT,TITLE
      common /PATH  / LATOM,LPARAM,REACT(200)
      common /MESH  / LATOM1,LPARA1,LATOM2,LPARA2
      common /MOLKST/ NUMAT,NAT(NUMATM),NFIRST(NUMATM),NMIDLE(NUMATM),
     1                NLAST(NUMATM), NORBS, NELECS,NALPHA,NBETA,
     2                NCLOSE,NOPEN,NDUMY,FRACT
      common /FMATRX/ HESINV(MAXHES)
      common /ERRFN / ERRFN(MAXPAR), AICORR(MAXPAR)
      common /NUMCAL/ NUMCAL
      dimension COORD(3,NUMATM)
      dimension PROFIL(200)
      dimension SURF(23*23)
      character ELEMNT*2, KEYWRD*241, GETNAM*80
      logical FIRST, INTXYZ
      save FIRST
c
      logical harakiri /.false./   ! we prefer enjoying life
c
      save    harakiri             ! it is worth remembering
                                   ! as any mistake may be fatal ...
c
      data ICALCN/0/
      FIRST=(ICALCN.EQ.NUMCAL)
      open(unit=MIOC,file=GETNAM('FOR009')
     +                     ,status='UNKNOWN',form='UNFORMATTED')
      rewind MIOC
      open(unit=MIOD,file=GETNAM('FOR010')
     +                     ,status='UNKNOWN',form='UNFORMATTED')
      rewind MIOD
      DEGREE=57.29577951D0
      IR=MIOC
      if (MDFP(9) .NE. 0) then
         if (MDFP(9) .EQ. 1) then
            write(MIOB,
     %          '(//10X,''- - - - - - - TIME UP - - - - - - -'',//)')
            if (INDEX(KEYWRD,'SADDLE') .NE. 0) then
               write(MIOB,'(//10X,'' NO RESTART EXISTS FOR SADDLE''//
     1     10X,'' HERE IS A DATA-FILE FILES THAT MIGHT BE SUITABLE''/
     2     10X,'' FOR RESTARTING THE CALCULATION'',///)')
               write(MIOB,'(A)')KEYWRD,KOMENT,TITLE
               INTXYZ=(NA(1).EQ.0)
               do 30 ILOOP=1,2
                  if (INTXYZ) then
                     GEO(2,1)=0.D0
                     GEO(3,1)=0.D0
                     GEO(1,1)=0.D0
                     GEO(2,2)=0.D0
                     GEO(3,2)=0.D0
                     GEO(3,3)=0.D0
                     do 10 I=1,NATOMS
                        do 10 J=1,3
   10                COORD(J,I)=GEO(J,I)
                  else
                     call XYZINT(GEO,NUMAT,NA,NB,NC,1.D0,COORD)
                  end if
                  call GEOUT(-MIOB)
                  do 20 I=1,NATOMS
                     do 20 J=1,3
   20             GEO(J,I)=GEOA(J,I)
                  NA(1)=99
   30          continue
               write(MIOB,'(///10X,''CALCULATION TERMINATED HERE'')')
c
c##               call executioner
                  call filclo  ! J/M
                  stop ' in DFPSAV !'
c
            end if
            write(MIOB,'(//10X,
     1        '' - THE CALCULATION IS BEING DUMPED TO DISK''/10X
     2        ''   RESTART IT USING THE MAGIC WORD "RESTART"'')')
            write(MIOB,'(//10X,''CURRENT VALUE OF HEAT OF FORMATION =''
     1  ,F12.6)')  FUNCT1
                               ! our time is over,
         harakiri =  .true.    ! we know that there is no other chance
                               ! one must die sometime ....
                               !  J/M
         end if
         if (MDFP(9) .EQ. 1) then
            if (NA(1) .EQ. 99) then
C
C  CONVERT FROM CARTESIAN COORDINATES TO INTERNAL
C
               do 40 I=1,NATOMS
                  do 40 J=1,3
   40          COORD(J,I)=GEO(J,I)
               call XYZINT(COORD,NUMAT,NA,NB,NC,1.D0,GEO)
            end if
            GEO(2,1)=0.D0
            GEO(3,1)=0.D0
            GEO(1,1)=0.D0
            GEO(2,2)=0.D0
            GEO(3,2)=0.D0
            GEO(3,3)=0.D0
            IVAR=1
            NA(1)=0
            call GEOUT(MIOB)
         end if
         write(IR)MDFP,XDFP,TOTIME,FUNCT1
         write(IR) (XPARAM(I),I=1,NVAR),(GD(I),I=1,NVAR)
         write(IR) (XLAST(I),I=1,NVAR),(GRAD(I),I=1,NVAR)
         LINEAR=(NVAR*(NVAR+1))/2
         write(IR) (HESINV(I),I=1,LINEAR)
         LINEAR=(NORBS*(NORBS+1))/2
         write(MIOD) (PA(I),I=1,LINEAR)
         if (NALPHA.NE.0) write(MIOD) (PB(I),I=1,LINEAR)
         if (LATOM.NE.0) then
            if (INDEX(KEYWRD,'STEP').NE.0) then
               write(IR) KLOOP
               write(IR) CURRT
               write(IR) (PROFIL(I),I=1,KLOOP)
            else
               write(IR) ((ALPARM(J,I),J=1,3),I=1,NVAR)
               write(IR)ILOOP,X0, X1, X2
            end if
         end if
         if (INDEX(KEYWRD,'STEP1').NE.0) then
            write(IR) IJLP,ILP,JLP,JLP1,IONE
            write(IR) CURRT1,CURRT2
            write(IR) (SURF(I),I=1,IJLP)
         end if
         write(IR) (ERRFN(I),I=1,NVAR)
         close (unit=MIOC)
         close (unit=MIOD)
c
        if (harakiri) then              ! all data is stored
          call filclo
          stop ' in DFPSAV !'
        endif
                                        ! get lost!
      else
         if (FIRST) write(MIOB,'(//10X,'' RESTORING DATA FROM DISK''/)')
         read(IR,end=60,ERR=60) MDFP,XDFP,TOTIME,FUNCT1
         if (FIRST) write(MIOB,'(10X,''FUNCTION ='',F13.6//)')FUNCT1
         read(IR) (XPARAM(I),I=1,NVAR),(GD(I),I=1,NVAR)
         read(IR) (XLAST(I),I=1,NVAR),(GRAD(I),I=1,NVAR)
         LINEAR=(NVAR*(NVAR+1))/2
         read(IR) (HESINV(I),I=1,LINEAR)
         LINEAR=(NORBS*(NORBS+1))/2
         read(MIOD) (PA(I),I=1,LINEAR)
         if (NALPHA.NE.0) read(MIOD) (PB(I),I=1,LINEAR)
         if (LATOM.NE.0) then
            if (INDEX(KEYWRD,'STEP').NE.0) then
               read(IR) KLOOP
               read(IR) CURRT
               read(IR) (PROFIL(I),I=1,KLOOP)
            else
               read(IR) ((ALPARM(J,I),J=1,3),I=1,NVAR)
               read(IR) ILOOP,X0, X1, X2
            end if
         end if
         if (INDEX(KEYWRD,'STEP1').NE.0) then
            read(IR) IJLP,ILP,JLP,JLP1,IONE
            read(IR) CURRT1,CURRT2
            read(IR) (SURF(I),I=1,IJLP)
         end if
         read(IR) (ERRFN(I),I=1,NVAR)
   50    FIRST=.FALSE.
         return
   60    write(MIOB,'(//10X,''NO RESTART FILE EXISTS!'')')
         call filclo  ! J/M
         stop ' in DFPSAV - NO RESTART FILE EXISTS'
      end if
      end
