1 program intrinsic77 2c 3c Test Fortran 77 intrinsic functions (ANSI X3.9-1978 Section 15.10) 4c 5c Test: 6c * specific functions 7c * generic functions with each argument type 8c * specific functions by passing as subroutine argument 9c where permiited by Section 13.12 of Fortran 90 standard 10c 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) 52c 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) 61c 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) 71c 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) 81c 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) 91c 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) 101c 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) 111c 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) 121c 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) 128c 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) 135c 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) 143c 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) 151c 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) 159c 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) 167c 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) 174c 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) 181c 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) 188c 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) 196c 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) 203c 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) 210c 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 220c 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)') 227c 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)') 234c 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)') 239c 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)') 247c 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 587