← Back to branch summary

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

« back to all changes in this revision

Viewing changes to src/smd/smd-9-10-08/smd_bondlist.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/smd-9-10-08/smd_bondlist.F
1
 
      subroutine smd_bondlist_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_bondlist
11
 
      character*32 tag,pname
12
 
      logical result
13
 
 
14
 
      pname = "smd_bondlist_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 = "bondlist"
27
 
      call smd_system_get_component(sp_bondlist,tag,result)
28
 
      if(.not.result) 
29
 
     >  call errquit(
30
 
     >       pname//'no component '//tag,0,0)
31
 
 
32
 
      call smd_bondlist_init(sp_bondlist,result)
33
 
 
34
 
200   continue
35
 
      if(.not.result) then
36
 
       tag = "bondlist"
37
 
       call smd_system_unset_component(tag)
38
 
      end if
39
 
c
40
 
      return
41
 
      end
42
 
 
43
 
      subroutine smd_bondlist_init(sp_bondlist,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_bondlist
53
 
      integer rtdb
54
 
c
55
 
      character*32 pname
56
 
      character*80 tag
57
 
      character*255 filename
58
 
      integer na,nb,ns
59
 
      integer i_it
60
 
      integer i_kb
61
 
      integer i_ib1,i_ib2,i_db,i_itb
62
 
      integer h_il1t,i_il1t
63
 
      integer h_il2t,i_il2t
64
 
      integer h_dlt,i_dlt
65
 
      integer h_klt,i_klt
66
 
      integer h_tlt,i_tlt
67
 
      integer i_il1
68
 
      integer i_il2
69
 
      integer i_dl
70
 
      integer i_kl
71
 
      integer i_tl
72
 
      logical result
73
 
      integer i
74
 
c
75
 
      pname = "smd_bondlist_init"
76
 
c
77
 
c      write(*,*) "in "//pname
78
 
c
79
 
c     get array of types
80
 
c     ------------------
81
 
      tag = "type:id"
82
 
      call smd_get_ind_dim(tag,i_it,na,result)
83
 
      if(.not. result) 
84
 
     >  call errquit(
85
 
     >       pname//'error getting index for'//tag,0, RTDB_ERR)
86
 
c
87
 
c     get bond arrays
88
 
c     ---------------
89
 
      tag = "bond:i1"
90
 
      call smd_get_ind(tag,i_ib1,result)
91
 
      if(.not. result) 
92
 
     >  call errquit(
93
 
     >       pname//'error getting index for '//tag,0, 0)
94
 
 
95
 
      tag = "bond:i2"
96
 
      call smd_get_ind(tag,i_ib2,result)
97
 
      if(.not. result) 
98
 
     >  call errquit(
99
 
     >       pname//'error getting index for '//tag,0, 0)
100
 
 
101
 
      tag = "bond:distance"
102
 
      call smd_get_ind(tag,i_db,result)
103
 
      if(.not. result) 
104
 
     >  call errquit(
105
 
     >       pname//'error getting index for '//tag,0, 0)
106
 
 
107
 
      tag = "bond:strength"
108
 
      call smd_get_ind(tag,i_kb,result)
109
 
      if(.not. result) 
110
 
     >  call errquit(
111
 
     >       pname//'error getting index for '//tag,0, 0)
112
 
 
113
 
 
114
 
      tag = "bond:type"
115
 
      call smd_get_ind_dim(tag,i_itb,nb,result)
116
 
      if(.not. result) 
117
 
     >  call errquit(
118
 
     >       pname//'error getting index for '//tag,0, 0)
119
 
 
120
 
c
121
 
c     allocate initial storage for bond list
122
 
c     ---------------------------------------
123
 
      ns = na
124
 
      if(.not.ma_push_get(mt_int,ns,'tmp i1',h_il1t,i_il1t))
125
 
     + call errquit(pname//'Failed to allocate memory',
126
 
     + 0, MA_ERR)
127
 
 
128
 
      if(.not.ma_push_get(mt_int,ns,'tmp i2',h_il2t,i_il2t))
129
 
     + call errquit(pname//'Failed to allocate memory',
130
 
     + 0, MA_ERR)
131
 
 
132
 
      if(.not.ma_push_get(mt_dbl,ns,'tmp d',h_dlt,i_dlt))
133
 
     + call errquit(pname//'Failed to allocate memory',
134
 
     + 0, MA_ERR)
135
 
 
136
 
      if(.not.ma_push_get(mt_dbl,ns,'tmp k',h_klt,i_klt))
137
 
     + call errquit(pname//'Failed to allocate memory',
138
 
     + 0, MA_ERR)
139
 
 
140
 
      if(.not.ma_push_get(mt_int,ns,'tmp t',h_tlt,i_tlt))
141
 
     + call errquit(pname//'Failed to allocate memory',
142
 
     + 0, MA_ERR)
143
 
 
144
 
 
145
 
      call smd_bondlist_set(ns,nb,na,
146
 
     >                       int_mb(i_il1t),
147
 
     >                       int_mb(i_il2t),
148
 
     >                       int_mb(i_tlt),
149
 
     >                       dbl_mb(i_dlt),
150
 
     >                       dbl_mb(i_klt),
151
 
     >                       int_mb(i_ib1),
152
 
     >                       int_mb(i_ib2),
153
 
     >                       int_mb(i_itb),
154
 
     >                       dbl_mb(i_db),
155
 
     >                       dbl_mb(i_kb),
156
 
     >                       int_mb(i_it))
157
 
c
158
 
c     create bond list structure
159
 
c     ---------------------------
160
 
      if(ns.eq.0) then
161
 
        result = .false.
162
 
        goto 200
163
 
      end if
164
 
      call smd_namespace_create(sp_bondlist)
165
 
      tag = "bond:i1"
166
 
      call smd_data_create_get(sp_bondlist,tag,ns,MT_INT,i_il1)
167
 
      tag = "bond:i2"
168
 
      call smd_data_create_get(sp_bondlist,tag,ns,MT_INT,i_il2)
169
 
      tag = "bond:distance"
170
 
      call smd_data_create_get(sp_bondlist,tag,ns,MT_DBL,i_dl)
171
 
      tag = "bond:strength"
172
 
      call smd_data_create_get(sp_bondlist,tag,ns,MT_DBL,i_kl)
173
 
      tag = "bond:type"
174
 
      call smd_data_create_get(sp_bondlist,tag,ns,MT_INT,i_tl)
175
 
 
176
 
c
177
 
      do i=1,ns
178
 
       int_mb(i_il1+i-1) = int_mb(i_il1t+i-1)
179
 
       int_mb(i_il2+i-1) = int_mb(i_il2t+i-1)
180
 
       int_mb(i_tl+i-1)  = int_mb(i_tlt+i-1)
181
 
       dbl_mb(i_dl+i-1)  = dbl_mb(i_dlt+i-1)
182
 
       dbl_mb(i_kl+i-1)  = dbl_mb(i_klt+i-1)
183
 
      end do
184
 
 
185
 
200   continue
186
 
 
187
 
      if(.not.ma_pop_stack(h_tlt))
188
 
     & call errquit(pname//'Failed to deallocate stack',0,
189
 
     &       MA_ERR)
190
 
 
191
 
      if(.not.ma_pop_stack(h_klt))
192
 
     & call errquit(pname//'Failed to deallocate stack',0,
193
 
     &       MA_ERR)
194
 
 
195
 
      if(.not.ma_pop_stack(h_dlt))
196
 
     & call errquit(pname//'Failed to deallocate stack',0,
197
 
     &       MA_ERR)
198
 
 
199
 
      if(.not.ma_pop_stack(h_il2t))
200
 
     & call errquit(pname//'Failed to deallocate stack',0,
201
 
     &       MA_ERR)
202
 
 
203
 
      if(.not.ma_pop_stack(h_il1t))
204
 
     & call errquit(pname//'Failed to deallocate stack',0,
205
 
     &       MA_ERR)
206
 
 
207
 
      return
208
 
      end
209
 
 
210
 
      subroutine smd_bondlist_set(ns,nb,na,
211
 
     >                       il1,
212
 
     >                       il2,
213
 
     >                       itl,
214
 
     >                       dl,
215
 
     >                       kl,
216
 
     >                       ib1,
217
 
     >                       ib2,
218
 
     >                       itb,
219
 
     >                       db,
220
 
     >                       kb,
221
 
     >                       it)
222
 
c
223
 
      implicit none
224
 
#include "errquit.fh"
225
 
#include "inp.fh"
226
 
#include "mafdecls.fh"
227
 
#include "rtdb.fh"
228
 
#include "util.fh"
229
 
#include "global.fh"
230
 
c
231
 
      integer ns,nb,na
232
 
      integer il1(ns)
233
 
      integer il2(ns)
234
 
      integer itl(ns)
235
 
      double precision  dl(ns)
236
 
      double precision  kl(ns)
237
 
      integer ib1(nb)
238
 
      integer ib2(nb)
239
 
      integer itb(nb)
240
 
      double precision  db(ns)
241
 
      double precision  kb(ns)
242
 
      integer it(na)
243
 
c
244
 
      integer i,i1,i2,j,nlist
245
 
c
246
 
      nlist = 0
247
 
      do i=1,nb
248
 
        i1=0
249
 
        i2=0
250
 
        do j=1,na
251
 
         if(it(j).eq.ib1(i)) i1=j
252
 
         if(it(j).eq.ib2(i)) i2=j
253
 
         if(i1*i2.ne.0) then
254
 
          nlist = nlist + 1
255
 
          il1(nlist) = min(i1,i2)
256
 
          il2(nlist) = max(i1,i2)
257
 
          itl(nlist) = itb(i)
258
 
          kl(nlist)  = kb(i)
259
 
          dl(nlist)  = db(i)
260
 
          i1=0
261
 
          i2=0
262
 
         end if
263
 
        end do
264
 
      end do
265
 
      ns = nlist
266
 
 
267
 
      return
268
 
      end
269