*----------------------------------------------------------------------*
      subroutine solve_nleq(mode_str,
     &     nopt,label_opt,label_res,label_prc,label_en,
     &     label_form,
     &     n_states,
     &     label_special,nspecial,           !<- eg. for R12
     &     label_spcfrm,nspcfrm,             !<- eg. for MRCC
     &     op_info,form_info,str_info,strmap_info,orb_info)
*----------------------------------------------------------------------*
*
*     solve non-linear equations
*
*     the formula with label "label_form" describes how to calculate
*     energy and residual
*
*     nopt               number of operators to be simultaneously optimized
*     label_opt(1..nop_opt) labels of those operators
*     label_opt(1..nop_opt) labels of preconditioners
*     label_res(nop_opt+1,..)   residuals
*     label_en                  energy
*
*     op_info:  operator definitions and files
*     str_info: string information (to be passed to subroutines)
*     orb_info: orbital space information (to be passed)
*
*----------------------------------------------------------------------*
      implicit none             ! what else ?

      include 'opdim.h'
      include 'stdunit.h'
      include 'mdef_operator_info.h'
      include 'def_graph.h'
      include 'def_strinf.h'
      include 'def_strmapinf.h'
      include 'def_orbinf.h'
      include 'def_optimize_info.h'
      include 'def_file_array.h'
      include 'def_optimize_status.h'
      include 'def_contraction.h'
      include 'def_formula_item.h'
      include 'mdef_formula_info.h'
      include 'def_dependency_info.h'
      include 'ifc_memman.h'
c dbg it's now itegral
      include 'ifc_input.h'
