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