1      subroutine add_block(d_file,array,size,offset)
2c
3c $Id$
4c
5c     This subroutine reads a section of a file and adds
6c     the content of an array to it and write it back to
7c     the original place in the file.  Note that two or more
8c     different processes can read/add/write to the same
9c     section, the entire read/add/write must be protected
10c     from interruption.
11c
12      implicit none
13#include "global.fh"
14#include "mafdecls.fh"
15#include "sf.fh"
16#include "eaf.fh"
17#include "util.fh"
18#include "stdio.fh"
19#include "errquit.fh"
20#include "tce.fh"
21#include "tce_main.fh"
22      integer d_file
23      integer d_f
24      integer size
25      integer offset
26      double precision array(size)
27      integer l_temp,k_temp
28      integer request
29      integer i,j
30      logical used
31      double precision element
32      character*255 filename
33      logical parallel
34c
35      cpusecs(4) = cpusecs(4) - util_cpusec()
36      cpusecs(54) = cpusecs(54) - util_wallsec()
37      parallel = (ga_nnodes().gt.1)
38      if (util_print('add_block',print_debug)) then
39         write(LuOut,9000) ga_nodeid(),d_file,size,offset
40      endif
41      if (offset .eq. -1)
42     1  call errquit('add_block: illegal offset',0,UNKNOWN_ERR)
43      if (ioalg.eq.0) then
44        if (parallel) call ga_lock(0)
45        used = .false.
46        do i = 1,nfiles
47          if (filehandles(i) .eq. d_file) then
48            j = i
49            used = .true.
50          endif
51        enddo
52        if (.not.used) call errquit('add_block: invalid handle',d_file,
53     1    UNKNOWN_ERR)
54        if (parallel) open(d_file,file=filenames(j),
55     1    access='direct',recl=bytes)
56        do i = 1,size
57          read(d_file,rec=offset+i) element
58          write(d_file,rec=offset+i) array(i)+element
59        enddo
60        if (parallel) then
61          close(d_file)
62          call ga_unlock(0)
63        endif
64      else if (ioalg.eq.1) then
65        if (.not.ma_push_get(mt_dbl,size,'temporary',
66     1    l_temp,k_temp))
67     2    call errquit('add_block: MA problem',0,MA_ERR)
68        if (parallel) then
69          used = .false.
70          do i = 1,nfiles
71            if (filehandles(i) .eq. d_file) then
72              j = i
73              used = .true.
74            endif
75          enddo
76          filename = filenames(j)
77          call ga_lock(0)
78          if (eaf_open(filename, EAF_RW, d_f).ne.0)
79     1      call errquit('add_block: eaf problem',2,DISK_ERR)
80          if (eaf_read(d_f,dfloat(bytes)*dfloat(offset),
81     1      dbl_mb(k_temp),bytes*size).ne.0)
82     2      call errquit('add_block: eaf problem',2,DISK_ERR)
83          do i = 1,size
84            dbl_mb(k_temp+i-1) = dbl_mb(k_temp+i-1) + array(i)
85          enddo
86          if (eaf_write(d_f,dfloat(bytes)*dfloat(offset),
87     1      dbl_mb(k_temp),bytes*size).ne.0)
88     2      call errquit('add_block: eaf problem',2,DISK_ERR)
89          if (eaf_close(d_f).ne.0)
90     1      call errquit('add_block: eaf problem',0,DISK_ERR)
91          call ga_unlock(0)
92        else
93          if (eaf_read(d_file,dfloat(bytes)*dfloat(offset),
94     1      dbl_mb(k_temp),bytes*size).ne.0)
95     2      call errquit('add_block: eaf problem',2,DISK_ERR)
96          do i = 1,size
97            dbl_mb(k_temp+i-1) = dbl_mb(k_temp+i-1) + array(i)
98          enddo
99          if (eaf_write(d_file,dfloat(bytes)*dfloat(offset),
100     1      dbl_mb(k_temp),bytes*size).ne.0)
101     2      call errquit('add_block: eaf problem',2,DISK_ERR)
102        endif
103        if (.not.ma_pop_stack(l_temp))
104     1    call errquit('add_block: MA problem',0,MA_ERR)
105      else if (ioalg.eq.2) then
106        call ga_acc(d_file,offset+1,offset+size,1,1,
107     1    array,1,1.0d0)
108      else if (ioalg.eq.3) then
109        if (.not.ma_push_get(mt_dbl,size,'temporary',
110     1    l_temp,k_temp))
111     2    call errquit('add_block: MA problem',0,MA_ERR)
112        if (parallel) then
113          call ga_lock(0)
114          if (sf_open(d_file).ne.0)
115     1      call errquit('add_block: sf problem',0,DISK_ERR)
116        endif
117        if (sf_read(d_file,dfloat(bytes)*dfloat(offset),
118     1    dfloat(bytes)*dfloat(size),dbl_mb(k_temp),request).ne.0)
119     2    call errquit('add_block: sf problem',1,DISK_ERR)
120        if (sf_wait(request).ne.0)
121     1    call errquit('add_block: sf problem',2,DISK_ERR)
122        do i = 1,size
123          dbl_mb(k_temp+i-1) = dbl_mb(k_temp+i-1) + array(i)
124        enddo
125        if (sf_write(d_file,dfloat(bytes)*dfloat(offset),
126     1    dfloat(bytes)*dfloat(size),dbl_mb(k_temp),request).ne.0)
127     2    call errquit('add_block: sf problem',3,DISK_ERR)
128        if (sf_wait(request).ne.0)
129     1    call errquit('add_block: sf problem',4,DISK_ERR)
130        if (parallel) then
131          if (sf_close(d_file).ne.0)
132     1      call errquit('add_block: sf problem',5,DISK_ERR)
133          call ga_unlock(0)
134        endif
135        if (.not.ma_pop_stack(l_temp))
136     1    call errquit('add_block: MA problem',1,MA_ERR)
137      else if (ioalg.eq.4) then
138        if (.not.ma_push_get(mt_dbl,size,'temporary',
139     1    l_temp,k_temp))
140     2    call errquit('add_block: MA problem',0,MA_ERR)
141        if (eaf_read(d_file,dfloat(bytes)*dfloat(offset),
142     1    dbl_mb(k_temp),bytes*size).ne.0)
143     2    call errquit('add_block: eaf problem',2,DISK_ERR)
144        do i = 1,size
145          dbl_mb(k_temp+i-1) = dbl_mb(k_temp+i-1) + array(i)
146        enddo
147        if (eaf_write(d_file,dfloat(bytes)*dfloat(offset),
148     1    dbl_mb(k_temp),bytes*size).ne.0)
149     2    call errquit('add_block: eaf problem',2,DISK_ERR)
150        if (.not.ma_pop_stack(l_temp))
151     1    call errquit('add_block: MA problem',0,MA_ERR)
152      else if (ioalg.eq.5) then
153        if (fileisga(d_file)) then
154          call ga_acc(filehandles(d_file),offset+1,offset+size,1,1,
155     1      array,1,1.0d0)
156        else
157          call errquit('add_block: read/write requests to DRA',0,
158     1      UNKNOWN_ERR)
159        endif
160      else if (ioalg.eq.6) then
161        if (fileisga(d_file)) then
162          call ga_acc(filehandles(d_file),offset+1,offset+size,1,1,
163     1      array,1,1.0d0)
164        else
165          if (.not.ma_push_get(mt_dbl,size,'temporary',
166     1      l_temp,k_temp))
167     2      call errquit('add_block: MA problem',0,MA_ERR)
168          if (eaf_read(filehandles(d_file),
169     1      dfloat(bytes)*dfloat(offset),
170     2      dbl_mb(k_temp),bytes*size).ne.0)
171     3      call errquit('add_block: eaf problem',2,DISK_ERR)
172          do i = 1,size
173            dbl_mb(k_temp+i-1) = dbl_mb(k_temp+i-1) + array(i)
174          enddo
175          if (eaf_write(filehandles(d_file),
176     1      dfloat(bytes)*dfloat(offset),
177     2      dbl_mb(k_temp),bytes*size).ne.0)
178     3      call errquit('add_block: eaf problem',2,DISK_ERR)
179          if (.not.ma_pop_stack(l_temp))
180     1      call errquit('add_block: MA problem',0,MA_ERR)
181        endif
182      endif
183 9000 format(1x,'node',i3,' add_block request to file:',i10,
184     1  ' size:',i10,' offset:',i10)
185      cpusecs(4) = cpusecs(4) + util_cpusec()
186      cpusecs(54) = cpusecs(54) + util_wallsec()
187      return
188      end
189
190
191
192
193
194
195
196
197
198
199
200
201      subroutine add_block_nb(d_file,array,size,offset,nbh)
202c
203      implicit none
204#include "global.fh"
205#include "mafdecls.fh"
206#include "stdio.fh"
207#include "errquit.fh"
208#include "util.fh"
209#include "tce.fh"
210#include "tce_main.fh"
211c
212      integer d_file
213      integer size
214      integer offset
215      integer nbh
216      double precision array(size)
217      logical parallel
218c
219      cpusecs(4) = cpusecs(4) - util_cpusec()
220      cpusecs(54) = cpusecs(54) - util_wallsec()
221c
222      parallel = (ga_nnodes().gt.1)
223c
224      if (util_print('add_block',print_debug)) then
225         write(LuOut,9000) ga_nodeid(),d_file,size,offset
226      endif
227c
228      if (offset .eq. -1)
229     1  call errquit('add_block_nb: illegal offset',0,UNKNOWN_ERR)
230c
231      if (ioalg.eq.2) then
232        call ga_nbacc(d_file,offset+1,offset+size,1,1,array,1,1.0d0,nbh)
233      else
234        call errquit('add_block_nb: only for GA!!!',911,MA_ERR)
235      endif
236c
237      cpusecs(4) = cpusecs(4) + util_cpusec()
238      cpusecs(54) = cpusecs(54) + util_wallsec()
239      return
240c
241 9000 format(1x,'node',i3,' add_block_nb request to file:',i10,
242     1  ' size:',i10,' offset:',i10)
243c
244      end
245