1
2c     **********************************
3c     *                                *
4c     *      ion_scaling_atoms_start   *
5c     *                                *
6c     **********************************
7      subroutine ion_scaling_atoms_start(rtdb)
8      implicit none
9      integer rtdb
10
11#include "bafdecls.fh"
12#include "btdb.fh"
13#include "errquit.fh"
14#include "ion_scaling_atoms.fh"
15
16      if(.not.btdb_get(rtdb,'nwpw:scaling_natms',
17     >                 mt_int,1,scaling_natms)) then
18         scaling_natms = -1
19      end if
20
21      if (scaling_natms.gt.0) then
22         if (.not.BA_alloc_get(mt_int,scaling_natms,
23     >           'ionscaling_atoms',scaling_atoms(2),scaling_atoms(1)))
24     >      call errquit('scaling_atoms_init:out of memory',0,MA_ERR)
25
26         if (.not.btdb_get(rtdb,'nwpw:scaling_atoms',
27     >                mt_int,scaling_natms,int_mb(scaling_atoms(1))))
28     >      call errquit('scaling_atoms_init',0,RTDB_ERR)
29      end if
30
31      return
32      end
33
34c     **********************************
35c     *                                *
36c     *      ion_scaling_atoms_end     *
37c     *                                *
38c     **********************************
39      subroutine ion_scaling_atoms_end()
40      implicit none
41
42#include "bafdecls.fh"
43#include "errquit.fh"
44#include "ion_scaling_atoms.fh"
45
46      if (scaling_natms.gt.0) then
47         if (.not.BA_free_heap(scaling_atoms(2)))
48     >      call errquit('scaling_atoms_init:freeing memory',0,MA_ERR)
49      end if
50      return
51      end
52
53
54c     **********************************
55c     *                                *
56c     *      ion_scaling_atoms_print   *
57c     *                                *
58c     **********************************
59      subroutine ion_scaling_atoms_print(luout)
60      implicit none
61      integer luout
62
63#include "bafdecls.fh"
64#include "ion_scaling_atoms.fh"
65
66      integer i
67
68      if (scaling_natms.gt.0) then
69        write(luout,10) (int_mb(scaling_atoms(1)+i-1),i=1,scaling_natms)
70      end if
71
72      return
73 10   FORMAT(5X, ' cooling/heating atoms: ',10I5)
74      end
75
76
77c     **********************************
78c     *                                *
79c     *      ion_scaling_atoms_natms   *
80c     *                                *
81c     **********************************
82      integer function ion_scaling_atoms_natms()
83      implicit none
84
85#include "ion_scaling_atoms.fh"
86
87      ion_scaling_atoms_natms = scaling_natms
88      return
89      end
90
91
92c     **********************************
93c     *                                *
94c     *      ion_scaling_atoms         *
95c     *                                *
96c     **********************************
97      subroutine ion_scaling_atoms(rti,nion,vion)
98      implicit none
99      real*8  rti
100      integer nion
101      real*8  vion(3,nion)
102
103#include "bafdecls.fh"
104#include "ion_scaling_atoms.fh"
105
106*     **** local variables ****
107      integer i,ii
108
109      if (scaling_natms.gt.0) then
110         do i=1,scaling_natms
111            ii = int_mb(scaling_atoms(1)+i-1)
112            vion(1,ii) = vion(1,ii)*rti
113            vion(2,ii) = vion(2,ii)*rti
114            vion(3,ii) = vion(3,ii)*rti
115         end do
116      else
117         call dscal(3*nion,rti,vion,1)
118      end if
119
120      return
121      end
122