← Back to branch summary

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

« back to all changes in this revision

Viewing changes to src/smd/graveyard/smd-9-10-08/smd_lat.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/smd/graveyard/smd-9-10-08/smd_lat.F
 
1
      subroutine smd_lat_init_system()
 
2
      implicit none
 
3
#include "errquit.fh"
 
4
#include "inp.fh"
 
5
#include "mafdecls.fh"
 
6
#include "rtdb.fh"
 
7
#include "util.fh"
 
8
#include "global.fh"
 
9
c     
 
10
      character*32 sp_lat
 
11
      character*32 tag,pname
 
12
      logical result
 
13
 
 
14
      pname = "smd_lat_init_system"
 
15
c
 
16
      tag = "lattice"
 
17
      call smd_system_get_component(sp_lat,tag,result)
 
18
      if(.not.result)
 
19
     >  call errquit(
 
20
     >       pname//'no component '//tag,0,0)
 
21
 
 
22
      call smd_lat_init(sp_lat,result)
 
23
      if(.not.result) then
 
24
       tag = "lattice"
 
25
       call smd_system_unset_component(tag)
 
26
      end if
 
27
c
 
28
 
 
29
      return
 
30
      end
 
31
 
 
32
      subroutine smd_lat_init(namespace,result)
 
33
      implicit none
 
34
#include "errquit.fh"
 
35
#include "inp.fh"
 
36
#include "mafdecls.fh"
 
37
#include "rtdb.fh"
 
38
#include "util.fh"
 
39
#include "global.fh"
 
40
c     
 
41
      character*(*) namespace
 
42
      logical result
 
43
c
 
44
      integer rtdb
 
45
      character*32 pname
 
46
      character*80 tag
 
47
      integer i_lc,i_lrc,i_lfc
 
48
      double precision vol
 
49
c
 
50
      pname = "smd_lat_init"
 
51
c
 
52
c      write(*,*) "in "//pname
 
53
c
 
54
      call smd_rtdb_get_handle(rtdb)
 
55
c
 
56
c     check if there is any lattice in rtdb
 
57
      call smd_lat_rtdb_check(rtdb,result)
 
58
      if(.not.result) then
 
59
        call util_warning(
 
60
     >       pname//'no lattice found in rtdb',0,0)
 
61
        return
 
62
      end if
 
63
c
 
64
      call smd_namespace_create(namespace)
 
65
c
 
66
c     create lattice data structures
 
67
c     ------------------------------
 
68
      tag = "lat:fconst"
 
69
      call smd_data_create_get(namespace,tag,2,MT_DBL,i_lfc)
 
70
      tag = "lat:cell"
 
71
      call smd_data_create_get(namespace,tag,9,MT_DBL,i_lc)
 
72
      tag = "lat:rcell"
 
73
      call smd_data_create_get(namespace,tag,9,MT_DBL,i_lrc)
 
74
      
 
75
      call smd_lat_rtdb_read(rtdb,dbl_mb(i_lc))
 
76
      call smd_lat_invrt(dbl_mb(i_lc),dbl_mb(i_lrc))
 
77
      call smd_latt_vol(dbl_mb(i_lc),vol)
 
78
      dbl_mb(i_lfc) = vol
 
79
      return
 
80
      end
 
81
 
 
82
      subroutine smd_lat_rtdb_check(rtdb,olatt)
 
83
      implicit none
 
84
#include "errquit.fh"
 
85
#include "inp.fh"
 
86
#include "mafdecls.fh"
 
87
#include "rtdb.fh"
 
88
#include "util.fh"
 
89
#include "global.fh"
 
90
c     
 
91
      integer rtdb
 
92
      logical olatt
 
93
c
 
94
      double precision latt(3,3)
 
95
      character*32 pname
 
96
      character*80 tag
 
97
      double precision a(3)
 
98
      integer i
 
99
c
 
100
      pname = "smd_lat_rtdb_read"
 
101
c
 
102
c      write(*,*) "in "//pname
 
103
c
 
104
      olatt = .true.
 
105
      tag="smd:lat_a"
 
106
      call smd_rtdb_get_dbl(tag,3,a(1),olatt)
 
107
c      if (.not.rtdb_get(rtdb,tag,mt_dbl,3,a(1))) 
 
108
c     >      olatt=.false.
 
109
 
 
110
      return
 
111
      end
 
112
 
 
113
      subroutine smd_lat_rtdb_read(rtdb,latt)
 
114
      implicit none
 
115
#include "errquit.fh"
 
116
#include "inp.fh"
 
117
#include "mafdecls.fh"
 
118
#include "rtdb.fh"
 
119
#include "util.fh"
 
120
#include "global.fh"
 
121
c     
 
122
      double precision latt(3,3)
 
123
      integer rtdb
 
124
c
 
125
      character*32 pname
 
126
      character*80 tag
 
127
      double precision a(3)
 
128
      integer i
 
129
      logical result
 
130
c
 
131
      pname = "smd_lat_rtdb_read"
 
132
c
 
133
c      write(*,*) "in "//pname
 
134
c
 
135
      tag="smd:lat_a"
 
136
      call smd_rtdb_get_dbl(tag,3,a(1),result)
 
137
      if (.not.result) 
 
138
     >      call errquit(pname//'failed to get'//tag,0,
 
139
     >       RTDB_ERR)
 
140
 
 
141
c      if (.not.rtdb_get(rtdb,tag,mt_dbl,3,a(1))) 
 
142
c     >      call errquit(pname//'failed to get'//tag,0,
 
143
c     >       RTDB_ERR)
 
144
      do i=1,3
 
145
       latt(i,1)=a(i)
 
146
      end do
 
147
      tag="smd:lat_b"
 
148
      call smd_rtdb_get_dbl(tag,3,a(1),result)
 
149
      if (.not.result) 
 
150
     >      call errquit(pname//'failed to get'//tag,0,
 
151
     >       RTDB_ERR)
 
152
 
 
153
c      if (.not.rtdb_get(rtdb,tag,mt_dbl,3,a(1))) 
 
154
c     >      call errquit(pname//'failed to get'//tag,0,
 
155
c     >       RTDB_ERR)
 
156
      do i=1,3
 
157
       latt(i,2)=a(i)
 
158
      end do
 
159
      tag="smd:lat_c"
 
160
      call smd_rtdb_get_dbl(tag,3,a(1),result)
 
161
      if (.not.result) 
 
162
     >      call errquit(pname//'failed to get'//tag,0,
 
163
     >       RTDB_ERR)
 
164
 
 
165
c      if (.not.rtdb_get(rtdb,tag,mt_dbl,3,a(1))) 
 
166
c     >      call errquit(pname//'failed to get'//tag,0,
 
167
c     >       RTDB_ERR)
 
168
      do i=1,3
 
169
       latt(i,3)=a(i)
 
170
      end do
 
171
      return
 
172
      end
 
173
 
 
174
      subroutine smd_lat_invrt(latt,rlatt)
 
175
      implicit none
 
176
      double precision  latt(3,3),rlatt(3,3)
 
177
c
 
178
      double precision  det
 
179
 
 
180
      rlatt(1,1)=latt(2,2)*latt(3,3)-latt(3,2)*latt(2,3)
 
181
      rlatt(2,1)=latt(3,1)*latt(2,3)-latt(2,1)*latt(3,3)
 
182
      rlatt(3,1)=latt(2,1)*latt(3,2)-latt(3,1)*latt(2,2)
 
183
      rlatt(1,2)=latt(3,2)*latt(1,3)-latt(1,2)*latt(3,3)
 
184
      rlatt(2,2)=latt(1,1)*latt(3,3)-latt(3,1)*latt(1,3)
 
185
      rlatt(3,2)=latt(3,1)*latt(1,2)-latt(1,1)*latt(3,2)
 
186
      rlatt(1,3)=latt(1,2)*latt(2,3)-latt(2,2)*latt(1,3)
 
187
      rlatt(2,3)=latt(2,1)*latt(1,3)-latt(1,1)*latt(2,3)
 
188
      rlatt(3,3)=latt(1,1)*latt(2,2)-latt(2,1)*latt(1,2)
 
189
      
 
190
      det=latt(1,1)*rlatt(1,1)+latt(1,2)*rlatt(2,1)+latt(1,3)*rlatt(3,1)
 
191
      if(abs(det).gt.0.d0)det=1.d0/det
 
192
      
 
193
      rlatt(1,1)=det*rlatt(1,1)
 
194
      rlatt(2,1)=det*rlatt(2,1)
 
195
      rlatt(3,1)=det*rlatt(3,1)
 
196
      rlatt(1,2)=det*rlatt(1,2)
 
197
      rlatt(2,2)=det*rlatt(2,2)
 
198
      rlatt(3,2)=det*rlatt(3,2)
 
199
      rlatt(1,3)=det*rlatt(1,3)
 
200
      rlatt(2,3)=det*rlatt(2,3)
 
201
      rlatt(3,3)=det*rlatt(3,3)
 
202
 
 
203
      return
 
204
 
 
205
      end
 
206
 
 
207
      subroutine smd_latt_vol(latt,vol)
 
208
      implicit none
 
209
      real*8 x,y,z,latt,vol
 
210
 
 
211
      dimension latt(3,3)
 
212
 
 
213
      x=latt(2,2)*latt(3,3)-latt(2,3)*latt(2,3)
 
214
      y=latt(3,2)*latt(1,3)-latt(1,2)*latt(3,3)
 
215
      z=latt(1,2)*latt(2,3)-latt(2,2)*latt(1,3)
 
216
 
 
217
      vol=abs(latt(1,1)*x+latt(2,1)*y+latt(3,1)*z)
 
218
 
 
219
      return
 
220
 
 
221
      END
 
222
 
 
223
      subroutine smd_latt_get_vol(vol)
 
224
      implicit none
 
225
#include "errquit.fh"
 
226
#include "inp.fh"
 
227
#include "mafdecls.fh"
 
228
#include "rtdb.fh"
 
229
#include "util.fh"
 
230
#include "global.fh"
 
231
c     
 
232
      double precision vol
 
233
c
 
234
      character*72 tag
 
235
      character*30 pname
 
236
      integer i_fconst
 
237
      logical result
 
238
 
 
239
      pname = "smd_latt_vol"
 
240
      tag = "lat:fconst"
 
241
      call smd_get_ind(tag,i_fconst,result)
 
242
      if(.not. result) 
 
243
     >  call errquit(
 
244
     >       pname//'error getting ntot '//tag,0, RTDB_ERR)
 
245
      vol = dbl_mb(i_fconst)
 
246
 
 
247
      return
 
248
      end
 
249
 
 
250
      subroutine smd_lat_rebox(n,c)
 
251
      implicit none
 
252
#include "errquit.fh"
 
253
#include "inp.fh"
 
254
#include "mafdecls.fh"
 
255
#include "rtdb.fh"
 
256
#include "util.fh"
 
257
#include "global.fh"
 
258
c     
 
259
      integer n
 
260
      double precision c(n,3)
 
261
c
 
262
      character*32 sp_lattice
 
263
c
 
264
      character*72 tag
 
265
      character*30 pname
 
266
      integer na
 
267
      integer i_c,i_lrc,i_lc
 
268
      logical result
 
269
 
 
270
      pname = "smd_lat_rebox"
 
271
c
 
272
c     get lattice params if any
 
273
c     -------------------------
 
274
      call smd_system_get_component(sp_lattice,"lattice",result)
 
275
      if(.not.result) then
 
276
        call util_warning(
 
277
     >       pname//'skipping reboxing as there is no lattice ',0,0)
 
278
        return
 
279
      end if
 
280
 
 
281
      tag = "lat:cell"
 
282
      call smd_data_get_index(sp_lattice,tag,i_lc,result)
 
283
      if(.not. result)
 
284
     >  call errquit(
 
285
     >       pname//'error getting index for '//tag,0, RTDB_ERR)
 
286
 
 
287
      tag = "lat:rcell"
 
288
      call smd_data_get_index(sp_lattice,tag,i_lrc,result)
 
289
      if(.not. result)
 
290
     >  call errquit(
 
291
     >       pname//'error getting index for '//tag,0, RTDB_ERR)
 
292
 
 
293
      call smd_util_rebox(n,
 
294
     >                    dbl_mb(i_lc),
 
295
     >                    dbl_mb(i_lrc),
 
296
     >                    c)
 
297
 
 
298
      return
 
299
      end