1*DECK DBIKCK
2      SUBROUTINE DBIKCK (LUN, KPRINT, IPASS)
3C***BEGIN PROLOGUE  DBIKCK
4C***PURPOSE  Quick check for DBESI and DBESK.
5C***LIBRARY   SLATEC
6C***TYPE      DOUBLE PRECISION (BIKCK-S, DBIKCK-D)
7C***KEYWORDS  QUICK CHECK
8C***AUTHOR  Amos, D. E., (SNLA)
9C***DESCRIPTION
10C
11C   DBIKCK is a quick check routine for DBESI and DBESK.  The main loops
12C   evaluate the Wronskian and test the error.  Underflow and overflow
13C   diagnostics are checked in addition to illegal arguments.
14C
15C***ROUTINES CALLED  D1MACH, DBESI, DBESK, NUMXER, XERCLR, XGETF, XSETF
16C***REVISION HISTORY  (YYMMDD)
17C   750101  DATE WRITTEN
18C   890911  Removed unnecessary intrinsics.  (WRB)
19C   891004  Removed unreachable code.  (WRB)
20C   891004  REVISION DATE from Version 3.2
21C   891214  Prologue converted to Version 4.0 format.  (BAB)
22C   901205  Changed usage of D1MACH(3) to D1MACH(4).  (RWC)
23C   910121  Editorial Changes.  (RWC)
24C   910501  Added TYPE record.  (WRB)
25C   910708  Code revised to test error returns for all values of
26C           KPRINT.  (WRB)
27C   910801  Editorial changes, some restructing and modifications to
28C           obtain more information when there is failure of the
29C           Wronskian.  (WRB)
30C***END PROLOGUE  DBIKCK
31      INTEGER I, IPASS, IX, K, KODE, KONTRL, LUN, M, N, NERR, NU, NW, NY
32      DOUBLE PRECISION ALP, DEL, ER, FNU, FNUP, RX, TOL, X
33      DOUBLE PRECISION FN(3), W(5), XX(5), Y(5)
34      DOUBLE PRECISION D1MACH
35      LOGICAL FATAL
36C***FIRST EXECUTABLE STATEMENT  DBIKCK
37      IF (KPRINT .GE. 2) WRITE (LUN,90000)
38C
39      IPASS = 1
40      XX(1) = 0.49D0
41      XX(2) = 1.3D0
42      XX(3) = 5.3D0
43      XX(4) = 13.3D0
44      XX(5) = 21.3D0
45      FN(1) = 0.095D0
46      FN(2) = 0.70D0
47      FN(3) = 0.0D0
48      TOL = MAX(500.0D0*D1MACH(4), 7.1D-12)
49      DO 60 KODE=1,2
50         DO 50 M=1,3
51            DO 40 N=1,4
52               DO 30 NU=1,4
53                  FNU = FN(M) + 12*(NU-1)
54                  DO 20 IX=1,5
55                     IF (IX.LT.2 .AND. NU.GT.3) GO TO 20
56                     X = XX(IX)
57                     RX = 1.0D0/X
58                     CALL DBESI(X, FNU, KODE, N, Y, NY)
59                     IF (NY.NE.0) GO TO 20
60                     CALL DBESK(X, FNU, KODE, N, W, NW)
61                     IF (NW.NE.0) GO TO 20
62                     FNUP = FNU + N
63                     CALL DBESI(X,FNUP,KODE,1,Y(N+1),NY)
64                     IF (NY.NE.0) GO TO 20
65                     CALL DBESK(X,FNUP,KODE,1,W(N+1),NW)
66                     IF (NW.NE.0) GO TO 20
67                     DO 10 I=1,N
68                        ER = Y(I+1)*W(I) + W(I+1)*Y(I) - RX
69                        ER = ABS(ER)*X
70                        IF (ER.GT.TOL) THEN
71                           IPASS = 0
72                           IF (KPRINT.GE.2) WRITE (LUN,90010) KODE,M,N,
73     *                        NU,IX,I,X,ER,TOL,
74     *                        Y(I),Y(I+1),W(I),W(I+1)
75                        ENDIF
76   10                CONTINUE
77   20             CONTINUE
78   30          CONTINUE
79   40       CONTINUE
80   50    CONTINUE
81   60 CONTINUE
82C
83C     Check small values of X and order
84C
85      N = 2
86      FNU = 1.0D0
87      X = D1MACH(4)
88      DO 80 I=1,3
89         DO 70 KODE=1,2
90            CALL DBESI(X, FNU, KODE, N, Y, NY)
91            CALL DBESK(X, FNU, KODE, N, W, NW)
92            ER = Y(2)*W(1) + W(2)*Y(1) - 1.0D0/X
93            ER = ABS(ER)*X
94            IF (ER.GT.TOL) THEN
95               IPASS = 0
96               IF (KPRINT.GE.2) WRITE (LUN,90020) I,KODE,FNU,X,ER,TOL,
97     +            Y(1),Y(2),W(1),W(2)
98               GO TO 700
99            ENDIF
100   70    CONTINUE
101C
102  700    FNU = D1MACH(4)/100.0D0
103         X = XX(2*I-1)
104   80 CONTINUE
105C
106C     Check large values of X and order
107C
108      KODE = 2
109      DO 76 K=1,2
110         DEL = 30*(K-1)
111         FNU = 45.0D0+DEL
112         DO 75 N=1,2
113            X = 20.0D0 + DEL
114            DO 71 I=1,5
115               RX = 1.0D0/X
116               CALL DBESI(X, FNU, KODE, N, Y, NY)
117               IF (NY.NE.0) GO TO 71
118               CALL DBESK(X, FNU, KODE, N, W, NW)
119               IF (NW.NE.0) GO TO 71
120               IF (N.EQ.1) THEN
121                  FNUP = FNU + 1.0D0
122                  CALL DBESI(X,FNUP,KODE,1,Y(2),NY)
123                  IF (NY.NE.0) GO TO 71
124                  CALL DBESK(X,FNUP,KODE,1,W(2),NW)
125                  IF (NW.NE.0) GO TO 71
126               ENDIF
127               ER = Y(2)*W(1) + Y(1)*W(2) - RX
128               ER = ABS(ER)*X
129               IF (ER.GT.TOL) THEN
130                  IPASS = 0
131                  IF (KPRINT.GE.2) WRITE (LUN,90030) K,N,I,FNUP,X,
132     +               ER,TOL,Y(1),Y(2),W(1),W(2)
133                  GO TO 760
134               ENDIF
135               X = X + 10.0D0
136   71       CONTINUE
137   75    CONTINUE
138   76 CONTINUE
139C
140C     Check underflow flags
141C
142  760 X = D1MACH(1)*10.0D0
143      ALP = 12.3D0
144      N = 3
145      CALL DBESI(X, ALP, 1, N, Y, NY)
146      IF (NY.NE.3) THEN
147         IPASS = 0
148         IF (KPRINT.GE.2) WRITE (LUN,90040)
149      ENDIF
150C
151      X = LOG(D1MACH(2)/10.0D0) + 20.0D0
152      ALP = 1.3D0
153      N = 3
154      CALL DBESK(X, ALP, 1, N, W, NW)
155      IF (NW.NE.3) THEN
156         IPASS = 0
157         IF (KPRINT.GE.2) WRITE (LUN,90050)
158      ENDIF
159C
160C     Trigger 10 error conditions
161C
162      CALL XGETF (KONTRL)
163      IF (KPRINT .LE. 2) THEN
164         CALL XSETF (0)
165      ELSE
166         CALL XSETF (1)
167      ENDIF
168      FATAL = .FALSE.
169      CALL XERCLR
170C
171      IF (KPRINT .GE. 3) WRITE (LUN,90060)
172      XX(1) = 1.0D0
173      XX(2) = 1.0D0
174      XX(3) = 1.0D0
175      XX(4) = 1.0D0
176C
177C     Illegal arguments
178C
179      DO 90 I=1,4
180         XX(I) = -XX(I)
181         K = INT(XX(3))
182         N = INT(XX(4))
183         CALL DBESI(XX(1), XX(2), K, N, Y, NY)
184         IF (NUMXER(NERR) .NE. 2) THEN
185            IPASS = 0
186            FATAL = .TRUE.
187         ENDIF
188         CALL XERCLR
189         CALL DBESK(XX(1), XX(2), K, N, W, NW)
190         IF (NUMXER(NERR) .NE. 2) THEN
191            IPASS = 0
192            FATAL = .TRUE.
193         ENDIF
194         CALL XERCLR
195         XX(I) = -XX(I)
196   90 CONTINUE
197C
198C     Trigger overflow
199C
200      X = LOG(D1MACH(2)/10.0D0) + 20.0D0
201      N = 3
202      ALP = 2.3D0
203      CALL DBESI(X, ALP, 1, N, Y, NY)
204      IF (NUMXER(NERR) .NE. 6) THEN
205         IPASS = 0
206         FATAL = .TRUE.
207      ENDIF
208      CALL XERCLR
209C
210      X = D1MACH(1)*10.0D0
211      CALL DBESK(X, ALP, 1, N, W, NW)
212      IF (NUMXER(NERR) .NE. 6) THEN
213         IPASS = 0
214         FATAL = .TRUE.
215      ENDIF
216      CALL XERCLR
217C
218      CALL XSETF (KONTRL)
219      IF (FATAL) THEN
220         IF (KPRINT .GE. 2) THEN
221            WRITE (LUN, 90070)
222         ENDIF
223      ELSE
224         IF (KPRINT .GE. 3) THEN
225            WRITE (LUN, 90080)
226         ENDIF
227      ENDIF
228C
229      IF (IPASS.EQ.1 .AND. KPRINT.GE.2) WRITE (LUN,90100)
230      IF (IPASS.EQ.0 .AND. KPRINT.GE.1) WRITE (LUN,90110)
231      RETURN
23290000 FORMAT (/ ' QUICK CHECKS FOR DBESI AND DBESK' //)
23390010 FORMAT (/ ' ERROR IN QUICK CHECK OF WRONSKIAN', 1P /
234     +        ' KODE = ', I1,', M = ', I1, ', N = ', I1, ', NU = ', I1,
235     +        ', IX = ', I1, ', I = ', I1 /
236     +        ' X = ', E14.7, ', ER   = ', E14.7, ', TOL = ', E14.7 /
237     +        ' Y(I) = ', E14.7, ', Y(I+1) = ', E14.7 /
238     +        ' W(I) = ', E14.7, ', W(I+1) = ', E14.7)
23990020 FORMAT (/ ' ERROR IN QUICK CHECK OF SMALL X AND ORDER', 1P /
240     +        ' I = ', I1,', KODE = ', I1, ', FNU = ', E14.7 /
241     +        ' X = ', E14.7, ', ER = ', E14.7, ', TOL = ', E14.7 /
242     +        ' Y(1) = ', E14.7, ', Y(2) = ', E14.7 /
243     +        ' W(1) = ', E14.7, ', W(2) = ', E14.7)
24490030 FORMAT (/ ' ERROR IN QUICK CHECK OF LARGE X AND ORDER', 1P /
245     +        ' K = ', I1,', N = ', I1, ', I = ', I1,
246     +        ', FNUP = ', E14.7 /
247     +        ' X = ', E14.7, ', ER = ', E14.7, ', TOL = ', E14.7 /
248     +        ' Y(1) = ', E14.7, ', Y(2) = ', E14.7 /
249     +        ' W(1) = ', E14.7, ', W(2) = ', E14.7)
25090040 FORMAT (/ ' ERROR IN DBESI UNDERFLOW TEST' /)
25190050 FORMAT (/ ' ERROR IN DBESK UNDERFLOW TEST' /)
25290060 FORMAT (// ' TRIGGER 10 ERROR CONDITIONS' //)
25390070 FORMAT (/ ' AT LEAST ONE INCORRECT ARGUMENT TEST FAILED')
25490080 FORMAT (/ ' ALL INCORRECT ARGUMENT TESTS PASSED')
25590100 FORMAT (/' *********DBESI AND DBESK PASSED ALL TESTS***********')
25690110 FORMAT (/' *********DBESI OR DBESK FAILED SOME TESTS***********')
257      END
258