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