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