_ACCESSING LARGE ARRAYS WITH X-ARRAY_
by Barr E. Bauer 


[LISTING ONE]

* Extended memory manipulation using X-arRAY Fortran Library.
* Does the following: 1. allocates a 1 Mbyte real*4 array a(512,512); 2. loads 
*   array a with real*4 values; 3. saves the data in array a to disk; 
*   4. allocates two 1 Mbyte real*4 arrays b and c; 5. loads data from file 
*   (step 3) into array b; 6. scales all members of array b by 5.0; 7. does an 
*   element-by-element array multiplication of arrays a and b, results into 
*   array c; 8. sums all members of array c, reports results.
* Compile with Microsoft Fortran 5.1 using:
*    fl /FPi87 /G2 example1.for putback.for bagit.for /link xarray
* B. E. Bauer 3/20/92 

      interface to subroutine a2axtd(i1,i2,i3,i4[VALUE],r1,i5,i6)
      integer*4 i1,i2,i3,i4,i5
      integer*2 i6
      real*4 r1
      end

      interface to subroutine sgtrnm(i1,i2,i3[VALUE],i4,r1,i5)
      integer*4 i1,i2,i3,i4
      integer*2 i5
      real*4 r1
      end
      
      interface to subroutine sptrnm(i1,i2,i3[VALUE],i4,r1,i5)
      integer*4 i1,i2,i3,i4
      integer*2 i5
      real*4 r1
      end

      interface to subroutine smprnm(i1,i2,i3[VALUE],i4[VALUE],
     +  i5[VALUE],i6)
      integer*4 i1,i2,i3,i4,i5
      integer*2 i6
      end
      
      interface to subroutine ssmrnm(i1,i2,i3[VALUE],r1,i4)
      integer*4 i1,i2,i3
      real*4 r1
      integer*2 i4
      end      

      include 'bagit.inc'  ! error codes and other symbols
    integer*4 kb_total, kb_unallocated, number_allocations
    integer*4 memory_manager, required_memory, shortage
    integer*4 handle_array(1), key_array(1)
    integer*4 ARRAY_SIZE(ARRAY_DIM), allocated_array(1)

    integer*4 handle, key, key1, kb_allocated
    integer*4 bytes_moved, increment
      integer*4 keyb, keyc, handleb, handlec
    real*4 temp, a(SIZE)
    integer*2 return_status, eflag
      character*13 tempfile
      data tempfile /'tempfile.dat'C/ ! C string format
      data ARRAY_SIZE / SIZE, SIZE /

* enable extended memory routine flashing
      call flashr(ON,LOWER_RIGHT,eflag)
      if (eflag .ne. 0) call bagit(FLASHR_ERROR)
      required_memory = 3*SIZE*SIZE*REAL4/1024 ! need 3 Mbytes
* determine status of extended memory
      call inqxtd(kb_total, kb_unallocated, number_allocations,
     +      memory_manager, handle_array, key_array, 
     +      allocated_array, return_status, eflag)
      if (eflag .ne. 0) call bagit(INQXTD_ERROR)
      if ((memory_manager .eq. 0) .or. 
     +    (memory_manager .gt. 2)) then
            call bagit(WRONG_MMANAGER)
      else if (memory_manager .eq. 1) then 
        print *,'XMS in use'
      else 
        print *,'Modified LIM in use'
      endif
      print *,'Extended memory available ',kb_unallocated,' kb'
      if (kb_unallocated .lt. required_memory) then
            shortage = required_memory - kb_unallocated
            print *,'insufficient memory, need',shortage,'kb'
            call bagit(STOPPING)
      endif
* enough memory present, allocate memory for 1st array
      print *,'just ahead of memory allocation'
      ! allocate a 2D array of real*4 dimensioned 512 by 512
      call getxtd(ARRAY_DIM,ARRAY_SIZE,REAL4,XMS,handle,key,
     1      kb_allocated,return_status, eflag)      
      if (eflag .ne. 0) call bagit(GETXTD_ERROR)
