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