1 2c $Id$ 3 4* ************************************************ 5* * * 6* * cpsp_projector_init * 7* * * 8* ************************************************ 9 subroutine cpsp_projector_init(npsp0) 10 implicit none 11 integer npsp0 12 13#include "bafdecls.fh" 14#include "cpsp_projector.fh" 15#include "errquit.fh" 16 17* **** local variables **** 18 logical value 19 integer ltag 20 21* **** external functions **** 22 logical control_brillioun_ondisk 23 external control_brillioun_ondisk 24 25 brill_ondisk = control_brillioun_ondisk() 26 curr_nb = 1 27 28 npsp = npsp0 29 tagmax = 0 30 31 value = BA_alloc_get(mt_int,npsp,'nsize_prj', 32 > nsize_prj(2),nsize_prj(1)) 33 value = value.and.BA_alloc_get(mt_int,npsp,'nprj_prj', 34 > nprj_prj(2),nprj_prj(1)) 35 value = value.and.BA_alloc_get(mt_int,npsp,'nbrill_prj', 36 > nbrill_prj(2),nbrill_prj(1)) 37 value = value.and.BA_alloc_get(mt_int,npsp,'indx_prj', 38 > indx_prj(2),indx_prj(1)) 39 value = value.and.BA_alloc_get(mt_int,npsp,'hndl_prj', 40 > hndl_prj(2),hndl_prj(1)) 41 value = value.and.BA_alloc_get(mt_int,npsp,'list_prj', 42 > list_prj(2),list_prj(1)) 43 if (.not.value) 44 > call errquit('cpsp_projector_init: out of heap memory',0,MA_ERR) 45 46 do ltag=0,npsp-1 47 int_mb(list_prj(1)+ltag) = ltag 48 end do 49 50 return 51 end 52 53* ************************************************ 54* * * 55* * cpsp_projector_alloc * 56* * * 57* ************************************************ 58* 59 integer function cpsp_projector_alloc(nbrill,nprj,nsize) 60 implicit none 61 integer nbrill,nprj,nsize 62 63#include "bafdecls.fh" 64#include "cpsp_projector.fh" 65#include "errquit.fh" 66 67* ***** local variables **** 68 logical value 69 integer tag,hndl,indx 70 71 tag = int_mb(list_prj(1)+tagmax) 72 int_mb(nbrill_prj(1)+tag) = nbrill 73 int_mb(nprj_prj(1)+tag) = nprj 74 int_mb(nsize_prj(1)+tag) = nsize 75 76 value = BA_alloc_get(mt_dbl,nbrill*nprj*nsize, 77 > 'prj_alloc',hndl,indx) 78 if (.not.value) 79 > call errquit('cpsp_projector_alloc: out of heap memory',0,MA_ERR) 80 81 int_mb(indx_prj(1)+tag) = indx 82 int_mb(hndl_prj(1)+tag) = hndl 83 84 tagmax = tagmax + 1 85 86 cpsp_projector_alloc = tag 87 return 88 end 89 90* ************************************************ 91* * * 92* * cpsp_projector_dealloc * 93* * * 94* ************************************************ 95 96 subroutine cpsp_projector_dealloc(tagin) 97 implicit none 98 integer tagin 99 100#include "bafdecls.fh" 101#include "cpsp_projector.fh" 102#include "errquit.fh" 103 104* **** local variables **** 105 integer ltagin,taglast,hndl 106 107 hndl = int_mb(hndl_prj(1)+tagin) 108 if (.not.BA_free_heap(hndl)) 109 >call errquit('cpsp_projector_dealloc:error freeing heap',0,MA_ERR) 110 111 tagmax = tagmax - 1 112 taglast = int_mb(list_prj(1)+tagmax) 113 114* **** swap list_prj(tagin) with list_prj(tagmax) *** 115 if (tagin.ne.taglast) then 116 !*** find where tagin is in the list **** 117 ltagin = 0 118 do while (int_mb(list_prj(1)+ltagin).ne.tagin) 119 ltagin = ltagin + 1 120 end do 121 if (ltagin.gt.tagmax) 122 > call errquit('cpsp_projector_dealloc:cannot find tagin',tagin,0) 123 int_mb(list_prj(1) + ltagin) = int_mb(list_prj(1) + tagmax) 124 int_mb(list_prj(1) + tagmax) = tagin 125 end if 126 return 127 end 128 129 130* ************************************************ 131* * * 132* * cpsp_projector_end * 133* * * 134* ************************************************ 135* 136 subroutine cpsp_projector_end() 137 implicit none 138 139#include "bafdecls.fh" 140#include "cpsp_projector.fh" 141#include "errquit.fh" 142 143* ***** local variables **** 144 logical value 145 integer tag,ltag,hndl,indx 146 147 value = .true. 148 do ltag=0,tagmax-1 149 tag = int_mb(list_prj(1)+ltag) 150 hndl = int_mb(hndl_prj(1)+tag) 151 value = value.and.BA_free_heap(hndl) 152 end do 153 value = value.and.BA_free_heap(nbrill_prj(2)) 154 value = value.and.BA_free_heap(nprj_prj(2)) 155 value = value.and.BA_free_heap(nsize_prj(2)) 156 value = value.and.BA_free_heap(indx_prj(2)) 157 value = value.and.BA_free_heap(hndl_prj(2)) 158 value = value.and.BA_free_heap(list_prj(2)) 159 if (.not.value) 160 > call errquit('cpsp_projector_end:error freeing heap',0,MA_ERR) 161 162 return 163 end 164 165* ************************************************ 166* * * 167* * cpsp_projector_add * 168* * * 169* ************************************************ 170* 171 subroutine cpsp_projector_add(tag,nb,n,proj) 172 implicit none 173 integer tag,nb,n 174 real*8 proj(*) 175 176#include "bafdecls.fh" 177#include "cpsp_projector.fh" 178#include "errquit.fh" 179 180* ***** local variables **** 181 integer indx,nprj,nsize,shift 182 183 indx = int_mb(indx_prj(1)+tag) 184 nprj = int_mb(nprj_prj(1)+tag) 185 nsize = int_mb(nsize_prj(1)+tag) 186 187 curr_nb = nb 188c if (brill_ondisk) then 189c shift = indx + ((nb-1)*nprj + (n-1))*nsize 190c .... add to local diskfile *** 191c else 192c shift = indx + ((n-1))*nsize 193c end if 194 195 shift = indx + ((nb-1)*nprj + (n-1))*nsize 196 call dcopy(nsize,proj,1,dbl_mb(shift),1) 197 198 return 199 end 200 201* ************************************************ 202* * * 203* * cpsp_projector_get_ptr * 204* * * 205* ************************************************ 206* 207 integer function cpsp_projector_get_ptr(tag,nb,n) 208 implicit none 209 integer tag,nb,n 210 211#include "bafdecls.fh" 212#include "cpsp_projector.fh" 213#include "errquit.fh" 214 215* ***** local variables **** 216 integer indx,nprj,nsize,shift 217 218 indx = int_mb(indx_prj(1)+tag) 219 nprj = int_mb(nprj_prj(1)+tag) 220 nsize = int_mb(nsize_prj(1)+tag) 221 cpsp_projector_get_ptr = indx + ((nb-1)*nprj + (n-1))*nsize 222 return 223 end 224