1 ! Using two spaces between dg-do and run is a hack to keep gfortran-dg-runtest
2 ! from cycling through optimization options for this expensive test.
4 ! { dg-options "-O3 -fcray-pointer -fbounds-check -fno-inline" }
5 ! { dg-timeout-factor 4 }
7 ! Series of routines for testing a Cray pointer implementation
9 ! Note: Some of the test cases violate Fortran's alias rules;
10 ! the "-fno-inline option" for now prevents failures.
13 common /errors
/errors(400)
14 common /foo
/foo
! To prevent optimizations
34 ! NOTE: Tests 1 through 12 were removed from this file
35 ! and placed in loc_1.f90, so we start at 13
38 ! print *,"Test",i,"failed."
43 ! print *,"Test did not run correctly."
48 ! ptr1 through ptr13 that Cray pointees are correctly used with
49 ! a variety of declaration styles
51 common /errors
/errors(400)
52 logical :: errors
, intne
, realne
, chne
, ch8ne
54 integer, parameter :: n
= 9
55 integer, parameter :: m
= 10
56 integer, parameter :: o
= 11
59 integer itarg3 (o
,m
,n
)
64 character chtarg2(m
,n
)
65 character chtarg3(o
,m
,n
)
66 character*8 ch8targ1(n
)
67 character*8 ch8targ2(m
,n
)
68 character*8 ch8targ3(o
,m
,n
)
75 type(drvd
) dtarg2(m
,n
)
76 type(drvd
) dtarg3(o
,m
,n
)
80 type(drvd
) dpte3(o
,m
,n
)
89 character chpte3(o
,m
,n
)
90 character*8 ch8pte1(n
)
91 character*8 ch8pte2(m
,n
)
92 character*8 ch8pte3(o
,m
,n
)
103 pointer(iptr10
,chpte1
)
104 pointer(iptr11
,chpte2
)
105 pointer(iptr12
,chpte3
)
106 pointer(iptr13
,ch8pte1
)
107 pointer(iptr14
,ch8pte2
)
108 pointer(iptr15
,ch8pte3
)
122 iptr13
= loc(ch8targ1
)
123 iptr14
= loc(ch8targ2
)
124 iptr15
= loc(ch8targ3
)
129 if (intne(dpte1(i
)%i1
, dtarg1(i
)%i1
)) then
134 dtarg1(i
)%i1
=2*dpte1(i
)%i1
135 if (intne(dpte1(i
)%i1
, dtarg1(i
)%i1
)) then
141 if (intne(ipte1(i
), itarg1(i
))) then
146 itarg1(i
) = -ipte1(i
)
147 if (intne(ipte1(i
), itarg1(i
))) then
153 if (realne(rpte1(i
), rtarg1(i
))) then
158 rtarg1(i
) = i
* (-5.0)
159 if (realne(rpte1(i
), rtarg1(i
))) then
165 if (chne(chpte1(i
), chtarg1(i
))) then
171 if (chne(chpte1(i
), chtarg1(i
))) then
176 ch8pte1(i
) = 'aaaaaaaa'
177 if (ch8ne(ch8pte1(i
), ch8targ1(i
))) then
182 ch8targ1(i
) = 'zzzzzzzz'
183 if (ch8ne(ch8pte1(i
), ch8targ1(i
))) then
190 if (realne(dpte2(j
,i
)%r1
, dtarg2(j
,i
)%r1
)) then
195 dtarg2(j
,i
)%r1
=2*dpte2(j
,i
)%r1
196 if (realne(dpte2(j
,i
)%r1
, dtarg2(j
,i
)%r1
)) then
202 if (intne(ipte2(j
,i
), itarg2(j
,i
))) then
207 itarg2(j
,i
) = -ipte2(j
,i
)
208 if (intne(ipte2(j
,i
), itarg2(j
,i
))) then
213 rpte2(j
,i
) = i
* (-2.0)
214 if (realne(rpte2(j
,i
), rtarg2(j
,i
))) then
219 rtarg2(j
,i
) = i
* (-3.0)
220 if (realne(rpte2(j
,i
), rtarg2(j
,i
))) then
226 if (chne(chpte2(j
,i
), chtarg2(j
,i
))) then
232 if (chne(chpte2(j
,i
), chtarg2(j
,i
))) then
237 ch8pte2(j
,i
) = 'aaaaaaaa'
238 if (ch8ne(ch8pte2(j
,i
), ch8targ2(j
,i
))) then
243 ch8targ2(j
,i
) = 'zzzzzzzz'
244 if (ch8ne(ch8pte2(j
,i
), ch8targ2(j
,i
))) then
249 dpte3(k
,j
,i
)%i2(1+mod(i
,5))=i
250 if (intne(dpte3(k
,j
,i
)%i2(1+mod(i
,5)), &
251 dtarg3(k
,j
,i
)%i2(1+mod(i
,5)))) then
256 dtarg3(k
,j
,i
)%i2(1+mod(i
,5))=2*dpte3(k
,j
,i
)%i2(1+mod(i
,5))
257 if (intne(dpte3(k
,j
,i
)%i2(1+mod(i
,5)), &
258 dtarg3(k
,j
,i
)%i2(1+mod(i
,5)))) then
264 if (intne(ipte3(k
,j
,i
), itarg3(k
,j
,i
))) then
269 itarg3(k
,j
,i
) = -ipte3(k
,j
,i
)
270 if (intne(ipte3(k
,j
,i
), itarg3(k
,j
,i
))) then
275 rpte3(k
,j
,i
) = i
* 2.0
276 if (realne(rpte3(k
,j
,i
), rtarg3(k
,j
,i
))) then
281 rtarg3(k
,j
,i
) = i
* 3.0
282 if (realne(rpte3(k
,j
,i
), rtarg3(k
,j
,i
))) then
288 if (chne(chpte3(k
,j
,i
), chtarg3(k
,j
,i
))) then
294 if (chne(chpte3(k
,j
,i
), chtarg3(k
,j
,i
))) then
299 ch8pte3(k
,j
,i
) = 'aaaaaaaa'
300 if (ch8ne(ch8pte3(k
,j
,i
), ch8targ3(k
,j
,i
))) then
305 ch8targ3(k
,j
,i
) = 'zzzzzzzz'
306 if (ch8ne(ch8pte3(k
,j
,i
), ch8targ3(k
,j
,i
))) then
321 if (intne(itarg3(k
,j
,i
), i
)) then
326 if (realne(rtarg3(k
,j
,i
), i
+.5)) then
338 common /errors
/errors(400)
339 logical :: errors
, intne
, realne
, chne
, ch8ne
341 integer, parameter :: n
= 9
342 integer, parameter :: m
= 10
343 integer, parameter :: o
= 11
346 integer itarg3 (o
,m
,n
)
351 character chtarg2(m
,n
)
352 character chtarg3(o
,m
,n
)
353 character*8 ch8targ1(n
)
354 character*8 ch8targ2(m
,n
)
355 character*8 ch8targ3(o
,m
,n
)
362 type(drvd
) dtarg2(m
,n
)
363 type(drvd
) dtarg3(o
,m
,n
)
381 pointer(iptr1
,dpte1(n
))
382 pointer(iptr2
,dpte2(m
,n
))
383 pointer(iptr3
,dpte3(o
,m
,n
))
384 pointer(iptr4
,ipte1(n
))
385 pointer(iptr5
,ipte2 (m
,n
))
386 pointer(iptr6
,ipte3(o
,m
,n
))
387 pointer(iptr7
,rpte1(n
))
388 pointer(iptr8
,rpte2(m
,n
))
389 pointer(iptr9
,rpte3(o
,m
,n
))
390 pointer(iptr10
,chpte1(n
))
391 pointer(iptr11
,chpte2(m
,n
))
392 pointer(iptr12
,chpte3(o
,m
,n
))
393 pointer(iptr13
,ch8pte1(n
))
394 pointer(iptr14
,ch8pte2(m
,n
))
395 pointer(iptr15
,ch8pte3(o
,m
,n
))
409 iptr13
= loc(ch8targ1
)
410 iptr14
= loc(ch8targ2
)
411 iptr15
= loc(ch8targ3
)
415 if (intne(dpte1(i
)%i1
, dtarg1(i
)%i1
)) then
420 dtarg1(i
)%i1
=2*dpte1(i
)%i1
421 if (intne(dpte1(i
)%i1
, dtarg1(i
)%i1
)) then
427 if (intne(ipte1(i
), itarg1(i
))) then
432 itarg1(i
) = -ipte1(i
)
433 if (intne(ipte1(i
), itarg1(i
))) then
439 if (realne(rpte1(i
), rtarg1(i
))) then
444 rtarg1(i
) = i
* (-5.0)
445 if (realne(rpte1(i
), rtarg1(i
))) then
451 if (chne(chpte1(i
), chtarg1(i
))) then
457 if (chne(chpte1(i
), chtarg1(i
))) then
462 ch8pte1(i
) = 'aaaaaaaa'
463 if (ch8ne(ch8pte1(i
), ch8targ1(i
))) then
468 ch8targ1(i
) = 'zzzzzzzz'
469 if (ch8ne(ch8pte1(i
), ch8targ1(i
))) then
476 if (realne(dpte2(j
,i
)%r1
, dtarg2(j
,i
)%r1
)) then
481 dtarg2(j
,i
)%r1
=2*dpte2(j
,i
)%r1
482 if (realne(dpte2(j
,i
)%r1
, dtarg2(j
,i
)%r1
)) then
488 if (intne(ipte2(j
,i
), itarg2(j
,i
))) then
493 itarg2(j
,i
) = -ipte2(j
,i
)
494 if (intne(ipte2(j
,i
), itarg2(j
,i
))) then
499 rpte2(j
,i
) = i
* (-2.0)
500 if (realne(rpte2(j
,i
), rtarg2(j
,i
))) then
505 rtarg2(j
,i
) = i
* (-3.0)
506 if (realne(rpte2(j
,i
), rtarg2(j
,i
))) then
512 if (chne(chpte2(j
,i
), chtarg2(j
,i
))) then
518 if (chne(chpte2(j
,i
), chtarg2(j
,i
))) then
523 ch8pte2(j
,i
) = 'aaaaaaaa'
524 if (ch8ne(ch8pte2(j
,i
), ch8targ2(j
,i
))) then
529 ch8targ2(j
,i
) = 'zzzzzzzz'
530 if (ch8ne(ch8pte2(j
,i
), ch8targ2(j
,i
))) then
535 dpte3(k
,j
,i
)%i2(1+mod(i
,5))=i
536 if (intne(dpte3(k
,j
,i
)%i2(1+mod(i
,5)), dtarg3(k
,j
,i
)%i2(1+mod(i
,5)))) then
541 dtarg3(k
,j
,i
)%i2(1+mod(i
,5))=2*dpte3(k
,j
,i
)%i2(1+mod(i
,5))
542 if (intne(dpte3(k
,j
,i
)%i2(1+mod(i
,5)), dtarg3(k
,j
,i
)%i2(1+mod(i
,5)))) then
548 if (intne(ipte3(k
,j
,i
), itarg3(k
,j
,i
))) then
553 itarg3(k
,j
,i
) = -ipte3(k
,j
,i
)
554 if (intne(ipte3(k
,j
,i
), itarg3(k
,j
,i
))) then
559 rpte3(k
,j
,i
) = i
* 2.0
560 if (realne(rpte3(k
,j
,i
), rtarg3(k
,j
,i
))) then
565 rtarg3(k
,j
,i
) = i
* 3.0
566 if (realne(rpte3(k
,j
,i
), rtarg3(k
,j
,i
))) then
572 if (chne(chpte3(k
,j
,i
), chtarg3(k
,j
,i
))) then
578 if (chne(chpte3(k
,j
,i
), chtarg3(k
,j
,i
))) then
583 ch8pte3(k
,j
,i
) = 'aaaaaaaa'
584 if (ch8ne(ch8pte3(k
,j
,i
), ch8targ3(k
,j
,i
))) then
589 ch8targ3(k
,j
,i
) = 'zzzzzzzz'
590 if (ch8ne(ch8pte3(k
,j
,i
), ch8targ3(k
,j
,i
))) then
605 if (intne(itarg3(k
,j
,i
), i
)) then
610 if (realne(rtarg3(k
,j
,i
), i
+.5)) then
620 common /errors
/errors(400)
621 logical :: errors
, intne
, realne
, chne
, ch8ne
623 integer, parameter :: n
= 9
624 integer, parameter :: m
= 10
625 integer, parameter :: o
= 11
628 integer itarg3 (o
,m
,n
)
633 character chtarg2(m
,n
)
634 character chtarg3(o
,m
,n
)
635 character*8 ch8targ1(n
)
636 character*8 ch8targ2(m
,n
)
637 character*8 ch8targ3(o
,m
,n
)
644 type(drvd
) dtarg2(m
,n
)
645 type(drvd
) dtarg3(o
,m
,n
)
647 pointer(iptr1
,dpte1(n
))
648 pointer(iptr2
,dpte2(m
,n
))
649 pointer(iptr3
,dpte3(o
,m
,n
))
650 pointer(iptr4
,ipte1(n
))
651 pointer(iptr5
,ipte2 (m
,n
))
652 pointer(iptr6
,ipte3(o
,m
,n
))
653 pointer(iptr7
,rpte1(n
))
654 pointer(iptr8
,rpte2(m
,n
))
655 pointer(iptr9
,rpte3(o
,m
,n
))
656 pointer(iptr10
,chpte1(n
))
657 pointer(iptr11
,chpte2(m
,n
))
658 pointer(iptr12
,chpte3(o
,m
,n
))
659 pointer(iptr13
,ch8pte1(n
))
660 pointer(iptr14
,ch8pte2(m
,n
))
661 pointer(iptr15
,ch8pte3(o
,m
,n
))
691 iptr13
= loc(ch8targ1
)
692 iptr14
= loc(ch8targ2
)
693 iptr15
= loc(ch8targ3
)
697 if (intne(dpte1(i
)%i1
, dtarg1(i
)%i1
)) then
702 dtarg1(i
)%i1
=2*dpte1(i
)%i1
703 if (intne(dpte1(i
)%i1
, dtarg1(i
)%i1
)) then
709 if (intne(ipte1(i
), itarg1(i
))) then
714 itarg1(i
) = -ipte1(i
)
715 if (intne(ipte1(i
), itarg1(i
))) then
721 if (realne(rpte1(i
), rtarg1(i
))) then
726 rtarg1(i
) = i
* (-5.0)
727 if (realne(rpte1(i
), rtarg1(i
))) then
733 if (chne(chpte1(i
), chtarg1(i
))) then
739 if (chne(chpte1(i
), chtarg1(i
))) then
744 ch8pte1(i
) = 'aaaaaaaa'
745 if (ch8ne(ch8pte1(i
), ch8targ1(i
))) then
750 ch8targ1(i
) = 'zzzzzzzz'
751 if (ch8ne(ch8pte1(i
), ch8targ1(i
))) then
758 if (realne(dpte2(j
,i
)%r1
, dtarg2(j
,i
)%r1
)) then
763 dtarg2(j
,i
)%r1
=2*dpte2(j
,i
)%r1
764 if (realne(dpte2(j
,i
)%r1
, dtarg2(j
,i
)%r1
)) then
770 if (intne(ipte2(j
,i
), itarg2(j
,i
))) then
775 itarg2(j
,i
) = -ipte2(j
,i
)
776 if (intne(ipte2(j
,i
), itarg2(j
,i
))) then
781 rpte2(j
,i
) = i
* (-2.0)
782 if (realne(rpte2(j
,i
), rtarg2(j
,i
))) then
787 rtarg2(j
,i
) = i
* (-3.0)
788 if (realne(rpte2(j
,i
), rtarg2(j
,i
))) then
794 if (chne(chpte2(j
,i
), chtarg2(j
,i
))) then
800 if (chne(chpte2(j
,i
), chtarg2(j
,i
))) then
805 ch8pte2(j
,i
) = 'aaaaaaaa'
806 if (ch8ne(ch8pte2(j
,i
), ch8targ2(j
,i
))) then
811 ch8targ2(j
,i
) = 'zzzzzzzz'
812 if (ch8ne(ch8pte2(j
,i
), ch8targ2(j
,i
))) then
817 dpte3(k
,j
,i
)%i2(1+mod(i
,5))=i
818 if (intne(dpte3(k
,j
,i
)%i2(1+mod(i
,5)), &
819 dtarg3(k
,j
,i
)%i2(1+mod(i
,5)))) then
824 dtarg3(k
,j
,i
)%i2(1+mod(i
,5))=2*dpte3(k
,j
,i
)%i2(1+mod(i
,5))
825 if (intne(dpte3(k
,j
,i
)%i2(1+mod(i
,5)), &
826 dtarg3(k
,j
,i
)%i2(1+mod(i
,5)))) then
832 if (intne(ipte3(k
,j
,i
), itarg3(k
,j
,i
))) then
837 itarg3(k
,j
,i
) = -ipte3(k
,j
,i
)
838 if (intne(ipte3(k
,j
,i
), itarg3(k
,j
,i
))) then
843 rpte3(k
,j
,i
) = i
* 2.0
844 if (realne(rpte3(k
,j
,i
), rtarg3(k
,j
,i
))) then
849 rtarg3(k
,j
,i
) = i
* 3.0
850 if (realne(rpte3(k
,j
,i
), rtarg3(k
,j
,i
))) then
856 if (chne(chpte3(k
,j
,i
), chtarg3(k
,j
,i
))) then
862 if (chne(chpte3(k
,j
,i
), chtarg3(k
,j
,i
))) then
867 ch8pte3(k
,j
,i
) = 'aaaaaaaa'
868 if (ch8ne(ch8pte3(k
,j
,i
), ch8targ3(k
,j
,i
))) then
873 ch8targ3(k
,j
,i
) = 'zzzzzzzz'
874 if (ch8ne(ch8pte3(k
,j
,i
), ch8targ3(k
,j
,i
))) then
889 if (intne(itarg3(k
,j
,i
), i
)) then
894 if (realne(rtarg3(k
,j
,i
), i
+.5)) then
904 common /errors
/errors(400)
905 logical :: errors
, intne
, realne
, chne
, ch8ne
907 integer, parameter :: n
= 9
908 integer, parameter :: m
= 10
909 integer, parameter :: o
= 11
912 integer itarg3 (o
,m
,n
)
917 character chtarg2(m
,n
)
918 character chtarg3(o
,m
,n
)
919 character*8 ch8targ1(n
)
920 character*8 ch8targ2(m
,n
)
921 character*8 ch8targ3(o
,m
,n
)
928 type(drvd
) dtarg2(m
,n
)
929 type(drvd
) dtarg3(o
,m
,n
)
931 pointer(iptr1
,dpte1
),(iptr2
,dpte2
),(iptr3
,dpte3
)
932 pointer (iptr4
,ipte1
), (iptr5
,ipte2
) ,(iptr6
,ipte3
),(iptr7
,rpte1
)
934 pointer(iptr9
,rpte3
),(iptr10
,chpte1
)
935 pointer(iptr11
,chpte2
),(iptr12
,chpte3
),(iptr13
,ch8pte1
)
936 pointer(iptr14
,ch8pte2
)
937 pointer(iptr15
,ch8pte3
)
940 type(drvd
) dpte2(m
,n
)
941 type(drvd
) dpte3(o
,m
,n
)
944 integer ipte3 (o
,m
,n
)
949 character chpte2(m
,n
)
950 character chpte3(o
,m
,n
)
951 character*8 ch8pte1(n
)
952 character*8 ch8pte2(m
,n
)
953 character*8 ch8pte3(o
,m
,n
)
967 iptr13
= loc(ch8targ1
)
968 iptr14
= loc(ch8targ2
)
969 iptr15
= loc(ch8targ3
)
974 if (intne(dpte1(i
)%i1
, dtarg1(i
)%i1
)) then
979 dtarg1(i
)%i1
=2*dpte1(i
)%i1
980 if (intne(dpte1(i
)%i1
, dtarg1(i
)%i1
)) then
986 if (intne(ipte1(i
), itarg1(i
))) then
991 itarg1(i
) = -ipte1(i
)
992 if (intne(ipte1(i
), itarg1(i
))) then
998 if (realne(rpte1(i
), rtarg1(i
))) then
1000 errors(113) = .true
.
1003 rtarg1(i
) = i
* (-5.0)
1004 if (realne(rpte1(i
), rtarg1(i
))) then
1006 errors(114) = .true
.
1010 if (chne(chpte1(i
), chtarg1(i
))) then
1012 errors(115) = .true
.
1016 if (chne(chpte1(i
), chtarg1(i
))) then
1018 errors(116) = .true
.
1021 ch8pte1(i
) = 'aaaaaaaa'
1022 if (ch8ne(ch8pte1(i
), ch8targ1(i
))) then
1024 errors(117) = .true
.
1027 ch8targ1(i
) = 'zzzzzzzz'
1028 if (ch8ne(ch8pte1(i
), ch8targ1(i
))) then
1030 errors(118) = .true
.
1035 if (realne(dpte2(j
,i
)%r1
, dtarg2(j
,i
)%r1
)) then
1037 errors(119) = .true
.
1040 dtarg2(j
,i
)%r1
=2*dpte2(j
,i
)%r1
1041 if (realne(dpte2(j
,i
)%r1
, dtarg2(j
,i
)%r1
)) then
1043 errors(120) = .true
.
1047 if (intne(ipte2(j
,i
), itarg2(j
,i
))) then
1049 errors(121) = .true
.
1052 itarg2(j
,i
) = -ipte2(j
,i
)
1053 if (intne(ipte2(j
,i
), itarg2(j
,i
))) then
1055 errors(122) = .true
.
1058 rpte2(j
,i
) = i
* (-2.0)
1059 if (realne(rpte2(j
,i
), rtarg2(j
,i
))) then
1061 errors(123) = .true
.
1064 rtarg2(j
,i
) = i
* (-3.0)
1065 if (realne(rpte2(j
,i
), rtarg2(j
,i
))) then
1067 errors(124) = .true
.
1071 if (chne(chpte2(j
,i
), chtarg2(j
,i
))) then
1073 errors(125) = .true
.
1077 if (chne(chpte2(j
,i
), chtarg2(j
,i
))) then
1079 errors(126) = .true
.
1082 ch8pte2(j
,i
) = 'aaaaaaaa'
1083 if (ch8ne(ch8pte2(j
,i
), ch8targ2(j
,i
))) then
1085 errors(127) = .true
.
1088 ch8targ2(j
,i
) = 'zzzzzzzz'
1089 if (ch8ne(ch8pte2(j
,i
), ch8targ2(j
,i
))) then
1091 errors(128) = .true
.
1094 dpte3(k
,j
,i
)%i2(1+mod(i
,5))=i
1095 if (intne(dpte3(k
,j
,i
)%i2(1+mod(i
,5)), &
1096 dtarg3(k
,j
,i
)%i2(1+mod(i
,5)))) then
1098 errors(129) = .true
.
1101 dtarg3(k
,j
,i
)%i2(1+mod(i
,5))=2*dpte3(k
,j
,i
)%i2(1+mod(i
,5))
1102 if (intne(dpte3(k
,j
,i
)%i2(1+mod(i
,5)), &
1103 dtarg3(k
,j
,i
)%i2(1+mod(i
,5)))) then
1105 errors(130) = .true
.
1109 if (intne(ipte3(k
,j
,i
), itarg3(k
,j
,i
))) then
1111 errors(131) = .true
.
1114 itarg3(k
,j
,i
) = -ipte3(k
,j
,i
)
1115 if (intne(ipte3(k
,j
,i
), itarg3(k
,j
,i
))) then
1117 errors(132) = .true
.
1120 rpte3(k
,j
,i
) = i
* 2.0
1121 if (realne(rpte3(k
,j
,i
), rtarg3(k
,j
,i
))) then
1123 errors(133) = .true
.
1126 rtarg3(k
,j
,i
) = i
* 3.0
1127 if (realne(rpte3(k
,j
,i
), rtarg3(k
,j
,i
))) then
1129 errors(134) = .true
.
1133 if (chne(chpte3(k
,j
,i
), chtarg3(k
,j
,i
))) then
1135 errors(135) = .true
.
1138 chtarg3(k
,j
,i
) = 'z'
1139 if (chne(chpte3(k
,j
,i
), chtarg3(k
,j
,i
))) then
1141 errors(136) = .true
.
1144 ch8pte3(k
,j
,i
) = 'aaaaaaaa'
1145 if (ch8ne(ch8pte3(k
,j
,i
), ch8targ3(k
,j
,i
))) then
1147 errors(137) = .true
.
1150 ch8targ3(k
,j
,i
) = 'zzzzzzzz'
1151 if (ch8ne(ch8pte3(k
,j
,i
), ch8targ3(k
,j
,i
))) then
1153 errors(138) = .true
.
1166 if (intne(itarg3(k
,j
,i
), i
)) then
1168 errors(139) = .true
.
1171 if (realne(rtarg3(k
,j
,i
), i
+.5)) then
1173 errors(140) = .true
.
1182 common /errors
/errors(400)
1183 logical :: errors
, intne
, realne
, chne
, ch8ne
1185 integer, parameter :: n
= 9
1186 integer, parameter :: m
= 10
1187 integer, parameter :: o
= 11
1189 integer itarg2 (m
,n
)
1190 integer itarg3 (o
,m
,n
)
1194 character chtarg1(n
)
1195 character chtarg2(m
,n
)
1196 character chtarg3(o
,m
,n
)
1197 character*8 ch8targ1(n
)
1198 character*8 ch8targ2(m
,n
)
1199 character*8 ch8targ3(o
,m
,n
)
1205 type(drvd
) dtarg1(n
)
1206 type(drvd
) dtarg2(m
,n
)
1207 type(drvd
) dtarg3(o
,m
,n
)
1210 type(drvd
) dpte2(m
,*)
1211 type(drvd
) dpte3(o
,m
,*)
1214 integer ipte3 (o
,m
,*)
1219 character chpte2(m
,*)
1220 character chpte3(o
,m
,*)
1221 character*8 ch8pte1(*)
1222 character*8 ch8pte2(m
,*)
1223 character*8 ch8pte3(o
,m
,*)
1225 pointer(iptr1
,dpte1
)
1226 pointer(iptr2
,dpte2
)
1227 pointer(iptr3
,dpte3
)
1228 pointer(iptr4
,ipte1
)
1229 pointer(iptr5
,ipte2
)
1230 pointer(iptr6
,ipte3
)
1231 pointer(iptr7
,rpte1
)
1232 pointer(iptr8
,rpte2
)
1233 pointer(iptr9
,rpte3
)
1234 pointer(iptr10
,chpte1
)
1235 pointer(iptr11
,chpte2
)
1236 pointer(iptr12
,chpte3
)
1237 pointer(iptr13
,ch8pte1
)
1238 pointer(iptr14
,ch8pte2
)
1239 pointer(iptr15
,ch8pte3
)
1250 iptr10
= loc(chtarg1
)
1251 iptr11
= loc(chtarg2
)
1252 iptr12
= loc(chtarg3
)
1253 iptr13
= loc(ch8targ1
)
1254 iptr14
= loc(ch8targ2
)
1255 iptr15
= loc(ch8targ3
)
1260 if (intne(dpte1(i
)%i1
, dtarg1(i
)%i1
)) then
1262 errors(141) = .true
.
1265 dtarg1(i
)%i1
=2*dpte1(i
)%i1
1266 if (intne(dpte1(i
)%i1
, dtarg1(i
)%i1
)) then
1268 errors(142) = .true
.
1272 if (intne(ipte1(i
), itarg1(i
))) then
1274 errors(143) = .true
.
1277 itarg1(i
) = -ipte1(i
)
1278 if (intne(ipte1(i
), itarg1(i
))) then
1280 errors(144) = .true
.
1284 if (realne(rpte1(i
), rtarg1(i
))) then
1286 errors(145) = .true
.
1289 rtarg1(i
) = i
* (-5.0)
1290 if (realne(rpte1(i
), rtarg1(i
))) then
1292 errors(146) = .true
.
1296 if (chne(chpte1(i
), chtarg1(i
))) then
1298 errors(147) = .true
.
1302 if (chne(chpte1(i
), chtarg1(i
))) then
1304 errors(148) = .true
.
1307 ch8pte1(i
) = 'aaaaaaaa'
1308 if (ch8ne(ch8pte1(i
), ch8targ1(i
))) then
1310 errors(149) = .true
.
1313 ch8targ1(i
) = 'zzzzzzzz'
1314 if (ch8ne(ch8pte1(i
), ch8targ1(i
))) then
1316 errors(150) = .true
.
1321 if (realne(dpte2(j
,i
)%r1
, dtarg2(j
,i
)%r1
)) then
1323 errors(151) = .true
.
1326 dtarg2(j
,i
)%r1
=2*dpte2(j
,i
)%r1
1327 if (realne(dpte2(j
,i
)%r1
, dtarg2(j
,i
)%r1
)) then
1329 errors(152) = .true
.
1333 if (intne(ipte2(j
,i
), itarg2(j
,i
))) then
1335 errors(153) = .true
.
1338 itarg2(j
,i
) = -ipte2(j
,i
)
1339 if (intne(ipte2(j
,i
), itarg2(j
,i
))) then
1341 errors(154) = .true
.
1344 rpte2(j
,i
) = i
* (-2.0)
1345 if (realne(rpte2(j
,i
), rtarg2(j
,i
))) then
1347 errors(155) = .true
.
1350 rtarg2(j
,i
) = i
* (-3.0)
1351 if (realne(rpte2(j
,i
), rtarg2(j
,i
))) then
1353 errors(156) = .true
.
1357 if (chne(chpte2(j
,i
), chtarg2(j
,i
))) then
1359 errors(157) = .true
.
1363 if (chne(chpte2(j
,i
), chtarg2(j
,i
))) then
1365 errors(158) = .true
.
1368 ch8pte2(j
,i
) = 'aaaaaaaa'
1369 if (ch8ne(ch8pte2(j
,i
), ch8targ2(j
,i
))) then
1371 errors(159) = .true
.
1374 ch8targ2(j
,i
) = 'zzzzzzzz'
1375 if (ch8ne(ch8pte2(j
,i
), ch8targ2(j
,i
))) then
1377 errors(160) = .true
.
1380 dpte3(k
,j
,i
)%i2(1+mod(i
,5))=i
1381 if (intne(dpte3(k
,j
,i
)%i2(1+mod(i
,5)), &
1382 dtarg3(k
,j
,i
)%i2(1+mod(i
,5)))) then
1384 errors(161) = .true
.
1387 dtarg3(k
,j
,i
)%i2(1+mod(i
,5))=2*dpte3(k
,j
,i
)%i2(1+mod(i
,5))
1388 if (intne(dpte3(k
,j
,i
)%i2(1+mod(i
,5)), &
1389 dtarg3(k
,j
,i
)%i2(1+mod(i
,5)))) then
1391 errors(162) = .true
.
1395 if (intne(ipte3(k
,j
,i
), itarg3(k
,j
,i
))) then
1397 errors(163) = .true
.
1400 itarg3(k
,j
,i
) = -ipte3(k
,j
,i
)
1401 if (intne(ipte3(k
,j
,i
), itarg3(k
,j
,i
))) then
1403 errors(164) = .true
.
1406 rpte3(k
,j
,i
) = i
* 2.0
1407 if (realne(rpte3(k
,j
,i
), rtarg3(k
,j
,i
))) then
1409 errors(165) = .true
.
1412 rtarg3(k
,j
,i
) = i
* 3.0
1413 if (realne(rpte3(k
,j
,i
), rtarg3(k
,j
,i
))) then
1415 errors(166) = .true
.
1419 if (chne(chpte3(k
,j
,i
), chtarg3(k
,j
,i
))) then
1421 errors(167) = .true
.
1424 chtarg3(k
,j
,i
) = 'z'
1425 if (chne(chpte3(k
,j
,i
), chtarg3(k
,j
,i
))) then
1427 errors(168) = .true
.
1430 ch8pte3(k
,j
,i
) = 'aaaaaaaa'
1431 if (ch8ne(ch8pte3(k
,j
,i
), ch8targ3(k
,j
,i
))) then
1433 errors(169) = .true
.
1436 ch8targ3(k
,j
,i
) = 'zzzzzzzz'
1437 if (ch8ne(ch8pte3(k
,j
,i
), ch8targ3(k
,j
,i
))) then
1439 errors(170) = .true
.
1449 common /errors
/errors(400)
1450 logical :: errors
, intne
, realne
, chne
, ch8ne
1452 integer, parameter :: n
= 9
1453 integer, parameter :: m
= 10
1454 integer, parameter :: o
= 11
1456 integer itarg2 (m
,n
)
1457 integer itarg3 (o
,m
,n
)
1461 character chtarg1(n
)
1462 character chtarg2(m
,n
)
1463 character chtarg3(o
,m
,n
)
1464 character*8 ch8targ1(n
)
1465 character*8 ch8targ2(m
,n
)
1466 character*8 ch8targ3(o
,m
,n
)
1472 type(drvd
) dtarg1(n
)
1473 type(drvd
) dtarg2(m
,n
)
1474 type(drvd
) dtarg3(o
,m
,n
)
1492 pointer(iptr1
,dpte1(*))
1493 pointer(iptr2
,dpte2(m
,*))
1494 pointer(iptr3
,dpte3(o
,m
,*))
1495 pointer(iptr4
,ipte1(*))
1496 pointer(iptr5
,ipte2 (m
,*))
1497 pointer(iptr6
,ipte3(o
,m
,*))
1498 pointer(iptr7
,rpte1(*))
1499 pointer(iptr8
,rpte2(m
,*))
1500 pointer(iptr9
,rpte3(o
,m
,*))
1501 pointer(iptr10
,chpte1(*))
1502 pointer(iptr11
,chpte2(m
,*))
1503 pointer(iptr12
,chpte3(o
,m
,*))
1504 pointer(iptr13
,ch8pte1(*))
1505 pointer(iptr14
,ch8pte2(m
,*))
1506 pointer(iptr15
,ch8pte3(o
,m
,*))
1517 iptr10
= loc(chtarg1
)
1518 iptr11
= loc(chtarg2
)
1519 iptr12
= loc(chtarg3
)
1520 iptr13
= loc(ch8targ1
)
1521 iptr14
= loc(ch8targ2
)
1522 iptr15
= loc(ch8targ3
)
1526 if (intne(dpte1(i
)%i1
, dtarg1(i
)%i1
)) then
1528 errors(171) = .true
.
1531 dtarg1(i
)%i1
=2*dpte1(i
)%i1
1532 if (intne(dpte1(i
)%i1
, dtarg1(i
)%i1
)) then
1534 errors(172) = .true
.
1538 if (intne(ipte1(i
), itarg1(i
))) then
1540 errors(173) = .true
.
1543 itarg1(i
) = -ipte1(i
)
1544 if (intne(ipte1(i
), itarg1(i
))) then
1546 errors(174) = .true
.
1550 if (realne(rpte1(i
), rtarg1(i
))) then
1552 errors(175) = .true
.
1555 rtarg1(i
) = i
* (-5.0)
1556 if (realne(rpte1(i
), rtarg1(i
))) then
1558 errors(176) = .true
.
1562 if (chne(chpte1(i
), chtarg1(i
))) then
1564 errors(177) = .true
.
1568 if (chne(chpte1(i
), chtarg1(i
))) then
1570 errors(178) = .true
.
1573 ch8pte1(i
) = 'aaaaaaaa'
1574 if (ch8ne(ch8pte1(i
), ch8targ1(i
))) then
1576 errors(179) = .true
.
1579 ch8targ1(i
) = 'zzzzzzzz'
1580 if (ch8ne(ch8pte1(i
), ch8targ1(i
))) then
1582 errors(180) = .true
.
1587 if (realne(dpte2(j
,i
)%r1
, dtarg2(j
,i
)%r1
)) then
1589 errors(181) = .true
.
1592 dtarg2(j
,i
)%r1
=2*dpte2(j
,i
)%r1
1593 if (realne(dpte2(j
,i
)%r1
, dtarg2(j
,i
)%r1
)) then
1595 errors(182) = .true
.
1599 if (intne(ipte2(j
,i
), itarg2(j
,i
))) then
1601 errors(183) = .true
.
1604 itarg2(j
,i
) = -ipte2(j
,i
)
1605 if (intne(ipte2(j
,i
), itarg2(j
,i
))) then
1607 errors(184) = .true
.
1610 rpte2(j
,i
) = i
* (-2.0)
1611 if (realne(rpte2(j
,i
), rtarg2(j
,i
))) then
1613 errors(185) = .true
.
1616 rtarg2(j
,i
) = i
* (-3.0)
1617 if (realne(rpte2(j
,i
), rtarg2(j
,i
))) then
1619 errors(186) = .true
.
1623 if (chne(chpte2(j
,i
), chtarg2(j
,i
))) then
1625 errors(187) = .true
.
1629 if (chne(chpte2(j
,i
), chtarg2(j
,i
))) then
1631 errors(188) = .true
.
1634 ch8pte2(j
,i
) = 'aaaaaaaa'
1635 if (ch8ne(ch8pte2(j
,i
), ch8targ2(j
,i
))) then
1637 errors(189) = .true
.
1640 ch8targ2(j
,i
) = 'zzzzzzzz'
1641 if (ch8ne(ch8pte2(j
,i
), ch8targ2(j
,i
))) then
1643 errors(190) = .true
.
1646 dpte3(k
,j
,i
)%i2(1+mod(i
,5))=i
1647 if (intne(dpte3(k
,j
,i
)%i2(1+mod(i
,5)), &
1648 dtarg3(k
,j
,i
)%i2(1+mod(i
,5)))) then
1650 errors(191) = .true
.
1653 dtarg3(k
,j
,i
)%i2(1+mod(i
,5))=2*dpte3(k
,j
,i
)%i2(1+mod(i
,5))
1654 if (intne(dpte3(k
,j
,i
)%i2(1+mod(i
,5)), &
1655 dtarg3(k
,j
,i
)%i2(1+mod(i
,5)))) then
1657 errors(192) = .true
.
1661 if (intne(ipte3(k
,j
,i
), itarg3(k
,j
,i
))) then
1663 errors(193) = .true
.
1666 itarg3(k
,j
,i
) = -ipte3(k
,j
,i
)
1667 if (intne(ipte3(k
,j
,i
), itarg3(k
,j
,i
))) then
1669 errors(194) = .true
.
1672 rpte3(k
,j
,i
) = i
* 2.0
1673 if (realne(rpte3(k
,j
,i
), rtarg3(k
,j
,i
))) then
1675 errors(195) = .true
.
1678 rtarg3(k
,j
,i
) = i
* 3.0
1679 if (realne(rpte3(k
,j
,i
), rtarg3(k
,j
,i
))) then
1681 errors(196) = .true
.
1685 if (chne(chpte3(k
,j
,i
), chtarg3(k
,j
,i
))) then
1687 errors(197) = .true
.
1690 chtarg3(k
,j
,i
) = 'z'
1691 if (chne(chpte3(k
,j
,i
), chtarg3(k
,j
,i
))) then
1693 errors(198) = .true
.
1696 ch8pte3(k
,j
,i
) = 'aaaaaaaa'
1697 if (ch8ne(ch8pte3(k
,j
,i
), ch8targ3(k
,j
,i
))) then
1699 errors(199) = .true
.
1702 ch8targ3(k
,j
,i
) = 'zzzzzzzz'
1703 if (ch8ne(ch8pte3(k
,j
,i
), ch8targ3(k
,j
,i
))) then
1705 errors(200) = .true
.
1714 common /errors
/errors(400)
1715 logical :: errors
, intne
, realne
, chne
, ch8ne
1717 integer, parameter :: n
= 9
1718 integer, parameter :: m
= 10
1719 integer, parameter :: o
= 11
1721 integer itarg2 (m
,n
)
1722 integer itarg3 (o
,m
,n
)
1726 character chtarg1(n
)
1727 character chtarg2(m
,n
)
1728 character chtarg3(o
,m
,n
)
1729 character*8 ch8targ1(n
)
1730 character*8 ch8targ2(m
,n
)
1731 character*8 ch8targ3(o
,m
,n
)
1737 type(drvd
) dtarg1(n
)
1738 type(drvd
) dtarg2(m
,n
)
1739 type(drvd
) dtarg3(o
,m
,n
)
1741 pointer(iptr1
,dpte1(*))
1742 pointer(iptr2
,dpte2(m
,*))
1743 pointer(iptr3
,dpte3(o
,m
,*))
1744 pointer(iptr4
,ipte1(*))
1745 pointer(iptr5
,ipte2 (m
,*))
1746 pointer(iptr6
,ipte3(o
,m
,*))
1747 pointer(iptr7
,rpte1(*))
1748 pointer(iptr8
,rpte2(m
,*))
1749 pointer(iptr9
,rpte3(o
,m
,*))
1750 pointer(iptr10
,chpte1(*))
1751 pointer(iptr11
,chpte2(m
,*))
1752 pointer(iptr12
,chpte3(o
,m
,*))
1753 pointer(iptr13
,ch8pte1(*))
1754 pointer(iptr14
,ch8pte2(m
,*))
1755 pointer(iptr15
,ch8pte3(o
,m
,*))
1782 iptr10
= loc(chtarg1
)
1783 iptr11
= loc(chtarg2
)
1784 iptr12
= loc(chtarg3
)
1785 iptr13
= loc(ch8targ1
)
1786 iptr14
= loc(ch8targ2
)
1787 iptr15
= loc(ch8targ3
)
1791 if (intne(dpte1(i
)%i1
, dtarg1(i
)%i1
)) then
1793 errors(201) = .true
.
1796 dtarg1(i
)%i1
=2*dpte1(i
)%i1
1797 if (intne(dpte1(i
)%i1
, dtarg1(i
)%i1
)) then
1799 errors(202) = .true
.
1803 if (intne(ipte1(i
), itarg1(i
))) then
1805 errors(203) = .true
.
1808 itarg1(i
) = -ipte1(i
)
1809 if (intne(ipte1(i
), itarg1(i
))) then
1811 errors(204) = .true
.
1815 if (realne(rpte1(i
), rtarg1(i
))) then
1817 errors(205) = .true
.
1820 rtarg1(i
) = i
* (-5.0)
1821 if (realne(rpte1(i
), rtarg1(i
))) then
1823 errors(206) = .true
.
1827 if (chne(chpte1(i
), chtarg1(i
))) then
1829 errors(207) = .true
.
1833 if (chne(chpte1(i
), chtarg1(i
))) then
1835 errors(208) = .true
.
1838 ch8pte1(i
) = 'aaaaaaaa'
1839 if (ch8ne(ch8pte1(i
), ch8targ1(i
))) then
1841 errors(209) = .true
.
1844 ch8targ1(i
) = 'zzzzzzzz'
1845 if (ch8ne(ch8pte1(i
), ch8targ1(i
))) then
1847 errors(210) = .true
.
1852 if (realne(dpte2(j
,i
)%r1
, dtarg2(j
,i
)%r1
)) then
1854 errors(211) = .true
.
1857 dtarg2(j
,i
)%r1
=2*dpte2(j
,i
)%r1
1858 if (realne(dpte2(j
,i
)%r1
, dtarg2(j
,i
)%r1
)) then
1860 errors(212) = .true
.
1864 if (intne(ipte2(j
,i
), itarg2(j
,i
))) then
1866 errors(213) = .true
.
1869 itarg2(j
,i
) = -ipte2(j
,i
)
1870 if (intne(ipte2(j
,i
), itarg2(j
,i
))) then
1872 errors(214) = .true
.
1875 rpte2(j
,i
) = i
* (-2.0)
1876 if (realne(rpte2(j
,i
), rtarg2(j
,i
))) then
1878 errors(215) = .true
.
1881 rtarg2(j
,i
) = i
* (-3.0)
1882 if (realne(rpte2(j
,i
), rtarg2(j
,i
))) then
1884 errors(216) = .true
.
1888 if (chne(chpte2(j
,i
), chtarg2(j
,i
))) then
1890 errors(217) = .true
.
1894 if (chne(chpte2(j
,i
), chtarg2(j
,i
))) then
1896 errors(218) = .true
.
1899 ch8pte2(j
,i
) = 'aaaaaaaa'
1900 if (ch8ne(ch8pte2(j
,i
), ch8targ2(j
,i
))) then
1902 errors(219) = .true
.
1905 ch8targ2(j
,i
) = 'zzzzzzzz'
1906 if (ch8ne(ch8pte2(j
,i
), ch8targ2(j
,i
))) then
1908 errors(220) = .true
.
1911 dpte3(k
,j
,i
)%i2(1+mod(i
,5))=i
1912 if (intne(dpte3(k
,j
,i
)%i2(1+mod(i
,5)), &
1913 dtarg3(k
,j
,i
)%i2(1+mod(i
,5)))) then
1915 errors(221) = .true
.
1918 dtarg3(k
,j
,i
)%i2(1+mod(i
,5))=2*dpte3(k
,j
,i
)%i2(1+mod(i
,5))
1919 if (intne(dpte3(k
,j
,i
)%i2(1+mod(i
,5)), &
1920 dtarg3(k
,j
,i
)%i2(1+mod(i
,5)))) then
1922 errors(222) = .true
.
1926 if (intne(ipte3(k
,j
,i
), itarg3(k
,j
,i
))) then
1928 errors(223) = .true
.
1931 itarg3(k
,j
,i
) = -ipte3(k
,j
,i
)
1932 if (intne(ipte3(k
,j
,i
), itarg3(k
,j
,i
))) then
1934 errors(224) = .true
.
1937 rpte3(k
,j
,i
) = i
* 2.0
1938 if (realne(rpte3(k
,j
,i
), rtarg3(k
,j
,i
))) then
1940 errors(225) = .true
.
1943 rtarg3(k
,j
,i
) = i
* 3.0
1944 if (realne(rpte3(k
,j
,i
), rtarg3(k
,j
,i
))) then
1946 errors(226) = .true
.
1950 if (chne(chpte3(k
,j
,i
), chtarg3(k
,j
,i
))) then
1952 errors(227) = .true
.
1955 chtarg3(k
,j
,i
) = 'z'
1956 if (chne(chpte3(k
,j
,i
), chtarg3(k
,j
,i
))) then
1958 errors(228) = .true
.
1961 ch8pte3(k
,j
,i
) = 'aaaaaaaa'
1962 if (ch8ne(ch8pte3(k
,j
,i
), ch8targ3(k
,j
,i
))) then
1964 errors(229) = .true
.
1967 ch8targ3(k
,j
,i
) = 'zzzzzzzz'
1968 if (ch8ne(ch8pte3(k
,j
,i
), ch8targ3(k
,j
,i
))) then
1970 errors(230) = .true
.
1979 common /errors
/errors(400)
1980 logical :: errors
, intne
, realne
, chne
, ch8ne
1982 integer, parameter :: n
= 9
1983 integer, parameter :: m
= 10
1984 integer, parameter :: o
= 11
1986 integer itarg2 (m
,n
)
1987 integer itarg3 (o
,m
,n
)
1991 character chtarg1(n
)
1992 character chtarg2(m
,n
)
1993 character chtarg3(o
,m
,n
)
1994 character*8 ch8targ1(n
)
1995 character*8 ch8targ2(m
,n
)
1996 character*8 ch8targ3(o
,m
,n
)
2002 type(drvd
) dtarg1(n
)
2003 type(drvd
) dtarg2(m
,n
)
2004 type(drvd
) dtarg3(o
,m
,n
)
2006 pointer(iptr1
,dpte1
)
2007 pointer(iptr2
,dpte2
)
2008 pointer(iptr3
,dpte3
)
2009 pointer(iptr4
,ipte1
)
2010 pointer(iptr5
,ipte2
)
2011 pointer(iptr6
,ipte3
)
2012 pointer(iptr7
,rpte1
)
2013 pointer(iptr8
,rpte2
)
2014 pointer(iptr9
,rpte3
)
2015 pointer(iptr10
,chpte1
)
2016 pointer(iptr11
,chpte2
)
2017 pointer(iptr12
,chpte3
)
2018 pointer(iptr13
,ch8pte1
)
2019 pointer(iptr14
,ch8pte2
)
2020 pointer(iptr15
,ch8pte3
)
2023 type(drvd
) dpte2(m
,*)
2024 type(drvd
) dpte3(o
,m
,*)
2027 integer ipte3 (o
,m
,*)
2032 character chpte2(m
,*)
2033 character chpte3(o
,m
,*)
2034 character*8 ch8pte1(*)
2035 character*8 ch8pte2(m
,*)
2036 character*8 ch8pte3(o
,m
,*)
2047 iptr10
= loc(chtarg1
)
2048 iptr11
= loc(chtarg2
)
2049 iptr12
= loc(chtarg3
)
2050 iptr13
= loc(ch8targ1
)
2051 iptr14
= loc(ch8targ2
)
2052 iptr15
= loc(ch8targ3
)
2057 if (intne(dpte1(i
)%i1
, dtarg1(i
)%i1
)) then
2059 errors(231) = .true
.
2062 dtarg1(i
)%i1
=2*dpte1(i
)%i1
2063 if (intne(dpte1(i
)%i1
, dtarg1(i
)%i1
)) then
2065 errors(232) = .true
.
2069 if (intne(ipte1(i
), itarg1(i
))) then
2071 errors(233) = .true
.
2074 itarg1(i
) = -ipte1(i
)
2075 if (intne(ipte1(i
), itarg1(i
))) then
2077 errors(234) = .true
.
2081 if (realne(rpte1(i
), rtarg1(i
))) then
2083 errors(235) = .true
.
2086 rtarg1(i
) = i
* (-5.0)
2087 if (realne(rpte1(i
), rtarg1(i
))) then
2089 errors(236) = .true
.
2093 if (chne(chpte1(i
), chtarg1(i
))) then
2095 errors(237) = .true
.
2099 if (chne(chpte1(i
), chtarg1(i
))) then
2101 errors(238) = .true
.
2104 ch8pte1(i
) = 'aaaaaaaa'
2105 if (ch8ne(ch8pte1(i
), ch8targ1(i
))) then
2107 errors(239) = .true
.
2110 ch8targ1(i
) = 'zzzzzzzz'
2111 if (ch8ne(ch8pte1(i
), ch8targ1(i
))) then
2113 errors(240) = .true
.
2118 if (realne(dpte2(j
,i
)%r1
, dtarg2(j
,i
)%r1
)) then
2120 errors(241) = .true
.
2123 dtarg2(j
,i
)%r1
=2*dpte2(j
,i
)%r1
2124 if (realne(dpte2(j
,i
)%r1
, dtarg2(j
,i
)%r1
)) then
2126 errors(242) = .true
.
2130 if (intne(ipte2(j
,i
), itarg2(j
,i
))) then
2132 errors(243) = .true
.
2135 itarg2(j
,i
) = -ipte2(j
,i
)
2136 if (intne(ipte2(j
,i
), itarg2(j
,i
))) then
2138 errors(244) = .true
.
2141 rpte2(j
,i
) = i
* (-2.0)
2142 if (realne(rpte2(j
,i
), rtarg2(j
,i
))) then
2144 errors(245) = .true
.
2147 rtarg2(j
,i
) = i
* (-3.0)
2148 if (realne(rpte2(j
,i
), rtarg2(j
,i
))) then
2150 errors(246) = .true
.
2154 if (chne(chpte2(j
,i
), chtarg2(j
,i
))) then
2156 errors(247) = .true
.
2160 if (chne(chpte2(j
,i
), chtarg2(j
,i
))) then
2162 errors(248) = .true
.
2165 ch8pte2(j
,i
) = 'aaaaaaaa'
2166 if (ch8ne(ch8pte2(j
,i
), ch8targ2(j
,i
))) then
2168 errors(249) = .true
.
2171 ch8targ2(j
,i
) = 'zzzzzzzz'
2172 if (ch8ne(ch8pte2(j
,i
), ch8targ2(j
,i
))) then
2174 errors(250) = .true
.
2177 dpte3(k
,j
,i
)%i2(1+mod(i
,5))=i
2178 if (intne(dpte3(k
,j
,i
)%i2(1+mod(i
,5)), &
2179 dtarg3(k
,j
,i
)%i2(1+mod(i
,5)))) then
2181 errors(251) = .true
.
2184 dtarg3(k
,j
,i
)%i2(1+mod(i
,5))=2*dpte3(k
,j
,i
)%i2(1+mod(i
,5))
2185 if (intne(dpte3(k
,j
,i
)%i2(1+mod(i
,5)), &
2186 dtarg3(k
,j
,i
)%i2(1+mod(i
,5)))) then
2188 errors(252) = .true
.
2192 if (intne(ipte3(k
,j
,i
), itarg3(k
,j
,i
))) then
2194 errors(253) = .true
.
2197 itarg3(k
,j
,i
) = -ipte3(k
,j
,i
)
2198 if (intne(ipte3(k
,j
,i
), itarg3(k
,j
,i
))) then
2200 errors(254) = .true
.
2203 rpte3(k
,j
,i
) = i
* 2.0
2204 if (realne(rpte3(k
,j
,i
), rtarg3(k
,j
,i
))) then
2206 errors(255) = .true
.
2209 rtarg3(k
,j
,i
) = i
* 3.0
2210 if (realne(rpte3(k
,j
,i
), rtarg3(k
,j
,i
))) then
2212 errors(256) = .true
.
2216 if (chne(chpte3(k
,j
,i
), chtarg3(k
,j
,i
))) then
2218 errors(257) = .true
.
2221 chtarg3(k
,j
,i
) = 'z'
2222 if (chne(chpte3(k
,j
,i
), chtarg3(k
,j
,i
))) then
2224 errors(258) = .true
.
2227 ch8pte3(k
,j
,i
) = 'aaaaaaaa'
2228 if (ch8ne(ch8pte3(k
,j
,i
), ch8targ3(k
,j
,i
))) then
2230 errors(259) = .true
.
2233 ch8targ3(k
,j
,i
) = 'zzzzzzzz'
2234 if (ch8ne(ch8pte3(k
,j
,i
), ch8targ3(k
,j
,i
))) then
2236 errors(260) = .true
.
2244 subroutine ptr9(nnn
,mmm
,ooo
)
2245 common /errors
/errors(400)
2246 logical :: errors
, intne
, realne
, chne
, ch8ne
2248 integer :: nnn
,mmm
,ooo
2249 integer, parameter :: n
= 9
2250 integer, parameter :: m
= 10
2251 integer, parameter :: o
= 11
2253 integer itarg2 (m
,n
)
2254 integer itarg3 (o
,m
,n
)
2258 character chtarg1(n
)
2259 character chtarg2(m
,n
)
2260 character chtarg3(o
,m
,n
)
2261 character*8 ch8targ1(n
)
2262 character*8 ch8targ2(m
,n
)
2263 character*8 ch8targ3(o
,m
,n
)
2269 type(drvd
) dtarg1(n
)
2270 type(drvd
) dtarg2(m
,n
)
2271 type(drvd
) dtarg3(o
,m
,n
)
2273 type(drvd
) dpte1(nnn
)
2274 type(drvd
) dpte2(mmm
,nnn
)
2275 type(drvd
) dpte3(ooo
,mmm
,nnn
)
2277 integer ipte2 (mmm
,nnn
)
2278 integer ipte3 (ooo
,mmm
,nnn
)
2281 real rpte3(ooo
,mmm
,nnn
)
2282 character chpte1(nnn
)
2283 character chpte2(mmm
,nnn
)
2284 character chpte3(ooo
,mmm
,nnn
)
2285 character*8 ch8pte1(nnn
)
2286 character*8 ch8pte2(mmm
,nnn
)
2287 character*8 ch8pte3(ooo
,mmm
,nnn
)
2289 pointer(iptr1
,dpte1
)
2290 pointer(iptr2
,dpte2
)
2291 pointer(iptr3
,dpte3
)
2292 pointer(iptr4
,ipte1
)
2293 pointer(iptr5
,ipte2
)
2294 pointer(iptr6
,ipte3
)
2295 pointer(iptr7
,rpte1
)
2296 pointer(iptr8
,rpte2
)
2297 pointer(iptr9
,rpte3
)
2298 pointer(iptr10
,chpte1
)
2299 pointer(iptr11
,chpte2
)
2300 pointer(iptr12
,chpte3
)
2301 pointer(iptr13
,ch8pte1
)
2302 pointer(iptr14
,ch8pte2
)
2303 pointer(iptr15
,ch8pte3
)
2314 iptr10
= loc(chtarg1
)
2315 iptr11
= loc(chtarg2
)
2316 iptr12
= loc(chtarg3
)
2317 iptr13
= loc(ch8targ1
)
2318 iptr14
= loc(ch8targ2
)
2319 iptr15
= loc(ch8targ3
)
2324 if (intne(dpte1(i
)%i1
, dtarg1(i
)%i1
)) then
2326 errors(261) = .true
.
2329 dtarg1(i
)%i1
=2*dpte1(i
)%i1
2330 if (intne(dpte1(i
)%i1
, dtarg1(i
)%i1
)) then
2332 errors(262) = .true
.
2336 if (intne(ipte1(i
), itarg1(i
))) then
2338 errors(263) = .true
.
2341 itarg1(i
) = -ipte1(i
)
2342 if (intne(ipte1(i
), itarg1(i
))) then
2344 errors(264) = .true
.
2348 if (realne(rpte1(i
), rtarg1(i
))) then
2350 errors(265) = .true
.
2353 rtarg1(i
) = i
* (-5.0)
2354 if (realne(rpte1(i
), rtarg1(i
))) then
2356 errors(266) = .true
.
2360 if (chne(chpte1(i
), chtarg1(i
))) then
2362 errors(267) = .true
.
2366 if (chne(chpte1(i
), chtarg1(i
))) then
2368 errors(268) = .true
.
2371 ch8pte1(i
) = 'aaaaaaaa'
2372 if (ch8ne(ch8pte1(i
), ch8targ1(i
))) then
2374 errors(269) = .true
.
2377 ch8targ1(i
) = 'zzzzzzzz'
2378 if (ch8ne(ch8pte1(i
), ch8targ1(i
))) then
2380 errors(270) = .true
.
2385 if (realne(dpte2(j
,i
)%r1
, dtarg2(j
,i
)%r1
)) then
2387 errors(271) = .true
.
2390 dtarg2(j
,i
)%r1
=2*dpte2(j
,i
)%r1
2391 if (realne(dpte2(j
,i
)%r1
, dtarg2(j
,i
)%r1
)) then
2393 errors(272) = .true
.
2397 if (intne(ipte2(j
,i
), itarg2(j
,i
))) then
2399 errors(273) = .true
.
2402 itarg2(j
,i
) = -ipte2(j
,i
)
2403 if (intne(ipte2(j
,i
), itarg2(j
,i
))) then
2405 errors(274) = .true
.
2408 rpte2(j
,i
) = i
* (-2.0)
2409 if (realne(rpte2(j
,i
), rtarg2(j
,i
))) then
2411 errors(275) = .true
.
2414 rtarg2(j
,i
) = i
* (-3.0)
2415 if (realne(rpte2(j
,i
), rtarg2(j
,i
))) then
2417 errors(276) = .true
.
2421 if (chne(chpte2(j
,i
), chtarg2(j
,i
))) then
2423 errors(277) = .true
.
2427 if (chne(chpte2(j
,i
), chtarg2(j
,i
))) then
2429 errors(278) = .true
.
2432 ch8pte2(j
,i
) = 'aaaaaaaa'
2433 if (ch8ne(ch8pte2(j
,i
), ch8targ2(j
,i
))) then
2435 errors(279) = .true
.
2438 ch8targ2(j
,i
) = 'zzzzzzzz'
2439 if (ch8ne(ch8pte2(j
,i
), ch8targ2(j
,i
))) then
2441 errors(280) = .true
.
2444 dpte3(k
,j
,i
)%i2(1+mod(i
,5))=i
2445 if (intne(dpte3(k
,j
,i
)%i2(1+mod(i
,5)), &
2446 dtarg3(k
,j
,i
)%i2(1+mod(i
,5)))) then
2448 errors(281) = .true
.
2451 dtarg3(k
,j
,i
)%i2(1+mod(i
,5))=2*dpte3(k
,j
,i
)%i2(1+mod(i
,5))
2452 if (intne(dpte3(k
,j
,i
)%i2(1+mod(i
,5)), &
2453 dtarg3(k
,j
,i
)%i2(1+mod(i
,5)))) then
2455 errors(282) = .true
.
2459 if (intne(ipte3(k
,j
,i
), itarg3(k
,j
,i
))) then
2461 errors(283) = .true
.
2464 itarg3(k
,j
,i
) = -ipte3(k
,j
,i
)
2465 if (intne(ipte3(k
,j
,i
), itarg3(k
,j
,i
))) then
2467 errors(284) = .true
.
2470 rpte3(k
,j
,i
) = i
* 2.0
2471 if (realne(rpte3(k
,j
,i
), rtarg3(k
,j
,i
))) then
2473 errors(285) = .true
.
2476 rtarg3(k
,j
,i
) = i
* 3.0
2477 if (realne(rpte3(k
,j
,i
), rtarg3(k
,j
,i
))) then
2479 errors(286) = .true
.
2483 if (chne(chpte3(k
,j
,i
), chtarg3(k
,j
,i
))) then
2485 errors(287) = .true
.
2488 chtarg3(k
,j
,i
) = 'z'
2489 if (chne(chpte3(k
,j
,i
), chtarg3(k
,j
,i
))) then
2491 errors(288) = .true
.
2494 ch8pte3(k
,j
,i
) = 'aaaaaaaa'
2495 if (ch8ne(ch8pte3(k
,j
,i
), ch8targ3(k
,j
,i
))) then
2497 errors(289) = .true
.
2500 ch8targ3(k
,j
,i
) = 'zzzzzzzz'
2501 if (ch8ne(ch8pte3(k
,j
,i
), ch8targ3(k
,j
,i
))) then
2503 errors(290) = .true
.
2516 if (intne(itarg3(k
,j
,i
), i
)) then
2518 errors(291) = .true
.
2521 if (realne(rtarg3(k
,j
,i
), i
+.5)) then
2523 errors(292) = .true
.
2531 subroutine ptr10(nnn
,mmm
,ooo
)
2532 common /errors
/errors(400)
2533 logical :: errors
, intne
, realne
, chne
, ch8ne
2535 integer :: nnn
,mmm
,ooo
2536 integer, parameter :: n
= 9
2537 integer, parameter :: m
= 10
2538 integer, parameter :: o
= 11
2540 integer itarg2 (m
,n
)
2541 integer itarg3 (o
,m
,n
)
2545 character chtarg1(n
)
2546 character chtarg2(m
,n
)
2547 character chtarg3(o
,m
,n
)
2548 character*8 ch8targ1(n
)
2549 character*8 ch8targ2(m
,n
)
2550 character*8 ch8targ3(o
,m
,n
)
2556 type(drvd
) dtarg1(n
)
2557 type(drvd
) dtarg2(m
,n
)
2558 type(drvd
) dtarg3(o
,m
,n
)
2576 pointer(iptr1
,dpte1(nnn
))
2577 pointer(iptr2
,dpte2(mmm
,nnn
))
2578 pointer(iptr3
,dpte3(ooo
,mmm
,nnn
))
2579 pointer(iptr4
,ipte1(nnn
))
2580 pointer(iptr5
,ipte2 (mmm
,nnn
))
2581 pointer(iptr6
,ipte3(ooo
,mmm
,nnn
))
2582 pointer(iptr7
,rpte1(nnn
))
2583 pointer(iptr8
,rpte2(mmm
,nnn
))
2584 pointer(iptr9
,rpte3(ooo
,mmm
,nnn
))
2585 pointer(iptr10
,chpte1(nnn
))
2586 pointer(iptr11
,chpte2(mmm
,nnn
))
2587 pointer(iptr12
,chpte3(ooo
,mmm
,nnn
))
2588 pointer(iptr13
,ch8pte1(nnn
))
2589 pointer(iptr14
,ch8pte2(mmm
,nnn
))
2590 pointer(iptr15
,ch8pte3(ooo
,mmm
,nnn
))
2601 iptr10
= loc(chtarg1
)
2602 iptr11
= loc(chtarg2
)
2603 iptr12
= loc(chtarg3
)
2604 iptr13
= loc(ch8targ1
)
2605 iptr14
= loc(ch8targ2
)
2606 iptr15
= loc(ch8targ3
)
2610 if (intne(dpte1(i
)%i1
, dtarg1(i
)%i1
)) then
2612 errors(293) = .true
.
2615 dtarg1(i
)%i1
=2*dpte1(i
)%i1
2616 if (intne(dpte1(i
)%i1
, dtarg1(i
)%i1
)) then
2618 errors(294) = .true
.
2622 if (intne(ipte1(i
), itarg1(i
))) then
2624 errors(295) = .true
.
2627 itarg1(i
) = -ipte1(i
)
2628 if (intne(ipte1(i
), itarg1(i
))) then
2630 errors(296) = .true
.
2634 if (realne(rpte1(i
), rtarg1(i
))) then
2636 errors(297) = .true
.
2639 rtarg1(i
) = i
* (-5.0)
2640 if (realne(rpte1(i
), rtarg1(i
))) then
2642 errors(298) = .true
.
2646 if (chne(chpte1(i
), chtarg1(i
))) then
2648 errors(299) = .true
.
2652 if (chne(chpte1(i
), chtarg1(i
))) then
2654 errors(300) = .true
.
2657 ch8pte1(i
) = 'aaaaaaaa'
2658 if (ch8ne(ch8pte1(i
), ch8targ1(i
))) then
2660 errors(301) = .true
.
2663 ch8targ1(i
) = 'zzzzzzzz'
2664 if (ch8ne(ch8pte1(i
), ch8targ1(i
))) then
2666 errors(302) = .true
.
2671 if (realne(dpte2(j
,i
)%r1
, dtarg2(j
,i
)%r1
)) then
2673 errors(303) = .true
.
2676 dtarg2(j
,i
)%r1
=2*dpte2(j
,i
)%r1
2677 if (realne(dpte2(j
,i
)%r1
, dtarg2(j
,i
)%r1
)) then
2679 errors(304) = .true
.
2683 if (intne(ipte2(j
,i
), itarg2(j
,i
))) then
2685 errors(305) = .true
.
2688 itarg2(j
,i
) = -ipte2(j
,i
)
2689 if (intne(ipte2(j
,i
), itarg2(j
,i
))) then
2691 errors(306) = .true
.
2694 rpte2(j
,i
) = i
* (-2.0)
2695 if (realne(rpte2(j
,i
), rtarg2(j
,i
))) then
2697 errors(307) = .true
.
2700 rtarg2(j
,i
) = i
* (-3.0)
2701 if (realne(rpte2(j
,i
), rtarg2(j
,i
))) then
2703 errors(308) = .true
.
2707 if (chne(chpte2(j
,i
), chtarg2(j
,i
))) then
2709 errors(309) = .true
.
2713 if (chne(chpte2(j
,i
), chtarg2(j
,i
))) then
2715 errors(310) = .true
.
2718 ch8pte2(j
,i
) = 'aaaaaaaa'
2719 if (ch8ne(ch8pte2(j
,i
), ch8targ2(j
,i
))) then
2721 errors(311) = .true
.
2724 ch8targ2(j
,i
) = 'zzzzzzzz'
2725 if (ch8ne(ch8pte2(j
,i
), ch8targ2(j
,i
))) then
2727 errors(312) = .true
.
2730 dpte3(k
,j
,i
)%i2(1+mod(i
,5))=i
2731 if (intne(dpte3(k
,j
,i
)%i2(1+mod(i
,5)), &
2732 dtarg3(k
,j
,i
)%i2(1+mod(i
,5)))) then
2734 errors(313) = .true
.
2737 dtarg3(k
,j
,i
)%i2(1+mod(i
,5))=2*dpte3(k
,j
,i
)%i2(1+mod(i
,5))
2738 if (intne(dpte3(k
,j
,i
)%i2(1+mod(i
,5)), &
2739 dtarg3(k
,j
,i
)%i2(1+mod(i
,5)))) then
2741 errors(314) = .true
.
2745 if (intne(ipte3(k
,j
,i
), itarg3(k
,j
,i
))) then
2747 errors(315) = .true
.
2750 itarg3(k
,j
,i
) = -ipte3(k
,j
,i
)
2751 if (intne(ipte3(k
,j
,i
), itarg3(k
,j
,i
))) then
2753 errors(316) = .true
.
2756 rpte3(k
,j
,i
) = i
* 2.0
2757 if (realne(rpte3(k
,j
,i
), rtarg3(k
,j
,i
))) then
2759 errors(317) = .true
.
2762 rtarg3(k
,j
,i
) = i
* 3.0
2763 if (realne(rpte3(k
,j
,i
), rtarg3(k
,j
,i
))) then
2765 errors(318) = .true
.
2769 if (chne(chpte3(k
,j
,i
), chtarg3(k
,j
,i
))) then
2771 errors(319) = .true
.
2774 chtarg3(k
,j
,i
) = 'z'
2775 if (chne(chpte3(k
,j
,i
), chtarg3(k
,j
,i
))) then
2777 errors(320) = .true
.
2780 ch8pte3(k
,j
,i
) = 'aaaaaaaa'
2781 if (ch8ne(ch8pte3(k
,j
,i
), ch8targ3(k
,j
,i
))) then
2783 errors(321) = .true
.
2786 ch8targ3(k
,j
,i
) = 'zzzzzzzz'
2787 if (ch8ne(ch8pte3(k
,j
,i
), ch8targ3(k
,j
,i
))) then
2789 errors(322) = .true
.
2802 if (intne(itarg3(k
,j
,i
), i
)) then
2804 errors(323) = .true
.
2807 if (realne(rtarg3(k
,j
,i
), i
+.5)) then
2809 errors(324) = .true
.
2814 end subroutine ptr10
2816 subroutine ptr11(nnn
,mmm
,ooo
)
2817 common /errors
/errors(400)
2818 logical :: errors
, intne
, realne
, chne
, ch8ne
2820 integer :: nnn
,mmm
,ooo
2821 integer, parameter :: n
= 9
2822 integer, parameter :: m
= 10
2823 integer, parameter :: o
= 11
2825 integer itarg2 (m
,n
)
2826 integer itarg3 (o
,m
,n
)
2830 character chtarg1(n
)
2831 character chtarg2(m
,n
)
2832 character chtarg3(o
,m
,n
)
2833 character*8 ch8targ1(n
)
2834 character*8 ch8targ2(m
,n
)
2835 character*8 ch8targ3(o
,m
,n
)
2841 type(drvd
) dtarg1(n
)
2842 type(drvd
) dtarg2(m
,n
)
2843 type(drvd
) dtarg3(o
,m
,n
)
2845 pointer(iptr1
,dpte1(nnn
))
2846 pointer(iptr2
,dpte2(mmm
,nnn
))
2847 pointer(iptr3
,dpte3(ooo
,mmm
,nnn
))
2848 pointer(iptr4
,ipte1(nnn
))
2849 pointer(iptr5
,ipte2 (mmm
,nnn
))
2850 pointer(iptr6
,ipte3(ooo
,mmm
,nnn
))
2851 pointer(iptr7
,rpte1(nnn
))
2852 pointer(iptr8
,rpte2(mmm
,nnn
))
2853 pointer(iptr9
,rpte3(ooo
,mmm
,nnn
))
2854 pointer(iptr10
,chpte1(nnn
))
2855 pointer(iptr11
,chpte2(mmm
,nnn
))
2856 pointer(iptr12
,chpte3(ooo
,mmm
,nnn
))
2857 pointer(iptr13
,ch8pte1(nnn
))
2858 pointer(iptr14
,ch8pte2(mmm
,nnn
))
2859 pointer(iptr15
,ch8pte3(ooo
,mmm
,nnn
))
2886 iptr10
= loc(chtarg1
)
2887 iptr11
= loc(chtarg2
)
2888 iptr12
= loc(chtarg3
)
2889 iptr13
= loc(ch8targ1
)
2890 iptr14
= loc(ch8targ2
)
2891 iptr15
= loc(ch8targ3
)
2895 if (intne(dpte1(i
)%i1
, dtarg1(i
)%i1
)) then
2897 errors(325) = .true
.
2900 dtarg1(i
)%i1
=2*dpte1(i
)%i1
2901 if (intne(dpte1(i
)%i1
, dtarg1(i
)%i1
)) then
2903 errors(326) = .true
.
2907 if (intne(ipte1(i
), itarg1(i
))) then
2909 errors(327) = .true
.
2912 itarg1(i
) = -ipte1(i
)
2913 if (intne(ipte1(i
), itarg1(i
))) then
2915 errors(328) = .true
.
2919 if (realne(rpte1(i
), rtarg1(i
))) then
2921 errors(329) = .true
.
2924 rtarg1(i
) = i
* (-5.0)
2925 if (realne(rpte1(i
), rtarg1(i
))) then
2927 errors(330) = .true
.
2931 if (chne(chpte1(i
), chtarg1(i
))) then
2933 errors(331) = .true
.
2937 if (chne(chpte1(i
), chtarg1(i
))) then
2939 errors(332) = .true
.
2942 ch8pte1(i
) = 'aaaaaaaa'
2943 if (ch8ne(ch8pte1(i
), ch8targ1(i
))) then
2945 errors(333) = .true
.
2948 ch8targ1(i
) = 'zzzzzzzz'
2949 if (ch8ne(ch8pte1(i
), ch8targ1(i
))) then
2951 errors(334) = .true
.
2956 if (realne(dpte2(j
,i
)%r1
, dtarg2(j
,i
)%r1
)) then
2958 errors(335) = .true
.
2961 dtarg2(j
,i
)%r1
=2*dpte2(j
,i
)%r1
2962 if (realne(dpte2(j
,i
)%r1
, dtarg2(j
,i
)%r1
)) then
2964 errors(336) = .true
.
2968 if (intne(ipte2(j
,i
), itarg2(j
,i
))) then
2970 errors(337) = .true
.
2973 itarg2(j
,i
) = -ipte2(j
,i
)
2974 if (intne(ipte2(j
,i
), itarg2(j
,i
))) then
2976 errors(338) = .true
.
2979 rpte2(j
,i
) = i
* (-2.0)
2980 if (realne(rpte2(j
,i
), rtarg2(j
,i
))) then
2982 errors(339) = .true
.
2985 rtarg2(j
,i
) = i
* (-3.0)
2986 if (realne(rpte2(j
,i
), rtarg2(j
,i
))) then
2988 errors(340) = .true
.
2992 if (chne(chpte2(j
,i
), chtarg2(j
,i
))) then
2994 errors(341) = .true
.
2998 if (chne(chpte2(j
,i
), chtarg2(j
,i
))) then
3000 errors(342) = .true
.
3003 ch8pte2(j
,i
) = 'aaaaaaaa'
3004 if (ch8ne(ch8pte2(j
,i
), ch8targ2(j
,i
))) then
3006 errors(343) = .true
.
3009 ch8targ2(j
,i
) = 'zzzzzzzz'
3010 if (ch8ne(ch8pte2(j
,i
), ch8targ2(j
,i
))) then
3012 errors(344) = .true
.
3015 dpte3(k
,j
,i
)%i2(1+mod(i
,5))=i
3016 if (intne(dpte3(k
,j
,i
)%i2(1+mod(i
,5)), &
3017 dtarg3(k
,j
,i
)%i2(1+mod(i
,5)))) then
3019 errors(345) = .true
.
3022 dtarg3(k
,j
,i
)%i2(1+mod(i
,5))=2*dpte3(k
,j
,i
)%i2(1+mod(i
,5))
3023 if (intne(dpte3(k
,j
,i
)%i2(1+mod(i
,5)), &
3024 dtarg3(k
,j
,i
)%i2(1+mod(i
,5)))) then
3026 errors(346) = .true
.
3030 if (intne(ipte3(k
,j
,i
), itarg3(k
,j
,i
))) then
3032 errors(347) = .true
.
3035 itarg3(k
,j
,i
) = -ipte3(k
,j
,i
)
3036 if (intne(ipte3(k
,j
,i
), itarg3(k
,j
,i
))) then
3038 errors(348) = .true
.
3041 rpte3(k
,j
,i
) = i
* 2.0
3042 if (realne(rpte3(k
,j
,i
), rtarg3(k
,j
,i
))) then
3044 errors(349) = .true
.
3047 rtarg3(k
,j
,i
) = i
* 3.0
3048 if (realne(rpte3(k
,j
,i
), rtarg3(k
,j
,i
))) then
3050 errors(350) = .true
.
3054 if (chne(chpte3(k
,j
,i
), chtarg3(k
,j
,i
))) then
3056 errors(351) = .true
.
3059 chtarg3(k
,j
,i
) = 'z'
3060 if (chne(chpte3(k
,j
,i
), chtarg3(k
,j
,i
))) then
3062 errors(352) = .true
.
3065 ch8pte3(k
,j
,i
) = 'aaaaaaaa'
3066 if (ch8ne(ch8pte3(k
,j
,i
), ch8targ3(k
,j
,i
))) then
3068 errors(353) = .true
.
3071 ch8targ3(k
,j
,i
) = 'zzzzzzzz'
3072 if (ch8ne(ch8pte3(k
,j
,i
), ch8targ3(k
,j
,i
))) then
3074 errors(354) = .true
.
3087 if (intne(itarg3(k
,j
,i
), i
)) then
3089 errors(355) = .true
.
3092 if (realne(rtarg3(k
,j
,i
), i
+.5)) then
3094 errors(356) = .true
.
3099 end subroutine ptr11
3101 subroutine ptr12(nnn
,mmm
,ooo
)
3102 common /errors
/errors(400)
3103 logical :: errors
, intne
, realne
, chne
, ch8ne
3105 integer :: nnn
,mmm
,ooo
3106 integer, parameter :: n
= 9
3107 integer, parameter :: m
= 10
3108 integer, parameter :: o
= 11
3110 integer itarg2 (m
,n
)
3111 integer itarg3 (o
,m
,n
)
3115 character chtarg1(n
)
3116 character chtarg2(m
,n
)
3117 character chtarg3(o
,m
,n
)
3118 character*8 ch8targ1(n
)
3119 character*8 ch8targ2(m
,n
)
3120 character*8 ch8targ3(o
,m
,n
)
3126 type(drvd
) dtarg1(n
)
3127 type(drvd
) dtarg2(m
,n
)
3128 type(drvd
) dtarg3(o
,m
,n
)
3130 pointer(iptr1
,dpte1
)
3131 pointer(iptr2
,dpte2
)
3132 pointer(iptr3
,dpte3
)
3133 pointer(iptr4
,ipte1
)
3134 pointer(iptr5
,ipte2
)
3135 pointer(iptr6
,ipte3
)
3136 pointer(iptr7
,rpte1
)
3137 pointer(iptr8
,rpte2
)
3138 pointer(iptr9
,rpte3
)
3139 pointer(iptr10
,chpte1
)
3140 pointer(iptr11
,chpte2
)
3141 pointer(iptr12
,chpte3
)
3142 pointer(iptr13
,ch8pte1
)
3143 pointer(iptr14
,ch8pte2
)
3144 pointer(iptr15
,ch8pte3
)
3146 type(drvd
) dpte1(nnn
)
3147 type(drvd
) dpte2(mmm
,nnn
)
3148 type(drvd
) dpte3(ooo
,mmm
,nnn
)
3150 integer ipte2 (mmm
,nnn
)
3151 integer ipte3 (ooo
,mmm
,nnn
)
3154 real rpte3(ooo
,mmm
,nnn
)
3155 character chpte1(nnn
)
3156 character chpte2(mmm
,nnn
)
3157 character chpte3(ooo
,mmm
,nnn
)
3158 character*8 ch8pte1(nnn
)
3159 character*8 ch8pte2(mmm
,nnn
)
3160 character*8 ch8pte3(ooo
,mmm
,nnn
)
3171 iptr10
= loc(chtarg1
)
3172 iptr11
= loc(chtarg2
)
3173 iptr12
= loc(chtarg3
)
3174 iptr13
= loc(ch8targ1
)
3175 iptr14
= loc(ch8targ2
)
3176 iptr15
= loc(ch8targ3
)
3181 if (intne(dpte1(i
)%i1
, dtarg1(i
)%i1
)) then
3183 errors(357) = .true
.
3186 dtarg1(i
)%i1
=2*dpte1(i
)%i1
3187 if (intne(dpte1(i
)%i1
, dtarg1(i
)%i1
)) then
3189 errors(358) = .true
.
3193 if (intne(ipte1(i
), itarg1(i
))) then
3195 errors(359) = .true
.
3198 itarg1(i
) = -ipte1(i
)
3199 if (intne(ipte1(i
), itarg1(i
))) then
3201 errors(360) = .true
.
3205 if (realne(rpte1(i
), rtarg1(i
))) then
3207 errors(361) = .true
.
3210 rtarg1(i
) = i
* (-5.0)
3211 if (realne(rpte1(i
), rtarg1(i
))) then
3213 errors(362) = .true
.
3217 if (chne(chpte1(i
), chtarg1(i
))) then
3219 errors(363) = .true
.
3223 if (chne(chpte1(i
), chtarg1(i
))) then
3225 errors(364) = .true
.
3228 ch8pte1(i
) = 'aaaaaaaa'
3229 if (ch8ne(ch8pte1(i
), ch8targ1(i
))) then
3231 errors(365) = .true
.
3234 ch8targ1(i
) = 'zzzzzzzz'
3235 if (ch8ne(ch8pte1(i
), ch8targ1(i
))) then
3237 errors(366) = .true
.
3242 if (realne(dpte2(j
,i
)%r1
, dtarg2(j
,i
)%r1
)) then
3244 errors(367) = .true
.
3247 dtarg2(j
,i
)%r1
=2*dpte2(j
,i
)%r1
3248 if (realne(dpte2(j
,i
)%r1
, dtarg2(j
,i
)%r1
)) then
3250 errors(368) = .true
.
3254 if (intne(ipte2(j
,i
), itarg2(j
,i
))) then
3256 errors(369) = .true
.
3259 itarg2(j
,i
) = -ipte2(j
,i
)
3260 if (intne(ipte2(j
,i
), itarg2(j
,i
))) then
3262 errors(370) = .true
.
3265 rpte2(j
,i
) = i
* (-2.0)
3266 if (realne(rpte2(j
,i
), rtarg2(j
,i
))) then
3268 errors(371) = .true
.
3271 rtarg2(j
,i
) = i
* (-3.0)
3272 if (realne(rpte2(j
,i
), rtarg2(j
,i
))) then
3274 errors(372) = .true
.
3278 if (chne(chpte2(j
,i
), chtarg2(j
,i
))) then
3280 errors(373) = .true
.
3284 if (chne(chpte2(j
,i
), chtarg2(j
,i
))) then
3286 errors(374) = .true
.
3289 ch8pte2(j
,i
) = 'aaaaaaaa'
3290 if (ch8ne(ch8pte2(j
,i
), ch8targ2(j
,i
))) then
3292 errors(375) = .true
.
3295 ch8targ2(j
,i
) = 'zzzzzzzz'
3296 if (ch8ne(ch8pte2(j
,i
), ch8targ2(j
,i
))) then
3298 errors(376) = .true
.
3301 dpte3(k
,j
,i
)%i2(1+mod(i
,5))=i
3302 if (intne(dpte3(k
,j
,i
)%i2(1+mod(i
,5)), &
3303 dtarg3(k
,j
,i
)%i2(1+mod(i
,5)))) then
3305 errors(377) = .true
.
3308 dtarg3(k
,j
,i
)%i2(1+mod(i
,5))=2*dpte3(k
,j
,i
)%i2(1+mod(i
,5))
3309 if (intne(dpte3(k
,j
,i
)%i2(1+mod(i
,5)), &
3310 dtarg3(k
,j
,i
)%i2(1+mod(i
,5)))) then
3312 errors(378) = .true
.
3316 if (intne(ipte3(k
,j
,i
), itarg3(k
,j
,i
))) then
3318 errors(379) = .true
.
3321 itarg3(k
,j
,i
) = -ipte3(k
,j
,i
)
3322 if (intne(ipte3(k
,j
,i
), itarg3(k
,j
,i
))) then
3324 errors(380) = .true
.
3327 rpte3(k
,j
,i
) = i
* 2.0
3328 if (realne(rpte3(k
,j
,i
), rtarg3(k
,j
,i
))) then
3330 errors(381) = .true
.
3333 rtarg3(k
,j
,i
) = i
* 3.0
3334 if (realne(rpte3(k
,j
,i
), rtarg3(k
,j
,i
))) then
3336 errors(382) = .true
.
3340 if (chne(chpte3(k
,j
,i
), chtarg3(k
,j
,i
))) then
3342 errors(383) = .true
.
3345 chtarg3(k
,j
,i
) = 'z'
3346 if (chne(chpte3(k
,j
,i
), chtarg3(k
,j
,i
))) then
3348 errors(384) = .true
.
3351 ch8pte3(k
,j
,i
) = 'aaaaaaaa'
3352 if (ch8ne(ch8pte3(k
,j
,i
), ch8targ3(k
,j
,i
))) then
3354 errors(385) = .true
.
3357 ch8targ3(k
,j
,i
) = 'zzzzzzzz'
3358 if (ch8ne(ch8pte3(k
,j
,i
), ch8targ3(k
,j
,i
))) then
3360 errors(386) = .true
.
3373 if (intne(itarg3(k
,j
,i
), i
)) then
3375 errors(387) = .true
.
3378 if (realne(rtarg3(k
,j
,i
), i
+.5)) then
3380 errors(388) = .true
.
3386 end subroutine ptr12
3389 subroutine ptr13(nnn
,mmm
)
3390 common /errors
/errors(400)
3391 logical :: errors
, intne
, realne
, chne
, ch8ne
3394 integer, parameter :: n
= 9
3395 integer, parameter :: m
= 10
3397 integer itarg2 (m
,n
)
3407 dimension rpte2(mmm
,nnn
)
3409 pointer(iptr4
,ipte1
)
3410 pointer(iptr5
,ipte2
)
3411 pointer(iptr7
,rpte1
)
3412 pointer(iptr8
,rpte2
)
3414 dimension ipte2(mmm
,nnn
)
3424 if (intne(ipte1(i
), itarg1(i
))) then
3426 errors(389) = .true
.
3429 itarg1(i
) = -ipte1(i
)
3430 if (intne(ipte1(i
), itarg1(i
))) then
3432 errors(390) = .true
.
3436 if (realne(rpte1(i
), rtarg1(i
))) then
3438 errors(391) = .true
.
3441 rtarg1(i
) = i
* (-5.0)
3442 if (realne(rpte1(i
), rtarg1(i
))) then
3444 errors(392) = .true
.
3449 if (intne(ipte2(j
,i
), itarg2(j
,i
))) then
3451 errors(393) = .true
.
3454 itarg2(j
,i
) = -ipte2(j
,i
)
3455 if (intne(ipte2(j
,i
), itarg2(j
,i
))) then
3457 errors(394) = .true
.
3460 rpte2(j
,i
) = i
* (-2.0)
3461 if (realne(rpte2(j
,i
), rtarg2(j
,i
))) then
3463 errors(395) = .true
.
3466 rtarg2(j
,i
) = i
* (-3.0)
3467 if (realne(rpte2(j
,i
), rtarg2(j
,i
))) then
3469 errors(396) = .true
.
3474 end subroutine ptr13
3477 ! Test the passing of pointers and pointees as parameters
3479 integer, parameter :: n
= 12
3480 integer, parameter :: m
= 13
3486 ! write(*,*) "loc(iarray)",loc(iarray)
3487 call parmptr(ipt
,iarray
,n
,m
)
3488 ! write(*,*) "loc(iptee)",loc(iptee)
3489 call parmpte(iptee
,iarray
,n
,m
)
3490 end subroutine parmtest
3492 subroutine parmptr(ipointer
,intarr
,n
,m
)
3493 common /errors
/errors(400)
3494 logical :: errors
, intne
3497 pointer (ipointer
,newpte
)
3499 ! write(*,*) "loc(newpte)",loc(newpte)
3500 ! write(*,*) "loc(intarr)",loc(intarr)
3501 ! write(*,*) "loc(newpte(1,1))",loc(newpte(1,1))
3503 ! write(*,*) "newpte(1,1)=",newpte(1,1)
3504 ! write(*,*) "intarr(1,1)=",intarr(1,1)
3508 if (intne(newpte(j
,i
),intarr(j
,i
))) then
3510 errors(397) = .true
.
3513 call donothing(newpte(j
,i
),intarr(j
,i
))
3514 intarr(j
,i
) = -newpte(j
,i
)
3515 if (intne(newpte(j
,i
),intarr(j
,i
))) then
3517 errors(398) = .true
.
3521 end subroutine parmptr
3523 subroutine parmpte(pointee
,intarr
,n
,m
)
3524 common /errors
/errors(400)
3525 logical :: errors
, intne
3527 integer pointee (m
,n
)
3528 integer intarr (m
,n
)
3529 ! write(*,*) "loc(pointee)",loc(pointee)
3530 ! write(*,*) "loc(intarr)",loc(intarr)
3531 ! write(*,*) "loc(pointee(1,1))",loc(pointee(1,1))
3533 ! write(*,*) "pointee(1,1)=",pointee(1,1)
3534 ! write(*,*) "intarr(1,1)=",intarr(1,1)
3539 if (intne(pointee(j
,i
),intarr(j
,i
))) then
3541 errors(399) = .true
.
3544 intarr(j
,i
) = 2*pointee(j
,i
)
3545 call donothing(pointee(j
,i
),intarr(j
,i
))
3546 if (intne(pointee(j
,i
),intarr(j
,i
))) then
3548 errors(400) = .true
.
3552 end subroutine parmpte
3554 ! Separate function calls to break Cray pointer-indifferent optimization
3555 logical function intne(ii
,jj
)
3562 write (*,*) ii
," doesn't equal ",jj
3566 logical function realne(r1
,r2
)
3573 write (*,*) r1
," doesn't equal ",r2
3577 logical function chne(ch1
,ch2
)
3578 character :: ch1
, ch2
3584 write (*,*) ch1
," doesn't equal ",ch2
3588 logical function ch8ne(ch1
,ch2
)
3589 character*8 :: ch1
, ch2
3595 write (*,*) ch1
," doesn't equal ",ch2
3599 subroutine donothing(ii
,jj
)
3601 integer :: ii
,jj
,foo
3610 ! print *,"Test did not run correctly"
3613 end subroutine donothing