This Fortran program is an example of the use of the LAPI active message call:
/* Amf.f */
INCLUDE 'lapif.h'
INTEGER VOLATILE CONT
COMMON /DATA/ CONT
INTEGER T_HNDL, T_INFO(10)
INTEGER TASKID, NUMTASKS
INTEGER T_BUF(10)
INTEGER L_CNTR, T_CNTR, C_CNTR
INTEGER GLOBAL_ADDR(2)
INTEGER TGT_ADDR(2), HNDLR_ADDR(2)
INTEGER LOOP, IERROR, TGT, TGT2, VAL, CUR_VAL, LENGTH
INTEGER T_ADDR
INTEGER T_UHDR(2)
INTEGER UHDR, UDATA
INTEGER UHDRLEN, UDATALEN
EXTERNAL DO_GET, HDR_HNDLR
INTEGER ERR_MSG_BUF(40)
c Not registering error handler function
DO I = 1,10
T_INFO(I) = 0
ENDDO
CALL LAPI_ADDRESS(MY_ERR_HNDLR, T_ADDR, IERROR)
T_INFO(7) = T_ADDR
CALL LAPI_INIT(T_HNDL, T_INFO, IERROR)
IF (IERROR .NE. LAPI_SUCCESS) THEN
VAL = IERROR
CALL LAPI_MSG_STRING(VAL, ERR_MSG_BUF, IERROR)
WRITE(6,*)'Error Message ',IERROR
STOP 1
ENDIF
c GET task number and number of tasks in job
CALL LAPI_QENV(T_HNDL, TASK_ID, TASKID, IERROR)
CALL LAPI_QENV(T_HNDL, NUM_TASKS, NUMTASKS, IERROR)
CALL LAPI_QENV(T_HNDL, TIMEOUT, TIME_OUT, IERROR)
CALL LAPI_QENV(T_HNDL, INTERRUPT_SET, INTR_SET, IERROR)
IF (TIME_OUT .gt. 30) THEN
VAL = 15
CALL LAPI_SENV(T_HNDL, TIMEOUT, VAL, IERROR)
ENDIF
IF (INTR_SET .eq. 1) THEN
c Turn off interrupts
VAL = 0
CALL LAPI_SENV(T_HNDL, INTERRUPT_SET, VAL, IERROR)
ENDIF
c Turn off parameter checking - default is on
VAL=0
CALL LAPI_SENV(T_HNDL, ERROR_CHK, VAL, IERROR)
c Initialize counters to be zero at the start
CALL LAPI_SETCNTR(T_HNDL, L_CNTR, VAL, IERROR)
CALL LAPI_SETCNTR(T_HNDL, T_CNTR, VAL, IERROR)
CALL LAPI_SETCNTR(T_HNDL, C_CNTR, VAL, IERROR)
WRITE(6,*) "Node ",TASKID," Running AM fortran test."
IF (NUMTASKS .eq. 2) THEN
c Run only if number of tasks equal 2
c Exchange buffer address to every task - Collective call
CALL LAPI_ADDRESS(T_BUF, T_ADDR, IERROR)
CALL LAPI_ADDRESS_INIT(T_HNDL,T_ADDR,GLOBAL_ADDR,IERROR)
CALL LAPI_ADDRESS(T_CNTR, T_ADDR, IERROR)
CALL LAPI_ADDRESS_INIT(T_HNDL,T_ADDR,TGT_ADDR,IERROR)
CALL LAPI_ADDRESS(HDR_HNDLR, T_ADDR, IERROR)
CALL LAPI_ADDRESS_INIT(T_HNDL,T_ADDR,HNDLR_ADDR,IERROR)
c Task id is 0 , Origin
IF (TASKID .eq. 0) THEN
TGT = TASKID + 1
c Buffer in Fortran start at 1 and not 0
TGT2 = TGT + 1
LENGTH = 10*4
DO LOOP = 1, 10
c Update buffer
T_BUF(LOOP) = TASKID - LOOP;
ENDDO
c Global FENCE to sync before starting
CALL LAPI_GFENCE(T_HNDL, IERROR)
c Fill in uhdr and udata buffers for AM call
CALL LAPI_ADDRESS(DO_GET, T_UHDR(1), IERROR)
T_UHDR(2) = GLOBAL_ADDR(TGT2)
UHDRLEN = 2 * 4
c Issue AM from origin to target
CALL LAPI_AMSEND(T_HNDL, TGT, HNDLR_ADDR(TGT2),
1 T_UHDR, UHDRLEN, T_BUF, LENGTH,
2 TGT_ADDR(TGT2), L_CNTR, C_CNTR, IERROR)
c CALL LAPI_PUT(T_HNDL,TGT,LENGTH,GLOBAL_ADDR(TGT2),
c 1 T_BUF, TGT_ADDR(TGT2),
c 2 L_CNTR, C_CNTR, IERROR)
VAL = 1
CALL LAPI_WAITCNTR(T_HNDL, L_CNTR, VAL,
1 LAPI_ADDR_NULL, IERROR)
c Local buffer can be reused now
DO LOOP = 1, 10
T_BUF(LOOP) = TGT2;
ENDDO
VAL = 1
CALL LAPI_WAITCNTR(T_HNDL, C_CNTR, VAL,
1 LAPI_ADDR_NULL, IERROR)
CALL LAPI_GFENCE(T_HNDL, IERROR)
c Issue GET from origin to target
CALL LAPI_GET(T_HNDL,TGT,LENGTH,GLOBAL_ADDR(TGT2),
1 T_BUF, TGT_ADDR(TGT2),
2 L_CNTR, IERROR)
VAL = 1
CALL LAPI_WAITCNTR(T_HNDL, L_CNTR, VAL,
1 LAPI_ADDR_NULL, IERROR)
WRITE(6,*) "Node ",TASKID,
1 "done issuing GET from node ", TGT
WRITE(6,*) "Result of GET from node ", TGT
DO LOOP = 1, 10
WRITE(6,*) "T_BUF(",LOOP,") = ", T_BUF(LOOP)
ENDDO
c Task id is 1 , Target
ELSEIF (TASKID .eq. 1) THEN
TGT = TASKID - 1
DO LOOP = 1, 10
c Zero out buffer
T_BUF(LOOP) = 0
ENDDO
VAL = 0
c Global FENCE to sync before starting
CALL LAPI_GFENCE(T_HNDL, IERROR)
CALL LAPI_GETCNTR(T_HNDL, T_CNTR, VAL, IERROR)
DO WHILE (VAL .LT. 1)
c Can Do some work
CALL LAPI_PROBE(T_HNDL, IERROR)
CALL LAPI_GETCNTR(T_HNDL, T_CNTR, VAL, IERROR)
ENDDO
WRITE(6,*) "Result of AM from ",TGT, ":"
DO LOOP = 1, 10
WRITE(6,*) "T_BUF(",LOOP,") = ", T_BUF(LOOP)
ENDDO
DO WHILE (CONT .NE. 1)
c Can Do some work
CALL LAPI_PROBE(T_HNDL, IERROR)
ENDDO
CALL LAPI_GFENCE(T_HNDL, IERROR)
c To clear the T_CNTR VALue
VAL = 1
CALL LAPI_WAITCNTR(T_HNDL, T_CNTR, VAL, CUR_VAL, IERROR)
WRITE(6,*) "Node ", TASKID,
1 "done doing work and processing AM"
VAL = 0
CALL LAPI_GETCNTR(T_HNDL, T_CNTR, VAL, IERROR)
DO WHILE (VAL .LT. 1)
c Can Do some work
CALL LAPI_PROBE(T_HNDL, IERROR)
CALL LAPI_GETCNTR(T_HNDL, T_CNTR, VAL, IERROR)
ENDDO
c To clear the T_CNTR VALue
VAL = 1
CALL LAPI_WAITCNTR(T_HNDL, T_CNTR, VAL, CUR_VAL, IERROR)
WRITE(6,*) "Node ", TASKID,
1 "done doing work and processing GET"
ENDIF
ENDIF
c Global FENCE to sync before terminating job
CALL LAPI_GFENCE(T_HNDL, IERROR)
CALL LAPI_TERM(T_HNDL, IERROR)
END
SUBROUTINE MY_ERR_HNDLR (HNDL, ERROR_CODE, ERR_TYPE,
1 TASKID, SRC)
INCLUDE "lapif.h"
INTEGER HNDL, ERROR_CODE, ERR_TYPE, TASKID, SRC
INTEGER BUF(40)
WRITE(6,*) "In my error handler, HNDL=",HNDL,
1 " ERROR_CODE=",ERROR_CODE," ERR_TYPE=",ERR_TYPE,
2 " TASKID=",TASKID," SRC=",SRC
CALL LAPI_MSG_STRING(ERROR_CODE, BUF, IERROR)
WRITE(6,*) "In my error handler, error code = ", ERROR_CODE
IF (ERROR_CODE .ne. LAPI_ERR_TIMEOUT) THEN
c Cause program to exit
STOP 2
ENDIF
RETURN
END
INTEGER FUNCTION HDR_HNDLR(HNDL, UHDR, UHDRLEN, MSGLEN,
1 COMPL_HNDLR, SAVED_INFO)
INCLUDE "lapif.h"
INTEGER HNDL
INTEGER UHDR(*)
INTEGER UHDRLEN
INTEGER MSGLEN, COMPL_HNDLR, SAVED_INFO
INTEGER T_ADDR
WRITE(6,*) "In Header Handler"
WRITE(6,*) "In Header Handler: UHDRLEN = ", UHDRLEN
COMPL_HNDLR = UHDR(1)
SAVED_INFO = UHDR(2)
HDR_HNDLR = UHDR(2)
RETURN
END
SUBROUTINE DO_GET (HNDL, PARAM)
INCLUDE "lapif.h"
INTEGER HNDL, PARAM(10)
INTEGER LOOP
INTEGER VOLATILE CONT
COMMON /DATA/ CONT
WRITE(6,*) "In Completion Handler: Result of AM call"
c Print Updated buffer
DO LOOP = 1, 10
WRITE(6,*) "val[",LOOP,"] = ",PARAM(LOOP)
ENDDO
CONT = 1
RETURN
END