gcc/testsuite/gfortran.dg/pr48757.f

   1 ! { dg-do compile { target i?86-*-* x86_64-*-* } }
   2 ! { dg-options "-O2 -w" }
   3 C fconc64.F, from CERNLIB (simplified)
   4
   5       FUNCTION DFCONC(X,TAU,M)
   6       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
   7       COMPLEX*16 WGAMMA,WLOGAM
   8       COMPLEX*16 CGM,CLG,CRG,I,A,B,C,TI,R,RR,U(0:3),V(0:3),W(19)
   9       LOGICAL LM0,LM1,LTA
  10       CHARACTER NAME*(*)
  11       CHARACTER*80 ERRTXT
  12       PARAMETER (NAME = 'RFCONC/DFCONC')
  13       DIMENSION T(7),H(9),S(5),P(11),D(-1:6)
  14       PARAMETER (PI  = 3.14159 26535 89793 24D+0)
  15       PARAMETER (RPI = 1.77245 38509 05516 03D+0)
  16       PARAMETER (I = (0,1))
  17       PARAMETER (Z1 = 1, HF = Z1/2, TH = 1+HF, C1 = Z1/10, C2 = Z1/5)
  18       PARAMETER (RPH = 2/PI, RPW = 2/RPI, TW = 20, NMAX = 200)
  19       DATA EPS /1D-14/
  20       ASSIGN 1 TO JP
  21       GO TO 20
  22     1 ASSIGN 2 TO JP
  23       GO TO 20
  24     2 IF(LM1) FC=2*FC/SQRT(1-X1)
  25       GO TO 99
  26    12 ASSIGN 3 TO JP
  27       GO TO 20
  28     3 IF(LM1) FC=SIGN(HF,1-X)*(TAU**2+HF**2)*SQRT(ABS(X**2-1))*FC
  29       GO TO 99
  30    13 ASSIGN 4 TO JP
  31       GO TO 20
  32     4 R1=EXP((TI-HF)*LOG(X+X)+CLG(1+TI)-CLG((TH-FM)+TI))*
  33      1        R*((HF-FM)+TI)/TI
  34       FC=RPW*R1
  35       IF(LM1) FC=FC/SQRT(1-X1)
  36       GO TO 99
  37    20 IF(LTA) THEN
  38        IF(ABS(R-RR) .LT. EPS) GO TO JP, (1,2,3,4)
  39       ELSE
  40        W(1)=X1*A*B/C
  41        R=1+W(1)
  42        DO 23 N = 1,NMAX
  43        RR=R
  44        W(1)=W(1)*X1*(A+FN)*(B+FN)/((C+FN)*(FN+1))
  45        IF(ABS(R-RR) .LT. EPS) GO TO JP, (1,2,3,4)
  46    23  CONTINUE
  47       END IF
  48    99 DFCONC=FC
  49       RETURN
  50   101 FORMAT('ILLEGAL ARGUMENT(S)  X = ',D15.8,' TAU = ',D15.8,
  51      1       ' M = ',I3)
  52   102 FORMAT('CONVERGENCE PROBLEM FOR HYPERGEOMETRIC FUNCTION, X = ',
  53      1        D15.8)
  54       END