* load extended memory array (X,Y) with 1.0 using column vector approach
      print *,'at loading stage'
      key1 = key
      temp = 0.0
      increment = SIZE*REAL4
      do j = 1,SIZE
            do k = 1,SIZE
                  a(k) = 1.0 ! fills the 1D array with values
            enddo
            ! move the 1D into extended memory by columns
            ! putback is a2axtd interfaced for 
            ! conventional -> extended memory transfers
            call putback(1,SIZE,REAL4,a,key1,bytes_moved,eflag)
            if (eflag .ne. 0) call bagit(PUTBACK_ERROR)
            if (bytes_moved .ne. increment) then
                call bagit(PUTBACK_BADCNT)
            endif
            key1 = key1 + increment
      enddo
* save a copy of this array to disk
      print *,'saving array to file'
      call a2fxtd(ARRAY_DIM,ARRAY_SIZE,REAL4,tempfile,key,
     +      ibytes_moved,eflag)
      if (ibytes_moved.ne.SIZE*SIZE*REAL4) then
          call bagit(A2FXTD_BADCNT)
      endif
      if (eflag.ne.0) call bagit(A2FXTD_ERROR)
* allocate extended memory for arrays b and c
      call getxtd(ARRAY_DIM,ARRAY_SIZE,REAL4,XMS,handleb,keyb,
     +      kb_allocated,return_status, eflag)      
      if (eflag .ne. 0) call bagit(GETXTD_ERROR)
      call getxtd(ARRAY_DIM,ARRAY_SIZE,REAL4,XMS,handlec,keyc,
     +      kb_allocated,return_status, eflag)      
      if (eflag .ne. 0) call bagit(GETXTD_ERROR)
* read file into extended memory for array b
      print *,'reading tempfile'       
      call f2axtd(ARRAY_DIM,ARRAY_SIZE,REAL4,tempfile,keyb,
     1      ibytes_moved,eflag)
      if (eflag.ne.0) call bagit(F2AXTD_ERROR)
      if (ibytes_moved.ne.SIZE*SIZE*REAL4) then
          call bagit(F2AXTD_BADCNT)
      endif
* scale array b by 5.0
      print *,'scaling array b elements by 5.0'
      call ssmrnm(ARRAY_DIM,ARRAY_SIZE,keyb,5.0,eflag)
      if (eflag.ne.0) call bagit(SSMRNM_ERROR)
* element-by-element mult of a and b, results to c
      print *,'ahead of array multiplication'      
      call smprnm(2,ARRAY_SIZE,key,keyb,keyc,eflag)
      if (eflag .ne. 0) call bagit(SMPRNM_ERROR)
* sum all elements of array c to check results by using column vectors to 
* bring data from extended into conventional memory, where sum is performed.
      key1 = keyc
      temp = 0.0
      increment = SIZE*REAL4
      do j = 1,SIZE
        call a2axtd(1,SIZE,REAL4,key1,a,bytes_moved,eflag)
        if (eflag.ne.0) call bagit(A2AXTD_ERROR)
        if (bytes_moved.ne.increment) call bagit(A2AXTD_BADCNT)
           do i=1,SIZE
               temp = temp + a(i)
           enddo
        key1 = key1 + increment ! advance to next column vector
      enddo
      print *,'done, sum = ',temp,' (correct = 1310720.000000)'
* done, remove all allocations through ENDXTD in bagit
      call bagit(DONE)
      stop
      end


[LISTING TWO]

* Performs a sum reduction first using column vector moves then individual 
* element accesses
* Compile with Microsoft Fortran 5.1
*  fl /FPi87 /G2 example1.for putback.for bagit.for /link xarray
* B. E. Bauer 3/20/92
*
      interface to subroutine a2axtd(i1,i2,i3,i4[VALUE],r1,i5,i6)
      integer*4 i1,i2,i3,i4,i5
      integer*2 i6
      real*4 r1
      end

      interface to subroutine sgtrnm(i1,i2,i3[VALUE],i4,r1,i5)
      integer*4 i1,i2,i3,i4
      integer*2 i5
      real*4 r1
      end
      
      interface to subroutine sptrnm(i1,i2,i3[VALUE],i4,r1,i5)
      integer*4 i1,i2,i3,i4
      integer*2 i5
      real*4 r1
      end

      include 'bagit.inc'
      
    integer*4 kb_total, kb_unallocated, number_allocations
    integer*4 memory_manager, required_memory, shortage
    integer*4 handle_array(1), key_array(1), allocated_array(1)
    integer*4 ARRAY_SIZE(2)

    integer*4 handle, key, key1, kb_allocated, increment
    integer*4 bytes_moved, index(2), keyj

    real*4 temp, a(SIZE), arrj(SIZE)
    integer*2 return_status, eflag

      data ARRAY_SIZE / SIZE, SIZE /   ! 2D 512x512 array used
