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