← Back to branch summary

~ubuntu-branches/ubuntu/saucy/nwchem/saucy

« back to all changes in this revision

Viewing changes to src/ddscf/uhf.F

  • Committer: Package Import Robot
  • Author(s): Michael Banck, Michael Banck, Daniel Leidert
  • Date: 2012-02-09 20:02:41 UTC
  • mfrom: (1.1.1)
  • Revision ID: package-import@ubuntu.com-20120209200241-jgk03qfsphal4ug2
Tags: 6.1-1
http://bugs.debian.org/632611
https://launchpad.net/bugs/791308
* New upstream release.

[ Michael Banck ]
* debian/patches/02_makefile_flags.patch: Updated.
* debian/patches/02_makefile_flags.patch: Use internal blas and lapack code.
* debian/patches/02_makefile_flags.patch: Define GCC4 for LINUX and LINUX64
  (Closes: #632611 and LP: #791308).
* debian/control (Build-Depends): Added openssh-client.
* debian/rules (USE_SCALAPACK, SCALAPACK): Removed variables (Closes:
  #654658).
* debian/rules (LIBDIR, USE_MPIF4, ARMCI_NETWORK): New variables.
* debian/TODO: New file.
* debian/control (Build-Depends): Removed libblas-dev, liblapack-dev and
  libscalapack-mpi-dev.
* debian/patches/04_show_testsuite_diff_output.patch: New patch, shows the
  diff output for failed tests.
* debian/patches/series: Adjusted.
* debian/testsuite: Optionally run all tests if "all" is passed as option.
* debian/rules: Run debian/testsuite with "all" if DEB_BUILD_OPTIONS
  contains "checkall".

[ Daniel Leidert ]
* debian/control: Used wrap-and-sort. Added Vcs-Svn and Vcs-Browser fields.
  (Priority): Moved to extra according to policy section 2.5.
  (Standards-Version): Bumped to 3.9.2.
  (Description): Fixed a typo.
* debian/watch: Added.
* debian/patches/03_hurd-i386_define_path_max.patch: Added.
  - Define MAX_PATH if not defines to fix FTBFS on hurd.
* debian/patches/series: Adjusted.

Show diffs side-by-side

added added

removed removed

Lines of Context:
src/ddscf/uhf.F
1
1
      logical function uhf(rtdb, energy)
2
 
C$Id: uhf.F,v 1.69 2009-01-16 05:32:29 niri Exp $
 
2
C$Id: uhf.F 21877 2012-01-26 19:52:10Z d3y133 $
3
3
      implicit none
4
4
#include "errquit.fh"
5
5
#include "global.fh"
218
218
c
219
219
      end
220
220
      logical function uhf_nr_solve(rtdb, energy, eone, etwo, enrep)
221
 
C     $Id: uhf.F,v 1.69 2009-01-16 05:32:29 niri Exp $
 
221
C     $Id: uhf.F 21877 2012-01-26 19:52:10Z d3y133 $
222
222
      implicit none
223
223
#include "errquit.fh"
224
224
#include "mafdecls.fh"
534
534
      end
535
535
      subroutine uhf_k2cf(basis, nbf, nmo, nalpha, nbeta, g_kvec,
536
536
     $     g_mocf_in, g_mocf_out)
537
 
C$Id: uhf.F,v 1.69 2009-01-16 05:32:29 niri Exp $
 
537
C$Id: uhf.F 21877 2012-01-26 19:52:10Z d3y133 $
538
538
      implicit none
539
539
#include "errquit.fh"
540
540
#include "mafdecls.fh"
630
630
#include "rtdb.fh"
631
631
#include "bgj.fh"
632
632
#include "case.fh"
 
633
#include "zora.fh"
633
634
c     
634
 
c     $Id: uhf.F,v 1.69 2009-01-16 05:32:29 niri Exp $
 
635
c     $Id: uhf.F 21877 2012-01-26 19:52:10Z d3y133 $
635
636
c
636
637
      integer g_vecs(2)
637
638
      double precision energy
774
775
c
775
776
        do ifock = 1,nfock
776
777
           g_tmp(ifock) = ga_create_atom_blocked(geom, basis, 'tmp')
 
778
           call ga_zero(g_tmp(ifock))
777
779
        end do
778
 
        call ga_zero(g_tmp)
779
780
c
780
 
        call case_setflags(.true.)
 
781
        call case_setflags(.true.)  ! set LC flag
781
782
        jfac(1)=0d0
782
783
        jfac(2)=0d0
783
784
        jfac(3)=0d0
788
789
        kfac(4)=1d0
789
790
        call fock_2e_cam(geom, basis, nfock, jfac, kfac, tol2e, 
790
791
     &     oskel, d, g_tmp, .false., .false.)
791
 
        call ga_dadd(1d0,f,1d0,g_tmp,f)
 
792
        call ga_dadd(1d0,f(2),1d0,g_tmp(2),f(2))  ! LC exchange part
 
793
        call ga_dadd(1d0,f(4),1d0,g_tmp(4),f(4))  ! LC exchange part
792
794
c
793
795
c       calculate the full Coulomb
794
796
c
795
 
        call case_setflags(.false.)
 
797
        do ifock = 1,nfock
 
798
           call ga_zero(g_tmp(ifock))
 
799
        end do
 
800
        call case_setflags(.false.) ! turn off LC flag for full Coulomb
796
801
        jfac(1)=1d0
797
802
        jfac(2)=0d0
798
803
        jfac(3)=1d0
802
807
        kfac(3)=0d0
803
808
        kfac(4)=0d0
804
809
        call fock_2e_cam(geom, basis, nfock, jfac, kfac, tol2e, 
805
 
     &     oskel, d, g_tmp, .false., .true.)
806
 
        call ga_dadd(1d0,f,1d0,g_tmp,f)
 
810
     &     oskel, d, g_tmp, .false., .true.)   ! last argument toggles xc
 
811
        call ga_dadd(1d0,f(1),1d0,g_tmp(1),f(1))   ! full Coulomb part
 
812
        call ga_dadd(1d0,f(3),1d0,g_tmp(3),f(3))   ! full Coulomb part
 
813
        call ga_dadd(1d0,f(2),1d0,g_tmp(2),f(2))   ! DFT xc part
 
814
        call ga_dadd(1d0,f(4),1d0,g_tmp(4),f(4))   ! DFT xc part
807
815
c
808
816
c       destroy work space
809
817
        if (.not. ga_destroy(g_tmp)) 
810
818
     &   call errquit('uhf: ga corrupt?',0, GA_ERR)
811
 
      end if
 
819
      end if  ! cam_exch
812
820
      call do_riscf (.true.)
813
821
c
814
822
      e_a_coul = 0.5d0*
857
865
c
858
866
      g_hcore = g_a_exch
859
867
      call ga_zero(g_hcore)
860
 
      call int_1e_ga(basis, basis, g_hcore, 'kinetic', oskel)
861
 
      call int_1e_ga(basis, basis, g_hcore, 'potential', oskel)
 
868
      call int_1e_ga(basis, basis, g_hcore, 'kinetic', oskel)  ! kinetic
 
869
      if (do_zora .and. .not.(do_NonRel)) then
 
870
        call ga_dadd(1.d0,g_hcore,1.d0,g_zora_Kinetic(1),g_hcore) ! zora kinetic
 
871
      endif
 
872
      call int_1e_ga(basis, basis, g_hcore, 'potential', oskel) ! potential
862
873
      eone = 
863
874
     $     (ga_ddot(g_a_dens,g_hcore) + ga_ddot(g_b_dens,g_hcore))
864
875
      call ga_dadd(one, g_hcore, one, g_a_coul, g_a_coul)
1110
1121
      end
1111
1122
      subroutine uhf_precond(g_x, solveshift)
1112
1123
      implicit none
 
1124
#include "stdio.fh"
 
1125
#include "util.fh"
1113
1126
#include "errquit.fh"
1114
1127
#include "global.fh"
1115
1128
#include "mafdecls.fh"
1122
1135
      integer i, j, ioff, ibase
1123
1136
      integer l_diag, k_diag, l_x, k_x
1124
1137
      integer g_f(2), ivec, nvec, gtype, vlen
1125
 
      double precision diag, denominator, shift
 
1138
      double precision diag, denominator, shift, dnrm
 
1139
      integer ilo(2), ihi(2)
 
1140
c
 
1141
      logical oprint, olprint
 
1142
c
1126
1143
      diag(i) = dbl_mb(k_diag + i - 1)
1127
1144
c     
1128
1145
      g_f(1) = cuhf_g_falpha
1130
1147
      nocc(1) = nalpha
1131
1148
      nocc(2) = nbeta
1132
1149
c
 
1150
      oprint = util_print('precond',print_high)
 
1151
      olprint = oprint .and. (ga_nodeid().eq.0)
 
1152
c
1133
1153
      if (.not.ma_push_get(MT_DBL,nmo,'uhf: tmp',l_diag,k_diag))
1134
1154
     $     call errquit('uhf_precond: cannot allocate',0, MA_ERR)
1135
1155
      if (.not.ma_push_get(MT_DBL,nmo,'uhf: tmp',l_x,k_x))
1140
1160
c
1141
1161
      shift = lshift - solveshift
1142
1162
c
 
1163
      if (oprint) then
 
1164
        do ivec = 1, nvec
 
1165
          ilo(1) = 1
 
1166
          ilo(2) = ivec
 
1167
          ihi(1) = vlen
 
1168
          ihi(2) = ivec
 
1169
          call nga_normf_patch(g_x,ilo,ihi,dnrm)
 
1170
          if (olprint) then
 
1171
            write(LuOut,'(1x,a,": in g_x = ",i4,f24.8)')
 
1172
     +      __FILE__,ivec,dnrm
 
1173
          endif
 
1174
        enddo
 
1175
      endif
 
1176
c
1143
1177
      ibase = 1
1144
1178
      do iset = 1, 2
1145
1179
         nvir = nmo - nocc(iset)
1164
1198
         ibase = ibase + nocc(1)*(nmo-nocc(1))
1165
1199
      end do
1166
1200
c
 
1201
      if (oprint) then
 
1202
        do ivec = 1, nvec
 
1203
          ilo(1) = 1
 
1204
          ilo(2) = ivec
 
1205
          ihi(1) = vlen
 
1206
          ihi(2) = ivec
 
1207
          call nga_normf_patch(g_x,ilo,ihi,dnrm)
 
1208
          if (olprint) then
 
1209
            write(LuOut,'(1x,a,": out g_x = ",i4,f24.8)')
 
1210
     +      __FILE__,ivec,dnrm
 
1211
          endif
 
1212
        enddo
 
1213
      endif
 
1214
c
1167
1215
      if (.not. ma_pop_stack(l_x)) call errquit('uhf:pop x',0, MA_ERR)
1168
1216
      if (.not. ma_pop_stack(l_diag)) call errquit('uhf:pop ',0, MA_ERR)
1169
1217
      call ga_sync()
1208
1256
c
1209
1257
      end
1210
1258
      subroutine uhf_canon(oaufbau, oprint)
1211
 
C$Id: uhf.F,v 1.69 2009-01-16 05:32:29 niri Exp $
 
1259
C$Id: uhf.F 21877 2012-01-26 19:52:10Z d3y133 $
1212
1260
      implicit none
1213
1261
#include "errquit.fh"
1214
1262
#include "mafdecls.fh"