C E X A M P L E 20
C
C Program name:
CHARACTER*10 MYNAME
PARAMETER (MYNAME='EXAMPLE_20')
C
C FMS matrix file attributes:
C Unfactored matrix:
INTEGER LUA(25)
C FMS matrix attribute elements:
INTEGER LUA_LENRLU
PARAMETER (LUA_LENRLU= 5)
INTEGER LUA_LENDIA
PARAMETER (LUA_LENDIA= 9)
INTEGER LUA_NUMRLU
PARAMETER (LUA_NUMRLU=10)
INTEGER LUA_LENTAB
PARAMETER (LUA_LENTAB=15)
C
INTEGER LUX(25)
C FMS vector attribute elements:
INTEGER LUX_LENREC
PARAMETER (LUX_LENREC= 4)
INTEGER LUX_NUMVEC
PARAMETER (LUX_NUMVEC= 6)
C
C FMS Parameter values:
INTEGER MFMAT
INTEGER INCORE_S
INTEGER NOOPEN_S
INTEGER NUMIOQ
C
C Local variables:
C FMS Module number:
INTEGER MOD
C Number of equations:
INTEGER N
REAL*8 R8_N
C Number of R.H.S. vectors:
INTEGER NRHS
C Data type:
INTEGER IDTYPE
C Matrix symmetry:
INTEGER ISTYPE
C Input function:
LOGICAL ASK
INTEGER ASK_I
C Minimum file size
REAL*8 R8SIZE
INTEGER KBMIN
C FMS Off-diagonal matrix size:
REAL*8 R8OFF
INTEGER KBOFF
C FMS Striped file size (Kbytes)
INTEGER KBS
C FMS Non-striped file size (Kbytes)
INTEGER KBNS
C Ratio of FMS to minimum size:
REAL*8 RATIO
C Profile vector for a full matrix:
INTEGER LOWEQ(1)
DATA LOWEQ/-1/
100 CONTINUE
1 CONTINUE
WRITE (6,*) 'The FMS modules are numbered as follows:'
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'
MOD = ASK_I('Enter the FMS module number (1 to 5)')
IF( (MOD.LT.1) .OR. (MOD.GT.5) ) GO TO 1
IDTYPE = 1
IF(MOD .EQ. 3) IDTYPE = 2
IF(MOD .EQ. 4) IDTYPE = 2
IF(MOD .EQ. 5) IDTYPE = 2
ISTYPE = 1
IF((MOD .EQ. 2) .OR. (MOD .EQ. 5)) ISTYPE = 2
IF (MOD .EQ. 3) ISTYPE = 3
N = ASK_I('Enter the number of equations')
R8_N = DFLOAT(N)
NRHS = ASK_I('Enter the number of solution vectors')
WRITE (6,*) 'FMS may be initialized as follows:'
WRITE (6,*) ' 0 = Normal'
WRITE (6,*) ' 1 = Reduced with some output'
WRITE (6,*) ' 2 = Reduced with no output'
INIT = ASK_I('Type of initialization (Argument to FMSIN2)')
C
C (1) Initialize FMS:
CALL FMSIN2 (INIT)
CALL FMSIGT ('LICAPL' , LICAPL )
CALL FMSPSH (MYNAME)
WRITE (6,*) 'You may now alter any FMS parameter.'
WRITE (6,*) 'When you are finished, type the letters RETURN'
CALL FMSSET
CALL FMSIGT ('MFMAT' , MFMAT )
CALL FMSIGT ('NUMIOQ', NUMIOQ )
CALL FMSIGT ('INCORE', INCORE_S)
CALL FMSIST ('INCORE', 0)
CALL FMSIGT ('NOOPEN', NOOPEN_S)
CALL FMSIST ('NOOPEN', 1)
C
C (2) Open FMS files:
IF(MOD.EQ.1) CALL RSDI (LOWEQ, N, 'LUA', LUA)
IF(MOD.EQ.2) CALL RNDI (LOWEQ, N, 'LUA', LUA)
IF(MOD.EQ.3) CALL CHDI (LOWEQ, N, 'LUA', LUA)
IF(MOD.EQ.4) CALL CSDI (LOWEQ, N, 'LUA', LUA)
IF(MOD.EQ.5) CALL CNDI (LOWEQ, N, 'LUA', LUA)
C
C Compute the size of the off-diagonal matrix files:
R8OFF = DFLOAT(LUA(LUA_LENRLU)) * DFLOAT(LUA(LUA_NUMRLU))
IF(ISTYPE .EQ. 2) R8OFF = (2.0D0)*R8OFF
KBOFF = INT(R8OFF/(128.0D0))
C
C Compute the size of the striped and non-striped files:
KBNS = ( LUA(LUA_LENDIA) +
1 LUA(LUA_LENTAB) )/128
IF(NUMIOQ .EQ. 0) THEN
C Matrix files are not striped:
KBS = 0
KBNS = KBNS + KBOFF
ELSE
C Matrix files are striped:
KBS = KBOFF
END IF
C
C Compute the minimum size required:
IF(ISTYPE .EQ. 2) THEN
R8SIZE = R8_N * R8_N
ELSE
R8SIZE = R8_N * (R8_N + 1.0D0)/(2.0D0)
END IF
IF(IDTYPE .EQ. 2) R8SIZE = (2.0D0)*R8SIZE
KBMIN = INT(R8SIZE/(128.0D0))
RATIO = DFLOAT(KBS+KBNS)/DFLOAT(KBMIN)
WRITE(6,2000) N, MFMAT, IDTYPE, ISTYPE, KBMIN, KBS, KBNS, RATIO
C
C Compute the size of the FMS vector file:
CALL FMSOV (N, IDTYPE, NRHS, 'LUX', LUX)
R8SIZE = DFLOAT(LUX(LUX_LENREC)) * DFLOAT(LUX(LUX_NUMVEC))
KBX = INT( R8SIZE/(128.0D0) )
IF(NUMIOQ .EQ. 0) THEN
C Vector file is not striped:
KBNS = KBX
KBS = 0
ELSE
C Vector file is striped:
KBNS = 0
KBS = KBX
END IF
C
C Compute the minimum space required:
R8SIZE = R8_N * DFLOAT(NRHS)
IF(IDTYPE .EQ. 2) R8SIZE = (2.0D0)*R8SIZE
KBMIN = INT(R8SIZE/(128.0D0))
RATIO = DFLOAT(KBS+KBNS)/DFLOAT(KBMIN)
WRITE(6,2001) N, NRHS, IDTYPE, KBMIN, KBS, KBNS, RATIO
C
C Show the status of the Matrix and Vector files:
CALL FMSCST ('SHOW', 'FILES')
C
C (6) Close FMS files:
CALL FMSCM (LUA)
CALL FMSCV (LUX)
CALL FMSIST ('INCORE', INCORE_S)
CALL FMSIST ('NOOPEN', NOOPEN_S)
CALL FMSPOP (MYNAME)
CALL FMSEND
IF(ASK('Do you want another solution?')) GO TO 100
2000 FORMAT (/
1 'File size for matrix:'/
2 ' Number of equations.............=',I10/
3 ' Matrix format...................=',I10/
4 ' Data type.......................=',I10/
5 ' Symmetry........................=',I10/
6 ' Minimum space...........(Kbytes)=',I10/
7 ' FMS striped space.......(Kbytes)=',I10/
8 ' FMS non-striped space...(Kbytes)=',I10/
9 ' Ratio (FMS space/Minimum space).=',F10.2)
2001 FORMAT (/
1 'File size for vectors:'/
2 ' Number of equations.............=',I10/
3 ' Number of vectors...............=',I10/
4 ' Data type.......................=',I10/
5 ' Minimum space...........(Kbytes)=',I10/
6 ' FMS striped space.......(Kbytes)=',I10/
7 ' FMS non-striped space...(Kbytes)=',I10/
8 ' Ratio (FMS space/Minimum space).=',F10.2)
END
C=======================================================================
LOGICAL FUNCTION ASK(QUESTION)
C=======================================================================
CHARACTER* (*) QUESTION
CHARACTER*1 IYN
WRITE(6,2000) QUESTION
READ (5,1000) IYN
WRITE(6,2001) 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)>')
2001 FORMAT (4X,'You entered ',A)
END
C=======================================================================
INTEGER FUNCTION ASK_I(STRING)
C=======================================================================
CHARACTER* (*) STRING
WRITE(6,2000) STRING
READ (5,*) ASK_I
RETURN
2000 FORMAT (1X,A,'>')
END