gcc/testsuite/g77.f-torture/execute/intrinsic77.f

   1       program intrinsic77
   2 c
   3 c  Test Fortran 77 intrinsic functions (ANSI X3.9-1978 Section 15.10)
   4 c
   5 c  Test:
   6 c  *  specific functions
   7 c  *  generic functions with each argument type
   8 c  *  specific functions by passing as subroutine argument
   9 c     where permiited by Section 13.12 of Fortran 90 standard
  10 c
  11       logical fail
  12       common /flags/ fail
  13
  14       fail = .false.
  15       call type_conversion
  16       call truncation
  17       call nearest_whole_number
  18       call nearest_integer
  19       call absolute_value
  20       call remaindering
  21       call transfer_of_sign
  22       call positive_difference
  23       call double_precision_product
  24       call choosing_largest_value
  25       call choosing_smallest_value
  26       call length_of_character_array
  27       call index_of_substring
  28       call imaginary_part
  29       call complex_conjugate
  30       call square_root
  31       call exponential
  32       call natural_logarithm
  33       call common_logarithm
  34       call sine
  35       call cosine
  36       call tangent
  37       call arcsine
  38       call arccosine
  39       call arctangent
  40       call hyperbolic_sine
  41       call hyperbolic_cosine
  42       call hyperbolic_tangent
  43       call lexically_greater_than_or_equal
  44       call lexically_greater_than
  45       call lexically_less_than_or_equal
  46       call lexically_less_than
  47
  48       if ( fail ) call abort()
  49       end
  50
  51       subroutine failure(label)
  52 c     Report failure and set flag
  53       character*(*) label
  54       logical fail
  55       common /flags/ fail
  56       write(6,'(a,a,a)') 'Test ',label,' FAILED'
  57       fail = .true.
  58       end
  59
  60       subroutine c_i(i,j,label)
  61 c     Check if INTEGER i equals j, and fail otherwise
  62       integer i,j
  63       character*(*) label
  64       if ( i .ne. j ) then
  65          call failure(label)
  66          write(6,*) 'Got ',i,' expected ', j
  67       end if
  68       end
  69
  70       subroutine c_r(a,b,label)
  71 c     Check if REAL a equals b, and fail otherwise
  72       real a, b
  73       character*(*) label
  74       if ( abs(a-b) .gt. 1.0e-5 ) then
  75          call failure(label)
  76          write(6,*) 'Got ',a,' expected ', b
  77       end if
  78       end
  79
  80       subroutine c_d(a,b,label)
  81 c     Check if DOUBLE PRECISION a equals b, and fail otherwise
  82       double precision a, b
  83       character*(*) label
  84       if ( abs(a-b) .gt. 1.0d-5 ) then
  85          call failure(label)
  86          write(6,*) 'Got ',a,' expected ', b
  87       end if
  88       end
  89
  90       subroutine c_c(a,b,label)
  91 c     Check if COMPLEX a equals b, and fail otherwise
  92       complex a, b
  93       character*(*) label
  94       if ( abs(a-b) .gt. 1.0e-5 ) then
  95          call failure(label)
  96          write(6,*) 'Got ',a,' expected ', b
  97       end if
  98       end
  99
 100       subroutine c_l(a,b,label)
 101 c     Check if LOGICAL a equals b, and fail otherwise
 102       logical a, b
 103       character*(*) label
 104       if ( a .neqv. b ) then
 105          call failure(label)
 106          write(6,*) 'Got ',a,' expected ', b
 107       end if
 108       end
 109
 110       subroutine c_ch(a,b,label)
 111 c     Check if CHARACTER a equals b, and fail otherwise
 112       character*(*) a, b
 113       character*(*) label
 114       if ( a .ne. b ) then
 115          call failure(label)
 116          write(6,*) 'Got ',a,' expected ', b
 117       end if
 118       end
 119
 120       subroutine p_i_i(f,x,i,label)
 121 c     Check if INTEGER f(x) equals i for INTEGER x
 122       integer f,x,i
 123       character*(*) label
 124       call c_i(f(x),i,label)
 125       end
 126
 127       subroutine p_i_ii(f,x1,x2,i,label)
 128 c     Check if INTEGER f(x1,x2) equals i for INTEGER x
 129       integer f,x1,x2,i
 130       character*(*) label
 131       call c_i(f(x1,x2),i,label)
 132       end
 133
 134       subroutine p_i_r(f,x,i,label)
 135 c     Check if INTEGER f(x) equals i for REAL x
 136       real x
 137       integer f,i
 138       character*(*) label
 139       call c_i(f(x),i,label)
 140       end
 141
 142       subroutine p_i_d(f,x,i,label)
 143 c     Check if INTEGER f(x) equals i for DOUBLE PRECISION x
 144       double precision x
 145       integer f,i
 146       character*(*) label
 147       call c_i(f(x),i,label)
 148       end
 149
 150       subroutine p_i_ch(f,x,a,label)
 151 c     Check if INTEGER f(x) equals a for CHARACTER x
 152       character*(*) x
 153       integer f, a
 154       character*(*) label
 155       call c_i(f(x),a,label)
 156       end
 157
 158       subroutine p_i_chch(f,x1,x2,a,label)
 159 c     Check if INTEGER f(x1,x2) equals a for CHARACTER x1 and x2
 160       character*(*) x1,x2
 161       integer f, a
 162       character*(*) label
 163       call c_i(f(x1,x2),a,label)
 164       end
 165
 166       subroutine p_r_r(f,x,a,label)
 167 c     Check if REAL f(x) equals a for REAL x
 168       real f,x,a
 169       character*(*) label
 170       call c_r(f(x),a,label)
 171       end
 172
 173       subroutine p_r_rr(f,x1,x2,a,label)
 174 c     Check if REAL f(x1,x2) equals a for REAL x1, x2
 175       real f,x1,x2,a
 176       character*(*) label
 177       call c_r(f(x1,x2),a,label)
 178       end
 179
 180       subroutine p_d_d(f,x,a,label)
 181 c     Check if DOUBLE PRECISION f(x) equals a for DOUBLE PRECISION x
 182       double precision f,x,a
 183       character*(*) label
 184       call c_d(f(x),a,label)
 185       end
 186
 187       subroutine p_d_rr(f,x1,x2,a,label)
 188 c     Check if DOUBLE PRECISION f(x1,x2) equals a for real x1,x2
 189       double precision f,a
 190       real x1,x2
 191       character*(*) label
 192       call c_d(f(x1,x2),a,label)
 193       end
 194
 195       subroutine p_d_dd(f,x1,x2,a,label)
 196 c     Check if DOUBLE PRECISION f(x1,x2) equals a for DOUBLE PRECISION x1,x2
 197       double precision f,x1,x2,a
 198       character*(*) label
 199       call c_d(f(x1,x2),a,label)
 200       end
 201
 202       subroutine p_c_c(f,x,a,label)
 203 c     Check if COMPLEX f(x) equals a for COMPLEX x
 204       complex f,x,a
 205       character*(*) label
 206       call c_c(f(x),a,label)
 207       end
 208
 209       subroutine p_r_c(f,x,a,label)
 210 c     Check if REAL f(x) equals a for COMPLEX x
 211       complex x
 212       real f, a
 213       character*(*) label
 214       call c_r(f(x),a,label)
 215       end
 216
 217       subroutine type_conversion
 218       integer i
 219       character*1 c
 220 c     conversion to integer
 221       call c_i(INT(5),5,'INT(integer)')
 222       call c_i(INT(5.01),5,'INT(real)')
 223       call c_i(INT(5.01d0),5,'INT(double)')
 224       call c_i(INT((5.01,-3.0)),5,'INT(complex)')
 225       call c_i(IFIX(5.01),5,'IFIX(real)')
 226       call c_i(IDINT(5.01d0),5,'IDINT(double)')
 227 c     conversion to real
 228       call c_r(REAL(-2),-2.0,'REAL(integer)')
 229       call c_r(REAL(-2.0),-2.0,'REAL(real)')
 230       call c_r(REAL(-2.0d0),-2.0,'REAL(double)')
 231       call c_r(REAL((-2.,9.)),-2.0,'REAL(complex)')
 232       call c_r(FLOAT(-2),-2.0,'FLOAT(int)')
 233       call c_r(SNGL(-2.0d0),-2.0,'SNGL(double)')
 234 c     conversion to double
 235       call c_d(DBLE(5),5.0d0,'DBLE(integer)')
 236       call c_d(DBLE(5.),5.0d0,'DBLE(real)')
 237       call c_d(DBLE(5.0d0),5.0d0,'DBLE(double)')
 238       call c_d(DBLE((5.0,0.5)),5.0d0,'DBLE(complex)')
 239 c     conversion to complex
 240       call c_c(CMPLX(1),(1.,0.),'CMPLX(integer)')
 241       call c_c(CMPLX(1,2),(1.,2.),'CMPLX(integer, integer)')
 242       call c_c(CMPLX(1.),(1.,0.),'CMPLX(real)')
 243       call c_c(CMPLX(1.,2.),(1.,2.),'CMPLX(real,real)')
 244       call c_c(CMPLX(1.d0),(1.,0.),'CMPLX(double)')
 245       call c_c(CMPLX(1.d0,2.d0),(1.,2.),'CMPLX(double,double)')
 246       call c_c(CMPLX(1.,2.),(1.,2.),'CMPLX(complex)')
 247 c     character conversion
 248       c = 'C'
 249       i = ichar(c)
 250       call c_i(ICHAR(c),i,'ICHAR')
 251       call c_ch(CHAR(i),c,'CHAR')
 252       end
 253
 254       subroutine truncation
 255       intrinsic aint, dint
 256       call c_r(AINT(9.2),9.0,'AINT(real)')
 257       call c_d(AINT(9.2d0),9.0d0,'AINT(double)')
 258       call c_d(DINT(9.2d0),9.0d0,'DINT(double)')
 259       call p_r_r(AINT,9.2,9.0,'AINT')
 260       call p_d_d(DINT,9.2d0,9.0d0,'DINT')
 261       end
 262
 263       subroutine nearest_whole_number
 264       intrinsic anint, dnint
 265       call c_r(ANINT(9.2),9.0,'ANINT(real)')
 266       call c_d(ANINT(9.2d0),9.0d0,'ANINT(double)')
 267       call c_d(DNINT(9.2d0),9.0d0,'DNINT(double)')
 268       call p_r_r(ANINT,9.2,9.0,'ANINT')
 269       call p_d_d(DNINT,9.2d0,9.0d0,'DNINT')
 270       end
 271
 272       subroutine nearest_integer
 273       intrinsic nint, idnint
 274       call c_i(NINT(9.2),9,'NINT(real)')
 275       call c_i(NINT(9.2d0),9,'NINT(double)')
 276       call c_i(IDNINT(9.2d0),9,'IDNINT(double)')
 277       call p_i_r(NINT,9.2,9,'NINT')
 278       call p_i_d(IDNINT,9.2d0,9,'IDNINT')
 279       end
 280
 281       subroutine absolute_value
 282       intrinsic iabs, abs, dabs, cabs
 283       call c_i(ABS(-7),7,'ABS(integer)')
 284       call c_r(ABS(-7.),7.,'ABS(real)')
 285       call c_d(ABS(-7.d0),7.d0,'ABS(double)')
 286       call c_r(ABS((3.,-4.)),5.0,'ABS(complex)')
 287       call c_i(IABS(-7),7,'IABS(integer)')
 288       call c_d( DABS(-7.d0),7.d0,'DABS(double)')
 289       call c_r( CABS((3.,-4.)),5.0,'CABS(complex)')
 290       call p_i_i(IABS,-7,7,'IABS')
 291       call p_r_r(ABS,-7.,7.,'ABS')
 292       call p_d_d(DABS,-7.0d0,7.0d0,'DABS')
 293       call p_r_c(CABS,(3.,-4.), 5.0,'CABS')
 294       end
 295
 296       subroutine remaindering
 297       intrinsic mod, amod, dmod
 298       call c_i( MOD(8,3),2,'MOD(integer,integer)')
 299       call c_r( MOD(8.,3.),2.,'MOD(real,real)')
 300       call c_d( MOD(8.d0,3.d0),2.d0,'MOD(double,double)')
 301       call c_r( AMOD(8.,3.),2.,'AMOD(real,real)')
 302       call c_d( DMOD(8.d0,3.d0),2.d0,'DMOD(double,double)')
 303       call p_i_ii(MOD,8,3,2,'MOD')
 304       call p_r_rr(AMOD,8.,3.,2.,'AMOD')
 305       call p_d_dd(DMOD,8.d0,3.d0,2.d0,'DMOD')
 306       end
 307
 308       subroutine transfer_of_sign
 309       intrinsic isign,sign,dsign
 310       call c_i(SIGN(8,-3),-8,'SIGN(integer)')
 311       call c_r(SIGN(8.,-3.),-8.,'SIGN(real,real)')
 312       call c_d(SIGN(8.d0,-3.d0),-8.d0,'SIGN(double,double)')
 313       call c_i(ISIGN(8,-3),-8,'ISIGN(integer)')
 314       call c_d(DSIGN(8.d0,-3.d0),-8.d0,'DSIGN(double,double)')
 315       call p_i_ii(ISIGN,8,-3,-8,'ISIGN')
 316       call p_r_rr(SIGN,8.,-3.,-8.,'SIGN')
 317       call p_d_dd(DSIGN,8.d0,-3.d0,-8.d0,'DSIGN')
 318       end
 319
 320       subroutine positive_difference
 321       intrinsic idim, dim, ddim
 322       call c_i(DIM(-8,-3),0,'DIM(integer)')
 323       call c_r(DIM(-8.,-3.),0.,'DIM(real,real)')
 324       call c_d(DIM(-8.d0,-3.d0),0.d0,'DIM(double,double)')
 325       call c_i(IDIM(-8,-3),0,'IDIM(integer)')
 326       call c_d(DDIM(-8.d0,-3.d0),0.d0,'DDIM(double,double)')
 327       call p_i_ii(IDIM,-8,-3,0,'IDIM')
 328       call p_r_rr(DIM,-8.,-3.,0.,'DIM')
 329       call p_d_dd(DDIM,-8.d0,-3.d0,0.d0,'DDIM')
 330       end
 331
 332       subroutine double_precision_product
 333       intrinsic dprod
 334       call c_d(DPROD(-8.,-3.),24.d0,'DPROD(real,real)')
 335       call p_d_rr(DPROD,-8.,-3.,24.d0,'DPROD')
 336       end
 337
 338       subroutine choosing_largest_value
 339       call c_i(MAX(1,2,3),3,'MAX(integer,integer,integer)')
 340       call c_r(MAX(1.,2.,3.),3.,'MAX(real,real,real)')
 341       call c_d(MAX(1.d0,2.d0,3.d0),3.d0,'MAX(double,double,double)')
 342       call c_i(MAX0(1,2,3),3,'MAX0(integer,integer,integer)')
 343       call c_r(AMAX1(1.,2.,3.),3.,'MAX(real,real,real)')
 344       call c_d(DMAX1(1.d0,2.d0,3.d0),3.d0,'DMAX1(double,double,double)')
 345       call c_r(AMAX0(1,2,3),3.,'AMAX0(integer,integer,integer)')
 346       call c_i(MAX1(1.,2.,3.),3,'MAX1(real,real,real)')
 347       end
 348
 349       subroutine choosing_smallest_value
 350       call c_i(MIN(1,2,3),1,'MIN(integer,integer,integer)')
 351       call c_r(MIN(1.,2.,3.),1.,'MIN(real,real,real)')
 352       call c_d(MIN(1.d0,2.d0,3.d0),1.d0,'MIN(double,double,double)')
 353       call c_i(MIN0(1,2,3),1,'MIN0(integer,integer,integer)')
 354       call c_r(AMIN1(1.,2.,3.),1.,'MIN(real,real,real)')
 355       call c_d(DMIN1(1.d0,2.d0,3.d0),1.d0,'DMIN1(double,double,double)')
 356       call c_r(AMIN0(1,2,3),1.,'AMIN0(integer,integer,integer)')
 357       call c_i(MIN1(1.,2.,3.),1,'MIN1(real,real,real)')
 358       end
 359
 360       subroutine length_of_character_array
 361       intrinsic len
 362       call c_i(LEN('ABCDEF'),6,'LEN 1')
 363       call p_i_ch(LEN,'ABCDEF',6,'LEN 2')
 364       end
 365
 366       subroutine index_of_substring
 367       intrinsic index
 368       call c_i(INDEX('ABCDEF','C'),3,'INDEX 1')
 369       call p_i_chch(INDEX,'ABCDEF','C',3,'INDEX 2')
 370       end
 371
 372       subroutine imaginary_part
 373       intrinsic aimag
 374       call c_r(AIMAG((2.,-7.)),-7.,'AIMAG(complex)')
 375       call p_r_c(AIMAG,(2.,-7.),-7.,'AIMAG(complex)')
 376       end
 377
 378       subroutine complex_conjugate
 379       intrinsic conjg
 380       call c_c(CONJG((2.,-7.)),(2.,7.),'CONJG(complex)')
 381       call p_c_c(CONJG,(2.,-7.),(2.,7.),'CONJG')
 382       end
 383
 384       subroutine square_root
 385       intrinsic sqrt, dsqrt, csqrt
 386       real x, a
 387       x = 4.0
 388       a = 2.0
 389       call c_r(SQRT(x),a,'SQRT(real)')
 390       call c_d(SQRT(1.d0*x),1.d0*a,'SQRT(double)')
 391       call c_c(SQRT((1.,0.)*x),(1.,0.)*a,'SQRT(complex)')
 392       call c_d(DSQRT(1.d0*x),1.d0*a,'DSQRT(double)')
 393       call c_c(CSQRT((1.,0.)*x),(1.,0.)*a,'CSQRT(complex)')
 394       call p_r_r(SQRT,x,a,'SQRT')
 395       call p_d_d(DSQRT,1.d0*x,1.d0*a,'DSQRT')
 396       call p_c_c(CSQRT,(1.,0.)*x,(1.,0.)*a ,'CSQRT')
 397       end
 398
 399       subroutine exponential
 400       intrinsic exp, dexp, cexp
 401       real x, a
 402       x = 0.0
 403       a = 1.0
 404       call c_r(EXP(x),a,'EXP(real)')
 405       call c_d(EXP(1.d0*x),1.d0*a,'EXP(double)')
 406       call c_c(EXP((1.,0.)*x),(1.,0.)*a,'EXP(complex)')
 407       call c_d(DEXP(1.d0*x),1.d0*a,'DEXP(double)')
 408       call c_c(CEXP((1.,0.)*x),(1.,0.)*a,'CEXP(complex)')
 409       call p_r_r(EXP,x,a,'EXP')
 410       call p_d_d(DEXP,1.d0*x,1.d0*a,'DEXP')
 411       call p_c_c(CEXP,(1.,0.)*x,(1.,0.)*a ,'CEXP')
 412       end
 413
 414       subroutine natural_logarithm
 415       intrinsic alog, dlog, clog
 416       real x, a
 417       a = 1.234
 418       x = exp(a)
 419       call c_r(LOG(x),a,'LOG(real)')
 420       call c_d(LOG(1.d0*x),1.d0*a,'LOG(double)')
 421       call c_c(LOG((1.,0.)*x),(1.,0.)*a,'LOG(complex)')
 422       call c_r(ALOG(x),a,'ALOG(real)')
 423       call c_d(DLOG(1.d0*x),1.d0*a,'DLOG(double)')
 424       call c_c(CLOG((1.,0.)*x),(1.,0.)*a,'CLOG(complex)')
 425       call p_r_r(ALOG,x,a,'LOG')
 426       call p_d_d(DLOG,1.d0*x,1.d0*a,'DLOG')
 427       call p_c_c(CLOG,(1.,0.)*x,(1.,0.)*a,'CLOG')
 428       end
 429
 430       subroutine common_logarithm
 431       intrinsic alog10, dlog10
 432       real x, a
 433       x = 100.0
 434       a = 2.0
 435       call c_r(LOG10(x),a,'LOG10(real)')
 436       call c_d(LOG10(1.d0*x),1.d0*a,'LOG10(double)')
 437       call c_r(ALOG10(x),a,'ALOG10(real)')
 438       call c_d(DLOG10(1.d0*x),1.d0*a,'DLOG10(double)')
 439       call p_r_r(ALOG10,x,a,'ALOG10')
 440       call p_d_d(DLOG10,1.d0*x,1.d0*a ,'DLOG10')
 441       end
 442
 443       subroutine sine
 444       intrinsic sin, dsin, csin
 445       real x, a
 446       a = 1.0
 447       x = asin(a)
 448       call c_r(SIN(x),a,'SIN(real)')
 449       call c_d(SIN(1.d0*x),1.d0*a,'SIN(double)')
 450       call c_c(SIN((1.,0.)*x),(1.,0.)*a,'SIN(complex)')
 451       call c_d(DSIN(1.d0*x),1.d0*a,'DSIN(double)')
 452       call c_c(CSIN((1.,0.)*x),(1.,0.)*a,'CSIN(complex)')
 453       call p_r_r(SIN,x,a,'SIN')
 454       call p_d_d(DSIN,1.d0*x,1.d0*a,'DSIN')
 455       call p_c_c(CSIN,(1.,0.)*x,(1.,0.)*a ,'CSIN')
 456       end
 457
 458       subroutine cosine
 459       intrinsic cos, dcos, ccos
 460       real x, a
 461       a = 0.123456
 462       x = acos(a)
 463       call c_r(COS(x),a,'COS(real)')
 464       call c_d(COS(1.d0*x),1.d0*a,'COS(double)')
 465       call c_c(COS((1.,0.)*x),(1.,0.)*a,'COS(complex)')
 466       call c_r(COS(x),a,'COS(real)')
 467       call c_d(DCOS(1.d0*x),1.d0*a,'DCOS(double)')
 468       call c_c(CCOS((1.,0.)*x),(1.,0.)*a,'CCOS(complex)')
 469       call p_r_r(COS,x,a,'COS')
 470       call p_d_d(DCOS,1.d0*x,1.d0*a ,'DCOS')
 471       call p_c_c(CCOS,(1.,0.)*x, (1.,0.)*a ,'CCOS')
 472       end
 473
 474       subroutine tangent
 475       intrinsic tan, dtan
 476       real x, a
 477       a = 0.5
 478       x = atan(a)
 479       call c_r(TAN(x),a,'TAN(real)')
 480       call c_d(TAN(1.d0*x),1.d0*a,'TAN(double)')
 481       call c_d(DTAN(1.d0*x),1.d0*a,'DTAN(double)')
 482       call p_r_r(TAN,x,a,'TAN')
 483       call p_d_d(DTAN,1.d0*x,1.d0*a ,'DTAN')
 484       end
 485
 486       subroutine arcsine
 487       intrinsic asin, dasin
 488       real x, a
 489       a = 0.5
 490       x = sin(a)
 491       call c_r(ASIN(x),a,'ASIN(real)')
 492       call c_d(ASIN(1.d0*x),1.d0*a,'ASIN(double)')
 493       call c_d(DASIN(1.d0*x),1.d0*a,'DASIN(double)')
 494       call p_r_r(ASIN,x,a,'ASIN')
 495       call p_d_d(DASIN,1.d0*x,1.d0*a ,'DASIN')
 496       end
 497
 498       subroutine arccosine
 499       intrinsic acos, dacos
 500       real x, a
 501       x = 0.70710678
 502       a = 0.785398
 503       call c_r(ACOS(x),a,'ACOS(real)')
 504       call c_d(ACOS(1.d0*x),1.d0*a,'ACOS(double)')
 505       call c_d(DACOS(1.d0*x),1.d0*a,'DACOS(double)')
 506       call p_r_r(ACOS,x,a,'ACOS')
 507       call p_d_d(DACOS,1.d0*x,1.d0*a ,'DACOS')
 508       end
 509
 510       subroutine arctangent
 511       intrinsic atan, atan2, datan, datan2
 512       real x1, x2, a
 513       a = 0.75
 514       x1 = tan(a)
 515       x2 = 1.0
 516       call c_r(ATAN(x1),a,'ATAN(real)')
 517       call c_d(ATAN(1.d0*x1),1.d0*a,'ATAN(double)')
 518       call c_d(DATAN(1.d0*x1),1.d0*a,'DATAN(double)')
 519       call c_r(ATAN2(x1,x2),a,'ATAN2(real)')
 520       call c_d(ATAN2(1.d0*x1,1.d0*x2),1.d0*a,'ATAN2(double)')
 521       call c_d(DATAN2(1.d0*x1,1.d0*x2),1.0d0*a,'DATAN2(double)')
 522       call p_r_r(ATAN,x1,a,'ATAN')
 523       call p_d_d(DATAN,1.d0*x1,1.d0*a,'DATAN')
 524       call p_r_rr(ATAN2,x1,x2,a,'ATAN2')
 525       call p_d_dd(DATAN2,1.d0*x1,1.d0*x2,1.d0*a,'DATAN2')
 526       end
 527
 528       subroutine hyperbolic_sine
 529       intrinsic sinh, dsinh
 530       real x, a
 531       x = 1.0
 532       a = 1.1752012
 533       call c_r(SINH(x),a,'SINH(real)')
 534       call c_d(SINH(1.d0*x),1.d0*a,'SINH(double)')
 535       call c_d(DSINH(1.d0*x),1.d0*a,'DSINH(double)')
 536       call p_r_r(SINH,x,a,'SINH')
 537       call p_d_d(DSINH,1.d0*x,1.d0*a ,'DSINH')
 538       end
 539
 540       subroutine hyperbolic_cosine
 541       intrinsic cosh, dcosh
 542       real x, a
 543       x = 1.0
 544       a = 1.5430806
 545       call c_r(COSH(x),a,'COSH(real)')
 546       call c_d(COSH(1.d0*x),1.d0*a,'COSH(double)')
 547       call c_d(DCOSH(1.d0*x),1.d0*a,'DCOSH(double)')
 548       call p_r_r(COSH,x,a,'COSH')
 549       call p_d_d(DCOSH,1.d0*x,1.d0*a ,'DCOSH')
 550       end
 551
 552       subroutine hyperbolic_tangent
 553       intrinsic tanh, dtanh
 554       real x, a
 555       x = 1.0
 556       a = 0.76159416
 557       call c_r(TANH(x),a,'TANH(real)')
 558       call c_d(TANH(1.d0*x),1.d0*a,'TANH(double)')
 559       call c_d(DTANH(1.d0*x),1.d0*a,'DTANH(double)')
 560       call p_r_r(TANH,x,a,'TANH')
 561       call p_d_d(DTANH,1.d0*x,1.d0*a ,'DTANH')
 562       end
 563
 564       subroutine lexically_greater_than_or_equal
 565       call c_l(LGE('A','B'),.FALSE.,'LGE(character,character) 1')
 566       call c_l(LGE('B','A'),.TRUE.,'LGE(character,character) 2')
 567       call c_l(LGE('A','A'),.TRUE.,'LGE(character,character) 3')
 568       end
 569
 570       subroutine lexically_greater_than
 571       call c_l(LGT('A','B'),.FALSE.,'LGT(character,character) 1')
 572       call c_l(LGT('B','A'),.TRUE.,'LGT(character,character) 2')
 573       call c_l(LGT('A','A'),.FALSE.,'LGT(character,character) 3')
 574       end
 575
 576       subroutine lexically_less_than_or_equal
 577       call c_l(LLE('A','B'),.TRUE.,'LLE(character,character) 1')
 578       call c_l(LLE('B','A'),.FALSE.,'LLE(character,character) 2')
 579       call c_l(LLE('A','A'),.TRUE.,'LLE(character,character) 3')
 580       end
 581
 582       subroutine lexically_less_than
 583       call c_l(LLT('A','B'),.TRUE.,'LLT(character,character) 1')
 584       call c_l(LLT('B','A'),.FALSE.,'LLT(character,character) 2')
 585       call c_l(LLT('A','A'),.FALSE.,'LLT(character,character) 3')
 586       end