code continued
!
do i = 1,28
m_i4 = get_free_memory_size (i)
!
do k = 0,m_i4 ! this loop included for LF95, reducing
allocate (ii(m_i4), stat=iostat)
if (iostat == 0) exit
m_i4 = m_i4-1
if (m_i4 < 4) exit
end do
if (k > 0) write (lu,*) 'Target array size reduced from', m_i4+k,' to',m_i4, iostat
!lf95 l = pointer (ii)
l = loc (ii)
!
m8 = m_i4
bytes = m8 * four
call cpu_sec (sec) ; sec = sec - sec_0
write (lu,1002) i, bytes, l, iostat, sec
if (iostat /= 0) exit
if (m_i4 < 4) exit
!
! Insert block info into table
do k = nblock,0,-1
if (block_start(k) < l) then
block_start(k+1) = l ! start address
block_size(k+1) = bytes ! memory size
block_sec(k+1) = sec
nblock = nblock+1
exit
else
block_start(k+1) = block_start(k)
block_size(k+1) = block_size(k)
block_sec(k+1) = block_sec(k)
end if
end do
end do
!
1002 format (' Array A',i2.2,' allocated as ',b'zz,zzz,zzz,zz#',' bytes, at address ',b'zz,zzz,zzz,zz#', i5, f10.4)
!
! Now provide a map of free and reserved memory
!
write (lu,2000) 'Free Memory Mapping'
write (lu,2000) ' Blk Lead Gap Start Size_bytes Size_mb'
do k = 1,nblock
mb = block_size(k) / 1024. / 1024.
write (lu,2002) k, block_start(k) - (block_start(k-1)+block_size(k-1)), block_start(k), block_size(k), mb, block_sec(k)
end do
2000 format (/1x,a)
2002 format (i5,3(b'zzz,zzz,zzz,zz#'), f10.2, f10.4)
end
integer*4 function get_free_memory_size (i)
!
! This routinme searches for the largest available memory block still available
! LF95 does not give non-zero STAT if array is > 2gb
!
integer*4 i, m_low, m_high, m, iostat
integer*4, allocatable, dimension(:) :: jj
! real*4 mb
integer*4, parameter :: m_high_start = 2**30 + 2**28 ! works as 2**29
data m_high / -1 /
!
if (m_high < 0) m_high = m_high_start
m_low = 0
!
do
m = m_low + (m_high-m_low)/2
if (m == m_low) exit
allocate (jj(m), stat=iostat)
! mb = m ; mb = mb / one_mb_r4
! write (*,2001)' testing', m, mb, iostat
!2001 format (a,b'zz,zzz,zzz,zz#',3x,b'zzz,zz#.##',' mb : error code ',i0)
if (iostat /= 0) then
m_high = m
else
m_low = m
deallocate (jj)
end if
end do
!
get_free_memory_size = m
!
end function get_free_memory_size
subroutine test_JJ (jj, m, lu)
!
! Tests array jj(m) exists by setting and checking values
!
integer*4 m, jj(m), lu, i, k, er
real*8 mb, sec, sec_0
real*8, parameter :: one_mb_r4 = 1024. * 1024. / 4.
integer*8 byte_address
data sec_0 / -1 /
!
if (sec_0 < 0) call cpu_sec (sec_0)
er = 0
k = m/2
do i = 1,m
k = k-1
jj(i) = k
end do
!
k = m/2
do i = 1,m
k = k-1
if (jj(i) /= k) er = er+1
end do
!
