home *** CD-ROM | disk | FTP | other *** search
/ Shareware Supreme Volume 6 #1 / swsii.zip / swsii / 215 / DDJ9206.ZIP / XARRAY.ASC < prev    next >
Text File  |  1992-05-18  |  18KB  |  506 lines
  1. _ACCESSING LARGE ARRAYS WITH X-ARRAY_
  2. by Barr E. Bauer 
  3.  
  4.  
  5. [LISTING ONE]
  6.  
  7. * Extended memory manipulation using X-arRAY Fortran Library.
  8. * Does the following: 1. allocates a 1 Mbyte real*4 array a(512,512); 2. loads 
  9. *   array a with real*4 values; 3. saves the data in array a to disk; 
  10. *   4. allocates two 1 Mbyte real*4 arrays b and c; 5. loads data from file 
  11. *   (step 3) into array b; 6. scales all members of array b by 5.0; 7. does an 
  12. *   element-by-element array multiplication of arrays a and b, results into 
  13. *   array c; 8. sums all members of array c, reports results.
  14. * Compile with Microsoft Fortran 5.1 using:
  15. *    fl /FPi87 /G2 example1.for putback.for bagit.for /link xarray
  16. * B. E. Bauer 3/20/92 
  17.  
  18.       interface to subroutine a2axtd(i1,i2,i3,i4[VALUE],r1,i5,i6)
  19.       integer*4 i1,i2,i3,i4,i5
  20.       integer*2 i6
  21.       real*4 r1
  22.       end
  23.  
  24.       interface to subroutine sgtrnm(i1,i2,i3[VALUE],i4,r1,i5)
  25.       integer*4 i1,i2,i3,i4
  26.       integer*2 i5
  27.       real*4 r1
  28.       end
  29.       
  30.       interface to subroutine sptrnm(i1,i2,i3[VALUE],i4,r1,i5)
  31.       integer*4 i1,i2,i3,i4
  32.       integer*2 i5
  33.       real*4 r1
  34.       end
  35.  
  36.       interface to subroutine smprnm(i1,i2,i3[VALUE],i4[VALUE],
  37.      +  i5[VALUE],i6)
  38.       integer*4 i1,i2,i3,i4,i5
  39.       integer*2 i6
  40.       end
  41.       
  42.       interface to subroutine ssmrnm(i1,i2,i3[VALUE],r1,i4)
  43.       integer*4 i1,i2,i3
  44.       real*4 r1
  45.       integer*2 i4
  46.       end      
  47.  
  48.       include 'bagit.inc'  ! error codes and other symbols
  49.     integer*4 kb_total, kb_unallocated, number_allocations
  50.     integer*4 memory_manager, required_memory, shortage
  51.     integer*4 handle_array(1), key_array(1)
  52.     integer*4 ARRAY_SIZE(ARRAY_DIM), allocated_array(1)
  53.  
  54.     integer*4 handle, key, key1, kb_allocated
  55.     integer*4 bytes_moved, increment
  56.       integer*4 keyb, keyc, handleb, handlec
  57.     real*4 temp, a(SIZE)
  58.     integer*2 return_status, eflag
  59.       character*13 tempfile
  60.       data tempfile /'tempfile.dat'C/ ! C string format
  61.       data ARRAY_SIZE / SIZE, SIZE /
  62.  
  63. * enable extended memory routine flashing
  64.       call flashr(ON,LOWER_RIGHT,eflag)
  65.       if (eflag .ne. 0) call bagit(FLASHR_ERROR)
  66.       required_memory = 3*SIZE*SIZE*REAL4/1024 ! need 3 Mbytes
  67. * determine status of extended memory
  68.       call inqxtd(kb_total, kb_unallocated, number_allocations,
  69.      +      memory_manager, handle_array, key_array, 
  70.      +      allocated_array, return_status, eflag)
  71.       if (eflag .ne. 0) call bagit(INQXTD_ERROR)
  72.       if ((memory_manager .eq. 0) .or. 
  73.      +    (memory_manager .gt. 2)) then
  74.             call bagit(WRONG_MMANAGER)
  75.       else if (memory_manager .eq. 1) then 
  76.         print *,'XMS in use'
  77.       else 
  78.         print *,'Modified LIM in use'
  79.       endif
  80.       print *,'Extended memory available ',kb_unallocated,' kb'
  81.       if (kb_unallocated .lt. required_memory) then
  82.             shortage = required_memory - kb_unallocated
  83.             print *,'insufficient memory, need',shortage,'kb'
  84.             call bagit(STOPPING)
  85.       endif
  86. * enough memory present, allocate memory for 1st array
  87.       print *,'just ahead of memory allocation'
  88.       ! allocate a 2D array of real*4 dimensioned 512 by 512
  89.       call getxtd(ARRAY_DIM,ARRAY_SIZE,REAL4,XMS,handle,key,
  90.      1      kb_allocated,return_status, eflag)      
  91.       if (eflag .ne. 0) call bagit(GETXTD_ERROR)
  92. * load extended memory array (X,Y) with 1.0 using column vector approach
  93.       print *,'at loading stage'
  94.       key1 = key
  95.       temp = 0.0
  96.       increment = SIZE*REAL4
  97.       do j = 1,SIZE
  98.             do k = 1,SIZE
  99.                   a(k) = 1.0 ! fills the 1D array with values
  100.             enddo
  101.             ! move the 1D into extended memory by columns
  102.             ! putback is a2axtd interfaced for 
  103.             ! conventional -> extended memory transfers
  104.             call putback(1,SIZE,REAL4,a,key1,bytes_moved,eflag)
  105.             if (eflag .ne. 0) call bagit(PUTBACK_ERROR)
  106.             if (bytes_moved .ne. increment) then
  107.                 call bagit(PUTBACK_BADCNT)
  108.             endif
  109.             key1 = key1 + increment
  110.       enddo
  111. * save a copy of this array to disk
  112.       print *,'saving array to file'
  113.       call a2fxtd(ARRAY_DIM,ARRAY_SIZE,REAL4,tempfile,key,
  114.      +      ibytes_moved,eflag)
  115.       if (ibytes_moved.ne.SIZE*SIZE*REAL4) then
  116.           call bagit(A2FXTD_BADCNT)
  117.       endif
  118.       if (eflag.ne.0) call bagit(A2FXTD_ERROR)
  119. * allocate extended memory for arrays b and c
  120.       call getxtd(ARRAY_DIM,ARRAY_SIZE,REAL4,XMS,handleb,keyb,
  121.      +      kb_allocated,return_status, eflag)      
  122.       if (eflag .ne. 0) call bagit(GETXTD_ERROR)
  123.       call getxtd(ARRAY_DIM,ARRAY_SIZE,REAL4,XMS,handlec,keyc,
  124.      +      kb_allocated,return_status, eflag)      
  125.       if (eflag .ne. 0) call bagit(GETXTD_ERROR)
  126. * read file into extended memory for array b
  127.       print *,'reading tempfile'       
  128.       call f2axtd(ARRAY_DIM,ARRAY_SIZE,REAL4,tempfile,keyb,
  129.      1      ibytes_moved,eflag)
  130.       if (eflag.ne.0) call bagit(F2AXTD_ERROR)
  131.       if (ibytes_moved.ne.SIZE*SIZE*REAL4) then
  132.           call bagit(F2AXTD_BADCNT)
  133.       endif
  134. * scale array b by 5.0
  135.       print *,'scaling array b elements by 5.0'
  136.       call ssmrnm(ARRAY_DIM,ARRAY_SIZE,keyb,5.0,eflag)
  137.       if (eflag.ne.0) call bagit(SSMRNM_ERROR)
  138. * element-by-element mult of a and b, results to c
  139.       print *,'ahead of array multiplication'      
  140.       call smprnm(2,ARRAY_SIZE,key,keyb,keyc,eflag)
  141.       if (eflag .ne. 0) call bagit(SMPRNM_ERROR)
  142. * sum all elements of array c to check results by using column vectors to 
  143. * bring data from extended into conventional memory, where sum is performed.
  144.       key1 = keyc
  145.       temp = 0.0
  146.       increment = SIZE*REAL4
  147.       do j = 1,SIZE
  148.         call a2axtd(1,SIZE,REAL4,key1,a,bytes_moved,eflag)
  149.         if (eflag.ne.0) call bagit(A2AXTD_ERROR)
  150.         if (bytes_moved.ne.increment) call bagit(A2AXTD_BADCNT)
  151.            do i=1,SIZE
  152.                temp = temp + a(i)
  153.            enddo
  154.         key1 = key1 + increment ! advance to next column vector
  155.       enddo
  156.       print *,'done, sum = ',temp,' (correct = 1310720.000000)'
  157. * done, remove all allocations through ENDXTD in bagit
  158.       call bagit(DONE)
  159.       stop
  160.       end
  161.  
  162.  
  163. [LISTING TWO]
  164.  
  165. * Performs a sum reduction first using column vector moves then individual 
  166. * element accesses
  167. * Compile with Microsoft Fortran 5.1
  168. *  fl /FPi87 /G2 example1.for putback.for bagit.for /link xarray
  169. * B. E. Bauer 3/20/92
  170. *
  171.       interface to subroutine a2axtd(i1,i2,i3,i4[VALUE],r1,i5,i6)
  172.       integer*4 i1,i2,i3,i4,i5
  173.       integer*2 i6
  174.       real*4 r1
  175.       end
  176.  
  177.       interface to subroutine sgtrnm(i1,i2,i3[VALUE],i4,r1,i5)
  178.       integer*4 i1,i2,i3,i4
  179.       integer*2 i5
  180.       real*4 r1
  181.       end
  182.       
  183.       interface to subroutine sptrnm(i1,i2,i3[VALUE],i4,r1,i5)
  184.       integer*4 i1,i2,i3,i4
  185.       integer*2 i5
  186.       real*4 r1
  187.       end
  188.  
  189.       include 'bagit.inc'
  190.       
  191.     integer*4 kb_total, kb_unallocated, number_allocations
  192.     integer*4 memory_manager, required_memory, shortage
  193.     integer*4 handle_array(1), key_array(1), allocated_array(1)
  194.     integer*4 ARRAY_SIZE(2)
  195.  
  196.     integer*4 handle, key, key1, kb_allocated, increment
  197.     integer*4 bytes_moved, index(2), keyj
  198.  
  199.     real*4 temp, a(SIZE), arrj(SIZE)
  200.     integer*2 return_status, eflag
  201.  
  202.       data ARRAY_SIZE / SIZE, SIZE /   ! 2D 512x512 array used
  203. * enable console flashing when extended memory is accessed
  204.       call flashr(1,3,eflag)
  205.       if (eflag .ne. 0) call bagit(FLASHR_ERROR)
  206.       required_memory = SIZE*SIZE*REAL4/1024
  207. * check for adequate XMS memory, quit if inadequate
  208.       call inqxtd(kb_total, kb_unallocated, number_allocations,
  209.      +      memory_manager, handle_array, key_array, 
  210.      +      allocated_array, return_status, eflag)
  211.       if (eflag.ne.0) call bagit(INQXTD_ERROR)
  212.       if (required_memory .gt. kb_unallocated) call bagit(NOT_ENOUGH)     
  213. * allocate a 512 by 512 array of real*4
  214.       print *,'just ahead of memory allocation'
  215.       call getxtd(2,ARRAY_SIZE,REAL4,XMS,handle,key,
  216.      1      kb_allocated,return_status, eflag)      
  217.       if (eflag .ne. 0) call bagit(GETXTD_ERROR)
  218. * load extended memory array (X,Y) using column vectors
  219.       print *,'at loading stage'
  220.       key1 = key
  221.       temp = 0.0
  222.       increment = SIZE*REAL4
  223.       do j = 1,SIZE
  224.         do k = 1,SIZE
  225.            a(k) = float(k) + float(SIZE*(j-1))
  226.         enddo
  227.         call putback(1,SIZE,REAL4,a,key1,bytes_moved,eflag)
  228.         if (eflag .ne. 0) call bagit(PUTBACK_ERROR)
  229.         if (bytes_moved .ne. increment) then
  230.           call bagit(PUTBACK_BADCNT)
  231.         endif
  232.         key1 = key1 + increment
  233.       enddo
  234. * column vector summation
  235.       print *,'start column vector sum reduction'
  236.       sum_col = 0.0
  237.       chunk = SIZE*REAL4
  238.       do j=1,SIZE
  239.         keyj = key + chunk*(j-1)  ! address arithmetic
  240.         ! put (,j) into arrj
  241.         call a2axtd(1,SIZE,REAL4,keyj,arrj,bytes_moved,eflag)
  242.         if (eflag.ne.0) call bagit(A2AXTD_ERROR)
  243.         if (bytes_moved.ne.chunk) call bagit(A2AXTD_BADCNT)
  244.         do k=1,SIZE ! process the column vector
  245.           sum_col = sum_col +arrj(k)
  246.         enddo
  247.       enddo
  248.       print *,'done with column vector sum reduction'
  249. * individual element access
  250.       print *,'start individual access sum reduction'
  251.       sum_ind = 0.0
  252.       do i=1,SIZE
  253.         do j=1,SIZE
  254.           index(1)=i   ! row of element
  255.           index(2)=j   ! column of element
  256.           ! get the element into retval
  257.           call sgtrnm(2,ARRAY_SIZE,key,index,retval,eflag)
  258.           if (eflag.ne.0) call bagit(SGTRNM_ERROR)
  259.           sum_ind = sum_ind + retval
  260.         enddo
  261.       enddo
  262.       print *,'done with individual access sum reduction'
  263.       print *,'column sum =',sum_col,', individual sum =',sum_ind
  264.       call bagit(DONE)
  265.       stop
  266.       end
  267.                         
  268.       
  269.  
  270.  
  271. [LISTING THREE]
  272.  
  273. * Triangular array manipulation of a single 1 Mbyte real*4 array arr(512,512) 
  274. *  using X-arRAY routines
  275. * Does the following:
  276. *    do j=1,512
  277. *        do k = 1, j-1
  278. *            do i = k+1, 512
  279. *                arr(i,j) = arr(i,j) + arr(i,k) * arr(k,j)
  280. *            enddo
  281. *        enddo
  282. *    enddo
  283. * Compile in Microsoft Fortran 5.1 using:
  284. * fl /FPi87 /G2 example2.for putback.for bagit.for /link xarray
  285. * B. E. Bauer 3/20/92
  286. *
  287.       interface to subroutine a2axtd(i1,i2,i3,i4[VALUE],r1,i5,i6)
  288.       integer*4 i1,i2,i3,i4,i5
  289.       integer*2 i6
  290.       real*4 r1
  291.       end
  292.  
  293.       interface to subroutine sgtrnm(i1,i2,i3[VALUE],i4,r1,i5)
  294.       integer*4 i1,i2,i3,i4
  295.       integer*2 i5
  296.       real*4 r1
  297.       end
  298.       
  299.       interface to subroutine sptrnm(i1,i2,i3[VALUE],i4,r1,i5)
  300.       integer*4 i1,i2,i3,i4
  301.       integer*2 i5
  302.       real*4 r1
  303.       end
  304.  
  305.       include 'bagit.inc'
  306.  
  307.       integer*4 kb_total, kb_unallocated, number_allocations
  308.       integer*4 memory_manager, required_memory
  309.       integer*4 handle_array(1), key_array(1), allocated_array(1)
  310.       integer*4 ARRAY_SIZE(ARRAY_DIM)
  311.  
  312.       integer*4 handle, key, key1, kb_allocated, increment
  313.       integer*4 bytes_moved, index(2), keyj, keyk
  314.  
  315.       real*4 temp, a(SIZE), arrj(SIZE), arrk(SIZE)
  316.       integer*2 return_status, eflag
  317.  
  318.       data ARRAY_SIZE / SIZE, SIZE /
  319.       call flashr(ON,LOWER_RIGHT,eflag)
  320.       required_memory = SIZE*SIZE*REAL4/1024
  321.       call inqxtd(kb_total, kb_unallocated, number_allocations,
  322.      +      memory_manager, handle_array, key_array,
  323.      +      allocated_array, return_status, eflag)
  324.       if (eflag.ne.0) call bagit(INQXTD_ERROR)
  325.       if (kb_unallocated .lt. required_memory) then
  326.         call bagit(NOT_ENOUGH)
  327.       endif
  328. * allocate 1 Mbyte of extended memory     
  329.       print *,'just ahead of memory allocation'
  330.       call getxtd(ARRAY_DIM,ARRAY_SIZE,REAL4,XMS,handle,key,
  331.      +      kb_allocated,return_status, eflag)      
  332.       if (eflag .ne. 0) call bagit(GETXTD_ERROR)
  333.       print *,'loading extended memory'
  334.       key1 = key
  335.       temp = 0.0
  336.       increment = SIZE*REAL4
  337.       do j = 1,SIZE
  338.             do k = 1,SIZE
  339.                   a(k) = 0.00025
  340.             enddo
  341.             call putback(1,SIZE,REAL4,a,key1,bytes_moved,eflag)
  342.             if (eflag .ne. 0) call bagit(PUTBACK_ERROR)
  343.             if (bytes_moved .ne. increment) call bagit(PUTBACK_BADCNT)
  344.             key1 = key1 + increment
  345.       enddo
  346. * process triangular array
  347.       print *,'processing triangular array'
  348.       keyj = key
  349.       keyk = key
  350.       chunk = SIZE*REAL4
  351.       do j=1,SIZE
  352.         print *,'outer loop j = ',j
  353.         ! get arr(x,j) from extended into arrj(x)
  354.         call a2axtd(1,SIZE,REAL4,keyj,arrj,bytes_moved,eflag)
  355.         if (eflag.ne.0) call bagit(A2AXTD_ERROR)
  356.         if (bytes_moved.ne.chunk) call bagit(A2AXTD_BADCNT)
  357.         do k=1,j-1
  358.           keyk = key + (k-1)*chunk
  359.           ! get arr(x,k) from extended into arrk(x)
  360.           call a2axtd(1,SIZE,REAL4,keyk,arrk,bytes_moved,eflag)
  361.           if (eflag.ne.0) call bagit(A2AXTD_ERROR)
  362.           if (bytes_moved.ne.chunk) call bagit(A2AXTD_BADCNT)
  363.           ! do the manipulation
  364.           do i=k+1,SIZE
  365.             arrj(i) = arrj(i) + arrk(i)*arrj(k)
  366.           enddo
  367.         enddo
  368.         ! put arrj(x) back to extended memory 
  369.         call putback(1,SIZE,REAL4,arrj,keyj,bytes_moved,eflag)
  370.         if (eflag.ne.0) call bagit(A2AXTD_ERROR)
  371.         if (bytes_moved.ne.chunk) call bagit(A2AXTD_BADCNT)
  372.         keyj = keyj + chunk
  373.       enddo
  374. * sample selected members of the array in extended memory
  375.       do i=1,SIZE,125
  376.         do j=1,SIZE,125
  377.           index(1)=i
  378.           index(2)=j
  379.           call sgtrnm(ARRAY_DIM,ARRAY_SIZE,key,index,retval,eflag)
  380.           if (eflag.ne.0) call bagit(SGTRNM_ERROR)
  381.           print *,i,j,retval
  382.         enddo
  383.       enddo
  384.       call bagit(DONE)
  385.       stop
  386.       end
  387.      
  388.  
  389.  
  390. [LISTING FOUR]
  391.  
  392. * putback.for--interface a2axtd for conventional to extended memory block moves
  393. * B. E. Bauer  3/20/92
  394. *
  395.       interface to subroutine a2axtd(i1,i2,i3,r1,i4[VALUE],i5,i6)
  396.       integer*4 i1,i2,i3,i4,i5
  397.       integer*2 i6
  398.       real*4 r1
  399.       end
  400.  
  401.       subroutine putback(i1,i2,i3,r1,i4,i5,i6)
  402.       integer*4 i1, i2, i3, i4, i5
  403.       real*4 r1(*)
  404.       integer*2 i6
  405.       call a2axtd(i1,i2,i3,r1,i4,i5,i6)
  406.       return
  407.       end
  408.  
  409. [LISTING FIVE]
  410.  
  411. * bagit.inc--symbols and declarations used for error handling and the examples.
  412. * B. E. Bauer  3/20/92
  413. *
  414.       integer*4 INQXTD_ERROR,WRONG_MMANAGER,STOPPING,GETXTD_ERROR
  415.       integer*4 PUTBACK_ERROR,PUTBACK_BADCNT,A2AXTD_BADCNT
  416.       integer*4 A2AXTD_ERROR,A2FXTD_BADCNT,A2FXTD_ERROR
  417.       integer*4 F2AXTD_ERROR,F2AXTD_BADCNT,SSMRNM_ERROR
  418.       integer*4 SMPRNM_ERROR,NOT_ENOUGH,SGTRNM_ERROR
  419.       integer*4 FLASHR_ERROR,DONE
  420.       
  421.       integer*4 ARRAY_DIM,REAL4,XMS,SIZE,ON,LOWER_RIGHT
  422.  
  423.       parameter (INQXTD_ERROR=1)
  424.       parameter (WRONG_MMANAGER=2)
  425.       parameter (STOPPING=3)
  426.       parameter (GETXTD_ERROR=4)
  427.       parameter (PUTBACK_ERROR=5)
  428.       parameter (PUTBACK_BADCNT=6)
  429.       parameter (A2AXTD_BADCNT=7)
  430.       parameter (A2AXTD_ERROR=8)
  431.       parameter (A2FXTD_BADCNT=9)
  432.       parameter (A2FXTD_ERROR=9)
  433.       parameter (F2AXTD_ERROR=10)
  434.       parameter (F2AXTD_BADCNT=11)
  435.       parameter (SSMRNM_ERROR=12)
  436.       parameter (SMPRNM_ERROR=13)
  437.       parameter (NOT_ENOUGH=14)
  438.       parameter (SGTRNM_ERROR=15)
  439.       parameter (FLASHR_ERROR=16)
  440.       parameter (DONE=99)
  441.  
  442.       parameter (ARRAY_DIM = 2)       ! 2D array
  443.       parameter (REAL4 = 4)           ! size of real*4 
  444.       parameter (XMS = -1)            ! use available mmanager
  445.       parameter (SIZE = 512)          ! size of array
  446.       parameter (ON = 1)              ! convenient symbol
  447.       parameter (LOWER_RIGHT = 3)     ! where flashr flashes 
  448.  
  449.  
  450.  
  451. [LISTING SIX]
  452.  
  453. * bagit.for--error handler. Prints an appropriate message then calls endxtd 
  454. *   to ensure allocations are freed.
  455. * B. E. Bauer  3/20/92
  456. *
  457.       subroutine bagit(iflag)
  458.       integer*4 iflag
  459.       integer*2 return_status, eflag
  460.  
  461.       include 'bagit.inc'
  462.             
  463.       select case (iflag)
  464.         case (INQXTD_ERROR)
  465.           print *,'error reported by inqxtd'
  466.         case (WRONG_MMANAGER)
  467.           print *,'XMS or Mondified LIM memory manager not found'
  468.         case (STOPPING)
  469.           print *,'stopping...'
  470.         case (GETXTD_ERROR)
  471.           print *,'error reported by getxtd'
  472.         case (PUTBACK_ERROR)
  473.           print *,'error in putback(a2axtd)'
  474.         case (PUTBACK_BADCNT)
  475.           print *,'wrong number of bytes moved by putback(a2axtd)'
  476.         case (A2AXTD_BADCNT)
  477.           print *,'wrong number of bytes moved by a2axtd'
  478.         case (A2AXTD_ERROR)
  479.           print *,'error in a2axtd'
  480.         case (A2FXTD_BADCNT)
  481.           print *,'wrong number of bytes moved by a2fxtd'
  482.         case (A2FXTD_ERROR)
  483.           print *,'error in a2fxtd'
  484.         case (F2AXTD_ERROR)
  485.           print *,'error in f2axtd'
  486.         case (F2AXTD_BADCNT)
  487.           print *,'wrong number of bytes moved by f2axtd'
  488.         case (SSMRNM_ERROR)
  489.           print *,'error in ssmrnm (scalar multiply)'
  490.         case (SMPRNM_ERROR)
  491.           print *,'error in smprnm (el-by-el multiply)'
  492.         case (NOT_ENOUGH)
  493.           print *,'inadequate extended memory available'
  494.         case (SGTRNM_ERROR)
  495.           print *,'error in sgtrnm (real*4 get)'
  496.         case (FLASHR_ERROR)
  497.           print *,'error in flashr'
  498.         case (DONE)
  499.           print *,'freeing extended memory' 
  500.       end select
  501.       call endxtd(return_status, eflag)
  502.       stop 'done, exiting...'
  503.       end
  504.       
  505.  
  506.