c dbgend
      include 'routes.h'
      include 'mdef_target_info.h'
      include 'molpro_out.h'

      integer, parameter ::
     &     ntest = 000
      character(len=*),parameter::
     &     i_am = "solve_nleq"

      integer, intent(in) ::
     &     nopt, nspecial, nspcfrm, n_states
      character(*), intent(in) ::
     &     mode_str,
     &     label_opt(nopt),
     &     label_res(nopt),
     &     label_prc(nopt),
     &     label_special(nspecial),
     &     label_spcfrm(nspcfrm),
     &     label_en,
     &     label_form
      type(formula_info) ::
     &     form_info
      type(operator_info) ::
     &     op_info
      type(strinf) ::
     &     str_info
      type(strmapinf) ::
     &     strmap_info
      type(orbinf) ::
     &     orb_info

      logical ::
     &     conv, restart, traf, last_state, multistate, MS_coupled
      character(len_opname) ::
     &     label, dia_label
      integer ::
     &     imacit, imicit, imicit_tot, iprint, task, ifree, iopt, jopt,
     &     idx, idxmel, ierr, nout,
     &     ndx, idx_res_xret(nopt), jdx, it_print,refproj,
     &     i_state, i_state2, ndx_eff, idx_eff, n_energies, nopt_state
      integer, allocatable ::
     &     idx_en_xret(:)
      real(8) ::
     &     xresnrm(nopt), xdum
      real(8), allocatable ::
     &     thr_suggest(:), energy(:), old_energy(:)
      real(8), pointer ::
     &     xret(:)
      type(dependency_info) ::
     &     depend
      type(filinf), target ::
     &     ff_unit_dummy
      type(me_list_array), pointer ::
     &     me_opt(:), me_grd(:), me_dia(:), me_special(:),
     &     me_trv(:), me_h_trv(:)   ! not yet needed
      type(file_array), pointer ::
     &     ffopt(:), ffgrd(:), ffdia(:), ffspecial(:),
     &     ff_trv(:), ff_h_trv(:)   ! not yet needed
      type(optimize_info) ::
     &     opti_info
      type(optimize_status), pointer ::
     &     opti_stat
      type(formula), pointer ::
     &     form_en_res
      type(formula_item) ::
     &     fl_en_res, fl_spc(nspcfrm)

      integer, external ::
     &     idx_formlist, idx_mel_list, idx_xret
      logical, external ::
     &     file_exists
      real(8), external ::
     &     xnormop
      character(len_target_name) ::
     &     c_st, c_st2
      character(len_target_name), external ::
     &     state_label
      type(me_list), pointer ::
     &     mel_C0, mel_pnt
      character(50) ::
     &     out_format
      character(80) ::
     &     mol_format,
     &     mol_format2
      character(5) ::
     &     evp_mode
      character(2) ::
     &     MRCC_type
      character(len=5)::
     &     fname

      real(8)::
     &     cpu0_r,sys0_r,wall0_r, ! beginning of a rule
     &     cpu0_t,sys0_t,wall0_t, ! beginning of a target
     &     cpu,sys,wall, ! variables for timing information
     &     time_per_it, ! Molpro timing variables
     &     res_sum ! Sum of seperated residuals
      character(len=512)::
     &     timing_msg
      ifree = mem_setmark('solve_nleq')

      call get_argument_value('method.MR','multistate',
     &     lval=multistate)
      call get_argument_value('method.MRCC','coupled_states',
     &     lval=MS_coupled)
      call get_argument_value('method.MRCC','type',
     &     str=MRCC_type)
      call get_argument_value('calculate.solve.non_linear',
     &                        'restart',lval=restart)

      nopt_state = nopt/n_states

      if (iprlvl.ge.5) then
        write(lulog,*) 'formula: ',trim(label_form)
        if (nopt.gt.1)
     &       write(lulog,*) 'solving for ',nopt,
     &       ' operators simultaneously'
        write(lulog,*)   'solving for: ',trim(label_opt(1))
        do iopt = 2, nopt
          write(lulog,*) '             ',trim(label_opt(iopt))
        end do
      end if

      idx = idx_formlist(label_form,form_info)
      if (idx.le.0)
     &     call quit(1,i_am,
     &     'did not find formula '//trim(label_form))
      form_en_res => form_info%form_arr(idx)%form

      allocate(ffopt(nopt),ffdia(nopt),ffgrd(nopt),ffspecial(nspecial),
     &     me_opt(nopt),me_dia(nopt),me_grd(nopt),me_special(nspecial))
      allocate(thr_suggest(n_states))
      allocate(opti_stat)

      ! associate all normal ME-Lists (amplitutes, gradients, preconditioner)
      do iopt = 1, nopt
         me_opt(iopt)%mel   => get_mel_h(label_opt(iopt), op_info)
         if (.not.mel_has_file_h( me_opt(iopt)%mel))then
            call quit(1,i_am,
     &           'no file associated with list '//trim(label_opt(iopt)))
         else
            ffopt(iopt)%fhand => me_opt(iopt)%mel%fhand
         end if

         me_grd(iopt)%mel => get_mel_h(label_res(iopt), op_info)
         if (.not.mel_has_file_h( me_grd(iopt)%mel))then
            call quit(1,i_am,
     &           'no file associated with list '//trim(label_res(iopt)))
         else
            ffgrd(iopt)%fhand => me_grd(iopt)%mel%fhand
         end if

         me_dia(iopt)%mel   => get_mel_h(label_prc(iopt),op_info)
         if (.not.mel_has_file_h( me_dia(iopt)%mel))then
            call quit(1,i_am,
     &           'no file associated with list '//trim(label_prc(iopt)))
         else
            ffdia(iopt)%fhand => me_dia(iopt)%mel%fhand
         end if
      end do

      ! special lists needed?
      do idx = 1, nspecial
         me_special(idx)%mel => get_mel_h(label_special(idx), op_info)
         if (.not.mel_has_file_h( me_special(idx)%mel))then
            call quit(1,i_am,
     &      'no file associated with list '//trim(label_special(idx)))
         else
            ffspecial(idx)%fhand => me_special(idx)%mel%fhand
         end if
      end do

      ! special formulae
      do jdx = 1, nspcfrm
c dbg
c       write(lulog,*),"solve_nleq: label_spcfrm: ",
c     &      trim(label_spcfrm(jdx))
c dbg end
        idx = idx_formlist(label_spcfrm(jdx),form_info)
        if (idx.le.0)
     &       call quit(1,i_am,
     &       'did not find formula '//trim(label_spcfrm(jdx)))
        ! read formula
        call read_form_list(form_info%form_arr(idx)%form%fhand,
     &                      fl_spc(jdx),.true.)
      end do

      ! for safety reasons, we allocate the two guys
      allocate(me_trv(1),me_h_trv(1))

! role of restart? it looks to me that currently ffopt(iopt)%fhand%unit is already open when present, hence no effect of restart option here (for icMRCC at least).
      do iopt = 1, nopt

        ! open result vector file(s)
cmh     if file already open, use as initial guess!
        if (ffopt(iopt)%fhand%unit.gt.0) then
          write(lulog,'(x,a,i1,3a)')
     &         'Using existing amplitudes as initial guess for vector ',
     &         iopt,'! (',trim(me_opt(iopt)%mel%label),')'
        else
          call file_open(ffopt(iopt)%fhand)
          ! hard restart? (just use old amplitude file as initial guess)
          if (restart) then
            inquire(file=trim(ffopt(iopt)%fhand%name),exist=restart)
            if (.not.restart) call warn(i_am,
     &         'No amplitude file found for restart! Setting to zero.')
          end if
          if (restart) then
            write(lulog,'(x,a,i1,a)')
     &         'Using old amplitude file for vector ',iopt,'!'
          else
            call zeroop(me_opt(iopt)%mel)
          end if
        end if
        ! open corresponding residuals ...
        call file_open(ffgrd(iopt)%fhand)
        ! ... and corresponding preconditioner(s)
        if (ffdia(iopt)%fhand%unit.le.0)
     &       call file_open(ffdia(iopt)%fhand)
      end do

      do idx = 1, nspecial
        if (ffspecial(idx)%fhand%unit.le.0)
     &       call file_open(ffspecial(idx)%fhand)
      end do

cmh      ! get initial amplitudes
cmh      do iopt = 1, nopt
cmhc        if (.not.file_exists(me_opt(iopt)%mel%fhand)) then
cmh          call zeroop(me_opt(iopt)%mel)
cmhc dbg DBGDBG!!!
cmhc        else
cmhc          call warn('solve_nleq','debug version of restart active')
cmhc        end if
cmh      end do

      ! use mode_str to set special preconditioning, e.g. for R12

      call set_opti_info(opti_info,1,nopt,1,me_opt,mode_str)

      ! write information to opti_info about signs which might occur
      ! in preconditioning step
      ! relevant when amp is njoined=1 op. but grd is njoined=2 op.
      call set_opti_info_signs(opti_info,1,nopt,
     &                         me_opt,me_grd,me_grd,me_grd,.false.)

      ! read formula
      call read_form_list(form_en_res%fhand,fl_en_res,.true.)

      ! set dependency info for submitted formula list
      call set_formula_dependencies(depend,fl_en_res,op_info)

      if (opti_info%skip_resx) then
        ! exclude residuals which are not needed from dependency info
        ! (these residuals are also defined as up to date)
        idxmel = idx_mel_list(label_res(nopt),op_info)
        call trunc_formula_dependencies(depend,idxmel,op_info)
      end if

      ! number of info values returned on xret
      nout = depend%ntargets
      allocate(xret(nout))
      if(multistate) then
       n_energies=n_states
      else
       n_energies=0
      end if
      allocate(idx_en_xret(0:n_energies))
      allocate(energy(0:n_energies))
      allocate(old_energy(0:n_energies))

      ! find out, which entries of xret are the ones that we need
      idx_en_xret(0) = idx_xret(label_en,op_info,depend)
      if(multistate)then
       do i_state = 1,n_states
        c_st = state_label(i_state,.true.)
        idx_en_xret(i_state) =
     &       idx_xret(trim(label_en)//trim(c_st),op_info,depend)
        if (idx_en_xret(i_state).le.0)
     &       call quit(1,i_am,
     &       'formula does not provide an update for all the energies')
       end do
      end if

      if (idx_en_xret(0).le.0)
     &     call quit(1,i_am,
     &     'formula does not provide an update for the energy')

      do iopt = 1, nopt
        idx_res_xret(iopt) = idx_xret(label_res(iopt),op_info,depend)
        if (idx_res_xret(iopt).le.0)
     &       call quit(1,i_am,
     &       'formula does not provide an update for all residuals')
      end do

      ! FIXME: no explicit referenc to list names
      idxmel = idx_mel_list("ME_C0",op_info)
      if (idxmel.GT.0)
     &     mel_C0 => op_info%mel_arr(idxmel)%mel

      if (lmol) then
         write(luout,*)
         write(luout,'(A112)') "ITER.  NCI    TOTAL ENERGY    ENERGY
     & CHANGE     RES       NSV    SV MIN     SV MAX    DIIS      TIME "
     & //"   TIME/IT"
         ! Turn off the printing of ci iterations
         no_print = .true.
      end if

      ! start optimization loop
      imacit = 0
      imicit = 0
      imicit_tot = 0
      task = 0
      old_energy = 0.0
      opt_loop: do !while(task.lt.8)
      call atim_csw(cpu0_t,sys0_t,wall0_t)
       if (multistate.and.MRCC_type.NE.'SU')
     &     call opt_solve_Heff(n_states,
     &     op_info,form_info,str_info,strmap_info,orb_info)

        call optcont
     &       (imacit,imicit,imicit_tot,
     &       task,conv,
     &       energy,xresnrm,
     &       me_opt,me_grd,me_dia,
     &       me_trv,me_h_trv,
     &      n_states,
     &       me_special, nspecial,! <- R12: pass B, X, H here
c     &       ffopt,ffgrd,ffdia,ffmet, ! <- R12: pass X here (metric)
c     &       ff_trv,ff_h_trv,
     &       fl_spc,nspcfrm,
     &       opti_info,opti_stat,
     &       orb_info,op_info,str_info,strmap_info)

        if (multistate.and.
     &       (opti_info%optref.eq.-1.or.opti_info%optref.eq.-2)) then ! save the just calculated ME_C0 in ME_C0_1
         ! FIXME: no explicit reference to list names
         idxmel = idx_mel_list("ME_C0_1",op_info)
         mel_pnt => op_info%mel_arr(idxmel)%mel
         call list_copy(mel_C0,mel_pnt,.false.)
         ! copy the saved ME_C0//c_st2 back to the records of ME_C0
         do i_state=2,n_states
          c_st = state_label(i_state,.true.)
          call switch_mel_record(mel_C0,i_state)
          idxmel = idx_mel_list("ME_C0"//trim(c_st),op_info)
          mel_pnt => op_info%mel_arr(idxmel)%mel
          call list_copy(mel_pnt,mel_C0,.false.)
         end do
         call switch_mel_record(mel_C0,1)
        end if

        ! output
        it_print = imacit-1
        if (conv) it_print = imacit
        if (luout.ne.lulog) then
         write(out_format,fmt='(A,i0,A,i0,A)')
     &        '(1x,i3,',n_states,'(f24.12,',nopt_state,
     &        '(x,g10.4)))'
         if (imacit.gt.1) then
          if (.not. lmol) then
           if (multistate) then
            write(luout,out_format)
     &           it_print, [(
     &           [energy(i_state),
     &           xresnrm((i_state-1)*nopt_state+1:i_state*nopt_state)]
     &           ,i_state = 1,n_states)]
           else

            write(luout,out_format)
     &            it_print,energy(0),xresnrm(1:nopt)
           end if

         else
           ! Print out new molpro output
           time_per_it = cpu0_t / (it_print)
           mol_format = "(i4,i7,f16.8,f16.8,d12.2,i7,d11.2,d11.2,"//
     &                  "i6,f11.2,f11.2)"

           if (multistate) then

            mol_format2 = "(f27.8,f16.8,d12.2)"

            do i_state = 1, n_states
             if (i_state==1) then
             write(luout,mol_format)
     &             it_print,ci_iter,energy(i_state),
     &             energy(i_state)-old_energy(i_state),
     &             xresnrm((i_state-1)*nopt_state+1:i_state*nopt_state),
     &             n_sv,sv_min,sv_max,
     &             opti_stat%ndim_rsbsp,cpu0_t,
     &             time_per_it
             else
             write(luout,mol_format2)
     &             energy(i_state),
     &             energy(i_state)-old_energy(i_state),
     &             xresnrm((i_state-1)*nopt_state+1:i_state*nopt_state)
             end if
            end do
            write(luout,*)

            do i_state = 1, n_states
               old_energy(i_state) = energy(i_state)
            end do

          else

            ! MRCC2 reports back seperate singles and doubles residuals,
            ! add them up and print out sum
            res_sum = 0.0
            do i_state = 1, nopt
             res_sum = res_sum + xresnrm(i_state)
            end do

            write(luout,mol_format)
     &            it_print,ci_iter,energy(0),
     &            energy(0)-old_energy(0),
     &            res_sum,
     &            n_sv,sv_min,sv_max,
     &            opti_stat%ndim_rsbsp,cpu0_t,time_per_it

            old_energy(0) = energy(0)
          end if

        end if

         end if
         if (task.ge.8) then
          write(luout,*)
          if (conv) then
           write(luout,'("    CONVERGED")')
          else
           write(luout,'("    NOT CONVERGED!")')
          end if
          write(luout,*)
         end if
        end if

        ! write on lulog
        write(out_format,fmt='(A,i0,A,i0,A)')
     &       '(">>>",i3,',n_states,'(f24.12,',nopt_state,
     &       '(x,g10.4)))'
        if (imacit.gt.1) then
         if(multistate)then
          write(lulog,out_format)
     &         it_print,[( [energy(i_state),
     &         xresnrm((i_state-1)*nopt_state+1:i_state*nopt_state)]
     &         ,i_state = 1,n_states)]
         else
          write(lulog,out_format)
     &         it_print,energy(0),xresnrm(1:nopt)
         end if
        end if
        if (task.ge.8) then
         if (conv) then
          write(lulog,'(">>> CONVERGED <<<")')
          write(out_format,fmt='(A,i0,A)')
     &         '(A,',n_states,'(x,f24.12)," <<<")'
          if(multistate)then
           write(lulog,out_format)
     &          ">>> final energies:", energy(1:n_states)
          else
           write(lulog,out_format)
     &          ">>> final energy:", energy(0)
          end if
         else
          write(lulog,'(">>> NOT CONVERGED! <<<")')
         end if
         exit opt_loop
        end if

        ci_iter = 0  ! reset value (only for print out)
        ! quick and dirty (for experimental use):
        ! do C0 optimization if requested
        if (opti_info%optref.eq.-3.and.
     &      (imacit.gt.1.or.restart.or.opti_info%skip_resx)
     &      .and..not.conv.and.nspcfrm.gt.n_states) then
          call get_argument_value('method.MR','ciroot',
     &       ival=idx)
          call get_argument_value('method.MR','maxroot',
     &       ival=ndx)
          call get_argument_value('method.MR','refproj',
     &       ival=refproj)

          if(ndx.le.0) ndx=idx
          call me_list_label(dia_label,'DIA',orb_info%lsym,
     &                       0,0,0,.false.)
          dia_label = trim(dia_label)//'C0'
          ! use weaker convergence threshold for micro-iterations
          do i_state=1,n_states
           thr_suggest(i_state) = min(xresnrm((i_state-1)*nopt_state+1)*
     &          opti_info%mic_ahead,1d-3)
          end do

          do i_state=1,n_states
           c_st  = state_label(i_state,.false.)
           c_st2 = state_label(i_state,.true.)
           if (multistate) call switch_mel_record(mel_C0,i_state)
           if (multistate) then
            ndx_eff = i_state
            idx_eff = i_state
           else
            ndx_eff = ndx
            idx_eff = idx
           end if

           ! FIXME: No explicit reference to list names
           if (spinadapt.gt.0.and.refproj.eq.0) then
             call solve_evp('SPP',1,ndx_eff,idx_eff,
     &            'ME_C0',trim(dia_label),'A_C0',
     &            'C0','FOPT_OMG_C0'//trim(c_st),
     &            'ME_C0_sp',1,
     &            'FOPT_C0_sp',1,
     &            thr_suggest(i_state),0,.false.,
     &            op_info,form_info,str_info,strmap_info,orb_info)

           else if (spinadapt.gt.0.and.refproj.gt.0) then
             call solve_evp('SRP',1,ndx_eff,idx_eff,
     &            'ME_C0',trim(dia_label),'A_C0',
     &            'C0','FOPT_OMG_C0'//trim(c_st),
     &            'ME_C0_sp',1,
     &            (/'FOPT_C0_prj','FOPT_C0_sp '/),2,
     &            thr_suggest(i_state),0,.false.,
     &            op_info,form_info,str_info,strmap_info,orb_info)

           else if (spinadapt.eq.0.and.refproj.gt.0) then
             call solve_evp('PRJ',1,ndx_eff,idx_eff,
     &            'ME_C0',trim(dia_label),'A_C0',
     &            'C0','FOPT_OMG_C0'//trim(c_st),
     &            '-',0,
     &            'FOPT_C0_prj',1,
     &            thr_suggest(i_state),0,.false.,
     &            op_info,form_info,str_info,strmap_info,orb_info)

           else
             call solve_evp('DIA',1,ndx_eff,idx_eff,
     &            'ME_C0',trim(dia_label),'A_C0',
     &            'C0','FOPT_OMG_C0'//trim(c_st),
     &            '-',0,
     &            '-',0,
     &            thr_suggest(i_state),0,.false.,
     &            op_info,form_info,str_info,strmap_info,orb_info)

          end if

           if (multistate) then ! save the just calculated ME_C0 in ME_C0//c_st2
              ! FIXME: No explicit reference to list names
              idxmel = idx_mel_list("ME_C0"//trim(c_st2),op_info)
              mel_pnt => op_info%mel_arr(idxmel)%mel
            call list_copy(mel_C0,mel_pnt,.false.)
           end if

          end do

!     copy the saved ME_C0//c_st2 back to the records of ME_C0
!     and get new C0_bar
          if(multistate)then
           do i_state=1,n_states
            c_st = state_label(i_state,.true.)
            call switch_mel_record(mel_C0,i_state)
            idxmel = idx_mel_list("ME_C0"//trim(c_st),op_info)
            mel_pnt => op_info%mel_arr(idxmel)%mel
            call list_copy(mel_pnt,mel_C0,.false.)
           end do
           call switch_mel_record(mel_C0,1)
           call opt_get_C0bar(n_states,
     &          op_info,form_info,str_info,strmap_info,orb_info)
          end if

c dbg
c          do i_state = 1,n_states
c           c_st = state_label(i_state,.false.)
c           idx = idx_mel_list('ME_C0'//trim(c_st),op_info)
c           print *,'current C0'//trim(c_st)//' vector: '
c           call wrt_mel_file(lulog,1000,op_info%mel_arr(idx)%mel,
c     &        1,op_info%mel_arr(idx)%mel%op%n_occ_cls,
c     &        str_info,orb_info)
c          end do
c dbgend
        end if !do C0 optimization if requested

        if (ntest.ge.1000) then
          do iopt = 1, nopt
            write(lulog,*) 'dump of '//trim(me_opt(iopt)%mel%label)
            write(lulog,*) 'iopt = ',iopt
            call wrt_mel_file(lulog,3,!5,
     &           me_opt(iopt)%mel,
     &           1,me_opt(iopt)%mel%op%n_occ_cls,
     &           str_info,orb_info)
          end do
        end if

        ! here?
        do iopt = 1, nopt
          if (opti_info%typ_prc(iopt).eq.optinf_prc_norm.and.
     &        opti_info%optref.ne.0) cycle !no unneeded metric update
          call touch_file_rec(ffopt(iopt)%fhand)
        end do
c dbg
c        if (opti_info%typ_prc(1).eq.optinf_prc_traf.and.
c     &      nspecial.ge.7)
c     &      call touch_file_rec(me_special(7)%mel%fhand)
c        if (opti_info%typ_prc(1).eq.optinf_prc_traf.and.
c     &      nspecial.ge.6.and.nopt.eq.1) then
c          ! very dirty trick: prevent calc. of Res.#2
c            call touch_file_rec(op_info%mel_arr(
c     &           idx_mel_list('ME_A_C0',op_info))%mel%fhand)
c          ! also delete information that Res.#2 depends on energy
c          if (imacit.eq.1) then
c            do idx = 1, depend%ndepend
c              if (depend%depends_on_idxlist(idx,3).eq.
c     &            depend%idxlist(1))
c     &           depend%depends_on_idxlist(idx,3) = 0
c            end do
c          end if
c        end if
c dbgend

        ! 1 - get energy
        ! 2 - get residual
        if (iand(task,1).eq.1.or.iand(task,2).eq.2) then
          call frm_sched(xret,fl_en_res,depend,0,0,
     &         .true.,.false.,op_info,str_info,strmap_info,orb_info)
          ! intermediates should be generated first, energy
          ! is expected to be the last "intermediate"
          do i_state = 0,n_energies
           energy(i_state) = xret(idx_en_xret(i_state))
          end do
c dbg
c          print *,'xret : ',xret
c dbg

          if (ntest.ge.1000) then
            do iopt = 1, nopt
              write(lulog,*) 'dump of residual '//
     &             trim(me_grd(iopt)%mel%label)
              call wrt_mel_file(lulog,3,!5,
     &           me_grd(iopt)%mel,
     &           1,me_grd(iopt)%mel%op%n_occ_cls,
     &           str_info,orb_info)
            end do
          end if
c dbg:
c test
c          if (imacit.ge.3) then
c            print *,'>> put O to zero'
c            do idx=1,20
c              print *,'   put O to zero'
c            end do
c            call scale_opblk(xdum,0d0,me_grd(1)%mel,me_grd(1)%mel,
c     &           1,1,orb_info)
c          end if
c test

          do iopt = 1, nopt
            xresnrm(iopt) = abs(xret(idx_res_xret(iopt)))
            traf = traf.or.opti_info%typ_prc(iopt).eq.optinf_prc_traf
     &                 .or.opti_info%typ_prc(iopt).eq.optinf_prc_invH0
          end do
        end if

        ! report untransformed residual
        if (traf)
     &   write(lulog,'(x,"norm of untransformed residual ",4(x,g10.4))')
     &   xresnrm(1:opti_info%nopt)

        ! another quick and dirty call to the linear solver
        ! for advanced preconditioning
        if (opti_info%optref.eq.-3.and.
     &      opti_info%typ_prc(1).eq.optinf_prc_invH0.and.
     &      .not.conv) then

          do i_state=1,n_states
           thr_suggest(i_state) = min(xresnrm((i_state-1)*nopt+1)*
     &          opti_info%mic_ahead,1d-4)
          end do

          idx = idx_mel_list('ME_C0',op_info)
          if (opti_info%optref.ne.0.and.
     &         op_info%mel_arr(idx)%mel%fhand%last_mod(
     &         op_info%mel_arr(idx)%mel%fhand%current_record).gt.
     &         me_special(2)%mel%fhand%last_mod(1)) then
             call update_metric(me_dia(1)%mel,
     &            me_special,nspecial,
     &            fl_spc,nspcfrm,orb_info,op_info,str_info,strmap_info,
     &            opti_info%update_prc.gt.0.and.
     &            mod(imacit,max(opti_info%update_prc,1)).eq.0)
          end if

          call solve_leq('TRF',
     &                 1,1,'ME_DlT',label_prc(1),'H0_DlT','DlT',!'S_DlT',
     &                 'OMGprj',xdum,'FOPT_H0INV',
     &            (/'ME_Tout  ','ME_Ttr   ','ME_Dtr   ','ME_Dtrdag'/),4,
     &                 'FOPT_Ttr_GEN',1,  thr_suggest(i_state),
     &                 op_info,form_info,str_info,strmap_info,orb_info)
          ! overwrite the gradient with preconditioned gradient
          call scale_copy_op(label_res(1),'ME_DlT',1d0,1,'--',0,
     &                  op_info,orb_info,str_info)
          ! get norm of projected gradient and report as gradient norm
          xresnrm(1) = xdum
        end if
      call atim_csw(cpu,sys,wall)
         if(iprlvl.ge.5)then
         write (timing_msg,"(x,'time for iteration ')")
         call prtim(lulog,trim(timing_msg),
     &          cpu-cpu0_t,sys-sys0_t,wall-wall0_t)
         end if

      end do opt_loop

      ! Turn on molpro output in solve_evp
      if (lmol) no_print = .false.

      call clean_formula_dependencies(depend)

      ! close files
      do iopt = 1, nopt
        ! open result vector file(s)
c dbg - for R12:
c        if (iopt.eq.2) then
c          write(lulog,*) ' iopt = ',iopt
c          call wrt_mel_file(lulog,1000,me_opt(iopt)%mel,
c     &       1,me_opt(iopt)%mel%op%n_occ_cls,
c     &       str_info,orb_info)
c        end if
c dbg
c dbg
c        ! very dirty: don't close file if needed for following opt.
c        if ((opti_info%typ_prc(1).ne.optinf_prc_traf.and.
c     &       opti_info%typ_prc(1).ne.optinf_prc_invH0).or.
c     &      opti_info%optref.eq.0.or.nopt.ne.n_states) then
c dbgend
        call file_close_keep(ffopt(iopt)%fhand)
c dbg
c        end if
c dbgend
        ! open corresponding residuals ...
        call file_close_keep(ffgrd(iopt)%fhand)
        ! ... and corresponding preconditioner(s)x
        if (ffdia(iopt)%fhand%unit.gt.0)
     &       call file_close_keep(ffdia(iopt)%fhand)
      end do

      do idx = 1, nspecial
        if (ffspecial(idx)%fhand%unit.gt.0)
     &       call file_close_keep(ffspecial(idx)%fhand)
      end do

      deallocate(thr_suggest)
      deallocate(energy)
      deallocate(old_energy)

      deallocate(ffopt,ffdia,ffgrd,ffspecial,
     &     me_opt,me_dia,me_grd,me_special,me_trv,me_h_trv,xret)
      call dealloc_formula_list(fl_en_res)
      do jdx = 1, nspcfrm
        call dealloc_formula_list(fl_spc(jdx))
      end do
      ifree = mem_flushmark()

      return
      contains
*----------------------------------------------------------------------*
!!    resolves a label to a pointer to the matrix element list object
!!
*----------------------------------------------------------------------*
      function get_mel_h(label, op_info)
*----------------------------------------------------------------------*
      implicit none
      character(*),intent(in) ::
     &     label
      type(operator_info), intent(inout) ::
     &     op_info

      type(me_list),pointer::
     &     get_mel_h
      integer,external::
     &     idx_mel_list
      integer::
     &     idxmel
      idxmel = idx_mel_list(label,op_info)
      if (idxmel.le.0)
     &       call quit(1,i_am,
     &       'did not find list '//trim(label_opt(iopt)))
      get_mel_h=> op_info%mel_arr(idxmel)%mel
      return
      end function
*----------------------------------------------------------------------*
!!    determines if the file of a subroutine is associated
!!
*----------------------------------------------------------------------*
      pure  function mel_has_file_h(mel)
      implicit none
      type(me_list),intent(in)::
     &     mel
      logical::
     &     mel_has_file_h
      mel_has_file_h=associated(mel%fhand)
      return
      end function
      end


c This module/program is part of DaliLite (c) L. Holm 1999
c
c
c----------------------------------------------------------------------
c
c	stack module
c		getnextbest: return best unique alignment or exception flag
c		clearstack: after overflow, make space by removing baddies
c		swapstack: chunk1 <-> chunk2
c		putchunk, putstack: pack, save chunk
c		getchunk, getstack: read, unpack chunk
c		declump: blank out alignment trace from stack
c		split: divide search space
c
c	variables
c		chunk: 1+[sum(is=1,ns)mi(seglist(is))+30]/31; est+candidates
c		link(): linked list of score estimates, points to stack
c			link(1,*) lower, link(2,*) higher score
c		bestest: points to beginning of linked list
c		stack: in chunks
c		top: starts from 1, points to estimate of chunk
c		ex(): energy table
c		start(iseg,jseg): pointer to ex(), index<0 means score is zero
c		ns: number of segments
c		mi: maximal number of residues in search space, including nul
c		ni,ci: work search space [packed]
c		ci0: initial search space [packed]
c
c----------------------------------------------------------------------
c
	subroutine split(est,ns,seglist,ex,top,stack,scorecutoff,ni,ci,mi,
     $		chunk,bestest,link,start,link_pointer,forward_pointer,
     $		backward_pointer,firstest,trans,lseqtl)
	implicit none
	include 'parsizes.for'
	integer re_estimate,start(maxseg,maxseg),trans(maxres0,maxseg)
	integer ns,seglist(maxseg),mi(maxseg),chunk,bestest,
     $ link(2,maxstack2)
	integer est,ex(exdim),scorecutoff,top,stack(maxstack)
	integer link_pointer(0:boxdim),forward_pointer(0:boxdim),
     $		backward_pointer(0:boxdim)
	real firstest
	logical lseqtl
c
c	split xseg according to ex(xseg,yseg,...)
c		find emax(xres)= max of ex(xseg,yseg,xres,...)
c		erange=smallest to largest emax(...)
c		lcand1(xres)=lcand(xseg,xres).and.emax(xres).le.midpoint
c		lcand2(xres)=lcand(xseg,xres).and.emax(xres).gt.midpoint
c		special case: smallest.eq.largest => assign every second to 1,2
c
	integer mini,maxi,xres,e,emax(maxres0),midpoint,
     $ ess(maxseg,maxseg)
	integer f,n1,ni(maxseg),ci(maxres0,maxseg),xr,yr
	integer iwhere,jw,ijstart
c
	integer emaxim,is,js,iseg,jseg,xseg,yseg,seed
	integer ni1,ni2,ci1(maxres0),ci2(maxres0),ci3(maxres0),
     $ ci4(maxres0)
	logical lclosed(maxseg)
	integer bestxres,ni3,ni4,ni5,ci5(maxres0),pr,ni6,ci6(maxres0)
c!!
	seed=1234567
c
	do is=1,ns
		iseg=seglist(is)
		lclosed(iseg)=(ni(iseg).le.1)
	end do
c
!	write(*,*) 'split',est,ns,top,scorecutoff
	call get_ess(ess,est,ns,seglist,ni,ci,ex,start,mi,trans,lseqtl)
	if(est.le.scorecutoff) return
c
	xseg=0
	yseg=0
	emaxim=-infinit
	do is=1,ns
	  iseg=seglist(is)
	  call getemax(ess(iseg,iseg),emaxim,lclosed,iseg,iseg,
     $ xseg,yseg,seed)
	  do js=1,is-1
	    jseg=seglist(js)
	    call getemax(ess(iseg,jseg),emaxim,lclosed,iseg,jseg,xseg,
     $ yseg,seed)
	  end do
	end do
	if((xseg.eq.0).and.(yseg.eq.0)) return
c
	if(start(xseg,yseg).lt.0) then
		maxi=0
		mini=0
		n1=0
	else
		maxi=-infinit
		mini=+infinit
		if(xseg.eq.yseg) then
			iwhere=start(xseg,xseg)
			do xr=1,ni(xseg)
				xres=ci(xr,xseg)
				emax(xres)=ex(iwhere+xres)
			end do
		else if(xseg.lt.yseg) then
			ijstart=start(xseg,yseg)
			jw=mi(yseg)
			do xr=1,ni(xseg)
				e=-infinit
				xres=ci(xr,xseg)
				iwhere=ijstart+(xres-1)*jw
				do yr=1,ni(yseg)
					e=max(e,ex(iwhere+ci(yr,yseg)))
				end do
				emax(xres)=e
			end do
		else if(xseg.gt.yseg) then
			do xr=1,ni(xseg)
				emax(ci(xr,xseg))=-infinit
			end do
			ijstart=start(yseg,xseg)
			jw=mi(xseg)
			do yr=1,ni(yseg)
				iwhere=ijstart+(ci(yr,yseg)-1)*jw
				do xr=1,ni(xseg)
					xres=ci(xr,xseg)
					e=emax(xres)
					emax(xres)=max(e,ex(iwhere+xres))
				end do
			end do
		end if
		n1=ni(xseg)
	end if
	bestxres=ci(1,xseg)
	do xr=1,n1
		xres=ci(xr,xseg)
		e=emax(xres)
		if(xr.gt.2) then
			if(e.gt.emax(bestxres)) bestxres=xres
		end if
		maxi=max(maxi,e)
		mini=min(mini,e)
	end do
c
c	split 90 % - 10 %
c
	midpoint=mini+(maxi-mini)*9/10
	ni1=0
	ni2=0
	if(mini.eq.maxi) then
		do xr=1,ni(xseg),2
			ni1=ni1+1
			ci1(ni1)=ci(xr,xseg)
		end do
		do xr=2,ni(xseg),2
			ni2=ni2+1
			ci2(ni2)=ci(xr,xseg)
		end do
	else
		do xr=1,ni(xseg)
			xres=ci(xr,xseg)
			if(emax(xres).le.midpoint) then
				ni2=ni2+1
				ci2(ni2)=ci(xr,xseg)
			else
				ni1=ni1+1
				ci1(ni1)=ci(xr,xseg)
			end if
		end do
	end if
!	if(ni1.le.0.or.ni2.le.0.or.ni1+ni2.ne.ni(xseg)) then
!	  write(*,*) 'mid:',midpoint,mini,maxi,xseg,yseg,ni(xseg),ni1,ni2
!	  stop
!	end if
c
c	stack better half
c
	if(lseqtl) then 	! split better half left&nul-top&right ci3,c4
		ni3=0
		ni4=0
		ni5=0
		ni6=0
		do xres=1,ni1
			pr=trans(ci1(xres),xseg)
			if(pr.eq.nul) then
				ni6=ni6+1
				ci6(ni6)=ci1(xres)
			else if(ci1(xres).lt.bestxres) then
				ni3=ni3+1
				ci3(ni3)=ci1(xres)
			else
				ni4=ni4+1
				ci4(ni4)=ci1(xres)
			end if
		end do
		if(ni6.gt.0) call copyandput(ni6,ci6,ni,ci,est,ns,
     $			seglist,ess,xseg,ex,start,mi,trans,lseqtl,
     $          	scorecutoff,top,stack,chunk,bestest,link,
     $			link_pointer,forward_pointer,backward_pointer,
     $			firstest)
		if(lskipflag) return
		if(ni5.gt.0) call copyandput(ni5,ci5,ni,ci,est,ns,
     $			seglist,ess,xseg,ex,start,mi,trans,lseqtl,
     $          	scorecutoff,top,stack,chunk,bestest,link,
     $			link_pointer,forward_pointer,backward_pointer,
     $			firstest)
		if(lskipflag) return
		if(ni3.gt.0) call copyandput(ni3,ci3,ni,ci,est,ns,
     $			seglist,ess,xseg,ex,start,mi,trans,lseqtl,
     $          	scorecutoff,top,stack,chunk,bestest,link,
     $			link_pointer,forward_pointer,backward_pointer,
     $			firstest)
		if(lskipflag) return
		if(ni4.gt.0) call copyandput(ni4,ci4,ni,ci,est,ns,
     $			seglist,ess,xseg,ex,start,mi,trans,lseqtl,
     $          	scorecutoff,top,stack,chunk,bestest,link,
     $			link_pointer,forward_pointer,backward_pointer,
     $			firstest)
		if(lskipflag) return
	else
		call copyandput(ni1,ci1,ni,ci,est,ns,
     $			seglist,ess,xseg,ex,start,mi,trans,lseqtl,
     $          	scorecutoff,top,stack,chunk,bestest,link,
     $			link_pointer,forward_pointer,backward_pointer,
     $			firstest)
 		if(lskipflag) return
	end if
c
c       stack lower half
c
	call copyandput(ni2,ci2,ni,ci,est,ns,
     $		seglist,ess,xseg,ex,start,mi,trans,lseqtl,
     $         	scorecutoff,top,stack,chunk,bestest,link,
     $		link_pointer,forward_pointer,backward_pointer,
     $		firstest)
	if(lskipflag) return
!       write(*,*) 'top',top

	return
	end
c
c----------------------------------------------------------------------
c
        subroutine copyandput(ni1,ci1,ni,ci,est,ns,seglist,ess,xseg,ex,
     $          start,mi,trans,lseqtl,scorecutoff,top,stack,chunk,
     $		bestest,link,link_pointer,forward_pointer,
     $          backward_pointer,firstest)
        implicit none
        include 'parsizes.for'
        integer re_estimate,start(maxseg,maxseg),trans(maxres0,maxseg)
        integer ns,seglist(maxseg),mi(maxseg),chunk,bestest
	integer link(2,maxstack2)
        integer est,ex(exdim),scorecutoff,top,stack(maxstack)
        integer link_pointer(0:boxdim),forward_pointer(0:boxdim),
     $          backward_pointer(0:boxdim)
        real firstest
        logical lseqtl
        integer xres,ess(maxseg,maxseg),f,ni(maxseg),ci(maxres0,maxseg)
        integer xseg,ni1,ci1(maxres0)
c
        if(ni1.eq.0) return
        ni(xseg)=ni1
        do xres=1,ni1
                ci(xres,xseg)=ci1(xres)
        end do
!        call excludeimpossible(ni,ci,ns,seglist,trans,lseqtl)
        f=re_estimate(est,ns,seglist,ess,xseg,ex,ni,ci,start,
     $          mi,trans,lseqtl)
        if(f.gt.scorecutoff) then
                top=top+chunk
                call putrequest(f,ni,ci,ns,seglist,mi,top,stack,chunk,
     $                  bestest,link,link_pointer,
     $                  forward_pointer,backward_pointer,firstest)
		if(lskipflag) return
        end if

        return
        end
c
c----------------------------------------------------------------------
c
	subroutine excludeimpossible(ni,ci,ns,seglist,trans,lseqtl)
	implicit none
	include 'parsizes.for'
	integer ni(maxseg),ci(maxres0,maxseg),trans(maxres0,maxseg)
	integer ns,seglist(maxseg)
	logical lseqtl
c
	integer is,iseg,leftmost,ritemost,ir,irx,i,nx
	logical lhasnul(maxseg)
c
	if(.not.lseqtl) return
	nx=0
	do is=1,ns
		iseg=seglist(is)
		lhasnul(iseg)=(trans(ci(ni(iseg),iseg),iseg).eq.nul)
!		type *,'before',iseg,(trans(ci(ir,iseg),iseg),ir=1,ni(iseg))
	end do
	leftmost=-infinit
	do is=1,ns
	  iseg=seglist(is)
	  if(.not.lhasnul(iseg)) then
		irx=0
		do ir=1,ni(iseg)
			i=trans(ci(ir,iseg),iseg)
!			if(i.le.leftmost.and.i.ne.nul) irx=ir
			if(i.lt.leftmost.and.i.ne.nul) irx=ir
		end do
		nx=nx+irx
		! exclude 1...irx
		if(irx.gt.0) then
			i=0
			do ir=irx+1,ni(iseg)
				i=i+1
				ci(i,iseg)=ci(ir,iseg)
			end do
			ni(iseg)=i
		end if
		if(ni(iseg).gt.0) then
			if(.not.lhasnul(iseg)) then
				leftmost=trans(ci(1,iseg),iseg)
			else if (ni(iseg).gt.1) then
				leftmost=trans(ci(1,iseg),iseg)
			end if
		else
			leftmost=+infinit
			goto 99
		end if
		i=ci(1,iseg)
!		type *,'leftmost:',lhasnul(iseg),iseg,leftmost,i,
!     $			trans(i,iseg),irx
	  end if
	end do
	if(leftmost.eq.infinit) goto 99
10	ritemost=+infinit
	do is=ns,1,-1
		iseg=seglist(is)
		if(.not.lhasnul(iseg)) then
			irx=0
			do ir=ni(iseg),1,-1
				i=trans(ci(ir,iseg),iseg)
!				if(i.ge.ritemost.and.i.ne.nul) irx=ir
				if(i.gt.ritemost.and.i.ne.nul) irx=ir
			end do
			if(irx.gt.0) nx=nx+ni(iseg)-irx
			! exclude irx...ni(iseg) except nul
			if(irx.gt.0) then
				if(lhasnul(iseg)) then
					ci(irx,iseg)=ci(ni(iseg),iseg)
					ni(iseg)=irx
			  	else
					ni(iseg)=irx-1
				end if
			end if
			if(ni(iseg).gt.0) then
				if(.not.lhasnul(iseg)) then
				  ritemost=trans(ci(ni(iseg),iseg),iseg)
				else if(ni(iseg).gt.1) then
				  ritemost=trans(ci(ni(iseg)-1,iseg),iseg)
				end if
			else
				ritemost=-infinit
				goto 99
			end if
		end if
		i=ci(ni(iseg),iseg)
!		type *,'ritemost:',iseg,ritemost,i,trans(i,iseg),irx
	end do

99	continue
!	if(nx.gt.0) then
!	  do is=1,ns
!		iseg=seglist(is)
!		type *,'after',iseg,(trans(ci(ir,iseg),iseg),ir=1,ni(iseg))
!	  end do
!	  type *,'nx',nx
!	end if

	return
	end
c
c----------------------------------------------------------------------
c
	subroutine getnextbest(scorecutoff,stack,top,chunk,ns,seglist,
     $		mi,bestest,ali,flag,link,ex,start,est,link_pointer,
     $		forward_pointer,backward_pointer,firstest,trans,lseqtl)
c
c	flags:	1 = empty stack
c		2 = top score below cutoff
c		4 = no candidates
c		5 = unique alignment, returned in ali()
c		3 = overflow
c
	implicit none
	include 'parsizes.for'
	integer scorecutoff,flag,stack(maxstack),top,chunk,ns,mi(maxseg)
	integer link(2,maxstack2),ali(maxseg),bestest,
     $ seglist(maxseg),ex(exdim)
	integer start(maxseg,maxseg),trans(maxres0,maxseg)
	integer link_pointer(0:boxdim),forward_pointer(0:boxdim),
     $		backward_pointer(0:boxdim)
	real firstest
	logical lseqtl
c
	integer is,est,nmin,nmax,ni(maxseg),ci(maxres0,maxseg),ir,iseg,i,m
c	write(*,*) 'getnextbest',scorecutoff,top,chunk,ns,bestest,firstest
	est=-infinit
	flag=0
c	check that bestest is!
c	call checkstack(stack,bestest,top,chunk,'getnext BUG ')
	do while(flag.eq.0)
c
c		check exceptions
c
		if(top.le.0) then
			flag=1
			est=-infinit
			return
		end if
		if(bestest.le.0) then
	write(*,*) scorecutoff,(stack(i),i=1,10),top,chunk,bestest
	write(*,*) (link(1,i),link(2,i),i=1,top)
	write(*,*) 'FATAL ERROR -- bestest out of range'
			lskipflag=.true.
			return
		end if
		if(stack(bestest).lt.scorecutoff) flag=2
		if(top+2*chunk.gt.maxstack) flag=3
c!!
		if(top.gt.maxstack-100) flag=3
		if(flag.ne.0) return
c
c		continue splitting / export unique alignment
c
		call toprequest(bestest,top,stack,chunk,link,mi,ns,seglist,
     $			ni,ci,est,link_pointer,forward_pointer,
     $			backward_pointer,firstest)
		if(lskipflag) return
c		write(*,*) 'top search space'
c		do is=1,ns
c			iseg=seglist(is)
c			write(*,*) is,iseg,mi(iseg),ni(iseg),
c     $				(ci(ir,iseg),ir=1,ni(iseg))
c		end do
		call getnminnmax(ni,ns,seglist,nmin,nmax)
		if(nmin.eq.0) flag=4
		if((nmin.eq.1).and.(nmax.eq.1)) flag=5
		if(flag.eq.0) call split(est,ns,seglist,ex,top,stack,
     $			scorecutoff,ni,ci,mi,chunk,bestest,link,start,
     $			link_pointer,forward_pointer,backward_pointer,firstest,
     $			trans,lseqtl)
		if(lskipflag) return
		if(flag.eq.5) then
			do is=1,ns
				ali(seglist(is))=ci(1,seglist(is))
			end do
		end if
c		write(*,*) 'flag is',flag
	end do

	return
	end
c
c----------------------------------------------------------------------
c
	subroutine lpack(lwork,i,l)
	implicit none
	include 'parsizes.for'
	logical lwork(maxres0*maxseg),l(31)
	integer i,j

	do j=0,30
		l(j+1)=lwork(i+j)
	end do

	return
	end
c
c----------------------------------------------------------------------
c
	subroutine putrequest(est,ni,ci,ns,seglist,mi,to,stack,
     $ chunk,bestest,link,link_pointer,forward_pointer,
     $ backward_pointer,firstest)
	implicit none
	include 'parsizes.for'
	integer ni(maxseg),ci(maxres0,maxseg),ns,mi(maxseg)
	integer seglist(maxseg)
	integer to,stack(maxstack),chunk,est,bestest,link(2,maxstack2)
	integer link_pointer(0:boxdim),forward_pointer(0:boxdim),
     $		backward_pointer(0:boxdim)
	real firstest
c
	integer i,j,is,ir,irray((1+(maxres0+30)/31)*maxseg),s,iseg,n
	logical lwork(maxres0*maxseg),l(31),lw(maxres0)
c
c	write(*,*) 'putrequest',est,ns,to,chunk,bestest,firstest
c	call checkstack(stack,bestest,to,chunk,'put BUG 1')
	n=0
	do is=1,ns
		iseg=seglist(is)
		do ir=1,mi(iseg)
			lw(ir)=.false.
		end do
		do ir=1,ni(iseg)
			lw(ci(ir,iseg))=.true.
		end do
		do ir=1,mi(iseg)
			n=n+1
			lwork(n)=lw(ir)
		end do
	end do
	do i=n+1,min(n+30,maxres0*maxseg)
		lwork(i)=.false.
	end do
	j=1
	irray(1)=est
	do i=1,n,31
		call lpack(lwork,i,l)
		call bitpack(s,l,31)
		j=j+1
		irray(j)=s
c		write(*,*) 'l',i,j,s
	end do
c	write(*,*) 'put irray',(irray(i),i=1,j)
	if(to+chunk.gt.maxstack) then
	write(*,*)  'FATAL ERROR in putrequest'
		lskipflag=.true.
		return
	end if
	call putchunk(to,irray,stack,chunk)
	if(lskipflag) return
	call createlink(to,bestest,link,stack,link_pointer,
     $		forward_pointer,backward_pointer,firstest,to,chunk)
	if(lskipflag) return
c	call checkstack(stack,bestest,to,chunk,'put BUG 2')

	return
	end
c
c----------------------------------------------------------------------
c
	subroutine declump(scorecutoff,stack,top,chunk,link,bestest,ns,
     $		seglist,mi,ali,ex,start,singletcutoff,link_pointer,
     $		forward_pointer,backward_pointer,firstest,trans,lseqtl)
	implicit none
	include 'parsizes.for'
	integer stack(maxstack),top,chunk,link(2,maxstack2),bestest
	integer scorecutoff,ns,mi(maxseg),ali(maxseg),seglist(maxseg)
	integer ex(exdim),start(maxseg,maxseg),singletcutoff
	integer link_pointer(0:boxdim),forward_pointer(0:boxdim),
     $		backward_pointer(0:boxdim),trans(maxres0,maxseg)
	real firstest
	logical lseqtl
c
	integer i,irray((1+(maxres0+30)/31)*maxseg),est,ci(maxres0,maxseg)
	integer ni(maxseg),oldtop,is,ir,jr,ess(maxseg,maxseg),
     $ ires,iseg,nold
	logical lchange
	integer m
c
c
c	write(*,500) scorecutoff,top,chunk,bestest,ns,(ali(seglist(i)),i=1,ns)
	oldtop=top
	top=1-chunk
	bestest=0
	call init_link_pointer(link_pointer,forward_pointer,
     $ backward_pointer)
	do i=1,oldtop,chunk
		call getchunk(i,irray,stack,chunk)
		call translatechunk(irray,mi,ns,seglist,ni,ci,est,chunk)
c
c		only declump chunks below singletcutoff !
c
c????
		if(est.gt.singletcutoff) goto 20
c
c		blank out ali()
c
		lchange=.false.
		do is=1,ns
			iseg=seglist(is)
			nold=ni(iseg)
			m=ali(iseg)
			do ir=1,nold
			  ires=ci(ir,iseg)
			  if(ires.eq.m) then
			    if(trans(ires,iseg).ne.nul) then
c				write(*,*) 'remove',ires,iseg
				do jr=ir+1,ni(iseg)
					ci(jr-1,iseg)=ci(jr,iseg)
				end do
				ni(iseg)=ni(iseg)-1
c				no candidates left !
				if(ni(iseg).eq.0) then
					est=-infinit
					goto 29
				end if
				lchange=.true.
				goto 19
			    end if
			  end if
			end do
19			continue
		end do
c
c		re_estimate score if changes made
c
		if(lchange) call get_ess(ess,est,ns,seglist,ni,ci,ex,start,mi,
     $			trans,lseqtl)
20		if(est.gt.scorecutoff) then
			top=top+chunk
			call putrequest(est,ni,ci,ns,seglist,mi,
     $ top,stack,chunk,bestest,link,link_pointer,
     $ forward_pointer,backward_pointer,firstest)
			if(lskipflag) return
		else
	end if
29	end do
500	format('declump',4i12,85i4)
c   500 format('declump',4i12,<maxseg+5>i4)
	return
	end
c
c----------------------------------------------------------------------
c
	subroutine clearstack(cutoff,stack,top,chunk,link,bestest,
     $ link_pointer,forward_pointer,backward_pointer,firstest)
c
c	remove all chunks that have a score below cutoff
c
	implicit none
	include 'parsizes.for'
	integer cutoff,stack(maxstack),top,chunk,link(2,maxstack2),bestest
	integer link_pointer(0:boxdim),forward_pointer(0:boxdim),
     $		backward_pointer(0:boxdim)
	real firstest
c
	integer i,dn,oldtop,x,getk,e
c
c	compress chunks
c
c	write(*,*) 'clearstack in ',cutoff,top,chunk,bestest
	oldtop=top
	top=1-chunk
	do i=1,oldtop,chunk
		if((stack(i).gt.cutoff).and.(top.lt.i)) then
			top=top+chunk
			call swapstack(i,top,stack,chunk,link,bestest,
     $			 link_pointer,forward_pointer,backward_pointer,firstest)
			if(lskipflag) return
		end if
	end do
	call init_link_pointer(link_pointer,forward_pointer,
     $ backward_pointer)
	do i=1,top,chunk
		e=stack(i)
		x=getk(e,i,stack,link_pointer,forward_pointer,
     $			backward_pointer,firstest)
		if(lskipflag) return
	end do
c
c	curtail linked list
c
	do i=1,top,chunk
		dn=link(1,i)
		if((dn.gt.0).and.(stack(dn).le.cutoff)) then
			link(1,i)=0
c			write(*,*) 'clearstack out',cutoff,top,chunk,bestest
			return
		end if
	end do

	return
	end
c
c----------------------------------------------------------------------
c
	subroutine init_link_pointer(link_pointer,forward_pointer,
     $		backward_pointer)
	implicit none
	include 'parsizes.for'
	integer link_pointer(0:boxdim),forward_pointer(0:boxdim),
     $		backward_pointer(0:boxdim)
c
	integer i
c
	do i=0,boxdim
		link_pointer(i)=0
		forward_pointer(i)=boxdim
		backward_pointer(i)=0
	end do
c
	return
	end
c
c----------------------------------------------------------------------
c
	subroutine createlink_ok(i,bestest,link,stack,link_pointer,
     $		forward_pointer,backward_pointer,firstest,top,chunk)
c
c	link in new chunk 'i'
c
	implicit none
	include 'parsizes.for'
	integer i,bestest,link(2,maxstack2),stack(maxstack),top,chunk
	integer link_pointer(0:boxdim),forward_pointer(0:boxdim),
     $		backward_pointer(0:boxdim)
	real firstest
c
	integer j,k,est
c
	if(i.gt.maxstack2) then
	write(*,*)  'FATAL ERROR link overflow - increase maxstack2 '
		lskipflag=.true.
		return
	end if
	link(1,i)=0
	link(2,i)=0
	est=stack(i)
	j=bestest
	k=0
	do while(j.gt.0)
		if(stack(j).gt.est) k=j
		j=link(1,j)
	end do
	if(k.eq.0) then
		if(bestest.ne.0) then
			link(1,i)=bestest
			link(2,bestest)=i
		end if
		bestest=i
	else
		j=link(1,k)
		link(1,i)=j
		if(j.ne.0) link(2,j)=i
		link(1,k)=i
		link(2,i)=k
	end if

	return
	end
c
c----------------------------------------------------------------------
c
	subroutine createlink(i,bestest,link,stack,link_pointer,
     $		forward_pointer,backward_pointer,firstest,top,chunk)
c
c	link in new chunk 'i'
c
	implicit none
	include 'parsizes.for'
	integer i,bestest,link(2,maxstack2),stack(maxstack)
	integer link_pointer(0:boxdim),forward_pointer(0:boxdim),
     $		backward_pointer(0:boxdim),top,chunk
	real firstest
c
	integer j,k,est,getk,x
c
c	write(*,*) 'createlink',i,bestest,firstest
	if(i.gt.maxstack2) then
	write(*,*)  'FATAL ERROR link overflow - increase maxstack2 '
		lskipflag=.true.
		return
	end if
	link(1,i)=0
	link(2,i)=0
	est=stack(i)
!	j=bestest
!	k=0
!	do while(j.gt.0)
!		if(stack(j).gt.est) k=j
!		j=link(1,j)
!	end do
!	x=k
	j=getk(est,i,stack,link_pointer,forward_pointer,
     $		backward_pointer,firstest)
	if(lskipflag) return
c	write(*,*) 'create',bestest,stack(bestest),j,stack(j),i,est
	k=0
	if(j.eq.0) j=bestest
	do while(j.gt.0)
		if(stack(j).gt.est) k=j
		j=link(1,j)
	end do
!	if(k.ne.x) write(*,*) 'BUG',x,stack(max(1,x)),bestest,
!     $		stack(max(1,bestest)),i,est,k,stack(max(1,k)),firstest
!	k=x
	if(k.eq.0) then
		if(bestest.ne.0) then
			link(1,i)=bestest
			link(2,bestest)=i
		end if
		bestest=i
c		call checkstack(stack,bestest,top,chunk,'create BUG 1')
	else
		j=link(1,k)
		link(1,i)=j
		if(j.ne.0) link(2,j)=i
		link(1,k)=i
		link(2,i)=k
c		call checkstack(stack,bestest,top,chunk,'create BUG 2')
	end if

	return
	end
c
c----------------------------------------------------------------------
c
	function getk(est,i,stack,link_pointer,forward_pointer,
     $		backward_pointer,firstest)
	implicit none
	include 'parsizes.for'
	integer getk,est,i,stack(maxstack)
	integer link_pointer(0:boxdim),forward_pointer(0:boxdim),
     $		backward_pointer(0:boxdim)
	real firstest
c
	integer box,k,b,funbox
c
c	returns stack-pointer to a next larger estimate, 0 if new best
c
c	box=funbox(est,firstest)
	box=max(1,int(float(est)/firstest*float(boxdim-1)))
	if(box.gt.boxdim) then
	write(*,*)  'FATAL ERROR -- boxfun overflow'
		lskipflag=.true.
		return
	end if
	if(link_pointer(box).eq.0) then
		do b=box+1,forward_pointer(box)
			backward_pointer(b)=box
		end do
		do b=backward_pointer(box),box-1
			forward_pointer(b)=box
		end do
		link_pointer(box)=i
		box=forward_pointer(box)
	else
		if(est.ge.stack(link_pointer(box))) then
			link_pointer(box)=i
			box=forward_pointer(box)
		end if
	end if
	if(box.eq.boxdim) then
		k=0
	else
		k=link_pointer(box)
	end if

	getk=k
c	write(*,*) 'getk',est,i,k,box,(link_pointer(b),b=0,boxdim)

	return
	end
c
c----------------------------------------------------------------------
c
	function funbox(est,firstest)
	implicit none
	include 'parsizes.for'
	integer est,funbox
	real firstest,r
c
	r=float(est)/firstest
	funbox=max(1,int(r*r*(boxdim-1)))
c
	return
	end
c
c----------------------------------------------------------------------
c
	subroutine removebox(est,i,stack,link,link_pointer,
     $ forward_pointer,backward_pointer,firstest)
	implicit none
	include 'parsizes.for'
	integer est,i,link(2,maxstack2),stack(maxstack)
	integer link_pointer(0:boxdim),forward_pointer(0:boxdim),
     $		backward_pointer(0:boxdim)
	real firstest
c
	integer b,box,k,bwp,fwp,funbox
c
c	box=funbox(est,firstest)
	box=max(1,int(float(est)/firstest*(boxdim-1)))
c	case: middle occupant of box -> no action
	if(link_pointer(box).ne.i) return
	k=link(1,i)
c	case: top is last in box, last in stack
	if(k.eq.0) then
		link_pointer(box)=0
		bwp=backward_pointer(box)
		fwp=forward_pointer(box)
		do b=box+1,fwp
			backward_pointer(b)=bwp
		end do
		do b=bwp,box-1
			forward_pointer(b)=fwp
		end do
		return
	end if
	if(k.gt.0) b=max(1,int(float(stack(k))/firstest*(boxdim-1)))
c	case: last in box
	if(b.ne.box) then
		link_pointer(box)=0
		bwp=backward_pointer(box)
		fwp=forward_pointer(box)
		do b=box+1,fwp
			backward_pointer(b)=bwp
		end do
		do b=bwp,box-1
			forward_pointer(b)=fwp
		end do
		return
	end if
c	case: remainders in box
	if(b.eq.box) then
		link_pointer(box)=k
		return
	end if

	return
	end
c
c----------------------------------------------------------------------
c
	subroutine toprequest(bestest,top,stack,chunk,link,mi,ns,seglist,
     $		ni,ci,est,link_pointer,forward_pointer,backward_pointer,
     $		firstest)
	implicit none
	include 'parsizes.for'
	integer bestest,top,stack(maxstack),chunk,link(2,maxstack2),ns
	integer ni(maxseg),ci(maxres0,maxseg),est,mi(maxseg),
     $ seglist(maxseg)
	integer link_pointer(0:boxdim),forward_pointer(0:boxdim),
     $		backward_pointer(0:boxdim)
	real firstest
c
	integer irray((1+(maxres0+30)/31)*maxseg),s,a
c
c	move best chunk to top of stack
c	translate chunk contents to ni,ci
c	decrement stack counter
c
c	call checkstack(stack,bestest,top,chunk,'top BUG 1')
	a=bestest
	if(top.ne.bestest) call swapstack(a,top,stack,chunk,link,bestest,
     $		link_pointer,forward_pointer,backward_pointer,firstest)
	if(lskipflag) return
c	check that top is really maximum!
c	call checkstack(stack,bestest,top,chunk,'top BUG 2')
	call getchunk(top,irray,stack,chunk)
	call translatechunk(irray,mi,ns,seglist,ni,ci,est,chunk)
	s=stack(bestest)
	call removebox(s,bestest,stack,link,link_pointer,
     $		forward_pointer,backward_pointer,firstest)
c	call checkstack(stack,bestest,top,chunk,'top BUG 3')
	call removetoplink(top,chunk,link,bestest)
c	call checkstack(stack,bestest,top,chunk,'top BUG 4')
c	write(*,*) 'toprequest',bestest,top,chunk,ns,est
c	write(*,*) 'ni',(ni(seglist(is)),is=1,ns)

	return
	end
c
c----------------------------------------------------------------------
c
	subroutine checkstack(stack,bestest,top,chunk,text)
	implicit none
	include 'parsizes.for'
	integer bestest,top,stack(maxstack),chunk
	character*40 text
c
	integer i,m
c
!	type *,'checkstack',bestest,top,chunk,text
	if(bestest.gt.0) then
	  m=stack(bestest)
	  do i=1,top-1,chunk
		if(stack(i).gt.m) then
			write(*,*) top,bestest,stack(top),stack(bestest)
			write(*,*) (stack(m),m=1,top,chunk)
			write(*,*) text
	write(*,*) ' FATAL ERROR in checkstack'
			lskipflag=.true.
			return
		end if
	  end do
	end if
c
	return
	end
c
c----------------------------------------------------------------------
c
	subroutine removetoplink(top,chunk,link,bestest)
	implicit none
	include 'parsizes.for'
	integer link(2,maxstack2),bestest,top,chunk
c
	bestest=link(1,bestest)
	if(bestest.gt.0) link(2,bestest)=0
	top=top-chunk

	return
	end
c
c----------------------------------------------------------------------
c
	subroutine translatechunk(irray,mi,ns,seglist,ni,ci,est,chunk)
	implicit none
	include 'parsizes.for'
	integer irray((1+(maxres0+30)/31)*maxseg),mi(maxseg)
	integer ns,est,ni(maxseg)
	integer chunk,seglist(maxseg),ci(maxres0,maxseg)
c
	integer i,j,ires,is,iseg,k
	logical l(31)
c
	est=irray(1)
	do is=1,ns
		ni(seglist(is))=0
	end do
	is=0
	ires=0
	do i=2,chunk
		call bitunpack(irray(i),l,1073741823,31)
		do j=1,31
			if(ires.eq.0) then
				is=is+1
				if(is.gt.ns) return
				iseg=seglist(is)
			end if
			ires=ires+1
			if(l(j)) then
				ni(iseg)=ni(iseg)+1
				ci(ni(iseg),iseg)=ires
			end if
c			zero ires counter before next segment
			if(ires.eq.mi(iseg)) ires=0
		end do
	end do

	return
	end
c
c----------------------------------------------------------------------
c
	subroutine swaplinks_new(a,b,link,bestest)
	implicit none
	include 'parsizes.for'
	integer a,b,link(2,maxstack2),bestest
c
	integer dn1,dn2,up1,up2
c
	dn1=link(1,a)
	up1=link(2,a)
	dn2=link(1,b)
	up2=link(2,b)

	if(up1.eq.b.or.up2.eq.a) then	! adjacent --a-b--
		link(1,a)=up2
		link(1,b)=a
		if(dn1.ne.0) link(1,dn1)=b
		link(2,a)=b
		link(2,b)=dn1
		if(up2.ne.0) link(2,up2)=a
	else			! non-adjacent --a-x-b--
		link(1,b)=dn1
		link(1,a)=dn2
		link(2,b)=up1
		link(2,a)=up2
		if(dn1.ne.0) link(2,dn1)=a
		if(dn2.ne.0) link(2,dn2)=b
		if(up1.ne.0) link(1,up1)=b
		if(up2.ne.0) link(1,up2)=a
	end if

	if(up1.eq.0) bestest=b
	if(up2.eq.0) bestest=a

	return
	end
c
c----------------------------------------------------------------------
c
	subroutine swaplinks(a,b,link,bestest)
	implicit none
	include 'parsizes.for'
	integer bestest,a,b,link(2,maxstack2)
c
	integer dn1,dn2,up1,up2
c
	dn1=link(1,a)
	up1=link(2,a)
	if(dn1.eq.b) dn1=a
	dn2=link(1,b)
	up2=link(2,b)
	if(up2.eq.a) up2=b
	link(1,b)=dn1
	link(2,b)=up1
	link(1,a)=dn2
	link(2,a)=up2
	if(dn1.ne.0) link(2,dn1)=b
	if(up1.ne.0) link(1,up1)=b
	if(dn2.ne.0) link(2,dn2)=a
	if(up2.ne.0) link(1,up2)=a
	if(up1.eq.0) bestest=b
	if(up2.eq.0) bestest=a

	return
	end
c
c----------------------------------------------------------------------
c
	subroutine swapstack(from,to,stack,chunk,link,bestest,
     $ link_pointer,forward_pointer,backward_pointer,firstest)
	implicit none
	include 'parsizes.for'
	integer from,to,stack(maxstack),chunk,link(2,maxstack2),bestest
	integer link_pointer(0:boxdim),forward_pointer(0:boxdim),
     $		backward_pointer(0:boxdim)
	real firstest
c
	integer i,a,b,e,getk
c
c	write(*,*) 'swap',from,stack(from),to,stack(to),firstest
	if(from.eq.to) return
	e=stack(from)
	call removebox(e,from,stack,link,link_pointer,
     $		forward_pointer,backward_pointer,firstest)
	e=stack(to)
	call removebox(e,to,stack,link,link_pointer,
     $		forward_pointer,backward_pointer,firstest)
	a=from
	b=to
	do i=1,chunk
		e=stack(b)
		stack(b)=stack(a)
		stack(a)=e
		a=a+1
		b=b+1
	end do
	call swaplinks(from,to,link,bestest)
	e=stack(from)
	i=getk(e,from,stack,link_pointer,
     $		forward_pointer,backward_pointer,firstest)
	if(lskipflag) return
	e=stack(to)
	i=getk(e,to,stack,link_pointer,
     $		forward_pointer,backward_pointer,firstest)
	if(lskipflag) return

	return
	end
c
c----------------------------------------------------------------------
c
	subroutine putchunk(to,irray,stack,chunk)
	implicit none
	include 'parsizes.for'
	integer to,stack(maxstack),chunk,irray(chunk)
c
	integer i,a
c
	a=to
	if(a+chunk.gt.maxstack) then
		write(*,*) to,chunk
	write(*,*)  'FATAL ERROR stack overflow - increase maxstack'
		lskipflag=.true.
		return
	end if
	do i=1,chunk
		stack(a)=irray(i)
		a=a+1
	end do

	return
	end
c
c----------------------------------------------------------------------
c
	subroutine getchunk(from,irray,stack,chunk)
	implicit none
	include 'parsizes.for'
	integer from,stack(maxstack),chunk,irray(chunk)
c
	integer i,a
c
	a=from
	do i=1,chunk
		irray(i)=stack(a)
		a=a+1
	end do

	return
	end
c
c----------------------------------------------------------------------
c
	subroutine getnminnmax(ni,ns,seglist,nmin,nmax)
	implicit none
	include 'parsizes.for'
	integer ns,ni(maxseg),nmin,nmax,seglist(maxseg)
c
	integer is,n
c
	nmin=infinit
	nmax=-infinit
	do is=1,ns
		n=ni(seglist(is))
		nmin=min(nmin,n)
		nmax=max(nmax,n)
	end do

	return
	end
c
c----------------------------------------------------------------------
c


      SUBROUTINE CALPAR
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON /ONELEC/ USS(107),UPP(107),UDD(107)
     1       /ATOMIC/ EISOL(107),EHEAT(107)
     2       /ALPHA / ALP(107)
     3       /EXPONT/ ZS(107),ZP(107),ZD(107)
     4       /GAUSS / FN1(107),FN2(107)
     5       /BETAS / BETAS(107),BETAP(107),BETAD(107)
     6       /TWOELE/ GSS(107),GSP(107),GPP(107),GP2(107),HSP(107),
     7                GSD(107),GPD(107),GDD(107)
     8       /IDEAS / GUESS1(107,10), GUESS2(107,10), GUESS3(107,10)
      COMMON /MNDO/  USSM(107), UPPM(107), UDDM(107), ZSM(107),ZPM(107),
     1ZDM(107), BETASM(107), BETAPM(107), BETADM(107), ALPM(107),
     2EISOLM(107), DDM(107), QQM(107), AMM(107), ADM(107), AQM(107)
     3,GSSM(107),GSPM(107),GPPM(107),GP2M(107),HSPM(107), POLVOM(107)
      COMMON /KEYWRD/ KEYWRD
      COMMON/MULTIP/ DD(107),QQ(107),AM(107),AD(107),AQ(107)
      DIMENSION NSPQN(107)
      CHARACTER KEYWRD*241
      DIMENSION USSC(107), UPPC(107), GSSC(107), GSPC(107), HSPC(107),
     1GP2C(107), GPPC(107), UDDC(107), GSDC(107), GDDC(107)
      SAVE NSPQN, USSC, UPPC, UDDC, GSSC, GSPC, HSPC, GP2C, GSDC, GDDC
      DATA NSPQN/2*1,8*2,8*3,18*4,18*5,32*6,21*0/
C
C THE CONTINUATION LINES INDICATE THE PRINCIPAL QUANTUM NUMBER.
C
      DATA USSC/
     11.D0,                                                      0.D0,
     21.D0,                                               6*2.D0,0.D0,
     31.D0,                                               6*2.D0,0.D0,
     41.D0,4*2.D0,1.D0,4*2.D0,1.D0,                       6*2.D0,0.D0,
     51.D0,3*2.D0,2*1.D0,2.D0,2*1.D0,0.D0,1.D0,           6*2.D0,0.D0,
     61.D0,22*2.D0,1.D0,1.D0,                             6*2.D0,0.D0,
     721*0.D0/
      DATA  UPPC/
     1 2*0.D0,
     2 2*0.D0,1.D0,2.D0,3.D0,4.D0,5.D0,6.D0,
     3 2*0.D0,1.D0,2.D0,3.D0,4.D0,5.D0,6.D0,
     412*0.D0,1.D0,2.D0,3.D0,4.D0,5.D0,6.D0,
     512*0.D0,1.D0,2.D0,3.D0,4.D0,5.D0,6.D0,
     626*0.D0,1.D0,2.D0,3.D0,4.D0,5.D0,6.D0,
     721*0.D0/
      DATA UDDC/18*0.D0,
     1 2*0.D0,1.D0,2.D0,3.D0,5.D0,5.D0,6.D0,7.D0,8.D0,1.D1,1.D1,6*0.D0,
     2 2*0.D0,1.D0,2.D0,4.D0,5.D0,5.D0,7.D0,8.D0,1.D1,1.D1,1.D1,6*0.D0,
     3 2*0.D0,1.D0,6*0.D0,1.D0,6*0.D0,1.D0,2.D0,3.D0,4.D0,
     4                           5.D0,6.D0,7.D0,9.D0,1.D1,1.D1,6*0.D0,
     5 21*0.D0/
      DATA GSSC/2*0.D0,
     1 0.D0,6*1.D0,0.D0,
     2 0.D0,6*1.D0,0.D0,
     3 0.D0,4*1.D0,0.D0,4*1.D0,0.D0,6*1.D0,0.D0,
     4 0.D0,3*1.D0,7*0.D0,6*1.D0,0.D0,
     5 0.D0,22*1.D0,2*1.D0,6*1.D0,0.D0,
     6 21*0.D0/
      DATA GSPC/2*0.D0,
     1 2*0.D0,2.D0,4.D0,6.D0,8.D0,10.D0,0.D0,
     2 2*0.D0,2.D0,4.D0,6.D0,8.D0,10.D0,0.D0,
     312*0.D0,2.D0,4.D0,6.D0,8.D0,10.D0,0.D0,
     412*0.D0,2.D0,4.D0,6.D0,8.D0,10.D0,0.D0,
     526*0.D0,2.D0,4.D0,6.D0,8.D0,10.D0,0.D0,
     621*0.D0/
      DATA HSPC/2*0.D0,
     1 2*0.D0,-1.D0,-2.D0,-3.D0,-4.D0,-5.D0,0.D0,
     2 2*0.D0,-1.D0,-2.D0,-3.D0,-4.D0,-5.D0,0.D0,
     312*0.D0,-1.D0,-2.D0,-3.D0,-4.D0,-5.D0,0.D0,
     412*0.D0,-1.D0,-2.D0,-3.D0,-4.D0,-5.D0,0.D0,
     526*0.D0,-1.D0,-2.D0,-3.D0,-4.D0,-5.D0,0.D0,
     621*0.D0/
      DATA GP2C/2*0.D0,
     1 3*0.D0,1.5D0,4.5D0,6.5D0,10.D0,0.D0,
     2 3*0.D0,1.5D0,4.5D0,6.5D0,10.D0,0.D0,
     313*0.D0,1.5D0,4.5D0,6.5D0,10.D0,0.D0,
     413*0.D0,1.5D0,4.5D0,6.5D0,10.D0,0.D0,
     527*0.D0,1.5D0,4.5D0,6.5D0,10.D0,0.D0,
     621*0.D0/
      DATA GPPC/2*0.D0,
     1 3*0.D0,-0.5D0,-1.5D0,-0.5D0,2*0.D0,
     2 3*0.D0,-0.5D0,-1.5D0,-0.5D0,2*0.D0,
     313*0.D0,-0.5D0,-1.5D0,-0.5D0,2*0.D0,
     413*0.D0,-0.5D0,-1.5D0,-0.5D0,2*0.D0,
     527*0.D0,-0.5D0,-1.5D0,-0.5D0,2*0.D0,
     621*0.D0/
     7GSDC/18*0.D0,
     8 2*0.D0,2.D0,4.D0,6.D0,5.D0,10.D0,12.D0,14.D0,16.D0,10.D0,7*0.D0,
     9 2*0.D0,2.D0,4.D0,4.D0,5.D0,6.D0,7.D0,8.D0,0.D0,1.D1,7*0.D0,
     1 2*0.D0,2.D0,6*0.D0,2.D0,6*0.D0,2.D0,4.D0,6.D0,8.D0,10.D0,12.D0,
     2                                         14.D0,9.D0,10.D0,7*0.D0,
     321*0.D0/
      DATA GDDC/18*0.D0,
     1 3*0.D0,1.D0,3.D0,10.D0,10.D0,15.D0,21.D0,28.D0,8*0.D0,
     2 3*0.D0,1.D0,6.D0,10.D0,15.D0,21.D0,28.D0,45.D0,8*0.D0,
     317*0.D0,1.D0,3.D0, 6.D0,10.D0,15.D0,21.D0,36.D0,8*0.D0,
     421*0.D0/
C  The DATA block shown above is derived from the ground-state atomic
C  configuration of the elements.  In checking it, pay careful attention
C  to the actual ground-state configuration. Note also that there are no
C  configurations which have both p and d electrons in the valence shell
C
C     SET SCALING PARAMETER.
      P=2.D0
      P2=P*P
      P4=P**4
      DO 30 I=2,98
         IF(ZP(I).LT.1.D-4.AND.ZS(I).LT.1.D-4)GOTO 30
**********************************************************************
*
*   CONSTRAINTS ON THE POSSIBLE VALUES OF PARAMETERS
*
**********************************************************************
         IF(ZP(I).LT.0.3D0) ZP(I)=0.3D0
C  PUT IN ANY CONSTRAINTS AT THIS POINT
**********************************************************************
         HPP=0.5D0*(GPP(I)-GP2(I))
         HPP=MAX(0.1D0,HPP)
         HSP(I)=MAX(1.D-7,HSP(I))
         EISOL(I)=USS(I)*USSC(I)+UPP(I)*UPPC(I)+UDD(I)*UDDC(I)+
     1         GSS(I)*GSSC(I)+GPP(I)*GPPC(I)+GSP(I)*GSPC(I)+
     2         GP2(I)*GP2C(I)+HSP(I)*HSPC(I)+GSD(I)*GSDC(I)+
     3         GDD(I)*GDDC(I)
         QN=NSPQN(I)
         DD(I)=(2.D0*QN+1)*(4.D0*ZS(I)*ZP(I))**(QN+0.5D0)/(ZS(I)+ZP(I))
     1**(2.D0*QN+2)/SQRT(3.D0)
         DDM(I)=DD(I)
         QQ(I)=SQRT((4.D0*QN*QN+6.D0*QN+2.D0)/20.D0)/ZP(I)
         QQM(I)=QQ(I)
C     CALCULATE ADDITIVE TERMS, IN ATOMIC UNITS.
         JMAX=5
         GDD1= (P2*HSP(I)/(27.21* 4.*DD(I)**2))**(1./3.)
         GQQ= (P4*HPP/(27.21*48.*QQ(I)**4))**0.2
         D1=GDD1
         D2=GDD1+0.04
         Q1=GQQ
         Q2=GQQ+0.04
         DO 10 J=1,JMAX
            DF=D2-D1
            HSP1= 2.*D1 - 2./SQRT(4.*DD(I)**2+1./D1**2)
            HSP2= 2.*D2 - 2./SQRT(4.*DD(I)**2+1./D2**2)
            HSP1= HSP1/P2
            HSP2= HSP2/P2
            D3= D1 + DF*(HSP(I)/27.21-HSP1)/(HSP2-HSP1)
            D1= D2
            D2= D3
   10    CONTINUE
         DO 20 J=1,JMAX
            QF=Q2-Q1
            HPP1= 4.*Q1 - 8./SQRT(4.*QQ(I)**2+1./Q1**2)
     1            + 4./SQRT(8.*QQ(I)**2+1./Q1**2)
            HPP2= 4.*Q2 - 8./SQRT(4.*QQ(I)**2+1./Q2**2)
     1            + 4./SQRT(8.*QQ(I)**2+1./Q2**2)
            HPP1= HPP1/P4
            HPP2= HPP2/P4
            Q3= Q1 + QF*(HPP/27.21-HPP1)/(HPP2-HPP1)
            Q1= Q2
            Q2= Q3
   20    CONTINUE
         AM(I)= GSS(I)/27.21
         AD(I)= D2
         AQ(I)= Q2
         AMM(I)=AM(I)
         ADM(I)=AD(I)
         AQM(I)=AQ(I)
   30 CONTINUE
      EISOL(1)=USS(1)
      AM(1)=GSS(1)/27.21D0
      AD(1)=AM(1)
      AQ(1)=AM(1)
      AMM(1)=AM(1)
      ADM(1)=AD(1)
      AQM(1)=AQ(1)
C
C     DEBUG PRINTING.
C     THIS IS FORMATTED FOR DIRECT INSERTION INTO 'PARAM'
C
      IF(INDEX(KEYWRD,'DEP').EQ.0) RETURN
      WRITE(6,50)
      DO 60 I=1,107
         IF(ZS(I).EQ.0) GOTO 60
         WRITE(6,'(''C'',20X,''DATA FOR ELEMENT'',I3)')I
         WRITE(6,'(6X,''DATA USSPM3('',I3,'')/'',F16.7,''D0/'')')
     1                    I,USS(I)
         IF(UPP(I) .NE. 0.D0)
     1WRITE(6,'(6X,''DATA UPPPM3('',I3,'')/'',F16.7,''D0/'')')I,UPP(I)
         IF(UDD(I) .NE. 0.D0)
     1WRITE(6,'(6X,''DATA UDDPM3('',I3,'')/'',F16.7,''D0/'')')I,UDD(I)
         IF(BETAS(I) .NE. 0.D0)
     1WRITE(6,'(6X,''DATA BETASP('',I3,'')/'',F16.7,''D0/'')')
     2I,BETAS(I)
         IF(BETAP(I) .NE. 0.D0)
     1WRITE(6,'(6X,''DATA BETAPP('',I3,'')/'',F16.7,''D0/'')')
     2I,BETAP(I)
         IF(BETAD(I) .NE. 0.D0)
     1WRITE(6,'(6X,''DATA BETADP('',I3,'')/'',F16.7,''D0/'')')
     2I,BETAD(I)
         WRITE(6,'(6X,''DATA ZSPM3 ('',I3,'')/'',F16.7,''D0/'')')
     1I,ZS(I)
         IF(ZP(I) .NE. 0.D0)
     1WRITE(6,'(6X,''DATA ZPPM3 ('',I3,'')/'',F16.7,''D0/'')')I,ZP(I)
         IF(ZD(I) .NE. 0.D0)
     1WRITE(6,'(6X,''DATA ZDPM3 ('',I3,'')/'',F16.7,''D0/'')')I,ZD(I)
         WRITE(6,'(6X,''DATA ALPPM3('',I3,'')/'',F16.7,''D0/'')')
     1I,ALP(I)
         WRITE(6,'(6X,''DATA EISOLP('',I3,'')/'',F16.7,''D0/'')')
     1I,EISOL(I)
         IF(GSS(I) .NE. 0.D0)
     1WRITE(6,'(6X,''DATA GSSPM3('',I3,'')/'',F16.7,''D0/'')')
     2I,GSS(I)
         IF(GSP(I) .NE. 0.D0)
     1WRITE(6,'(6X,''DATA GSPPM3('',I3,'')/'',F16.7,''D0/'')')
     2I,GSP(I)
         IF(GPP(I) .NE. 0.D0)
     1WRITE(6,'(6X,''DATA GPPPM3('',I3,'')/'',F16.7,''D0/'')')
     2I,GPP(I)
         IF(GP2(I) .NE. 0.D0)
     1WRITE(6,'(6X,''DATA GP2PM3('',I3,'')/'',F16.7,''D0/'')')
     2I,GP2(I)
         IF(HSP(I) .NE. 0.D0)
     1WRITE(6,'(6X,''DATA HSPPM3('',I3,'')/'',F16.7,''D0/'')')
     2I,HSP(I)
         IF(DD(I) .NE. 0.D0)
     1WRITE(6,'(6X,''DATA DDPM3 ('',I3,'')/'',F16.7,''D0/'')')I,DD(I)
         IF(QQ(I) .NE. 0.D0)
     1WRITE(6,'(6X,''DATA QQPM3 ('',I3,'')/'',F16.7,''D0/'')')I,QQ(I)
         WRITE(6,'(6X,''DATA AMPM3 ('',I3,'')/'',F16.7,''D0/'')')
     1I,AM(I)
         IF(AD(I) .NE. 0.D0)
     1WRITE(6,'(6X,''DATA ADPM3 ('',I3,'')/'',F16.7,''D0/'')')I,AD(I)
         IF(AQ(I) .NE. 0.D0)
     1WRITE(6,'(6X,''DATA AQPM3 ('',I3,'')/'',F16.7,''D0/'')')I,AQ(I)
         IF(FN1(I) .NE. 0.D0)
     1WRITE(6,'(6X,''DATA FN1PM3('',I3,'')/'',F16.7,''D0/'')')I,FN1(I)
         IF(FN2(I) .NE. 0.D0)
     1WRITE(6,'(6X,''DATA FN2PM3('',I3,'')/'',F16.7,''D0/'')')I,FN2(I)
         DO 40 J=1,10
            IF(GUESS1(I,J) .EQ.0.D0) GOTO 40
            WRITE(6,'(6X,''DATA GUESP1('',I3,'','',I1,'')/'',
     1F16.7,''D0/'')')I,J,GUESS1(I,J)
            WRITE(6,'(6X,''DATA GUESP2('',I3,'','',I1,'')/'',
     1F16.7,''D0/'')')I,J,GUESS2(I,J)
            WRITE(6,'(6X,''DATA GUESP3('',I3,'','',I1,'')/'',
     1F16.7,''D0/'')')I,J,GUESS3(I,J)
   40    CONTINUE
   50    FORMAT(1H ,1X,'OUTPUT INCLUDES DEBUG INFORMATION',//)
   60 CONTINUE
      RETURN
      END