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