← Back to branch summary

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

« back to all changes in this revision

Viewing changes to src/smd/smdlib/smd_shakelist.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/smdlib/smd_shakelist.F
 
1
      subroutine smd_shakelist_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_bond,sp_type,sp_shakelist
 
11
      character*32 tag,pname
 
12
      logical result
 
13
 
 
14
      pname = "smd_shakelist_init_system"
 
15
c
 
16
      tag = "bond"
 
17
      call smd_system_get_component(sp_bond,tag,result)
 
18
      if(.not.result) goto 200
 
19
 
 
20
      tag = "type"
 
21
      call smd_system_get_component(sp_type,tag,result)
 
22
      if(.not.result)
 
23
     >  call errquit(
 
24
     >       pname//'no component '//tag,0,0)
 
25
 
 
26
      tag = "shakelist"
 
27
      call smd_system_get_component(sp_shakelist,tag,result)
 
28
      if(.not.result) 
 
29
     >  call errquit(
 
30
     >       pname//'no component '//tag,0,0)
 
31
 
 
32
      call smd_shakelist_init(sp_shakelist,result)
 
33
 
 
34
200   continue
 
35
      if(.not.result) then
 
36
       tag = "shakelist"
 
37
       call smd_system_unset_component(tag)
 
38
      end if
 
39
c
 
40
      return
 
41
      end
 
42
 
 
43
      subroutine smd_shakelist_init(sp_shakelist,result)
 
44
      implicit none
 
45
#include "errquit.fh"
 
46
#include "inp.fh"
 
47
#include "mafdecls.fh"
 
48
#include "rtdb.fh"
 
49
#include "util.fh"
 
50
#include "global.fh"
 
51
c     
 
52
      character*(*) sp_shakelist
 
53
      integer rtdb
 
54
      logical result
 
55
c
 
56
      character*32 pname
 
57
      character*80 tag
 
58
      character*255 filename
 
59
      integer na,nb,ns
 
60
      integer i_it
 
61
      integer i_ib1,i_ib2,i_db,i_itb
 
62
      integer h_is1t,i_is1t
 
63
      integer h_is2t,i_is2t
 
64
      integer h_dst,i_dst
 
65
      integer i_is1
 
66
      integer i_is2
 
67
      integer i_ds
 
68
      integer i
 
69
c
 
70
      pname = "smd_shakelist_init"
 
71
c
 
72
c      write(*,*) "in "//pname
 
73
c
 
74
c     get array of types
 
75
c     ------------------
 
76
      tag = "type:id"
 
77
      call smd_get_ind_dim(tag,i_it,na,result)
 
78
      if(.not. result) 
 
79
     >  call errquit(
 
80
     >       pname//'error getting index for'//tag,0, RTDB_ERR)
 
81
c
 
82
c     get bond arrays
 
83
c     ---------------
 
84
      tag = "bond:i1"
 
85
      call smd_get_ind(tag,i_ib1,result)
 
86
      if(.not. result) 
 
87
     >  call errquit(
 
88
     >       pname//'error getting index for '//tag,0, 0)
 
89
 
 
90
      tag = "bond:i2"
 
91
      call smd_get_ind(tag,i_ib2,result)
 
92
      if(.not. result) 
 
93
     >  call errquit(
 
94
     >       pname//'error getting index for '//tag,0, 0)
 
95
 
 
96
      tag = "bond:distance"
 
97
      call smd_get_ind(tag,i_db,result)
 
98
      if(.not. result) 
 
99
     >  call errquit(
 
100
     >       pname//'error getting index for '//tag,0, 0)
 
101
 
 
102
      tag = "bond:type"
 
103
      call smd_get_ind_dim(tag,i_itb,nb,result)
 
104
      if(.not. result) 
 
105
     >  call errquit(
 
106
     >       pname//'error getting index for '//tag,0, 0)
 
107
 
 
108
 
 
109
c
 
110
c     allocate initial storage for shake list
 
111
c     ---------------------------------------
 
112
      ns = na
 
113
      if(.not.ma_push_get(mt_int,ns,'tmp i1',h_is1t,i_is1t))
 
114
     + call errquit(pname//'Failed to allocate memory',
 
115
     + 0, MA_ERR)
 
116
 
 
117
      if(.not.ma_push_get(mt_int,ns,'tmp i2',h_is2t,i_is2t))
 
118
     + call errquit(pname//'Failed to allocate memory',
 
119
     + 0, MA_ERR)
 
120
 
 
121
      if(.not.ma_push_get(mt_dbl,ns,'tmp d',h_dst,i_dst))
 
122
     + call errquit(pname//'Failed to allocate memory',
 
123
     + 0, MA_ERR)
 
124
 
 
125
 
 
126
      call smd_shakelist_set(ns,nb,na,
 
127
     >                       int_mb(i_is1t),
 
128
     >                       int_mb(i_is2t),
 
129
     >                       dbl_mb(i_dst),
 
130
     >                       int_mb(i_ib1),
 
131
     >                       int_mb(i_ib2),
 
132
     >                       int_mb(i_itb),
 
133
     >                       dbl_mb(i_db),
 
134
     >                       int_mb(i_it))
 
135
c
 
136
c     create shake list structure
 
137
c     ---------------------------
 
138
      if(ns.eq.0) then
 
139
        result = .false.
 
140
        goto 200
 
141
      end if
 
142
      call smd_namespace_create(sp_shakelist)
 
143
      tag = "shake:i1"
 
144
      call smd_data_create_get(sp_shakelist,tag,ns,MT_INT,i_is1)
 
145
      tag = "shake:i2"
 
146
      call smd_data_create_get(sp_shakelist,tag,ns,MT_INT,i_is2)
 
147
      tag = "shake:distance"
 
148
      call smd_data_create_get(sp_shakelist,tag,ns,MT_DBL,i_ds)
 
149
 
 
150
      do i=1,ns
 
151
       int_mb(i_is1+i-1) = int_mb(i_is1t+i-1)
 
152
       int_mb(i_is2+i-1) = int_mb(i_is2t+i-1)
 
153
       dbl_mb(i_ds+i-1)  = dbl_mb(i_dst+i-1)
 
154
      end do
 
155
 
 
156
200   continue
 
157
      if(.not.ma_pop_stack(h_dst))
 
158
     & call errquit(pname//'Failed to deallocate stack',0,
 
159
     &       MA_ERR)
 
160
 
 
161
      if(.not.ma_pop_stack(h_is2t))
 
162
     & call errquit(pname//'Failed to deallocate stack',0,
 
163
     &       MA_ERR)
 
164
 
 
165
      if(.not.ma_pop_stack(h_is1t))
 
166
     & call errquit(pname//'Failed to deallocate stack',0,
 
167
     &       MA_ERR)
 
168
 
 
169
      return
 
170
      end
 
171
 
 
172
      subroutine smd_shakelist_set(ns,nb,na,
 
173
     >                       is1,
 
174
     >                       is2,
 
175
     >                       ds,
 
176
     >                       ib1,
 
177
     >                       ib2,
 
178
     >                       itb,
 
179
     >                       db,
 
180
     >                       it)
 
181
c
 
182
      implicit none
 
183
#include "errquit.fh"
 
184
#include "inp.fh"
 
185
#include "mafdecls.fh"
 
186
#include "rtdb.fh"
 
187
#include "util.fh"
 
188
#include "global.fh"
 
189
c
 
190
      integer ns,nb,na
 
191
      integer is1(ns)
 
192
      integer is2(ns)
 
193
      double precision  ds(ns)
 
194
      integer ib1(nb)
 
195
      integer ib2(nb)
 
196
      integer itb(nb)
 
197
      double precision  db(ns)
 
198
      integer it(na)
 
199
c
 
200
      integer i,i1,i2,j,nlist
 
201
c
 
202
      nlist = 0
 
203
      do i=1,nb
 
204
       if(itb(i).eq.1) then
 
205
        i1=0
 
206
        i2=0
 
207
        do j=1,na
 
208
         if(it(j).eq.ib1(i)) i1=j
 
209
         if(it(j).eq.ib2(i)) i2=j
 
210
         if(i1*i2.ne.0) then
 
211
          nlist = nlist + 1
 
212
          is1(nlist) = min(i1,i2)
 
213
          is2(nlist) = max(i1,i2)
 
214
          ds(nlist)  = db(i)
 
215
          i1=0
 
216
          i2=0
 
217
         end if
 
218
        end do
 
219
       end if
 
220
      end do
 
221
      ns = nlist
 
222
 
 
223
      return
 
224
      end
 
225
 
 
226
c $Id: smd_shakelist.F 21176 2011-10-10 06:35:49Z d3y133 $