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(1)
DATA ALPHA(1)/(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 ('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 ('MEMPTR', CMD_PTR)
CALL FMSIGT ('LUPR', LUPR)
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 CNDAF (LUA(1,1), ALPHA, NUMAI, LUS, NUMSF, LUA0,
1 LUA(1,1), LUX, LUX, NUMRED)
CALL CNDAF (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 SYSTEM 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,2), 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