* enable console flashing when extended memory is accessed
      call flashr(1,3,eflag)
      if (eflag .ne. 0) call bagit(FLASHR_ERROR)
      required_memory = SIZE*SIZE*REAL4/1024
* check for adequate XMS memory, quit if inadequate
      call inqxtd(kb_total, kb_unallocated, number_allocations,
     +      memory_manager, handle_array, key_array, 
     +      allocated_array, return_status, eflag)
      if (eflag.ne.0) call bagit(INQXTD_ERROR)
      if (required_memory .gt. kb_unallocated) call bagit(NOT_ENOUGH)     
* allocate a 512 by 512 array of real*4
      print *,'just ahead of memory allocation'
      call getxtd(2,ARRAY_SIZE,REAL4,XMS,handle,key,
     1      kb_allocated,return_status, eflag)      
      if (eflag .ne. 0) call bagit(GETXTD_ERROR)
* load extended memory array (X,Y) using column vectors
      print *,'at loading stage'
      key1 = key
      temp = 0.0
      increment = SIZE*REAL4
      do j = 1,SIZE
        do k = 1,SIZE
           a(k) = float(k) + float(SIZE*(j-1))
        enddo
        call putback(1,SIZE,REAL4,a,key1,bytes_moved,eflag)
        if (eflag .ne. 0) call bagit(PUTBACK_ERROR)
        if (bytes_moved .ne. increment) then
          call bagit(PUTBACK_BADCNT)
        endif
        key1 = key1 + increment
      enddo
* column vector summation
      print *,'start column vector sum reduction'
      sum_col = 0.0
      chunk = SIZE*REAL4
      do j=1,SIZE
        keyj = key + chunk*(j-1)  ! address arithmetic
        ! put (,j) into arrj
        call a2axtd(1,SIZE,REAL4,keyj,arrj,bytes_moved,eflag)
        if (eflag.ne.0) call bagit(A2AXTD_ERROR)
        if (bytes_moved.ne.chunk) call bagit(A2AXTD_BADCNT)
        do k=1,SIZE ! process the column vector
          sum_col = sum_col +arrj(k)
        enddo
      enddo
      print *,'done with column vector sum reduction'
* individual element access
      print *,'start individual access sum reduction'
      sum_ind = 0.0
      do i=1,SIZE
        do j=1,SIZE
          index(1)=i   ! row of element
          index(2)=j   ! column of element
          ! get the element into retval
          call sgtrnm(2,ARRAY_SIZE,key,index,retval,eflag)
          if (eflag.ne.0) call bagit(SGTRNM_ERROR)
          sum_ind = sum_ind + retval
        enddo
      enddo
      print *,'done with individual access sum reduction'
      print *,'column sum =',sum_col,', individual sum =',sum_ind
      call bagit(DONE)
      stop
      end
                        
      


[LISTING THREE]

