Example 23. Populating two systems concurrently using OpenMP
This example illustrates how to use FMS to build
two systems of equations concurrently. The matrix and vector data
is generated in parallel using FMS or OpenMP.
C-----------------------------------------------------------------------
C DECLARATIONS
C-----------------------------------------------------------------------
C E X A M P L E 23
C
C FMS Parameters:
INTEGER LUPR
INTEGER MAXCPU
INTEGER MAXMD
INTEGER MDUSED
C
C Subroutines called in parallel:
EXTERNAL COLUMN
EXTERNAL RHS
C
C Name of this program:
CHARACTER*10 MYNAME
PARAMETER (MYNAME='EXAMPLE_23')
C
C Input Data functions:
LOGICAL ASK
INTEGER ASK_I
C
C Problem size parameters:
INTEGER NUMEQ1, NUMEQ2, NRHS
C
C Use OpenMP to fill matrix:
LOGICAL OMP_FILL
C
C Use OpenMP MUTEX locks:
COMMON/MYDATA/OMP_MUTEX
LOGICAL OMP_MUTEX
C
C Scale factor for input matrices to CNDAF:
COMPLEX*16 ALPHA
DATA ALPHA/(1.0D0,0.0D0)/
C
C Number of initialization matrices:
INTEGER NUMAI
DATA NUMAI/1/
C
C Number of submatrices:
INTEGER NUMSF
DATA NUMSF/0/
C
C Number of vectors to reduce during factoring:
INTEGER NUMRED
DATA NUMRED/0/
C
C Skip operations during solving (no):
INTEGER ISKIP
DATA ISKIP/0/
C
C Dummy Complex argument to FMSCOL:
COMPLEX*16 CDUMMY
DATA CDUMMY/(0.0D0,0.0D0)/
C
C FMS matrix and vector file attributes:
C Matrix file:
INTEGER LUA(25,2)
C Vector file:
INTEGER LUX(25,2)
C Dummy submatrix file:
INTEGER LUS(25)
C Dummy output matrix file:\
INTEGER LUA0(25)
DATA LUA0(1)/0/
C
C Data type:
INTEGER IDTYPE
C Complex*16:
PARAMETER (IDTYPE=2)
C
C FMS profile vector:
C LOWEQ(1)=-1 flags a full matrix:
INTEGER LOWEQ(1)
DATA LOWEQ/-1/
C
C Constants used for this test matrix:
COMPLEX*16 CZERO, CONE, ANSWER
PARAMETER (CZERO = (0.0D0, 0.0D0))
PARAMETER (ANSWER = (0.5D0,-0.5D0))
C
C Variables used to check answer:
REAL*8 ERROR, ETEST
C
C Local variables:
INTEGER L_X, LENX
INTEGER MDLEFT, MDINC
INTEGER LOCD
INTEGER LENVEC1, LENVEC2
C
C Work queue variables (shared):
INTEGER NXCOL, NXRHS
C
C FMS memory management requires the following arrays:
POINTER (CMD_PTR, CMD)
POINTER (RMD_PTR, RMD)
POINTER (IMD_PTR, IMD)
COMPLEX*16 CMD(0:1)
REAL*8 RMD(0:1)
INTEGER IMD(0:1)
C-----------------------------------------------------------------------
C (1) Initialize FMS:
C-----------------------------------------------------------------------
CALL FMSINI
CALL FMSPSH (MYNAME)
CALL FMSIGT ('MEMPTR', CMD_PTR)
CALL FMSIGT ('LUPR', LUPR)
CALL FMSIGT ('LOGTIM', LOGTIM)
IF(LOGTIM .LT. 3) CALL FMSIST ('LOGTIM', 3)
CALL FMSIST ('IPRF' , 1026)
C Loop back to here to do next problem:
100 CONTINUE
NUMEQ1 = ASK_I('Enter the number of equations in matrix 1')
NUMEQ2 = ASK_I('Enter the number of equations in matrix 2')
NRHS = ASK_I('Enter the number of solution vectors')
OMP_FILL = ASK('Do you want to use OpenMP to generate data')
IF(OMP_FILL) THEN
C Can use OpenMP or FMS locks:
OMP_MUTEX= ASK('Do you want to use OpenMP MUTEX locks')
ELSE
C Must use FMS locks:
OMP_MUTEX = .FALSE.
END IF
WRITE (6,*) 'You may now alter any FMS parameter.'
WRITE (6,*) 'When you are finished, type the letters RETURN'
CALL FMSSET
CALL FMSIGT ('MAXCPU', MAXCPU)
C-----------------------------------------------------------------------
C (2) Open FMS files:
C-----------------------------------------------------------------------
CALL CNDI (LOWEQ, NUMEQ1, 'Matrix1', LUA(1,1))
CALL CNDI (LOWEQ, NUMEQ2, 'Matrix2', LUA(1,2))
PRINT *,'Opening Vector file 1'
CALL FMSOV (NUMEQ1, IDTYPE, NRHS, 'Vectors1', LUX(1,1))
PRINT *,'Opening Vector file 2'
CALL FMSOV (NUMEQ2, IDTYPE, NRHS, 'Vectors2', LUX(1,2))
C-----------------------------------------------------------------------
C (3) Write data to FMS files:
C-----------------------------------------------------------------------
C
C Initialize FMSCOL for two matrices built simultaneously:
C
C Divide the remaining memory between the two matrix files:
CALL FMSIGT ('MAXMD', MAXMD)
CALL FMSIGT ('MDUSED', MDUSED)
MDLEFT = MAXMD - MDUSED
MDINC = MDLEFT/2
C Save the existing value of MAXMD:
MAXMD_S = MAXMD
C
C Initialize FMSCOL for the first file:
MAXMD = MDUSED + MDINC
CALL FMSIST ('MAXMD', MAXMD)
PRINT *,'Initializing FMSCOL for Matrix 1'
CALL FMSCOL (-1, CDUMMY, LUA(1,1))
C
C Initialize FMSCOL for the second file:
PRINT *,'Initializing FMSCOL for Matrix 2'
CALL FMSIST ('MAXMD', MAXMD_S)
CALL FMSCOL (-1, CDUMMY, LUA(1,2))
C
C Generate matrix elements in parallel
C ====================================
WRITE(LUPR,2000)
NXCOL = 0
IF(OMP_FILL) THEN
C Use OpenMP to fill in parallel:
!$OMP PARALLEL DO DEFAULT(SHARED) NUM_THREADS(MAXCPU)
DO ICPU = 1,MAXCPU
CALL COLUMN(LUA,NXCOL)
END DO
!$OMP END PARALLEL DO
ELSE
C Use FMS to fill in parallel:
C Loop over children processes:
DO ICPU = 2,MAXCPU
CALL FMSPAR (2, COLUMN, LUA, NXCOL)
END DO
C
C Start the children running:
IF(MAXCPU .GT. 1) CALL FMSRUN
C
C Do parent's part:
CALL COLUMN(LUA,NXCOL)
C
C Wait for the children to complete:
IF(MAXCPU .GT. 1) CALL FMSYNC
END IF
C
C End FMSCOL:
PRINT *,'Ending FMSCOL for Matrix 1'
CALL FMSCOL (NUMEQ1+1, CDUMMY, LUA(1,1))
PRINT *,'Ending FMSCOL for Matrix 2'
CALL FMSCOL (NUMEQ2+1, CDUMMY, LUA(1,2))
C
C Generate the RHS vectors in parallel
C ====================================
WRITE(LUPR,2001)
NXRHS = 0
IF(OMP_FILL) THEN
C Use OpenMP to fill in parallel:
!$OMP PARALLEL DO DEFAULT(SHARED) NUM_THREADS(MAXCPU)
DO ICPU = 1,MAXCPU
CALL RHS(LUX,NXRHS)
END DO
!$OMP END PARALLEL DO
ELSE
C Use FMS to fill in parallel:
C Loop over children processes:
DO ICPU = 2,MAXCPU
CALL FMSPAR (2, RHS, LUX, NXRHS)
END DO
C
C Start the children running:
IF(MAXCPU .GT. 1) CALL FMSRUN
C
C Do parent's part:
CALL RHS (LUX,NXRHS)
C
C Wait for the children to complete:
IF(MAXCPU .GT. 1) CALL FMSYNC
END IF
C-----------------------------------------------------------------------
C (4) Perform matrix algebra:
C-----------------------------------------------------------------------
CALL CNDF (LUA(1,1), ALPHA, NUMAI, LUS, NUMSF, LUA0,
1 LUA(1,1), LUX, LUX, NUMRED)
CALL CNDF (LUA(1,2), ALPHA, NUMAI, LUS, NUMSF, LUA0,
1 LUA(1,2), LUX, LUX, NUMRED)
CALL CNDS (LUA(1,1), LUX(1,1), LUX(1,1), NRHS, ISKIP)
CALL CNDS (LUA(1,2), LUX(1,2), LUX(1,2), NRHS, ISKIP)
C-----------------------------------------------------------------------
C (5) Read data from FMS files:
C-----------------------------------------------------------------------
LENVEC1 = LUX(4,1)
LENVEC2 = LUX(4,2)
IF(LENVEC1 .GT. LOENVEC2) THEN
LENX = LENVEC1/2
ELSE
LENX = LENVEC2/2
END IF
CALL FMSCMG (CMD, L_X, LENX)
C
C Check system 1:
LOCD = 1
ERROR = 0.0D0
DO IVEC = 1,NRHS
CALL FMSRED (LUX(1,1), LOCD, CMD(L_X), LENVEC1)
LOCD = LOCD + LUX(4,1)
DO I=1,NUMEQ1
ETEST = ABS( CMD(L_X + I - 1) - ANSWER )
IF(ETEST .GT. ERROR) ERROR = ETEST
END DO
END DO
PRINT *,'MAXIMUM ERROR IN SYTSTEM 1=', ERROR
C
C Check system 2:
LOCD = 1
ERROR = 0.0D0
DO IVEC = 1,NRHS
CALL FMSRED (LUX(1,2), LOCD, CMD(L_X), LENVEC2)
LOCD = LOCD + LUX(4,2)
DO I=1,NUMEQ2
ETEST = ABS( CMD(L_X + I - 1) - ANSWER )
IF(ETEST .GT. ERROR) ERROR = ETEST
END DO
END DO
PRINT *,'MAXIMUM ERROR IN SYTSTEM 2=', ERROR
CALL FMSCMR (CMD, L_X, LENX)
C-----------------------------------------------------------------------
C (6) End FMS:
C-----------------------------------------------------------------------
C Do the next problem.
CALL FMSCV (LUX(1,1))
CALL FMSCV (LUX(1,2))
CALL FMSCM (LUA(1,1))
CALL FMSCM (LUA(1,2))
IF(ASK('Do you want another solution?;')) GO TO 100
CALL FMSPOP (MYNAME)
CALL FMSEND
C-----------------------------------------------------------------------
C FORMAT STATEMENTS
C-----------------------------------------------------------------------
2000 FORMAT (/
1 ' Writing the Columns in parallel'/
2 ' ===============================')
2001 FORMAT (/
1 ' Writing the RHS vectors in parallel'/
2 ' ===================================')
END
C=======================================================================
SUBROUTINE COLUMN (LUA, NXCOL)
C-----------------------------------------------------------------------
C DESCRIPTION:
C This subroutine computes the matrix elements.
C It is designed to be run in parallel.
C
C FORMAL PARAMETERS:
C (R ) LUA(25,2) = Matrix file attribute lists
C
C (RW) NXCOL = Next column to process (shared)
C-----------------------------------------------------------------------
C Formal Parameters
C-----------------------------------------------------------------------
INTEGER LUA(25,2)
INTEGER NXCOL
C-----------------------------------------------------------------------
C Local Variables
C-----------------------------------------------------------------------
INTEGER MYCOL
INTEGER NUMEQ1, NUMEQ2
INTEGER L_A1, L_A2
LOGICAL IDO_1, IDO_2
INTEGER MY_TOTAL
INTEGER MYNODE, LUPR
COMPLEX*16 CZERO, DIA, OFFDIA
COMMON/MYDATA/OMP_MUTEX
LOGICAL OMP_MUTEX
DATA CZERO /( 0.0D0, 0.0D0)/
DATA DIA /( 1.0D0, 1.0D0)/
DATA OFFDIA/(-1.0D0,-1.0D0)/
CHARACTER*6 MYNAME
PARAMETER (MYNAME='COLUMN')
COMPLEX*16 CMD(0:1)
POINTER (CMD_PTR,CMD)
C-----------------------------------------------------------------------
CALL FMSPSH (MYNAME)
CALL FMSIGT ('MYNODE', MYNODE)
CALL FMSIGT ('LUPR', LUPR)
IDO_1 = .TRUE.
IDO_2 = .TRUE.
MY_TOTAL = 0
NUMEQ1 = LUA(8,1)
NUMEQ2 = LUA(8,2)
C
C Get temporary storage to hold a column:
CALL FMSIGT ('MEMPTR', CMD_PTR)
CALL FMSCMG (CMD, L_A1, NUMEQ1)
CALL FMSCMG (CMD, L_A2, NUMEQ2)
C
C Loop over columns:
100 CONTINUE
C Get your next column number:
C Critical Section
C ================
IF(OMP_MUTEX) THEN
!$OMP CRITICAL
MYCOL = INTINC(NXCOL)
!$OMP END CRITICAL
ELSE
CALL FMSONE
MYCOL = INTINC(NXCOL)
CALL FMSALL
END IF
C End of Critical Section
C =======================
IF(MYCOL .GT. NUMEQ1) IDO_1 = .FALSE.
IF(MYCOL .GT. NUMEQ2) IDO_2 = .FALSE.
IF((.NOT.IDO_1) .AND.
1 (.NOT.IDO_2) ) THEN
C This process is done.
CALL FMSCMR (CMD, L_A1, NUMEQ1)
CALL FMSCMR (CMD, L_A2, NUMEQ2)
C Report your total work:
IF(OMP_MUTEX) THEN
!$OMP CRITICAL
WRITE(LUPR,2000) MYNODE, MY_TOTAL
!$OMP END CRITICAL
ELSE
CALL FMSONE
WRITE(LUPR,2000) MYNODE, MY_TOTAL
CALL FMSALL
END IF
CALL FMSPOP (MYNAME)
RETURN
ELSE
MY_TOTAL = MY_TOTAL + 1
END IF
C
IF(IDO_1) THEN
IF(MYCOL .EQ. 1) THEN
CMD(L_A1) = DCMPLX(NUMEQ1,NUMEQ1)
DO I=2,NUMEQ1
CMD(L_A1+I-1) = OFFDIA
END DO
ELSE
CMD(L_A1) = OFFDIA
DO I=2,NUMEQ1
CMD(L_A1+I-1) = CZERO
END DO
CMD(L_A1+MYCOL-1) = DIA
END IF
CALL FMSCOL (MYCOL, CMD(L_A1), LUA(1,1))
END IF
C
IF(IDO_2) THEN
IF(MYCOL .EQ. 1) THEN
CMD(L_A2) = DCMPLX(NUMEQ2,NUMEQ2)
DO I=2,NUMEQ2
CMD(L_A2+I-1) = OFFDIA
END DO
ELSE
CMD(L_A2) = OFFDIA
DO I=2,NUMEQ2
CMD(L_A2+I-1) = CZERO
END DO
CMD(L_A2+MYCOL-1) = DIA
END IF
CALL FMSCOL (MYCOL, CMD(L_A2), LUA(1,2))
END IF
C
C Do the next column:
GO TO 100
2000 FORMAT (' Process',I3,' computed',I5,' Columns.')
END
C=======================================================================
SUBROUTINE RHS (LUX, NXRHS)
C=======================================================================
C
C DESCRIPTION:
C This subroutine computes the RHS vectors.
C It is designed to be run in parallel.
C
C FORMAL PARAMETERS:
C (R ) LUX(25,2) = FMS vector file attributes
C (RW) NXRHS = Next RHS to process (shared)
C-----------------------------------------------------------------------
C Formal Parameters:
C-----------------------------------------------------------------------
INTEGER LUX(25,2)
INTEGER NXRHS
C-----------------------------------------------------------------------
C Local Variables
C-----------------------------------------------------------------------
INTEGER MYRHS
LOGICAL IDO_1, IDO_2
INTEGER MY_TOTAL
INTEGER MYNODE, LUPR
CHARACTER*3 MYNAME
PARAMETER (MYNAME='RHS')
INTEGER NUMEQ1, NUMEQ2
INTEGER NUMVEC1, NUMVEC2
COMMON/MYDATA/OMP_MUTEX
LOGICAL OMP_MUTEX
COMPLEX*16 CZERO, CONE
DATA CZERO/(0.0D0,0.0D0)/
DATA CONE /(1.0D0,0.0D0)/
COMPLEX*16 CMD(0:1)
POINTER (CMD_PTR,CMD)
C
CALL FMSPSH (MYNAME)
CALL FMSIGT ('MYNODE', MYNODE)
CALL FMSIGT ('LUPR', LUPR)
IDO_1 = .TRUE.
IDO_2 = .TRUE.
MY_TOTAL = 0
NUMEQ1 = LUX( 3,1)
LENVEC1 = LUX( 4,1)
NUMVEC1 = LUX( 6,1)
NUMEQ2 = LUX( 3,2)
LENVEC2 = LUX( 4,2)
NUMVEC2 = LUX( 6,2)
C
C Get temporary storage to hold the longest vector record:
CALL FMSIGT ('MEMPTR', CMD_PTR)
IF(LENVEC1 .GT. LENVEC2) THEN
LENX = LENVEC1/2
ELSE
LENX = LENVEC2/2
END IF
CALL FMSCMG (CMD, L_X, LENX)
C
C Populate the vector with test data:
DO I=2,LENX
CMD(L_X+I-1) = CZERO
END DO
CMD(L_X) = CONE
C
C Loop over the RHS vectors:
100 CONTINUE
C Get your next RHS vector number:
C Critical Section
C ================
IF(OMP_MUTEX) THEN
!$OMP CRITICAL
MYRHS = INTINC(NXRHS)
!$OMP END CRITICAL
ELSE
CALL FMSONE
MYRHS = INTINC(NXRHS)
CALL FMSALL
END IF
C End of Critical Section
C =======================
IF(MYRHS .GT. NUMVEC1) IDO_1 = .FALSE.
IF(MYRHS .GT. NUMVEC2) IDO_2 = .FALSE.
IF((.NOT.IDO_1) .AND.
1 (.NOT.IDO_2) ) THEN
C This process is done.
CALL FMSCMR (CMD, L_X, LENX)
C Report your total work:
IF(OMP_MUTEX) THEN
!$OMP CRITICAL
WRITE(LUPR,2000) MYNODE, MY_TOTAL
!$OMP END CRITICAL
ELSE
CALL FMSONE
WRITE(LUPR,2000) MYNODE, MY_TOTAL
CALL FMSALL
END IF
CALL FMSPOP (MYNAME)
RETURN
ELSE
MY_TOTAL = MY_TOTAL + 1
END IF
C
IF(IDO_1) THEN
LDISK = 1 + LENVEC1*(MYRHS-1)
CALL FMSWRT (LUX(1,1), LDISK, CMD(L_X), LENVEC1)
END IF
C
IF(IDO_2) THEN
LDISK = 1 + LENVEC2*(MYRHS-1)
CALL FMSWRT (LUX(1,1), LDISK, CMD(L_X), LENVEC2)
END IF
GO TO 100
2000 FORMAT (' Process',I3,' computed',I5,' RHS vectors.')
END
C=======================================================================
INTEGER FUNCTION INTINC (I)
C-----------------------------------------------------------------------
C This function increments a volatile shared variable. It is
C placed in a subroutine to prevent some compilers from storing
C the value in a register and not updating it.
INTEGER I
I = I + 1
INTINC = I
RETURN
END
C=======================================================================
LOGICAL FUNCTION ASK(QUESTION)
C=======================================================================
CHARACTER* (*) QUESTION
CHARACTER*1 IYN
WRITE(6,2000) QUESTION
READ (5,1000) IYN
IF( (IYN .EQ. 'Y') .OR. (IYN .EQ. 'y') ) THEN
ASK = .TRUE.
ELSE
ASK = .FALSE.
END IF
RETURN
1000 FORMAT (A)
2000 FORMAT (1X,A,' (y,n)>')
END
C=======================================================================
INTEGER FUNCTION ASK_I(STRING)
C=======================================================================
CHARACTER* (*) STRING
WRITE(6,2000) STRING
READ (5,*) ASK_I
RETURN
2000 FORMAT (1X,A,'>')
END
Copyright © Multipath Corporation