OpenCores
URL https://opencores.org/ocsvn/openrisc/openrisc/trunk

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [testsuite/] [gfortran.dg/] [pr48757.f] - Blame information for rev 694

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 694 jeremybenn
! { 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

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.