* Triangular array manipulation of a single 1 Mbyte real*4 array arr(512,512) 
*  using X-arRAY routines
* Does the following:
*    do j=1,512
*        do k = 1, j-1
*            do i = k+1, 512
*                arr(i,j) = arr(i,j) + arr(i,k) * arr(k,j)
*            enddo
*        enddo
*    enddo
* Compile in Microsoft Fortran 5.1 using:
* fl /FPi87 /G2 example2.for putback.for bagit.for /link xarray
* B. E. Bauer 3/20/92
*
      interface to subroutine a2axtd(i1,i2,i3,i4[VALUE],r1,i5,i6)
      integer*4 i1,i2,i3,i4,i5
      integer*2 i6
      real*4 r1
      end

      interface to subroutine sgtrnm(i1,i2,i3[VALUE],i4,r1,i5)
      integer*4 i1,i2,i3,i4
      integer*2 i5
      real*4 r1
      end
      
      interface to subroutine sptrnm(i1,i2,i3[VALUE],i4,r1,i5)
      integer*4 i1,i2,i3,i4
      integer*2 i5
      real*4 r1
      end

      include 'bagit.inc'

      integer*4 kb_total, kb_unallocated, number_allocations
      integer*4 memory_manager, required_memory
      integer*4 handle_array(1), key_array(1), allocated_array(1)
      integer*4 ARRAY_SIZE(ARRAY_DIM)

      integer*4 handle, key, key1, kb_allocated, increment
      integer*4 bytes_moved, index(2), keyj, keyk

      real*4 temp, a(SIZE), arrj(SIZE), arrk(SIZE)
      integer*2 return_status, eflag

      data ARRAY_SIZE / SIZE, SIZE /
      call flashr(ON,LOWER_RIGHT,eflag)
      required_memory = SIZE*SIZE*REAL4/1024
      call inqxtd(kb_total, kb_unallocated, number_allocations,
     +      memory_manager, handle_array, key_array,
     +      allocated_array, return_status, eflag)
      if (eflag.ne.0) call bagit(INQXTD_ERROR)
      if (kb_unallocated .lt. required_memory) then
        call bagit(NOT_ENOUGH)
      endif
* allocate 1 Mbyte of extended memory     
      print *,'just ahead of memory allocation'
      call getxtd(ARRAY_DIM,ARRAY_SIZE,REAL4,XMS,handle,key,
     +      kb_allocated,return_status, eflag)      
      if (eflag .ne. 0) call bagit(GETXTD_ERROR)
      print *,'loading extended memory'
      key1 = key
      temp = 0.0
      increment = SIZE*REAL4
      do j = 1,SIZE
            do k = 1,SIZE
                  a(k) = 0.00025
            enddo
            call putback(1,SIZE,REAL4,a,key1,bytes_moved,eflag)
            if (eflag .ne. 0) call bagit(PUTBACK_ERROR)
            if (bytes_moved .ne. increment) call bagit(PUTBACK_BADCNT)
            key1 = key1 + increment
      enddo
* process triangular array
      print *,'processing triangular array'
      keyj = key
      keyk = key
      chunk = SIZE*REAL4
      do j=1,SIZE
        print *,'outer loop j = ',j
        ! get arr(x,j) from extended into arrj(x)
        call a2axtd(1,SIZE,REAL4,keyj,arrj,bytes_moved,eflag)
        if (eflag.ne.0) call bagit(A2AXTD_ERROR)
        if (bytes_moved.ne.chunk) call bagit(A2AXTD_BADCNT)
        do k=1,j-1
          keyk = key + (k-1)*chunk
          ! get arr(x,k) from extended into arrk(x)
          call a2axtd(1,SIZE,REAL4,keyk,arrk,bytes_moved,eflag)
          if (eflag.ne.0) call bagit(A2AXTD_ERROR)
          if (bytes_moved.ne.chunk) call bagit(A2AXTD_BADCNT)
          ! do the manipulation
          do i=k+1,SIZE
            arrj(i) = arrj(i) + arrk(i)*arrj(k)
          enddo
        enddo
        ! put arrj(x) back to extended memory 
        call putback(1,SIZE,REAL4,arrj,keyj,bytes_moved,eflag)
        if (eflag.ne.0) call bagit(A2AXTD_ERROR)
        if (bytes_moved.ne.chunk) call bagit(A2AXTD_BADCNT)
        keyj = keyj + chunk
      enddo
* sample selected members of the array in extended memory
      do i=1,SIZE,125
        do j=1,SIZE,125
          index(1)=i
          index(2)=j
          call sgtrnm(ARRAY_DIM,ARRAY_SIZE,key,index,retval,eflag)
          if (eflag.ne.0) call bagit(SGTRNM_ERROR)
          print *,i,j,retval
        enddo
      enddo
      call bagit(DONE)
      stop
      end
     


[LISTING FOUR]

* putback.for--interface a2axtd for conventional to extended memory block moves
* B. E. Bauer  3/20/92
*
      interface to subroutine a2axtd(i1,i2,i3,r1,i4[VALUE],i5,i6)
      integer*4 i1,i2,i3,i4,i5
      integer*2 i6
      real*4 r1
      end

      subroutine putback(i1,i2,i3,r1,i4,i5,i6)
      integer*4 i1, i2, i3, i4, i5
      real*4 r1(*)
      integer*2 i6
      call a2axtd(i1,i2,i3,r1,i4,i5,i6)
      return
      end

