Administration Guide

putv.f (Fortran)

This Fortran program is an example of transferring noncontiguous data using the LAPI vector transfer function:

/* lapi_fbinding_1 */
/* Example Program showing use of the LAPI vector transfer function. */
 
        implicit none
        include 'lapif.h'
        integer i
        integer eh_addr, hndl
        integer ierr, val, value
        integer ocntr,tcntr,ccntr,curcntrval
        integer addr_oc, addr_tc, addr_cc
        integer org_vec(4)
        integer tgt_vec(4)
        integer tgt_vec_addr
        integer tgt_vec_array(0:1023)
        integer recv_buf(1000000)
        integer send_buf(1000000)
        integer blk_size, stride, num_vecs
        integer tgt
        integer tgt_info_array(1024)
        integer org_info_array(1024)
        integer info(10)
        integer error_handler
        integer taskid,numtasks,maxuhdrsz,maxdatasz,maxpktsz
        character err_msg_buf(160)
 
        call LAPI_Init(hndl, info, ierr)
        if (ierr .ne. LAPI_SUCCESS) then
         val = ierr
         call LAPI_Msg_string(val,err_msg_buf,ierr)
         write(6,*) 'LAPI_Init Error message: ',err_msg_buf
         STOP 1
        else
         write(6,*) 'LAPI_Init SUCCESSFUL     '
        endif
 
        call LAPI_Address(tgt_vec, tgt_vec_addr , ierr)
        call LAPI_Address_init(hndl, tgt_vec_addr, tgt_vec_array, ierr)
 
        if (ierr .ne. LAPI_SUCCESS) then
         val = ierr
         call LAPI_Msg_string(val,err_msg_buf,ierr)
         write(6,*) 'LAPI_Address_init Error message: ',err_msg_buf
         STOP 1
        else
         write(6,*) 'LAPI_Address_init SUCCESSFUL     '
        endif
 
        call LAPI_Qenv(hndl,TASK_ID,taskid,ierr)
        if (ierr .ne. LAPI_SUCCESS) then
         val = ierr
         call LAPI_Msg_string(val,err_msg_buf,ierr)
         write(6,*) 'LAPI_Qenv Error message: ',err_msg_buf
         STOP 1
        endif
        call LAPI_Qenv(hndl,NUM_TASKS,numtasks,ierr)
        if (ierr .ne. LAPI_SUCCESS) then
         val = ierr
         call LAPI_Msg_string(val,err_msg_buf,ierr)
         write(6,*) 'LAPI_Qenv Error message: ',err_msg_buf
         STOP 1
        endif
        call LAPI_Qenv(hndl,MAX_UHDR_SZ,maxuhdrsz,ierr)
        if (ierr .ne. LAPI_SUCCESS) then
         val = ierr
         call LAPI_Msg_string(val,err_msg_buf,ierr)
         write(6,*) 'LAPI_Qenv Error message: ',err_msg_buf
         STOP 1
        endif
        call LAPI_Qenv(hndl,MAX_DATA_SZ,maxdatasz,ierr)
        if (ierr .ne. LAPI_SUCCESS) then
         val = ierr
         call LAPI_Msg_string(val,err_msg_buf,ierr)
         write(6,*) 'LAPI_Qenv Error message: ',err_msg_buf
         STOP 1
        endif
        call LAPI_Qenv(hndl,MAX_PKT_SZ,maxpktsz,ierr)
        if (ierr .ne. LAPI_SUCCESS) then
         val = ierr
         call LAPI_Msg_string(val,err_msg_buf,ierr)
         write(6,*) 'LAPI_Qenv Error message: ',err_msg_buf
         STOP 1
        endif
        write(6,*) 'numtasks = ',numtasks,' taskid = ',taskid,
     x    ' max_pkt_sz = ',maxpktsz,' max_uhdr_sz = ',maxuhdrsz,
     x    ' max_data_sz = ',maxdatasz
        blk_size = 1024
        num_vecs = 4
        stride   = 2000
        org_vec(1) = LAPI_GEN_STRIDED_XFER
        tgt_vec(1) = LAPI_GEN_STRIDED_XFER
        org_vec(2) = num_vecs
        tgt_vec(2) = num_vecs
        call LAPI_Address(org_info_array, org_vec(3), ierr)
        call LAPI_Address(tgt_info_array, tgt_vec(3), ierr)
        call LAPI_Address(send_buf, org_info_array(1), ierr)
        call LAPI_Address(recv_buf, tgt_info_array(1), ierr)
        org_info_array(2) = blk_size
        tgt_info_array(2) = blk_size
        org_info_array(3) = stride
        tgt_info_array(3) = stride
C
        tgt = mod((taskid + 1),numtasks)
 
 
        call LAPI_Gfence(hndl,ierr)
        write(6,*) 'After 1st Gfence...'
 
        write(6,*) "Issuing Putv..."
        call LAPI_Putv(hndl,tgt,tgt_vec_array(tgt),org_vec,
     x      LAPI_ADDR_NULL,LAPI_ADDR_NULL,LAPI_ADDR_NULL,ierr)
 
        write(6,*) "Done issuing Putv..."
 
        if (ierr .ne. LAPI_SUCCESS) then
         val = ierr
         call LAPI_Msg_string(val,err_msg_buf,ierr)
         write(6,*) 'LAPI_Putv Error message: ',err_msg_buf
        else
         write(6,*) 'LAPI_Putv SUCCESSFUL.....'
        endif
 
        write(6,*) 'Issuing LAPI_Gfence........'
        call LAPI_Gfence(hndl,ierr)
        write(6,*) 'Done issuing LAPI_Gfence........'
c
        write(6,*) 'Issuing LAPI_Term........'
        call LAPI_Term(hndl, ierr)
        write(6,*) 'Done issuing LAPI_Term........'
        if (ierr .ne. LAPI_SUCCESS) then
         val = ierr
         call LAPI_Msg_string(val,err_msg_buf,ierr)
         write(6,*) 'LAPI_Term Error message: ',err_msg_buf
         STOP 1
        else
         write(6,*) 'LAPI_Term SUCCESSFUL     '
        endif
c
        end
c
        subroutine error_handler(hndl,error_code,err_type,taskid,src)
        include "lapif.h"
        integer buf(40), ierr, error_code
        character carray(160)
        write(6,*) 'Error Handler: CODE = ',error_code,'error type = ',
     x   err_type,'taskid = ',taskid,' src = ',src
        call LAPI_Msg_string(error_code, carray, ierr)
        write(6,*) "Error message = ",carray
        return
        end