1 2* ********************************************************** 3* * * 4* * nwpw_expression_compile * 5* * * 6* ********************************************************** 7* 8* This function compiles the eqnstring into emachine code and stores it 9* on the rtdb 10* 11* Entry - rtdb: rtdb id 12* eqnstring: string that constains expression 13* Exit - returns an Id identifying the emachine 14* 15 integer function nwpw_expression_compile(rtdb,eqnstring) 16 implicit none 17 integer rtdb 18 character*(*) eqnstring 19 20#include "bafdecls.fh" 21#include "inp.fh" 22#include "btdb.fh" 23#include "util.fh" 24#include "errquit.fh" 25#include "stdio.fh" 26 27* **** local variables **** 28 logical value,dprint 29 real*8 fconst(50) 30 integer code(5,200),i,nf,nc,print_level,nemach,n1 31 character*80 rtdb_name 32 33* **** external functions **** 34 character*7 c_index_name 35 external c_index_name 36 37 call util_print_get_level(print_level) 38 dprint = (print_debug.le.print_level) 39 40* **** parse the eqnstring **** 41 n1 = inp_strlen(eqnstring) 42 call nwpw_emachine_parse(eqnstring,n1,nc,code,nf,fconst) 43 44 if (dprint) then 45 write(luout,'(A,A)') "eqnstring = ",trim(eqnstring) 46 write(luout,*) 47 do i=1,nc 48 write(luout,'(A,I3,A,5I6)') "emachine: ln=",i-1," code=", 49 > code(1,i),code(2,i), 50 > code(3,i),code(4,i),code(5,i) 51 end do 52 write(luout,*) 53 do i=1,nf 54 write(luout,'("emachine: fconst(",I3,")=",E15.6)') 55 > i-1,fconst(i) 56 end do 57 write(luout,*) 58 write(luout,*) 59 end if 60 61* ***** read number of emachines on rtdb **** 62 rtdb_name = 'nwpw:emachine:nemach' 63 if (.not.btdb_get(rtdb,rtdb_name,mt_int,1,nemach)) nemach = 0 64 65* ***** write emachine data to rtdb ***** 66 nemach = nemach + 1 67 value = btdb_put(rtdb,rtdb_name,mt_int,1,nemach) 68 69 rtdb_name = 'nwpw:emachine:eqnstring'//c_index_name(nemach) 70 value = value.and.btdb_cput(rtdb,rtdb_name,1,eqnstring) 71 72 rtdb_name = 'nwpw:emachine:nc'//c_index_name(nemach) 73 value = value.and.btdb_put(rtdb,rtdb_name,mt_int,1,nc) 74 75 rtdb_name = 'nwpw:emachine:nf'//c_index_name(nemach) 76 value = value.and.btdb_put(rtdb,rtdb_name,mt_int,1,nf) 77 78 rtdb_name = 'nwpw:emachine:code'//c_index_name(nemach) 79 value = value.and.btdb_put(rtdb,rtdb_name,mt_int,5*nc,code) 80 81 rtdb_name = 'nwpw:emachine:fconst'//c_index_name(nemach) 82 value = value.and.btdb_put(rtdb,rtdb_name,mt_dbl,nf,fconst) 83 if (.not.value) 84 > call errquit( 85 > 'nwpw_expression_compile:error writing emachine',0,RTDB_ERR) 86 87 nwpw_expression_compile = nemach 88 return 89 end 90 91* ********************************************************** 92* * * 93* * nwpw_expression_reset * 94* * * 95* ********************************************************** 96 subroutine nwpw_expression_reset(rtdb) 97 implicit none 98 integer rtdb 99 100#include "btdb.fh" 101#include "errquit.fh" 102 103 logical value 104 character*80 rtdb_name 105 106 rtdb_name = 'nwpw:emachine:nemach' 107 value = rtdb_delete(rtdb,rtdb_name) 108 109 return 110 end 111 112 113 114* ********************************************************** 115* * * 116* * nwpw_expression_start * 117* * * 118* ********************************************************** 119 subroutine nwpw_expression_start(rtdb) 120 implicit none 121 integer rtdb 122 123#include "bafdecls.fh" 124#include "inp.fh" 125#include "btdb.fh" 126#include "util.fh" 127#include "errquit.fh" 128 129 logical started 130 integer nc(2),nf(2),code(2),fconst(2) 131 common /nwpw_expression/ nc,nf,code,fconst,started 132 133* **** local variables **** 134 logical value 135 integer i,nemach 136 character*80 rtdb_name 137 138* **** external functions **** 139 character*7 c_index_name 140 external c_index_name 141 142 rtdb_name = 'nwpw:emachine:started' 143 if (.not.btdb_get(rtdb,rtdb_name,mt_log,1,started)) 144 > started=.false. 145 146* ***** read number of emachines on rtdb **** 147 rtdb_name = 'nwpw:emachine:nemach' 148 if (.not.btdb_get(rtdb,rtdb_name,mt_int,1,nemach)) nemach = 0 149 150 if ((.not.started).and.(nemach.gt.0)) then 151 started = .true. 152 153 154* ***** allocate and read pmeta,ameta,bmeta,parammeta, and ymeta **** 155 value = BA_alloc_get(mt_int,nemach,'emachine:nc',nc(2),nc(1)) 156 value = value.and. 157 > BA_alloc_get(mt_int,nemach,'emachine:nf',nf(2),nf(1)) 158 value = value.and. 159 > BA_alloc_get(mt_int,5*200*nemach,'emachine:code', 160 > code(2),code(1)) 161 value = value.and. 162 > BA_alloc_get(mt_dbl,50*nemach,'emachine:fconst', 163 > fconst(2),fconst(1)) 164 if (.not.value) 165 > call errquit( 166 > 'nwpw_expression_start:out of heap',0,MA_ERR) 167 168 do i=1,nemach 169 rtdb_name = 'nwpw:emachine:nc'//c_index_name(i) 170 value = value.and. 171 > btdb_get(rtdb,rtdb_name,mt_int,1,int_mb(nc(1)+i-1)) 172 173 rtdb_name = 'nwpw:emachine:nf'//c_index_name(i) 174 value = value.and. 175 > btdb_get(rtdb,rtdb_name,mt_int,1,int_mb(nf(1)+i-1)) 176 177 rtdb_name = 'nwpw:emachine:code'//c_index_name(i) 178 value = value.and. 179 > btdb_get(rtdb,rtdb_name,mt_int, 180 > 5*int_mb(nc(1)+i-1), 181 > int_mb(code(1)+(i-1)*5*200)) 182 183 rtdb_name = 'nwpw:emachine:fconst'//c_index_name(i) 184 value = value.and. 185 > btdb_get(rtdb,rtdb_name,mt_dbl,int_mb(nf(1)+i-1), 186 > dbl_mb(fconst(1)+(i-1)*50)) 187 end do 188 189* **** write started *** 190 rtdb_name = 'nwpw:emachine:started' 191 value = value.and.btdb_put(rtdb,rtdb_name,mt_log,1,started) 192 if (.not.value) 193 > call errquit( 194 > 'nwpw_expression_start:starting emachine',0,RTDB_ERR) 195 196 end if 197 198 return 199 end 200 201 202* ********************************************************** 203* * * 204* * nwpw_expression_end * 205* * * 206* ********************************************************** 207 subroutine nwpw_expression_end(rtdb) 208 implicit none 209 integer rtdb 210 211#include "bafdecls.fh" 212#include "btdb.fh" 213#include "errquit.fh" 214 215 logical started 216 integer nc(2),nf(2),code(2),fconst(2) 217 common /nwpw_expression/ nc,nf,code,fconst,started 218 219* **** local variables **** 220 logical value 221 character*80 rtdb_name 222 223 rtdb_name = 'nwpw:emachine:started' 224 value = rtdb_delete(rtdb,rtdb_name) 225 226 if (started) then 227 value = BA_free_heap(nc(2)) 228 value = value.and.BA_free_heap(nf(2)) 229 value = value.and.BA_free_heap(code(2)) 230 value = value.and.BA_free_heap(fconst(2)) 231 if (.not.value) 232 > call errquit( 233 > 'nwpw_expression_end:error calling rtdb_delete',0,RTDB_ERR) 234 end if 235 236 return 237 end 238 239* ********************************************************** 240* * * 241* * nwpw_expression_eqnstring * 242* * * 243* ********************************************************** 244* 245* returns eqnstring. 246* Warning - If called from serial than btdb_parallel must me turned off 247* 248 subroutine nwpw_expression_eqnstring(rtdb,i,eqnstring) 249 implicit none 250 integer rtdb 251 integer i 252 character*(*) eqnstring 253 254#include "btdb.fh" 255#include "errquit.fh" 256 257* **** external functions **** 258 character*7 c_index_name 259 external c_index_name 260 261 if (.not.btdb_cget(rtdb, 262 > 'nwpw:emachine:eqnstring'//c_index_name(i), 263 > 1,eqnstring)) 264 > call errquit( 265 > 'nwpw_expression_eqnstring:error calling btdb_cget',0,RTDB_ERR) 266 267 return 268 end 269 270* ********************************************************** 271* * * 272* * nwpw_expression_f * 273* * * 274* ********************************************************** 275* 276 real*8 function nwpw_expression_f(i,nion,rion) 277 implicit none 278 integer i 279 integer nion 280 real*8 rion(3,*) 281 282#include "bafdecls.fh" 283#include "inp.fh" 284#include "btdb.fh" 285#include "util.fh" 286#include "errquit.fh" 287 288 logical started 289 integer nc(2),nf(2),code(2),fconst(2) 290 common /nwpw_expression/ nc,nf,code,fconst,started 291 292* **** local variables **** 293 real*8 f 294 295* **** external functions **** 296 real*8 nwpw_emachine_f 297 external nwpw_emachine_f 298 299 f = 0.0 300 if (started) then 301 f = nwpw_emachine_f(int_mb(nc(1)+i-1), 302 > int_mb(code(1)+(i-1)*5*200), 303 > int_mb(nf(1)+i-1), 304 > dbl_mb(fconst(1)+(i-1)*50), 305 > nion,rion) 306 end if 307 308 nwpw_expression_f = f 309 return 310 end 311 312 313* ********************************************************** 314* * * 315* * nwpw_expression_fion * 316* * * 317* ********************************************************** 318* 319 subroutine nwpw_expression_fion(alpha,i,nion,rion,fion) 320 implicit none 321 real*8 alpha 322 integer i 323 integer nion 324 real*8 rion(3,*) 325 real*8 fion(3,*) 326 327#include "bafdecls.fh" 328#include "inp.fh" 329#include "btdb.fh" 330#include "util.fh" 331#include "errquit.fh" 332 333 logical started 334 integer nc(2),nf(2),code(2),fconst(2) 335 common /nwpw_expression/ nc,nf,code,fconst,started 336 337* **** local variables **** 338 integer i0,ii0 339 real*8 df 340 341* **** external functions **** 342 real*8 nwpw_emachine_df 343 external nwpw_emachine_df 344 345 if (started) then 346 do ii0 = 1,nion 347 do i0=1,3 348 df = nwpw_emachine_df(i0,ii0, 349 > int_mb(nc(1)+i-1), 350 > int_mb(code(1)+(i-1)*5*200), 351 > int_mb(nf(1)+i-1), 352 > dbl_mb(fconst(1)+(i-1)*50), 353 > nion,rion) 354 fion(i0,ii0) = fion(i0,ii0) - alpha*df 355 end do 356 end do 357 end if 358 359 return 360 end 361 362