*DECK DQCKIN SUBROUTINE DQCKIN (LUN, KPRINT, IPASS) C***BEGIN PROLOGUE DQCKIN C***PURPOSE Quick check for DBSKIN. C***LIBRARY SLATEC C***KEYWORDS QUICK CHECK C***AUTHOR Amos, D. E., (SNLA) C***DESCRIPTION C C ABSTRACT * A DOUBLE PRECISION ROUTINE * C DQCKIN IS A QUICK CHECK ROUTINE WHICH EXERCISES THE MAJOR C LOOPS IN SUBROUTINE DBSKIN (X,N,KODE,M,Y,NZ,IERR) FOR BICKLEY C FUNCTIONS KI(J,X). MORE PRECISELY, DQCKIN DOES CONSISTENCY CHECKS C ON THE OUTPUT FROM DBSKIN BY COMPARING SINGLE EVALUATIONS (M=1) C AGAINST SELECTED MEMBERS OF SEQUENCES WHICH ARE GENERATED BY C RECURSION. IF THE RELATIVE ERROR IS LESS THAN 1000 TIMES UNIT C ROUND OFF, THEN THE TEST IS PASSED - IF NOT, THEN X, THE VALUES C TO BE COMPARED, THE RELATIVE ERROR AND PARAMETERS KODE, N, M AND K C ARE WRITTEN ON LOGICAL UNIT 6 WHERE K IS THE MEMBER OF THE C SEQUENCE OF LENGTH M WHICH FAILED THE TEST. THAT IS, THE INDEX C OF THE FUNCTION WHICH FAILED THE TEST IS J=N+K-1. UNDERFLOW C TESTS ARE MADE AND ERROR CONDITIONS ARE TRIGGERED. C C FUNCTIONS I1MACH AND D1MACH MUST BE INITIALIZED ACCORDING TO THE C PROLOGUE IN EACH FUNCTION FOR THE MACHINE ENVIRONMENT BEFORE C DQCKIN OR DBSKIN CAN BE EXECUTED. FIFTEEN MACHINE ENVIRONMENTS C CAN BE DEFINED IN I1MACH AND D1MACH. C C***ROUTINES CALLED D1MACH, DBSKIN, I1MACH C***REVISION HISTORY (YYMMDD) C 820601 DATE WRITTEN C 890911 Removed unnecessary intrinsics. (WRB) C 890911 REVISION DATE from Version 3.2 C 891214 Prologue converted to Version 4.0 format. (BAB) C***END PROLOGUE DQCKIN INTEGER I, IERR, IFLG, IX, I1M12, J, K, KODE, LUN, M, MDEL, MM, * N, NDEL, NN INTEGER I1MACH DOUBLE PRECISION AIX, ER, TOL, V, X, XINC, Y DOUBLE PRECISION D1MACH DIMENSION V(1), Y(10) C***FIRST EXECUTABLE STATEMENT DQCKIN TOL = 1000.0D0*MAX(D1MACH(4),1.0D-18) IFLG = 0 IF(KPRINT.GE.3)WRITE (LUN,99999) 99999 FORMAT (1H1//35H QUICK CHECK DIAGNOSTICS FOR DBSKIN//) DO 70 KODE=1,2 N = 0 DO 60 NN=1,7 M = 1 DO 50 MM=1,4 X = 0.0D0 DO 40 IX=1,6 IF (N.EQ.0 .AND. IX.EQ.1) GO TO 30 CALL DBSKIN(X, N, KODE, M, Y, NZ, IERR) DO 20 K=1,M,2 J = N + K - 1 CALL DBSKIN(X, J, KODE, 1, V, NZ, IERR) ER = ABS((V(1)-Y(K))/V(1)) IF (ER.LE.TOL) GO TO 20 IF (IFLG.NE.0) GO TO 10 IF(KPRINT.GE.2)WRITE (LUN,99998) 99998 FORMAT (8X, 1HX, 13X, 4HV(1), 11X, 4HY(K), 9X, 6HREL ER, * 1HR, 5X, 4HKODE, 3X, 1HN, 4X, 1HM, 4X, 1HK) 10 CONTINUE IFLG = IFLG + 1 IF(KPRINT.GE.2) * WRITE (LUN,99997) X, V(1), Y(K), ER, KODE, N, M, K 99997 FORMAT (4E15.6, 4I5) IF (IFLG.GT.200) GO TO 130 20 CONTINUE 30 CONTINUE AIX = 2*IX - 3 XINC = MAX(1.0D0,AIX) X = X + XINC 40 CONTINUE MDEL = MAX(1,MM-1) M = M + MDEL 50 CONTINUE NDEL = MAX(1,2*N-2) N = N + NDEL 60 CONTINUE 70 CONTINUE C----------------------------------------------------------------------- C TEST UNDERFLOW C----------------------------------------------------------------------- KODE = 1 M = 10 N = 10 I1M12 = I1MACH(15) X = -2.302D0*D1MACH(5)*I1M12 CALL DBSKIN(X, N, KODE, M, Y, NZ, IERR) IF (NZ.EQ.M) GO TO 80 IF(KPRINT.GE.2)WRITE (LUN,99996) 99996 FORMAT (//30H NZ IN UNDERFLOW TEST IS NOT 1//) IFLG = IFLG + 1 GO TO 110 80 CONTINUE DO 90 I=1,M IF (Y(I).NE.0.0D0) GO TO 100 90 CONTINUE GO TO 110 100 CONTINUE IFLG = IFLG + 1 IF(KPRINT.GE.2)WRITE (LUN,99995) 99995 FORMAT (//43H SOME Y VALUE IN UNDERFLOW TEST IS NOT ZERO//) 110 CONTINUE IF (IFLG.NE.0.OR.KPRINT.LT.3) GO TO 120 WRITE (LUN,99994) 99994 FORMAT (//16H QUICK CHECKS OK//) 120 CONTINUE IPASS=0 IF(IFLG.EQ.0)IPASS=1 RETURN 130 CONTINUE IF(KPRINT.GE.2)WRITE (LUN,99992) 99992 FORMAT (//52H PROCESSING OF MAIN LOOPS TERMINATED BECAUSE THE NUM, * 36HBER OF DIAGNOSTIC PRINTS EXCEEDS 200//) IPASS=0 IF(IFLG.EQ.0)IPASS=1 RETURN END