1      subroutine dimqm_seed_init_tolerance(request)
2      implicit none
3#include "dimqm.fh"
4#include "stdio.fh"
5#include "global.fh"
6
7      double precision request
8c   Initialize finding the seed
9      dimqm_seeded = .false.
10c   Return if seeding is off
11      if(dimqm_noseed) return
12c   If the user set tolerance is less than the pre-seed tolerance, save the user's
13c   setting and change to the pre-seed tolerance.  This will be reversed once seeding
14c   has started.
15      if(dimtol < request) then
16        dimtol0 = dimtol
17        dimtol = request
18        if(ga_nodeid().eq.0 .and. ldebug) then
19          write(luout,*) "User requested tolerance below", request
20          write(luout,*) "Setting pre-seed tolerance to", request
21        end if
22      end if
23      end subroutine dimqm_seed_init_tolerance
24
25      subroutine dimqm_check_dipoles(tolerance, error)
26      implicit none
27#include "dimqm.fh"
28#include "stdio.fh"
29#include "global.fh"
30
31      double precision tolerance, error
32c   Return if seeding is off
33      if(dimqm_noseed) return
34c   Return if seed already selected
35      if(dimqm_seeded) return
36c   Return if this is the first cycle
37      if(lfirst) return
38c   Check to see if the error is below our seeding tolerance,
39      if(error < tolerance) then
40c       Return if we've already set the seed
41c       Otherwise, set the seed and revert the tolerance back to user requested level
42        dimqm_seeded = .true.
43        if(ga_nodeid().eq.0 .and. ldebug) then
44          write(luout,*) "Dipole error below ", tolerance
45          write(luout,*) "Setting current system as seed"
46          write(luout,*) "Reverting tolerance back to", dimtol0
47        end if
48        dimtol = dimtol0
49      end if
50      end subroutine dimqm_check_dipoles
51
52      subroutine dimqm_check_scf(de, rms, derr, ipol, tolerance)
53      implicit none
54#include "dimqm.fh"
55#include "stdio.fh"
56#include "global.fh"
57
58      double precision de, rms(2), tolerance, derr(2)
59      integer ipol
60      logical e, d1, d2, g1, g2
61c   Return if dimqm is off
62      if (.not.ldimqm) return
63c   Return if seeding is off
64      if(dimqm_noseed) return
65c   Return if the seed hasn't been set yet
66      if(.not.dimqm_seeded) return
67      e = .false.
68      d1 = .false.
69      d2 = .false.
70      g1 = .false.
71      g2 = .false.
72c   Check to see if the SCF RMS-density and delta E are below a given tolerance
73c   If not, then this is not a good seed system and we reset the seed flag
74      if(de .gt. tolerance) e = .true.
75      if(dsqrt(rms(1)) .gt. tolerance) d1 = .true.
76      if(derr(1) .gt. tolerance) g1 = .true.
77      if(ipol .gt. 1) then
78        if(dsqrt(rms(2)) .gt. tolerance) d2 = .true.
79        if(derr(2) .gt. tolerance) g2 = .true.
80      end if
81      if(e .or. d1 .or. d2 .or. g1 .or. g2) then
82        if(ga_nodeid().eq.0 .and. ldebug) then
83          write(luout,*) "Seed was set, but some SCF error"
84          write(luout,*) " is above ", tolerance
85          write(luout,*) "Unsetting seed and reverting tolerance back"
86          write(luout,*) "to 1.0d-4"
87        end if
88        dimqm_seeded = .false.
89        dimtol = 1.0d-4
90      end if
91      end subroutine dimqm_check_scf
92