- FMS Module
RS = Real Symmetric
RN = Real Nonsymmetric
CH = Complex Hermitian
CS = Complex Symmetric
CN = Complex Nonsymmetric
- Number of equations
- Number of solution vectors
- Any FMS Parameter
This example is designed to support pre-sales benchmarking of machines.
C E X A M P L E 11 C C Program name: CHARACTER*10 MYNAME PARAMETER (MYNAME='EXAMPLE_11') C C Subroutines called in parallel: EXTERNAL WRITEV C C Input data functions: LOGICAL ASK INTEGER ASK_I C C Number of vectors to reduce during factoring: PARAMETER (NUMRED = 0) C C Skip operations during solving (no): PARAMETER (ISKIP = 0) C C FMS matrix and vector file attributes: INTEGER LUF(25) INTEGER LUX(25) 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 Profile vector for a full matrix: INTEGER LOWEQ(1) C C FMS Parameter values: INTEGER MAXCPU INTEGER LOGTIM C C Local variables: INTEGER IDTYPE, I, LX, LENX, LDISK, NV REAL*8 EI, ERROR C C Common block to communicate with fill routines: COMMON /MYDATA/MOD, N, NRHS, LCPU1, LENLOC COMMON /SHARE/IWORK DATA LOWEQ/-1/ C C (1) Initialize FMS: CALL FMSINI C Default to generating iwatch html pages: CALL FMSIST ('IWATCH', 99) CALL FMSPSH(MYNAME) CALL FMSIST ('MDATAU', 2) CALL FMSIGT ('LOGTIM', LOGTIM) IF(LOGTIM .LT. 3) CALL FMSIST ('LOGTIM', 3) CALL FMSIGT ('IPRF', IPRF) IF(IAND(IPRF, 2) .EQ. 0) IPRF = IPRF + 2 IF(IAND(IPRF,1024) .EQ. 0) IPRF = IPRF + 1024 CALL FMSIST ('IPRF' , IPRF) C Default to using direct I/O: CALL FMSIST ('IOTYPE', 2) 1 CONTINUE WRITE (6,*) 'Enter the FMS module number (1 to 5)' WRITE (6,*) ' 1 = Real Symmetric' WRITE (6,*) ' 2 = Real Nonsymmetric' WRITE (6,*) ' 3 = Complex Hermitian' WRITE (6,*) ' 4 = Complex Symmetric' WRITE (6,*) ' 5 = Complex Nonsymmetric' READ (5,*) MOD IF( (MOD.LT.1) .OR. (MOD.GT.5) ) GO TO 1 N = ASK_I('Enter the number of equations') NRHS = ASK_I('Enter the number of solution vectors') WRITE (6,*) 'You may now alter any FMS parameter.' WRITE (6,*) 'When you are finished, type the letters RETURN' CALL FMSSET CALL FMSIGT ('MEMPTR', IMD_PTR) CALL FMSIGT ('MEMPTR', RMD_PTR) CALL FMSIGT ('MEMPTR', CMD_PTR) CALL FMSIGT ('MAXCPU', MAXCPU) IF(MOD .LE. 2) THEN IDTYPE = 1 ELSE IDTYPE = 2 END IF NUMEQ = N C C Allocate processor local workspace: LENLOC = NUMEQ IF(IDTYPE .EQ. 1) THEN CALL FMSRLG (RMD, LCPU1, LENLOC) ELSE CALL FMSCLG (CMD, LCPU1, LENLOC) END IF C C (2) Open FMS files: IF(MOD.EQ.1) CALL RSDI (LOWEQ, N, 'LUF', LUF) IF(MOD.EQ.2) CALL RNDI (LOWEQ, N, 'LUF', LUF) IF(MOD.EQ.3) CALL CHDI (LOWEQ, N, 'LUF', LUF) IF(MOD.EQ.4) CALL CSDI (LOWEQ, N, 'LUF', LUF) IF(MOD.EQ.5) CALL CNDI (LOWEQ, N, 'LUF', LUF) CALL FMSOV (N, IDTYPE, NRHS, 'LUX', LUX) C C (3) Write data to FMS files: C C Fill the RHS vectors in parallel: WRITE (6,2000) IWORK = 0 DO ICPU = 2,MAXCPU CALL FMSPAR (1, WRITEV, LUX) END DO IF(MAXCPU .GT. 1) CALL FMSRUN CALL WRITEV(LUX) IF(MAXCPU .GT. 1) CALL FMSYNC C C Return processor local workspace: IF(IDTYPE .EQ. 1) THEN CALL FMSRLR (RMD, LCPU1, LENLOC) ELSE CALL FMSCLR (RMD, LCPU1, LENLOC) END IF C C (4) Perform matrix algebra: IF(MOD.EQ.1) CALL RSDF (LUF, LUF, LUX, LUX, NUMRED) IF(MOD.EQ.2) CALL RNDF (LUF, LUF, LUX, LUX, NUMRED) IF(MOD.EQ.3) CALL CHDF (LUF, LUF, LUX, LUX, NUMRED) IF(MOD.EQ.4) CALL CSDF (LUF, LUF, LUX, LUX, NUMRED) IF(MOD.EQ.5) CALL CNDF (LUF, LUF, LUX, LUX, NUMRED) C CALL FMSIGT ('LOGTIM', LOGTIM) IF(LOGTIM .GE. 3) CALL FMSCST ('SHOW', 'CALLS') IF(MOD.EQ.1) CALL RSDS (LUF, LUX, LUX, NRHS, ISKIP) IF(MOD.EQ.2) CALL RNDS (LUF, LUX, LUX, NRHS, ISKIP) IF(MOD.EQ.3) CALL CHDS (LUF, LUX, LUX, NRHS, ISKIP) IF(MOD.EQ.4) CALL CSDS (LUF, LUX, LUX, NRHS, ISKIP) IF(MOD.EQ.5) CALL CNDS (LUF, LUX, LUX, NRHS, ISKIP) C C (5) Read data from FMS files: C Allocate a work array for reading the results: LENVEC = LUX(4) LDX = LENVEC/IDTYPE IF(IDTYPE .EQ. 1) THEN CALL FMSRMG (RMD, LX, LDX) ELSE CALL FMSCMG (CMD, LX, LDX) END IF C Check the answer: ERROR = 0.0D0 LDISK = 1 DO 60 NV = 1,NRHS IF(IDTYPE .EQ. 1) THEN CALL FMSRED (LUX(1), LDISK, RMD(LX), LENVEC) DO 50 I = 1,N EI = ABS(RMD(LX-1+I) - 1.0D0) IF(EI .GT. ERROR) ERROR = EI 50 CONTINUE ELSE CALL FMSRED (LUX(1), LDISK, CMD(LX), LENVEC) DO 51 I = 1,N EI = ABS(CMD(LX-1+I) - 1.0D0) IF(EI .GT. ERROR) ERROR = EI 51 CONTINUE END IF LDISK = LDISK + LENVEC 60 CONTINUE WRITE(6,*) 'MAXIMUM ERROR =', ERROR C C (6) Close FMS files: C Return the work array: IF(IDTYPE .EQ. 1) THEN CALL FMSRMR (RMD, LX, LDX) ELSE CALL FMSCMR (CMD, LX, LDX) END IF CALL FMSCM (LUF) CALL FMSCV (LUX) IF(ASK('Do you want another solution?')) GO TO 1 CALL FMSPOP(MYNAME) CALL FMSEND 2000 FORMAT (/ 1 ' Writing the RHS vectors in parallel'/ 2 ' ===================================') END C ================================================================ SUBROUTINE RSUBLK (A, D, LOWEQ, LOCEQ, IROW1, IROW2, 1 JCOL1, JCOL2, IJSTEP) C ================================================================ INTEGER IROW1, IROW2, JCOL1, JCOL2, IJSTEP INTEGER LOWEQ(*), LOCEQ(*) REAL*8 A(0:*), D(*), DIA, OFFDIA PARAMETER (DIA = 1.0D0) PARAMETER (OFFDIA=-1.0D0) COMMON /MYDATA/MOD, N, NRHS, LCPU1, LENLOC C C Populate the diagonal with test data: IF(IROW2 .EQ. JCOL2) THEN C This is a diagonal block: DO 10 I = IROW1,IROW2 D(I) = DIA 10 CONTINUE IF(IROW1 .EQ. 1) D(1) = DFLOAT(N) END IF C C Populate profile of [AL] with test data: C The term A(I,J) is addressed as A(LOCEQ(I)+IJSTEP*J) DO 20 I = IROW1,IROW2 J = LOWEQ(I) IF( (J .GE. JCOL1) .AND. 1 (J .LE. JCOL2) .AND. 2 (J .LT. I) ) A(LOCEQ(I) + IJSTEP*J) = OFFDIA 20 CONTINUE RETURN END C ================================================================ SUBROUTINE RNUBLK (A, D, LOWEQ, LOCEQ, IROW1, IROW2, 1 JCOL1, JCOL2, IJSTEP) C ================================================================ INTEGER IROW1, IROW2, JCOL1, JCOL2, IJSTEP INTEGER LOWEQ(*), LOCEQ(*) REAL*8 A(0:*), D(*), OFFDIA PARAMETER (OFFDIA=-1.0D0) C C Populate profile of [AL] with test data: C The term A(I,J) is addressed as A(LOCEQ(J)+IJSTEP*I) DO 20 J = JCOL1,JCOL2 I = LOWEQ(J) IF( (I .GE. IROW1) .AND. 1 (I .LE. IROW2) .AND. 2 (I .LT. J) ) A(LOCEQ(J) + IJSTEP*I) = OFFDIA 20 CONTINUE RETURN END C ================================================================ SUBROUTINE CHUBLK (A, D, LOWEQ, LOCEQ, IROW1, IROW2, 1 JCOL1, JCOL2, IJSTEP) C ================================================================ INTEGER IROW1, IROW2, JCOL1, JCOL2, IJSTEP INTEGER LOWEQ(*), LOCEQ(*) REAL*8 D(*), DIA COMPLEX*16 A(0:*), OFFDIA PARAMETER (DIA = 1.0D0 ) PARAMETER (OFFDIA=(-1.0D0,0.0D0)) COMMON /MYDATA/MOD, N, NRHS, LCPU1, LENLOC C C Populate the diagonal with test data: IF(IROW2 .EQ. JCOL2) THEN C This is a diagonal block: DO 10 I = IROW1,IROW2 D(I) = DIA 10 CONTINUE IF(IROW1 .EQ. 1) D(1) = DFLOAT(N) END IF C C Populate profile of [AL] with test data: C The term A(I,J) is addressed as A(LOCEQ(I)+IJSTEP*J) DO 20 I = IROW1,IROW2 J = LOWEQ(I) IF( (J .GE. JCOL1) .AND. 1 (J .LE. JCOL2) .AND. 2 (J .LT. I) ) A(LOCEQ(I) + IJSTEP*J) = OFFDIA 20 CONTINUE RETURN END C ================================================================ SUBROUTINE CSUBLK (A, D, LOWEQ, LOCEQ, IROW1, IROW2, 1 JCOL1, JCOL2, IJSTEP) C ================================================================ INTEGER IROW1, IROW2, JCOL1, JCOL2, IJSTEP INTEGER LOWEQ(*), LOCEQ(*) COMPLEX*16 A(0:*), D(*), DIA, OFFDIA PARAMETER (DIA =( 1.0D0, 1.0D0)) PARAMETER (OFFDIA=(-1.0D0,-1.0D0)) COMMON /MYDATA/MOD, N, NRHS, LCPU1, LENLOC C C Populate the diagonal with test data: IF(IROW2 .EQ. JCOL2) THEN C This is a diagonal block: DO 10 I = IROW1,IROW2 D(I) = DIA 10 CONTINUE IF(IROW1 .EQ. 1) D(1) = DCMPLX(N,N) END IF C C Populate profile of [AL] with test data: C The term A(I,J) is addressed as A(LOCEQ(I)+IJSTEP*J) DO 20 I = IROW1,IROW2 J = LOWEQ(I) IF( (J .GE. JCOL1) .AND. 1 (J .LE. JCOL2) .AND. 2 (J .LT. I) ) A(LOCEQ(I) + IJSTEP*J) = OFFDIA 20 CONTINUE RETURN END C ================================================================ SUBROUTINE CNUBLK (A, D, LOWEQ, LOCEQ, IROW1, IROW2, 1 JCOL1, JCOL2, IJSTEP) C ================================================================ INTEGER IROW1, IROW2, JCOL1, JCOL2, IJSTEP INTEGER LOWEQ(*), LOCEQ(*) COMPLEX*16 A(0:*), D(*), OFFDIA PARAMETER (OFFDIA=(-1.0D0,-1.0D0)) C C Populate profile of [AL] with test data: C The term A(I,J) is addressed as A(LOCEQ(J)+IJSTEP*I) DO 20 J = JCOL1,JCOL2 I = LOWEQ(J) IF( (I .GE. IROW1) .AND. 1 (I .LE. IROW2) .AND. 2 (I .LT. J) ) A(LOCEQ(J) + IJSTEP*I) = OFFDIA 20 CONTINUE RETURN END C ================================================================ SUBROUTINE RNUSLB (A, LOCI, LOCJ, LUFLAG, JEQN1, JEQN2, NUMEQ) C ================================================================ INTEGER JEQN1, JEQN2, NUMEQ INTEGER LOCI(NUMEQ), LOCJ(JEQN1:JEQN2,2), LUFLAG(NUMEQ) REAL*8 A(0:*), DIA, OFFDIA PARAMETER (DIA = 1.0D0) PARAMETER (OFFDIA=-1.0D0) C C Fill first row and diagonal: LU1 = LUFLAG(1) LI1 = LOCI(1) DO 10 J = JEQN1,JEQN2 LIJ = LI1 + LOCJ(J,LU1) A(LIJ) = OFFDIA LD = LOCI(J) + LOCJ(J,LUFLAG(J)) A(LD ) = DIA 10 CONTINUE C C Fill column 1 if this is the first slab: IF(JEQN1 .EQ. 1) THEN DO 20 I = 1,NUMEQ LIJ = LOCI(I) + LOCJ(1,LUFLAG(I)) A(LIJ) = OFFDIA 20 CONTINUE LD = LOCI(1) + LOCJ(1,LUFLAG(1)) A(LD) = DFLOAT(NUMEQ) END IF RETURN END C ================================================================ SUBROUTINE CNUSLB (A, LOCI, LOCJ, LUFLAG, JEQN1, JEQN2, NUMEQ) C ================================================================ INTEGER JEQN1, JEQN2, NUMEQ INTEGER LOCI(NUMEQ), LOCJ(JEQN1:JEQN2,2), LUFLAG(NUMEQ) COMPLEX*16 A(0:*), DIA, OFFDIA PARAMETER (DIA =( 1.0D0, 1.0D0)) PARAMETER (OFFDIA=(-1.0D0,-1.0D0)) C C Fill first row and diagonal: LU1 = LUFLAG(1) LI1 = LOCI(1) DO 10 J = JEQN1,JEQN2 LIJ = LI1 + LOCJ(J,LU1) A(LIJ) = OFFDIA LD = LOCI(J) + LOCJ(J,LUFLAG(J)) A(LD ) = DIA 10 CONTINUE C C Fill column 1 if this is the first slab: IF(JEQN1 .EQ. 1) THEN DO 20 I = 1,NUMEQ LIJ = LOCI(I) + LOCJ(1,LUFLAG(I)) A(LIJ) = OFFDIA 20 CONTINUE LD = LOCI(1) + LOCJ(1,LUFLAG(1)) A(LD) = DCMPLX(NUMEQ,NUMEQ) END IF RETURN END C======================================================================= SUBROUTINE WRITEV (LUX) C======================================================================= C C DESCRIPTION: C This subroutine runs in parallel. For each vector C that it finds, it fills in the terms and calls FMSWRT to C write the vector to the vector file LUX. C C FORMAL PARAMETERS: C (R ) LUX(25) = FMS vector file attributes C----------------------------------------------------------------------- C C Formal Parameters: INTEGER LUX(25) C C Local Variables: CHARACTER*6 MYNAME PARAMETER (MYNAME='WRITEV') INTEGER MYNODE INTEGER LUPR INTEGER NUMEQ INTEGER NUMVEC INTEGER NROWS, NCOLS INTEGER IEQN1, IEQN2, JEQN1, JEQN2 INTEGER MY_WORK INTEGER MY_TOTAL INTEGER LX REAL*8 RMD(0:1) COMPLEX*16 CMD(0:1) POINTER (RMD_PTR,RMD) POINTER (CMD_PTR,CMD) COMMON /MYDATA/MOD, N, NRHS, LCPU1, LENLOC COMMON/SHARE/IWORK INTEGER PARENT PARAMETER (PARENT = 0) C CALL FMSPSH(MYNAME) C Get your CPU number (0 to MAXCPU-1) CALL FMSIGT ('MYNODE', MYNODE) CALL FMSIGT ('LUPR', LUPR) NUMEQ = LUX( 3) LENVEC = LUX( 4) IDTYPE = LUX( 5) NUMVEC = LUX( 6) NROWS = NUMEQ NCOLS = 1 IEQN1 = 1 IEQN2 = NUMEQ LDX = LENVEC/IDTYPE C C Use the processor local storage for the data you generate: C For this example, we will fill [B] vector by vector. LX = LCPU1 + LENLOC*MYNODE IF(IDTYPE .EQ. 1) THEN CALL FMSIGT ('MEMPTR', RMD_PTR) DO I=1,NUMEQ RMD(LX+I-1) = 0.0D0 END DO RMD(LX) = 1.0D0 ELSE CALL FMSIGT ('MEMPTR', CMD_PTR) DO I=1,NUMEQ CMD(LX+I-1) = (0.0D0,0.0D0) END DO IF(MOD .EQ. 3) THEN CMD(LX) = (1.0D0,0.0D0) ELSE CMD(LX) = (1.0D0,1.0D0) END IF END IF C C Find the next vector to fill: MY_TOTAL = 0 10 CONTINUE CALL FMSONE C IWORK = IWORK + 1 C MY_WORK = IWORK MY_WORK = INTINC(IWORK) CALL FMSALL IF(MY_WORK .GT. NUMVEC) GO TO 100 MY_TOTAL = MY_TOTAL + 1 LDISK = 1 + LENVEC*(MY_WORK-1) C IF(IDTYPE .EQ. 1) THEN CALL FMSWRT (LUX, LDISK, RMD(LX), LENVEC) ELSE CALL FMSWRT (LUX, LDISK, CMD(LX), LENVEC) END IF GO TO 10 100 CONTINUE C Your part of the work is done: C C Report your total work: IF(MY_TOTAL .GT. 0) THEN CALL FMSONE WRITE(LUPR,2000) MYNODE, MY_TOTAL CALL FMSALL END IF CALL FMSPOP(MYNAME) RETURN 2000 FORMAT (' Process',I5,' computed',I5,' vectors.') 2001 FORMAT (' Process',I5,' is computing vector ',I5) 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 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