[LISTING FIVE]

* bagit.inc--symbols and declarations used for error handling and the examples.
* B. E. Bauer  3/20/92
*
      integer*4 INQXTD_ERROR,WRONG_MMANAGER,STOPPING,GETXTD_ERROR
      integer*4 PUTBACK_ERROR,PUTBACK_BADCNT,A2AXTD_BADCNT
      integer*4 A2AXTD_ERROR,A2FXTD_BADCNT,A2FXTD_ERROR
      integer*4 F2AXTD_ERROR,F2AXTD_BADCNT,SSMRNM_ERROR
      integer*4 SMPRNM_ERROR,NOT_ENOUGH,SGTRNM_ERROR
      integer*4 FLASHR_ERROR,DONE
      
      integer*4 ARRAY_DIM,REAL4,XMS,SIZE,ON,LOWER_RIGHT

      parameter (INQXTD_ERROR=1)
      parameter (WRONG_MMANAGER=2)
      parameter (STOPPING=3)
      parameter (GETXTD_ERROR=4)
      parameter (PUTBACK_ERROR=5)
      parameter (PUTBACK_BADCNT=6)
      parameter (A2AXTD_BADCNT=7)
      parameter (A2AXTD_ERROR=8)
      parameter (A2FXTD_BADCNT=9)
      parameter (A2FXTD_ERROR=9)
      parameter (F2AXTD_ERROR=10)
      parameter (F2AXTD_BADCNT=11)
      parameter (SSMRNM_ERROR=12)
      parameter (SMPRNM_ERROR=13)
      parameter (NOT_ENOUGH=14)
      parameter (SGTRNM_ERROR=15)
      parameter (FLASHR_ERROR=16)
      parameter (DONE=99)

      parameter (ARRAY_DIM = 2)       ! 2D array
      parameter (REAL4 = 4)           ! size of real*4 
      parameter (XMS = -1)            ! use available mmanager
      parameter (SIZE = 512)          ! size of array
      parameter (ON = 1)              ! convenient symbol
      parameter (LOWER_RIGHT = 3)     ! where flashr flashes 



[LISTING SIX]

* bagit.for--error handler. Prints an appropriate message then calls endxtd 
*   to ensure allocations are freed.
* B. E. Bauer  3/20/92
*
      subroutine bagit(iflag)
      integer*4 iflag
      integer*2 return_status, eflag

      include 'bagit.inc'
            
      select case (iflag)
        case (INQXTD_ERROR)
          print *,'error reported by inqxtd'
        case (WRONG_MMANAGER)
          print *,'XMS or Mondified LIM memory manager not found'
        case (STOPPING)
          print *,'stopping...'
        case (GETXTD_ERROR)
          print *,'error reported by getxtd'
        case (PUTBACK_ERROR)
          print *,'error in putback(a2axtd)'
        case (PUTBACK_BADCNT)
          print *,'wrong number of bytes moved by putback(a2axtd)'
        case (A2AXTD_BADCNT)
          print *,'wrong number of bytes moved by a2axtd'
        case (A2AXTD_ERROR)
          print *,'error in a2axtd'
        case (A2FXTD_BADCNT)
          print *,'wrong number of bytes moved by a2fxtd'
        case (A2FXTD_ERROR)
          print *,'error in a2fxtd'
        case (F2AXTD_ERROR)
          print *,'error in f2axtd'
        case (F2AXTD_BADCNT)
          print *,'wrong number of bytes moved by f2axtd'
        case (SSMRNM_ERROR)
          print *,'error in ssmrnm (scalar multiply)'
        case (SMPRNM_ERROR)
          print *,'error in smprnm (el-by-el multiply)'
        case (NOT_ENOUGH)
          print *,'inadequate extended memory available'
        case (SGTRNM_ERROR)
          print *,'error in sgtrnm (real*4 get)'
        case (FLASHR_ERROR)
          print *,'error in flashr'
        case (DONE)
          print *,'freeing extended memory' 
      end select
      call endxtd(return_status, eflag)
      stop 'done, exiting...'
      end