mirror of
https://git.planet-casio.com/Lephenixnoir/OpenLibm.git
synced 2025-01-01 06:23:39 +01:00
66 lines
2.3 KiB
Fortran
66 lines
2.3 KiB
Fortran
*DECK MPCHK
|
|
SUBROUTINE MPCHK (I, J)
|
|
C***BEGIN PROLOGUE MPCHK
|
|
C***SUBSIDIARY
|
|
C***PURPOSE Subsidiary to DQDOTA and DQDOTI
|
|
C***LIBRARY SLATEC
|
|
C***TYPE ALL (MPCHK-A)
|
|
C***AUTHOR (UNKNOWN)
|
|
C***DESCRIPTION
|
|
C
|
|
C Checks legality of B, T, M, MXR and LUN which should be set
|
|
C in COMMON. The condition on MXR (the dimension of the EP arrays)
|
|
C is that MXR .GE. (I*T + J)
|
|
C
|
|
C***SEE ALSO DQDOTA, DQDOTI, MPBLAS
|
|
C***ROUTINES CALLED I1MACH, MPERR
|
|
C***COMMON BLOCKS MPCOM
|
|
C***REVISION HISTORY (YYMMDD)
|
|
C 791001 DATE WRITTEN
|
|
C ?????? Modified for use with BLAS. Blank COMMON changed to named
|
|
C COMMON. R given dimension 12.
|
|
C 891009 Removed unreferenced statement label. (WRB)
|
|
C 891009 REVISION DATE from Version 3.2
|
|
C 891214 Prologue converted to Version 4.0 format. (BAB)
|
|
C 900402 Added TYPE section. (WRB)
|
|
C 930124 Increased Array size in MPCON for SUN -r8. (RWC)
|
|
C***END PROLOGUE MPCHK
|
|
COMMON /MPCOM/ B, T, M, LUN, MXR, R(30)
|
|
INTEGER B, T, R
|
|
C***FIRST EXECUTABLE STATEMENT MPCHK
|
|
LUN = I1MACH(4)
|
|
C NOW CHECK LEGALITY OF B, T AND M
|
|
IF (B.GT.1) GO TO 40
|
|
WRITE (LUN, 30) B
|
|
30 FORMAT (' *** B =', I10, ' ILLEGAL IN CALL TO MPCHK,'/
|
|
1 ' PERHAPS NOT SET BEFORE CALL TO AN MP ROUTINE ***')
|
|
CALL MPERR
|
|
40 IF (T.GT.1) GO TO 60
|
|
WRITE (LUN, 50) T
|
|
50 FORMAT (' *** T =', I10, ' ILLEGAL IN CALL TO MPCHK,'/
|
|
1 ' PERHAPS NOT SET BEFORE CALL TO AN MP ROUTINE ***')
|
|
CALL MPERR
|
|
60 IF (M.GT.T) GO TO 80
|
|
WRITE (LUN, 70)
|
|
70 FORMAT (' *** M .LE. T IN CALL TO MPCHK,'/
|
|
1 ' PERHAPS NOT SET BEFORE CALL TO AN MP ROUTINE ***')
|
|
CALL MPERR
|
|
C 8*B*B-1 SHOULD BE REPRESENTABLE, IF NOT WILL OVERFLOW
|
|
C AND MAY BECOME NEGATIVE, SO CHECK FOR THIS
|
|
80 IB = 4*B*B - 1
|
|
IF ((IB.GT.0).AND.((2*IB+1).GT.0)) GO TO 100
|
|
WRITE (LUN, 90)
|
|
90 FORMAT (' *** B TOO LARGE IN CALL TO MPCHK ***')
|
|
CALL MPERR
|
|
C CHECK THAT SPACE IN COMMON IS SUFFICIENT
|
|
100 MX = I*T + J
|
|
IF (MXR.GE.MX) RETURN
|
|
C HERE COMMON IS TOO SMALL, SO GIVE ERROR MESSAGE.
|
|
WRITE (LUN, 110) I, J, MX, MXR, T
|
|
110 FORMAT (' *** MXR TOO SMALL OR NOT SET TO DIM(R) BEFORE CALL',
|
|
1 ' TO AN MP ROUTINE *** ' /
|
|
2 ' *** MXR SHOULD BE AT LEAST', I3, '*T +', I4, ' =', I6, ' ***'
|
|
3 / ' *** ACTUALLY MXR =', I10, ', AND T =', I10, ' ***')
|
|
CALL MPERR
|
|
RETURN
|
|
END
|