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"
9c
10      character*32 sp_bond,sp_type,sp_bondlist
11      character*32 tag,pname
12      logical result
13
14      pname = "smd_bondlist_init_system"
15c
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
34200   continue
35      if(.not.result) then
36       tag = "bondlist"
37       call smd_system_unset_component(tag)
38      end if
39c
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"
51c
52      character*(*) sp_bondlist
53      integer rtdb
54c
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
74c
75      pname = "smd_bondlist_init"
76c
77c      write(*,*) "in "//pname
78c
79c     get array of types
80c     ------------------
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)
86c
87c     get bond arrays
88c     ---------------
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
120c
121c     allocate initial storage for bond list
122c     ---------------------------------------
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))
157c
158c     create bond list structure
159c     ---------------------------
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
176c
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
185200   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)
222c
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"
230c
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)
243c
244      integer i,i1,i2,j,nlist
245c
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
270c $Id$
271