1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
|
! Fails on x86 targets where sizeof(long double) == 16.
! { dg-do run }
! { dg-additional-sources PR100914.c }
! { dg-require-effective-target fortran_real_c_float128 }
! { dg-additional-options "-Wno-pedantic" }
!
! Test the fix for PR100914
!
module isof_m
use, intrinsic :: iso_c_binding, only: &
c_signed_char, c_int16_t
implicit none
private
public :: &
CFI_type_Complex, &
CFI_type_float_Complex, &
CFI_type_double_Complex, &
CFI_type_long_double_Complex, &
CFI_type_float128_Complex
public :: &
check_tk_as, &
check_tk_ar
public :: &
cfi_encode_type
integer, parameter :: CFI_type_t = c_int16_t
integer(kind=c_int16_t), parameter :: CFI_type_mask = int(z"FF", kind=c_int16_t)
integer(kind=c_int16_t), parameter :: CFI_type_kind_shift = 8_c_int16_t
! Intrinsic types. Their kind number defines their storage size. */
integer(kind=c_signed_char), parameter :: CFI_type_Complex = 4
! C-Fortran Interoperability types.
integer(kind=cfi_type_t), parameter :: CFI_type_float_Complex = &
ior(int(CFI_type_Complex, kind=c_int16_t), shiftl(4_c_int16_t, CFI_type_kind_shift))
integer(kind=cfi_type_t), parameter :: CFI_type_double_Complex = &
ior(int(CFI_type_Complex, kind=c_int16_t), shiftl(8_c_int16_t, CFI_type_kind_shift))
integer(kind=cfi_type_t), parameter :: CFI_type_long_double_Complex = &
ior(int(CFI_type_Complex, kind=c_int16_t), shiftl(10_c_int16_t, CFI_type_kind_shift))
integer(kind=cfi_type_t), parameter :: CFI_type_float128_Complex = &
ior(int(CFI_type_Complex, kind=c_int16_t), shiftl(16_c_int16_t, CFI_type_kind_shift))
interface
subroutine check_tk_as(a, t, k, e, n) &
bind(c, name="check_tk")
use, intrinsic :: iso_c_binding, only: &
c_int16_t, c_signed_char, c_size_t
implicit none
type(*), intent(in) :: a(:)
integer(c_int16_t), value, intent(in) :: t
integer(c_signed_char), value, intent(in) :: k
integer(c_size_t), value, intent(in) :: e
integer(c_size_t), value, intent(in) :: n
end subroutine check_tk_as
subroutine check_tk_ar(a, t, k, e, n) &
bind(c, name="check_tk")
use, intrinsic :: iso_c_binding, only: &
c_int16_t, c_signed_char, c_size_t
implicit none
type(*), intent(in) :: a(..)
integer(c_int16_t), value, intent(in) :: t
integer(c_signed_char), value, intent(in) :: k
integer(c_size_t), value, intent(in) :: e
integer(c_size_t), value, intent(in) :: n
end subroutine check_tk_ar
end interface
contains
elemental function cfi_encode_type(type, kind) result(itype)
integer(kind=c_signed_char), intent(in) :: type
integer(kind=c_signed_char), intent(in) :: kind
integer(kind=c_int16_t) :: itype, ikind
itype = int(type, kind=c_int16_t)
itype = iand(itype, CFI_type_mask)
ikind = int(kind, kind=c_int16_t)
ikind = iand(ikind, CFI_type_mask)
ikind = shiftl(ikind, CFI_type_kind_shift)
itype = ior(ikind, itype)
return
end function cfi_encode_type
end module isof_m
module iso_check_m
use, intrinsic :: iso_c_binding, only: &
c_signed_char, c_int16_t, c_size_t
use, intrinsic :: iso_c_binding, only: &
c_float_complex, &
c_double_complex, &
c_long_double_complex, &
c_float128_complex
use :: isof_m, only: &
CFI_type_Complex
use :: isof_m, only: &
CFI_type_float_Complex, &
CFI_type_double_Complex, &
CFI_type_long_double_Complex, &
CFI_type_float128_Complex
use :: isof_m, only: &
check_tk_as, &
check_tk_ar
use :: isof_m, only: &
cfi_encode_type
implicit none
private
public :: &
check_c_float_complex, &
check_c_double_complex, &
check_c_long_double_complex, &
check_c_float128_complex
integer :: i
integer(kind=c_size_t), parameter :: b = 8
integer, parameter :: n = 11
complex(kind=c_float_complex), parameter :: ref_c_float_complex(*) = &
[(cmplx(i, 2*i, kind=c_float_complex), i=1,n)]
complex(kind=c_double_complex), parameter :: ref_c_double_complex(*) = &
[(cmplx(i, 2*i, kind=c_double_complex), i=1,n)]
complex(kind=c_long_double_complex), parameter :: ref_c_long_double_complex(*) = &
[(cmplx(i, 2*i, kind=c_long_double_complex), i=1,n)]
complex(kind=c_float128_complex), parameter :: ref_c_float128_complex(*) = &
[(cmplx(i, 2*i, kind=c_float128_complex), i=1,n)]
contains
! CFI_type_float_complex
subroutine check_c_float_complex()
complex(kind=c_float_complex) :: a(n)
!
if (c_float_complex/=4) stop 1
a = ref_c_float_complex
call f_check_c_float_complex_as(a)
if(any(abs(a-ref_c_float_complex)>0.0_c_float_complex)) stop 2
a = ref_c_float_complex
call c_check_c_float_complex_as(a)
if(any(abs(a-ref_c_float_complex)>0.0_c_float_complex)) stop 3
a = ref_c_float_complex
call f_check_c_float_complex_ar(a)
if(any(abs(a-ref_c_float_complex)>0.0_c_float_complex)) stop 4
a = ref_c_float_complex
call c_check_c_float_complex_ar(a)
if(any(abs(a-ref_c_float_complex)>0.0_c_float_complex)) stop 5
return
end subroutine check_c_float_complex
subroutine f_check_c_float_complex_as(a)
complex(kind=c_float_complex), intent(in) :: a(:)
!
integer(kind=c_int16_t) :: t
integer(kind=c_signed_char) :: k
integer(kind=c_size_t) :: e
!
k = kind(a)
e = storage_size(a)/b
t = cfi_encode_type(CFI_type_complex, k)
if(k<=0_c_signed_char) stop 6
if(k/=4_c_signed_char) stop 7
if(int(k, kind=c_size_t)/=(e/2)) stop 8
if(t/=CFI_type_float_complex) stop 9
if(any(abs(a-ref_c_float_complex)>0.0_c_float_complex)) stop 10
call check_tk_as(a, t, k, e, 1_c_size_t)
if(any(abs(a-ref_c_float_complex)>0.0_c_float_complex)) stop 11
return
end subroutine f_check_c_float_complex_as
subroutine c_check_c_float_complex_as(a) bind(c)
complex(kind=c_float_complex), intent(in) :: a(:)
!
integer(kind=c_int16_t) :: t
integer(kind=c_signed_char) :: k
integer(kind=c_size_t) :: e
!
k = kind(a)
e = storage_size(a)/b
t = cfi_encode_type(CFI_type_complex, k)
if(k<=0_c_signed_char) stop 12
if(k/=4_c_signed_char) stop 13
if(int(k, kind=c_size_t)/=(e/2)) stop 14
if(t/=CFI_type_float_complex) stop 15
if(any(abs(a-ref_c_float_complex)>0.0_c_float_complex)) stop 16
call check_tk_as(a, t, k, e, 1_c_size_t)
if(any(abs(a-ref_c_float_complex)>0.0_c_float_complex)) stop 17
return
end subroutine c_check_c_float_complex_as
subroutine f_check_c_float_complex_ar(a)
complex(kind=c_float_complex), intent(in) :: a(..)
!
integer(kind=c_int16_t) :: t
integer(kind=c_signed_char) :: k
integer(kind=c_size_t) :: e
!
k = kind(a)
e = storage_size(a)/b
t = cfi_encode_type(CFI_type_complex, k)
if(k<=0_c_signed_char) stop 18
if(k/=4_c_signed_char) stop 19
if(int(k, kind=c_size_t)/=(e/2)) stop 20
if(t/=CFI_type_float_complex) stop 21
select rank(a)
rank(1)
if(any(abs(a-ref_c_float_complex)>0.0_c_float_complex)) stop 22
rank default
stop 23
end select
call check_tk_ar(a, t, k, e, 1_c_size_t)
select rank(a)
rank(1)
if(any(abs(a-ref_c_float_complex)>0.0_c_float_complex)) stop 24
rank default
stop 25
end select
return
end subroutine f_check_c_float_complex_ar
subroutine c_check_c_float_complex_ar(a) bind(c)
complex(kind=c_float_complex), intent(in) :: a(..)
!
integer(kind=c_int16_t) :: t
integer(kind=c_signed_char) :: k
integer(kind=c_size_t) :: e
!
k = kind(a)
e = storage_size(a)/b
t = cfi_encode_type(CFI_type_complex, k)
if(k<=0_c_signed_char) stop 26
if(k/=4_c_signed_char) stop 27
if(int(k, kind=c_size_t)/=(e/2)) stop 28
if(t/=CFI_type_float_complex) stop 29
select rank(a)
rank(1)
if(any(abs(a-ref_c_float_complex)>0.0_c_float_complex)) stop 30
rank default
stop 31
end select
call check_tk_ar(a, t, k, e, 1_c_size_t)
select rank(a)
rank(1)
if(any(abs(a-ref_c_float_complex)>0.0_c_float_complex)) stop 32
rank default
stop 33
end select
return
end subroutine c_check_c_float_complex_ar
! CFI_type_double_complex
subroutine check_c_double_complex()
complex(kind=c_double_complex) :: a(n)
!
if (c_double_complex/=8) stop 34
a = ref_c_double_complex
call f_check_c_double_complex_as(a)
if(any(abs(a-ref_c_double_complex)>0.0_c_double_complex)) stop 35
a = ref_c_double_complex
call c_check_c_double_complex_as(a)
if(any(abs(a-ref_c_double_complex)>0.0_c_double_complex)) stop 36
a = ref_c_double_complex
call f_check_c_double_complex_ar(a)
if(any(abs(a-ref_c_double_complex)>0.0_c_double_complex)) stop 37
a = ref_c_double_complex
call c_check_c_double_complex_ar(a)
if(any(abs(a-ref_c_double_complex)>0.0_c_double_complex)) stop 38
return
end subroutine check_c_double_complex
subroutine f_check_c_double_complex_as(a)
complex(kind=c_double_complex), intent(in) :: a(:)
!
integer(kind=c_int16_t) :: t
integer(kind=c_signed_char) :: k
integer(kind=c_size_t) :: e
!
k = kind(a)
e = storage_size(a)/b
t = cfi_encode_type(CFI_type_complex, k)
if(k<=0_c_signed_char) stop 39
if(k/=8_c_signed_char) stop 40
if(int(k, kind=c_size_t)/=(e/2)) stop 41
if(t/=CFI_type_double_complex) stop 42
if(any(abs(a-ref_c_double_complex)>0.0_c_double_complex)) stop 43
call check_tk_as(a, t, k, e, 1_c_size_t)
if(any(abs(a-ref_c_double_complex)>0.0_c_double_complex)) stop 44
return
end subroutine f_check_c_double_complex_as
subroutine c_check_c_double_complex_as(a) bind(c)
complex(kind=c_double_complex), intent(in) :: a(:)
!
integer(kind=c_int16_t) :: t
integer(kind=c_signed_char) :: k
integer(kind=c_size_t) :: e
!
k = kind(a)
e = storage_size(a)/b
t = cfi_encode_type(CFI_type_complex, k)
if(k<=0_c_signed_char) stop 45
if(k/=8_c_signed_char) stop 46
if(int(k, kind=c_size_t)/=(e/2)) stop 47
if(t/=CFI_type_double_complex) stop 48
if(any(abs(a-ref_c_double_complex)>0.0_c_double_complex)) stop 49
call check_tk_as(a, t, k, e, 1_c_size_t)
if(any(abs(a-ref_c_double_complex)>0.0_c_double_complex)) stop 50
return
end subroutine c_check_c_double_complex_as
subroutine f_check_c_double_complex_ar(a)
complex(kind=c_double_complex), intent(in) :: a(..)
!
integer(kind=c_int16_t) :: t
integer(kind=c_signed_char) :: k
integer(kind=c_size_t) :: e
!
k = kind(a)
e = storage_size(a)/b
t = cfi_encode_type(CFI_type_complex, k)
if(k<=0_c_signed_char) stop 51
if(k/=8_c_signed_char) stop 52
if(int(k, kind=c_size_t)/=(e/2)) stop 53
if(t/=CFI_type_double_complex) stop 54
select rank(a)
rank(1)
if(any(abs(a-ref_c_double_complex)>0.0_c_double_complex)) stop 55
rank default
stop 56
end select
call check_tk_ar(a, t, k, e, 1_c_size_t)
select rank(a)
rank(1)
if(any(abs(a-ref_c_double_complex)>0.0_c_double_complex)) stop 57
rank default
stop 58
end select
return
end subroutine f_check_c_double_complex_ar
subroutine c_check_c_double_complex_ar(a) bind(c)
complex(kind=c_double_complex), intent(in) :: a(..)
!
integer(kind=c_int16_t) :: t
integer(kind=c_signed_char) :: k
integer(kind=c_size_t) :: e
!
k = kind(a)
e = storage_size(a)/b
t = cfi_encode_type(CFI_type_complex, k)
if(k<=0_c_signed_char) stop 59
if(k/=8_c_signed_char) stop 60
if(int(k, kind=c_size_t)/=(e/2)) stop 61
if(t/=CFI_type_double_complex) stop 62
select rank(a)
rank(1)
if(any(abs(a-ref_c_double_complex)>0.0_c_double_complex)) stop 63
rank default
stop 64
end select
call check_tk_ar(a, t, k, e, 1_c_size_t)
select rank(a)
rank(1)
if(any(abs(a-ref_c_double_complex)>0.0_c_double_complex)) stop 65
rank default
stop 66
end select
return
end subroutine c_check_c_double_complex_ar
! CFI_type_long_double_complex
subroutine check_c_long_double_complex()
complex(kind=c_long_double_complex) :: a(n)
!
if (c_long_double_complex/=10) stop 67
a = ref_c_long_double_complex
call f_check_c_long_double_complex_as(a)
if(any(abs(a-ref_c_long_double_complex)>0.0_c_long_double_complex)) stop 68
a = ref_c_long_double_complex
call c_check_c_long_double_complex_as(a)
if(any(abs(a-ref_c_long_double_complex)>0.0_c_long_double_complex)) stop 69
a = ref_c_long_double_complex
call f_check_c_long_double_complex_ar(a)
if(any(abs(a-ref_c_long_double_complex)>0.0_c_long_double_complex)) stop 70
a = ref_c_long_double_complex
call c_check_c_long_double_complex_ar(a)
if(any(abs(a-ref_c_long_double_complex)>0.0_c_long_double_complex)) stop 71
return
end subroutine check_c_long_double_complex
subroutine f_check_c_long_double_complex_as(a)
complex(kind=c_long_double_complex), intent(in) :: a(:)
!
integer(kind=c_int16_t) :: t
integer(kind=c_signed_char) :: k
integer(kind=c_size_t) :: e
!
k = kind(a)
e = storage_size(a)/b
t = cfi_encode_type(CFI_type_complex, k)
if(k<=0_c_signed_char) stop 72
if(k/=10_c_signed_char) stop 73
if(e/=32) stop 74
if(t/=CFI_type_long_double_complex) stop 75
if(any(abs(a-ref_c_long_double_complex)>0.0_c_long_double_complex)) stop 76
call check_tk_as(a, t, k, e, 1_c_size_t)
if(any(abs(a-ref_c_long_double_complex)>0.0_c_long_double_complex)) stop 77
return
end subroutine f_check_c_long_double_complex_as
subroutine c_check_c_long_double_complex_as(a) bind(c)
complex(kind=c_long_double_complex), intent(in) :: a(:)
!
integer(kind=c_int16_t) :: t
integer(kind=c_signed_char) :: k
integer(kind=c_size_t) :: e
!
k = kind(a)
e = storage_size(a)/b
t = cfi_encode_type(CFI_type_complex, k)
if(k<=0_c_signed_char) stop 78
if(k/=10_c_signed_char) stop 79
if(e/=32) stop 80
if(t/=CFI_type_long_double_complex) stop 81
if(any(abs(a-ref_c_long_double_complex)>0.0_c_long_double_complex)) stop 82
call check_tk_as(a, t, k, e, 1_c_size_t)
if(any(abs(a-ref_c_long_double_complex)>0.0_c_long_double_complex)) stop 83
return
end subroutine c_check_c_long_double_complex_as
subroutine f_check_c_long_double_complex_ar(a)
complex(kind=c_long_double_complex), intent(in) :: a(..)
!
integer(kind=c_int16_t) :: t
integer(kind=c_signed_char) :: k
integer(kind=c_size_t) :: e
!
k = kind(a)
e = storage_size(a)/b
t = cfi_encode_type(CFI_type_complex, k)
if(k<=0_c_signed_char) stop 84
if(k/=10_c_signed_char) stop 85
if(e/=32) stop 86
if(t/=CFI_type_long_double_complex) stop 87
select rank(a)
rank(1)
if(any(abs(a-ref_c_long_double_complex)>0.0_c_long_double_complex)) stop 88
rank default
stop 89
end select
call check_tk_ar(a, t, k, e, 1_c_size_t)
select rank(a)
rank(1)
if(any(abs(a-ref_c_long_double_complex)>0.0_c_long_double_complex)) stop 90
rank default
stop 91
end select
return
end subroutine f_check_c_long_double_complex_ar
subroutine c_check_c_long_double_complex_ar(a) bind(c)
complex(kind=c_long_double_complex), intent(in) :: a(..)
!
integer(kind=c_int16_t) :: t
integer(kind=c_signed_char) :: k
integer(kind=c_size_t) :: e
!
k = kind(a)
e = storage_size(a)/b
t = cfi_encode_type(CFI_type_complex, k)
if(k<=0_c_signed_char) stop 92
if(k/=10_c_signed_char) stop 93
if(e/=32) stop 94
if(t/=CFI_type_long_double_complex) stop 95
select rank(a)
rank(1)
if(any(abs(a-ref_c_long_double_complex)>0.0_c_long_double_complex)) stop 96
rank default
stop 97
end select
call check_tk_ar(a, t, k, e, 1_c_size_t)
select rank(a)
rank(1)
if(any(abs(a-ref_c_long_double_complex)>0.0_c_long_double_complex)) stop 98
rank default
stop 99
end select
return
end subroutine c_check_c_long_double_complex_ar
! CFI_type_float128_complex
subroutine check_c_float128_complex()
complex(kind=c_float128_complex) :: a(n)
!
if (c_float128_complex/=16) stop 100
a = ref_c_float128_complex
call f_check_c_float128_complex_as(a)
if(any(abs(a-ref_c_float128_complex)>0.0_c_float128_complex)) stop 101
a = ref_c_float128_complex
call c_check_c_float128_complex_as(a)
if(any(abs(a-ref_c_float128_complex)>0.0_c_float128_complex)) stop 102
a = ref_c_float128_complex
call f_check_c_float128_complex_ar(a)
if(any(abs(a-ref_c_float128_complex)>0.0_c_float128_complex)) stop 103
a = ref_c_float128_complex
call c_check_c_float128_complex_ar(a)
if(any(abs(a-ref_c_float128_complex)>0.0_c_float128_complex)) stop 104
return
end subroutine check_c_float128_complex
subroutine f_check_c_float128_complex_as(a)
complex(kind=c_float128_complex), intent(in) :: a(:)
!
integer(kind=c_int16_t) :: t
integer(kind=c_signed_char) :: k
integer(kind=c_size_t) :: e
!
k = kind(a)
e = storage_size(a)/b
t = cfi_encode_type(CFI_type_complex, k)
if(k<=0_c_signed_char) stop 105
if(k/=16_c_signed_char) stop 106
if(int(k, kind=c_size_t)/=(e/2)) stop 107
if(t/=CFI_type_float128_complex) stop 108
if(any(abs(a-ref_c_float128_complex)>0.0_c_float128_complex)) stop 109
call check_tk_as(a, t, k, e, 1_c_size_t)
if(any(abs(a-ref_c_float128_complex)>0.0_c_float128_complex)) stop 110
return
end subroutine f_check_c_float128_complex_as
subroutine c_check_c_float128_complex_as(a) bind(c)
complex(kind=c_float128_complex), intent(in) :: a(:)
!
integer(kind=c_int16_t) :: t
integer(kind=c_signed_char) :: k
integer(kind=c_size_t) :: e
!
k = kind(a)
e = storage_size(a)/b
t = cfi_encode_type(CFI_type_complex, k)
if(k<=0_c_signed_char) stop 111
if(k/=16_c_signed_char) stop 112
if(int(k, kind=c_size_t)/=(e/2)) stop 113
if(t/=CFI_type_float128_complex) stop 114
if(any(abs(a-ref_c_float128_complex)>0.0_c_float128_complex)) stop 115
call check_tk_as(a, t, k, e, 1_c_size_t)
if(any(abs(a-ref_c_float128_complex)>0.0_c_float128_complex)) stop 116
return
end subroutine c_check_c_float128_complex_as
subroutine f_check_c_float128_complex_ar(a)
complex(kind=c_float128_complex), intent(in) :: a(..)
!
integer(kind=c_int16_t) :: t
integer(kind=c_signed_char) :: k
integer(kind=c_size_t) :: e
!
k = kind(a)
e = storage_size(a)/b
t = cfi_encode_type(CFI_type_complex, k)
if(k<=0_c_signed_char) stop 117
if(k/=16_c_signed_char) stop 118
if(int(k, kind=c_size_t)/=(e/2)) stop 119
if(t/=CFI_type_float128_complex) stop 120
select rank(a)
rank(1)
if(any(abs(a-ref_c_float128_complex)>0.0_c_float128_complex)) stop 121
rank default
stop 122
end select
call check_tk_ar(a, t, k, e, 1_c_size_t)
select rank(a)
rank(1)
if(any(abs(a-ref_c_float128_complex)>0.0_c_float128_complex)) stop 123
rank default
stop 124
end select
return
end subroutine f_check_c_float128_complex_ar
subroutine c_check_c_float128_complex_ar(a) bind(c)
complex(kind=c_float128_complex), intent(in) :: a(..)
!
integer(kind=c_int16_t) :: t
integer(kind=c_signed_char) :: k
integer(kind=c_size_t) :: e
!
k = kind(a)
e = storage_size(a)/b
t = cfi_encode_type(CFI_type_complex, k)
if(k<=0_c_signed_char) stop 125
if(k/=16_c_signed_char) stop 126
if(int(k, kind=c_size_t)/=(e/2)) stop 127
if(t/=CFI_type_float128_complex) stop 128
select rank(a)
rank(1)
if(any(abs(a-ref_c_float128_complex)>0.0_c_float128_complex)) stop 129
rank default
stop 130
end select
call check_tk_ar(a, t, k, e, 1_c_size_t)
select rank(a)
rank(1)
if(any(abs(a-ref_c_float128_complex)>0.0_c_float128_complex)) stop 131
rank default
stop 132
end select
return
end subroutine c_check_c_float128_complex_ar
end module iso_check_m
program main_p
use :: iso_check_m, only: &
check_c_float_complex, &
check_c_double_complex, &
check_c_long_double_complex, &
check_c_float128_complex
implicit none
call check_c_float_complex()
call check_c_double_complex()
! see PR100910
! call check_c_long_double_complex()
call check_c_float128_complex()
stop
end program main_p
!! Local Variables:
!! mode: f90
!! End:
|
