MINICERN/mathlib/gen/c/dbska64.F

   1 *
   2 * $Id$
   3 *
   4 * $Log$
   5 * Revision 1.1.1.1  1996/04/01 15:02:08  mclareni
   6 * Mathlib gen
   7 *
   8 *
   9 #include "gen/pilot.h"
  10 #if defined(CERNLIB_DOUBLE)
  11       SUBROUTINE DBSKA(X,IA,JA,NL,B)
  12       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
  13 #endif
  14 #if !defined(CERNLIB_DOUBLE)
  15       SUBROUTINE BSKA(X,IA,JA,NL,B)
  16 #include "gen/imp64.inc"
  17 #endif
  18       LOGICAL LEX
  19
  20       CHARACTER NAME*(*),ENAM*(*)
  21       CHARACTER*80 ERRTXT
  22       PARAMETER (NAME = 'BSKA/DBSKA', ENAM = 'EBSKA/DEBKA')
  23
  24       PARAMETER (Z1 = 1, Z2 = 2, Z3 = 3, Z4 = 4)
  25       PARAMETER (Z12 = Z1/Z2, Z13 = Z1/Z3, Z14 = Z1/Z4, Z23 = Z2/Z3)
  26       PARAMETER (Z34 = Z3/Z4)
  27
  28       DIMENSION B(0:*)
  29
  30       PARAMETER (PI = 3.14159 26535 89793D0, PIV = PI/4)
  31
  32       LEX=.FALSE.
  33       GO TO 9
  34
  35 #if defined(CERNLIB_DOUBLE)
  36       ENTRY DEBKA(X,IA,JA,NL,B)
  37 #endif
  38 #if !defined(CERNLIB_DOUBLE)
  39       ENTRY EBKA(X,IA,JA,NL,B)
  40 #endif
  41       LEX=.TRUE.
  42
  43     9 MODE=10*IA+JA
  44       N=NL-1
  45       U=2/X
  46       IF(LEX) THEN
  47        IF(X .LE. 0) THEN
  48         N=0
  49         WRITE(ERRTXT,101) X
  50         CALL MTLPRT(ENAM,'C341.1',ERRTXT)
  51        ELSEIF(NL .LT. 0 .OR. NL .GT. 100) THEN
  52         N=0
  53         WRITE(ERRTXT,103) NL
  54         CALL MTLPRT(ENAM,'C341.3',ERRTXT)
  55        ELSEIF(IA .EQ. 0) THEN
  56         A=0
  57         B(0)=DEBSK0(X)
  58         B(1)=DEBSK1(X)
  59        ELSEIF(MODE .EQ. 12) THEN
  60         A=Z12
  61         B(0)=SQRT(PIV*U)
  62         B(1)=B(0)*(1+A*U)
  63        ELSEIF(MODE .EQ. 13) THEN
  64         A=Z13
  65         B(0)=DEBKR3(X,1)
  66         B(1)=DEBKR3(X,2)+A*U*B(0)
  67        ELSEIF(MODE .EQ. 14) THEN
  68         A=Z14
  69         B(0)=DEBKR4(X,1)
  70         B(1)=DEBKR4(X,3)+A*U*B(0)
  71        ELSEIF(MODE .EQ. 23) THEN
  72         A=Z23
  73         B(0)=DEBKR3(X,2)
  74         B(1)=DEBKR3(X,1)+A*U*B(0)
  75        ELSEIF(MODE .EQ. 34) THEN
  76         A=Z34
  77         B(0)=DEBKR4(X,3)
  78         B(1)=DEBKR4(X,1)+A*U*B(0)
  79        ELSE
  80         N=0
  81         WRITE(ERRTXT,102) IA,JA
  82         CALL MTLPRT(ENAM,'C341.2',ERRTXT)
  83        ENDIF
  84       ELSE
  85        IF(X .LE. 0) THEN
  86         N=0
  87         WRITE(ERRTXT,101) X
  88         CALL MTLPRT(NAME,'C341.1',ERRTXT)
  89        ELSEIF(NL .LT. 0 .OR. NL .GT. 100) THEN
  90         N=0
  91         WRITE(ERRTXT,103) NL
  92         CALL MTLPRT(NAME,'C341.3',ERRTXT)
  93        ELSEIF(IA .EQ. 0) THEN
  94         A=0
  95         B(0)=DBESK0(X)
  96         B(1)=DBESK1(X)
  97        ELSEIF(MODE .EQ. 12) THEN
  98         A=Z12
  99         B(0)=EXP(-X)*SQRT(PIV*U)
 100         B(1)=B(0)*(1+A*U)
 101        ELSEIF(MODE .EQ. 13) THEN
 102         A=Z13
 103         B(0)=DBSKR3(X,1)
 104         B(1)=DBSKR3(X,2)+A*U*B(0)
 105        ELSEIF(MODE .EQ. 14) THEN
 106         A=Z14
 107         B(0)=DBSKR4(X,1)
 108         B(1)=DBSKR4(X,3)+A*U*B(0)
 109        ELSEIF(MODE .EQ. 23) THEN
 110         A=Z23
 111         B(0)=DBSKR3(X,2)
 112         B(1)=DBSKR3(X,1)+A*U*B(0)
 113        ELSEIF(MODE .EQ. 34) THEN
 114         A=Z34
 115         B(0)=DBSKR4(X,3)
 116         B(1)=DBSKR4(X,1)+A*U*B(0)
 117        ELSE
 118         N=0
 119         WRITE(ERRTXT,102) IA,JA
 120         CALL MTLPRT(NAME,'C341.2',ERRTXT)
 121        ENDIF
 122       ENDIF
 123       DO 1 J = 1,N
 124       A=A+1
 125     1 B(J+1)=B(J-1)+A*U*B(J)
 126       RETURN
 127   101 FORMAT('NON-POSITIVE ARGUMENT  X = ',E15.6)
 128   102 FORMAT('PAIR (IA,JA) = (',I5,I5,')  ILLEGAL')
 129   103 FORMAT('ILLEGAL  NL =',I5)
 130       END