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