2 ! { dg-options "-fcray-pointer -fbounds-check" }
3 ! Series of routines for testing a Cray pointer implementation
5 common /errors
/errors(400)
6 common /foo
/foo
! To prevent optimizations
26 ! NOTE: Tests 1 through 12 were removed from this file
27 ! and placed in loc_1.f90, so we start at 13
30 ! print *,"Test",i,"failed."
35 ! print *,"Test did not run correctly."
40 ! ptr1 through ptr13 that Cray pointees are correctly used with
41 ! a variety of declaration styles
43 common /errors
/errors(400)
44 logical :: errors
, intne
, realne
, chne
, ch8ne
46 integer, parameter :: n
= 9
47 integer, parameter :: m
= 10
48 integer, parameter :: o
= 11
51 integer itarg3 (o
,m
,n
)
56 character chtarg2(m
,n
)
57 character chtarg3(o
,m
,n
)
58 character*8 ch8targ1(n
)
59 character*8 ch8targ2(m
,n
)
60 character*8 ch8targ3(o
,m
,n
)
67 type(drvd
) dtarg2(m
,n
)
68 type(drvd
) dtarg3(o
,m
,n
)
72 type(drvd
) dpte3(o
,m
,n
)
81 character chpte3(o
,m
,n
)
82 character*8 ch8pte1(n
)
83 character*8 ch8pte2(m
,n
)
84 character*8 ch8pte3(o
,m
,n
)
95 pointer(iptr10
,chpte1
)
96 pointer(iptr11
,chpte2
)
97 pointer(iptr12
,chpte3
)
98 pointer(iptr13
,ch8pte1
)
99 pointer(iptr14
,ch8pte2
)
100 pointer(iptr15
,ch8pte3
)
114 iptr13
= loc(ch8targ1
)
115 iptr14
= loc(ch8targ2
)
116 iptr15
= loc(ch8targ3
)
121 if (intne(dpte1(i
)%i1
, dtarg1(i
)%i1
)) then
126 dtarg1(i
)%i1
=2*dpte1(i
)%i1
127 if (intne(dpte1(i
)%i1
, dtarg1(i
)%i1
)) then
133 if (intne(ipte1(i
), itarg1(i
))) then
138 itarg1(i
) = -ipte1(i
)
139 if (intne(ipte1(i
), itarg1(i
))) then
145 if (realne(rpte1(i
), rtarg1(i
))) then
150 rtarg1(i
) = i
* (-5.0)
151 if (realne(rpte1(i
), rtarg1(i
))) then
157 if (chne(chpte1(i
), chtarg1(i
))) then
163 if (chne(chpte1(i
), chtarg1(i
))) then
168 ch8pte1(i
) = 'aaaaaaaa'
169 if (ch8ne(ch8pte1(i
), ch8targ1(i
))) then
174 ch8targ1(i
) = 'zzzzzzzz'
175 if (ch8ne(ch8pte1(i
), ch8targ1(i
))) then
182 if (realne(dpte2(j
,i
)%r1
, dtarg2(j
,i
)%r1
)) then
187 dtarg2(j
,i
)%r1
=2*dpte2(j
,i
)%r1
188 if (realne(dpte2(j
,i
)%r1
, dtarg2(j
,i
)%r1
)) then
194 if (intne(ipte2(j
,i
), itarg2(j
,i
))) then
199 itarg2(j
,i
) = -ipte2(j
,i
)
200 if (intne(ipte2(j
,i
), itarg2(j
,i
))) then
205 rpte2(j
,i
) = i
* (-2.0)
206 if (realne(rpte2(j
,i
), rtarg2(j
,i
))) then
211 rtarg2(j
,i
) = i
* (-3.0)
212 if (realne(rpte2(j
,i
), rtarg2(j
,i
))) then
218 if (chne(chpte2(j
,i
), chtarg2(j
,i
))) then
224 if (chne(chpte2(j
,i
), chtarg2(j
,i
))) then
229 ch8pte2(j
,i
) = 'aaaaaaaa'
230 if (ch8ne(ch8pte2(j
,i
), ch8targ2(j
,i
))) then
235 ch8targ2(j
,i
) = 'zzzzzzzz'
236 if (ch8ne(ch8pte2(j
,i
), ch8targ2(j
,i
))) then
241 dpte3(k
,j
,i
)%i2(1+mod(i
,5))=i
242 if (intne(dpte3(k
,j
,i
)%i2(1+mod(i
,5)), &
243 dtarg3(k
,j
,i
)%i2(1+mod(i
,5)))) then
248 dtarg3(k
,j
,i
)%i2(1+mod(i
,5))=2*dpte3(k
,j
,i
)%i2(1+mod(i
,5))
249 if (intne(dpte3(k
,j
,i
)%i2(1+mod(i
,5)), &
250 dtarg3(k
,j
,i
)%i2(1+mod(i
,5)))) then
256 if (intne(ipte3(k
,j
,i
), itarg3(k
,j
,i
))) then
261 itarg3(k
,j
,i
) = -ipte3(k
,j
,i
)
262 if (intne(ipte3(k
,j
,i
), itarg3(k
,j
,i
))) then
267 rpte3(k
,j
,i
) = i
* 2.0
268 if (realne(rpte3(k
,j
,i
), rtarg3(k
,j
,i
))) then
273 rtarg3(k
,j
,i
) = i
* 3.0
274 if (realne(rpte3(k
,j
,i
), rtarg3(k
,j
,i
))) then
280 if (chne(chpte3(k
,j
,i
), chtarg3(k
,j
,i
))) then
286 if (chne(chpte3(k
,j
,i
), chtarg3(k
,j
,i
))) then
291 ch8pte3(k
,j
,i
) = 'aaaaaaaa'
292 if (ch8ne(ch8pte3(k
,j
,i
), ch8targ3(k
,j
,i
))) then
297 ch8targ3(k
,j
,i
) = 'zzzzzzzz'
298 if (ch8ne(ch8pte3(k
,j
,i
), ch8targ3(k
,j
,i
))) then
313 if (intne(itarg3(k
,j
,i
), i
)) then
318 if (realne(rtarg3(k
,j
,i
), i
+.5)) then
330 common /errors
/errors(400)
331 logical :: errors
, intne
, realne
, chne
, ch8ne
333 integer, parameter :: n
= 9
334 integer, parameter :: m
= 10
335 integer, parameter :: o
= 11
338 integer itarg3 (o
,m
,n
)
343 character chtarg2(m
,n
)
344 character chtarg3(o
,m
,n
)
345 character*8 ch8targ1(n
)
346 character*8 ch8targ2(m
,n
)
347 character*8 ch8targ3(o
,m
,n
)
354 type(drvd
) dtarg2(m
,n
)
355 type(drvd
) dtarg3(o
,m
,n
)
373 pointer(iptr1
,dpte1(n
))
374 pointer(iptr2
,dpte2(m
,n
))
375 pointer(iptr3
,dpte3(o
,m
,n
))
376 pointer(iptr4
,ipte1(n
))
377 pointer(iptr5
,ipte2 (m
,n
))
378 pointer(iptr6
,ipte3(o
,m
,n
))
379 pointer(iptr7
,rpte1(n
))
380 pointer(iptr8
,rpte2(m
,n
))
381 pointer(iptr9
,rpte3(o
,m
,n
))
382 pointer(iptr10
,chpte1(n
))
383 pointer(iptr11
,chpte2(m
,n
))
384 pointer(iptr12
,chpte3(o
,m
,n
))
385 pointer(iptr13
,ch8pte1(n
))
386 pointer(iptr14
,ch8pte2(m
,n
))
387 pointer(iptr15
,ch8pte3(o
,m
,n
))
401 iptr13
= loc(ch8targ1
)
402 iptr14
= loc(ch8targ2
)
403 iptr15
= loc(ch8targ3
)
407 if (intne(dpte1(i
)%i1
, dtarg1(i
)%i1
)) then
412 dtarg1(i
)%i1
=2*dpte1(i
)%i1
413 if (intne(dpte1(i
)%i1
, dtarg1(i
)%i1
)) then
419 if (intne(ipte1(i
), itarg1(i
))) then
424 itarg1(i
) = -ipte1(i
)
425 if (intne(ipte1(i
), itarg1(i
))) then
431 if (realne(rpte1(i
), rtarg1(i
))) then
436 rtarg1(i
) = i
* (-5.0)
437 if (realne(rpte1(i
), rtarg1(i
))) then
443 if (chne(chpte1(i
), chtarg1(i
))) then
449 if (chne(chpte1(i
), chtarg1(i
))) then
454 ch8pte1(i
) = 'aaaaaaaa'
455 if (ch8ne(ch8pte1(i
), ch8targ1(i
))) then
460 ch8targ1(i
) = 'zzzzzzzz'
461 if (ch8ne(ch8pte1(i
), ch8targ1(i
))) then
468 if (realne(dpte2(j
,i
)%r1
, dtarg2(j
,i
)%r1
)) then
473 dtarg2(j
,i
)%r1
=2*dpte2(j
,i
)%r1
474 if (realne(dpte2(j
,i
)%r1
, dtarg2(j
,i
)%r1
)) then
480 if (intne(ipte2(j
,i
), itarg2(j
,i
))) then
485 itarg2(j
,i
) = -ipte2(j
,i
)
486 if (intne(ipte2(j
,i
), itarg2(j
,i
))) then
491 rpte2(j
,i
) = i
* (-2.0)
492 if (realne(rpte2(j
,i
), rtarg2(j
,i
))) then
497 rtarg2(j
,i
) = i
* (-3.0)
498 if (realne(rpte2(j
,i
), rtarg2(j
,i
))) then
504 if (chne(chpte2(j
,i
), chtarg2(j
,i
))) then
510 if (chne(chpte2(j
,i
), chtarg2(j
,i
))) then
515 ch8pte2(j
,i
) = 'aaaaaaaa'
516 if (ch8ne(ch8pte2(j
,i
), ch8targ2(j
,i
))) then
521 ch8targ2(j
,i
) = 'zzzzzzzz'
522 if (ch8ne(ch8pte2(j
,i
), ch8targ2(j
,i
))) then
527 dpte3(k
,j
,i
)%i2(1+mod(i
,5))=i
528 if (intne(dpte3(k
,j
,i
)%i2(1+mod(i
,5)), dtarg3(k
,j
,i
)%i2(1+mod(i
,5)))) then
533 dtarg3(k
,j
,i
)%i2(1+mod(i
,5))=2*dpte3(k
,j
,i
)%i2(1+mod(i
,5))
534 if (intne(dpte3(k
,j
,i
)%i2(1+mod(i
,5)), dtarg3(k
,j
,i
)%i2(1+mod(i
,5)))) then
540 if (intne(ipte3(k
,j
,i
), itarg3(k
,j
,i
))) then
545 itarg3(k
,j
,i
) = -ipte3(k
,j
,i
)
546 if (intne(ipte3(k
,j
,i
), itarg3(k
,j
,i
))) then
551 rpte3(k
,j
,i
) = i
* 2.0
552 if (realne(rpte3(k
,j
,i
), rtarg3(k
,j
,i
))) then
557 rtarg3(k
,j
,i
) = i
* 3.0
558 if (realne(rpte3(k
,j
,i
), rtarg3(k
,j
,i
))) then
564 if (chne(chpte3(k
,j
,i
), chtarg3(k
,j
,i
))) then
570 if (chne(chpte3(k
,j
,i
), chtarg3(k
,j
,i
))) then
575 ch8pte3(k
,j
,i
) = 'aaaaaaaa'
576 if (ch8ne(ch8pte3(k
,j
,i
), ch8targ3(k
,j
,i
))) then
581 ch8targ3(k
,j
,i
) = 'zzzzzzzz'
582 if (ch8ne(ch8pte3(k
,j
,i
), ch8targ3(k
,j
,i
))) then
597 if (intne(itarg3(k
,j
,i
), i
)) then
602 if (realne(rtarg3(k
,j
,i
), i
+.5)) then
612 common /errors
/errors(400)
613 logical :: errors
, intne
, realne
, chne
, ch8ne
615 integer, parameter :: n
= 9
616 integer, parameter :: m
= 10
617 integer, parameter :: o
= 11
620 integer itarg3 (o
,m
,n
)
625 character chtarg2(m
,n
)
626 character chtarg3(o
,m
,n
)
627 character*8 ch8targ1(n
)
628 character*8 ch8targ2(m
,n
)
629 character*8 ch8targ3(o
,m
,n
)
636 type(drvd
) dtarg2(m
,n
)
637 type(drvd
) dtarg3(o
,m
,n
)
639 pointer(iptr1
,dpte1(n
))
640 pointer(iptr2
,dpte2(m
,n
))
641 pointer(iptr3
,dpte3(o
,m
,n
))
642 pointer(iptr4
,ipte1(n
))
643 pointer(iptr5
,ipte2 (m
,n
))
644 pointer(iptr6
,ipte3(o
,m
,n
))
645 pointer(iptr7
,rpte1(n
))
646 pointer(iptr8
,rpte2(m
,n
))
647 pointer(iptr9
,rpte3(o
,m
,n
))
648 pointer(iptr10
,chpte1(n
))
649 pointer(iptr11
,chpte2(m
,n
))
650 pointer(iptr12
,chpte3(o
,m
,n
))
651 pointer(iptr13
,ch8pte1(n
))
652 pointer(iptr14
,ch8pte2(m
,n
))
653 pointer(iptr15
,ch8pte3(o
,m
,n
))
683 iptr13
= loc(ch8targ1
)
684 iptr14
= loc(ch8targ2
)
685 iptr15
= loc(ch8targ3
)
689 if (intne(dpte1(i
)%i1
, dtarg1(i
)%i1
)) then
694 dtarg1(i
)%i1
=2*dpte1(i
)%i1
695 if (intne(dpte1(i
)%i1
, dtarg1(i
)%i1
)) then
701 if (intne(ipte1(i
), itarg1(i
))) then
706 itarg1(i
) = -ipte1(i
)
707 if (intne(ipte1(i
), itarg1(i
))) then
713 if (realne(rpte1(i
), rtarg1(i
))) then
718 rtarg1(i
) = i
* (-5.0)
719 if (realne(rpte1(i
), rtarg1(i
))) then
725 if (chne(chpte1(i
), chtarg1(i
))) then
731 if (chne(chpte1(i
), chtarg1(i
))) then
736 ch8pte1(i
) = 'aaaaaaaa'
737 if (ch8ne(ch8pte1(i
), ch8targ1(i
))) then
742 ch8targ1(i
) = 'zzzzzzzz'
743 if (ch8ne(ch8pte1(i
), ch8targ1(i
))) then
750 if (realne(dpte2(j
,i
)%r1
, dtarg2(j
,i
)%r1
)) then
755 dtarg2(j
,i
)%r1
=2*dpte2(j
,i
)%r1
756 if (realne(dpte2(j
,i
)%r1
, dtarg2(j
,i
)%r1
)) then
762 if (intne(ipte2(j
,i
), itarg2(j
,i
))) then
767 itarg2(j
,i
) = -ipte2(j
,i
)
768 if (intne(ipte2(j
,i
), itarg2(j
,i
))) then
773 rpte2(j
,i
) = i
* (-2.0)
774 if (realne(rpte2(j
,i
), rtarg2(j
,i
))) then
779 rtarg2(j
,i
) = i
* (-3.0)
780 if (realne(rpte2(j
,i
), rtarg2(j
,i
))) then
786 if (chne(chpte2(j
,i
), chtarg2(j
,i
))) then
792 if (chne(chpte2(j
,i
), chtarg2(j
,i
))) then
797 ch8pte2(j
,i
) = 'aaaaaaaa'
798 if (ch8ne(ch8pte2(j
,i
), ch8targ2(j
,i
))) then
803 ch8targ2(j
,i
) = 'zzzzzzzz'
804 if (ch8ne(ch8pte2(j
,i
), ch8targ2(j
,i
))) then
809 dpte3(k
,j
,i
)%i2(1+mod(i
,5))=i
810 if (intne(dpte3(k
,j
,i
)%i2(1+mod(i
,5)), &
811 dtarg3(k
,j
,i
)%i2(1+mod(i
,5)))) then
816 dtarg3(k
,j
,i
)%i2(1+mod(i
,5))=2*dpte3(k
,j
,i
)%i2(1+mod(i
,5))
817 if (intne(dpte3(k
,j
,i
)%i2(1+mod(i
,5)), &
818 dtarg3(k
,j
,i
)%i2(1+mod(i
,5)))) then
824 if (intne(ipte3(k
,j
,i
), itarg3(k
,j
,i
))) then
829 itarg3(k
,j
,i
) = -ipte3(k
,j
,i
)
830 if (intne(ipte3(k
,j
,i
), itarg3(k
,j
,i
))) then
835 rpte3(k
,j
,i
) = i
* 2.0
836 if (realne(rpte3(k
,j
,i
), rtarg3(k
,j
,i
))) then
841 rtarg3(k
,j
,i
) = i
* 3.0
842 if (realne(rpte3(k
,j
,i
), rtarg3(k
,j
,i
))) then
848 if (chne(chpte3(k
,j
,i
), chtarg3(k
,j
,i
))) then
854 if (chne(chpte3(k
,j
,i
), chtarg3(k
,j
,i
))) then
859 ch8pte3(k
,j
,i
) = 'aaaaaaaa'
860 if (ch8ne(ch8pte3(k
,j
,i
), ch8targ3(k
,j
,i
))) then
865 ch8targ3(k
,j
,i
) = 'zzzzzzzz'
866 if (ch8ne(ch8pte3(k
,j
,i
), ch8targ3(k
,j
,i
))) then
881 if (intne(itarg3(k
,j
,i
), i
)) then
886 if (realne(rtarg3(k
,j
,i
), i
+.5)) then
896 common /errors
/errors(400)
897 logical :: errors
, intne
, realne
, chne
, ch8ne
899 integer, parameter :: n
= 9
900 integer, parameter :: m
= 10
901 integer, parameter :: o
= 11
904 integer itarg3 (o
,m
,n
)
909 character chtarg2(m
,n
)
910 character chtarg3(o
,m
,n
)
911 character*8 ch8targ1(n
)
912 character*8 ch8targ2(m
,n
)
913 character*8 ch8targ3(o
,m
,n
)
920 type(drvd
) dtarg2(m
,n
)
921 type(drvd
) dtarg3(o
,m
,n
)
923 pointer(iptr1
,dpte1
),(iptr2
,dpte2
),(iptr3
,dpte3
)
924 pointer (iptr4
,ipte1
), (iptr5
,ipte2
) ,(iptr6
,ipte3
),(iptr7
,rpte1
)
926 pointer(iptr9
,rpte3
),(iptr10
,chpte1
)
927 pointer(iptr11
,chpte2
),(iptr12
,chpte3
),(iptr13
,ch8pte1
)
928 pointer(iptr14
,ch8pte2
)
929 pointer(iptr15
,ch8pte3
)
932 type(drvd
) dpte2(m
,n
)
933 type(drvd
) dpte3(o
,m
,n
)
936 integer ipte3 (o
,m
,n
)
941 character chpte2(m
,n
)
942 character chpte3(o
,m
,n
)
943 character*8 ch8pte1(n
)
944 character*8 ch8pte2(m
,n
)
945 character*8 ch8pte3(o
,m
,n
)
959 iptr13
= loc(ch8targ1
)
960 iptr14
= loc(ch8targ2
)
961 iptr15
= loc(ch8targ3
)
966 if (intne(dpte1(i
)%i1
, dtarg1(i
)%i1
)) then
971 dtarg1(i
)%i1
=2*dpte1(i
)%i1
972 if (intne(dpte1(i
)%i1
, dtarg1(i
)%i1
)) then
978 if (intne(ipte1(i
), itarg1(i
))) then
983 itarg1(i
) = -ipte1(i
)
984 if (intne(ipte1(i
), itarg1(i
))) then
990 if (realne(rpte1(i
), rtarg1(i
))) then
995 rtarg1(i
) = i
* (-5.0)
996 if (realne(rpte1(i
), rtarg1(i
))) then
1002 if (chne(chpte1(i
), chtarg1(i
))) then
1004 errors(115) = .true
.
1008 if (chne(chpte1(i
), chtarg1(i
))) then
1010 errors(116) = .true
.
1013 ch8pte1(i
) = 'aaaaaaaa'
1014 if (ch8ne(ch8pte1(i
), ch8targ1(i
))) then
1016 errors(117) = .true
.
1019 ch8targ1(i
) = 'zzzzzzzz'
1020 if (ch8ne(ch8pte1(i
), ch8targ1(i
))) then
1022 errors(118) = .true
.
1027 if (realne(dpte2(j
,i
)%r1
, dtarg2(j
,i
)%r1
)) then
1029 errors(119) = .true
.
1032 dtarg2(j
,i
)%r1
=2*dpte2(j
,i
)%r1
1033 if (realne(dpte2(j
,i
)%r1
, dtarg2(j
,i
)%r1
)) then
1035 errors(120) = .true
.
1039 if (intne(ipte2(j
,i
), itarg2(j
,i
))) then
1041 errors(121) = .true
.
1044 itarg2(j
,i
) = -ipte2(j
,i
)
1045 if (intne(ipte2(j
,i
), itarg2(j
,i
))) then
1047 errors(122) = .true
.
1050 rpte2(j
,i
) = i
* (-2.0)
1051 if (realne(rpte2(j
,i
), rtarg2(j
,i
))) then
1053 errors(123) = .true
.
1056 rtarg2(j
,i
) = i
* (-3.0)
1057 if (realne(rpte2(j
,i
), rtarg2(j
,i
))) then
1059 errors(124) = .true
.
1063 if (chne(chpte2(j
,i
), chtarg2(j
,i
))) then
1065 errors(125) = .true
.
1069 if (chne(chpte2(j
,i
), chtarg2(j
,i
))) then
1071 errors(126) = .true
.
1074 ch8pte2(j
,i
) = 'aaaaaaaa'
1075 if (ch8ne(ch8pte2(j
,i
), ch8targ2(j
,i
))) then
1077 errors(127) = .true
.
1080 ch8targ2(j
,i
) = 'zzzzzzzz'
1081 if (ch8ne(ch8pte2(j
,i
), ch8targ2(j
,i
))) then
1083 errors(128) = .true
.
1086 dpte3(k
,j
,i
)%i2(1+mod(i
,5))=i
1087 if (intne(dpte3(k
,j
,i
)%i2(1+mod(i
,5)), &
1088 dtarg3(k
,j
,i
)%i2(1+mod(i
,5)))) then
1090 errors(129) = .true
.
1093 dtarg3(k
,j
,i
)%i2(1+mod(i
,5))=2*dpte3(k
,j
,i
)%i2(1+mod(i
,5))
1094 if (intne(dpte3(k
,j
,i
)%i2(1+mod(i
,5)), &
1095 dtarg3(k
,j
,i
)%i2(1+mod(i
,5)))) then
1097 errors(130) = .true
.
1101 if (intne(ipte3(k
,j
,i
), itarg3(k
,j
,i
))) then
1103 errors(131) = .true
.
1106 itarg3(k
,j
,i
) = -ipte3(k
,j
,i
)
1107 if (intne(ipte3(k
,j
,i
), itarg3(k
,j
,i
))) then
1109 errors(132) = .true
.
1112 rpte3(k
,j
,i
) = i
* 2.0
1113 if (realne(rpte3(k
,j
,i
), rtarg3(k
,j
,i
))) then
1115 errors(133) = .true
.
1118 rtarg3(k
,j
,i
) = i
* 3.0
1119 if (realne(rpte3(k
,j
,i
), rtarg3(k
,j
,i
))) then
1121 errors(134) = .true
.
1125 if (chne(chpte3(k
,j
,i
), chtarg3(k
,j
,i
))) then
1127 errors(135) = .true
.
1130 chtarg3(k
,j
,i
) = 'z'
1131 if (chne(chpte3(k
,j
,i
), chtarg3(k
,j
,i
))) then
1133 errors(136) = .true
.
1136 ch8pte3(k
,j
,i
) = 'aaaaaaaa'
1137 if (ch8ne(ch8pte3(k
,j
,i
), ch8targ3(k
,j
,i
))) then
1139 errors(137) = .true
.
1142 ch8targ3(k
,j
,i
) = 'zzzzzzzz'
1143 if (ch8ne(ch8pte3(k
,j
,i
), ch8targ3(k
,j
,i
))) then
1145 errors(138) = .true
.
1158 if (intne(itarg3(k
,j
,i
), i
)) then
1160 errors(139) = .true
.
1163 if (realne(rtarg3(k
,j
,i
), i
+.5)) then
1165 errors(140) = .true
.
1174 common /errors
/errors(400)
1175 logical :: errors
, intne
, realne
, chne
, ch8ne
1177 integer, parameter :: n
= 9
1178 integer, parameter :: m
= 10
1179 integer, parameter :: o
= 11
1181 integer itarg2 (m
,n
)
1182 integer itarg3 (o
,m
,n
)
1186 character chtarg1(n
)
1187 character chtarg2(m
,n
)
1188 character chtarg3(o
,m
,n
)
1189 character*8 ch8targ1(n
)
1190 character*8 ch8targ2(m
,n
)
1191 character*8 ch8targ3(o
,m
,n
)
1197 type(drvd
) dtarg1(n
)
1198 type(drvd
) dtarg2(m
,n
)
1199 type(drvd
) dtarg3(o
,m
,n
)
1202 type(drvd
) dpte2(m
,*)
1203 type(drvd
) dpte3(o
,m
,*)
1206 integer ipte3 (o
,m
,*)
1211 character chpte2(m
,*)
1212 character chpte3(o
,m
,*)
1213 character*8 ch8pte1(*)
1214 character*8 ch8pte2(m
,*)
1215 character*8 ch8pte3(o
,m
,*)
1217 pointer(iptr1
,dpte1
)
1218 pointer(iptr2
,dpte2
)
1219 pointer(iptr3
,dpte3
)
1220 pointer(iptr4
,ipte1
)
1221 pointer(iptr5
,ipte2
)
1222 pointer(iptr6
,ipte3
)
1223 pointer(iptr7
,rpte1
)
1224 pointer(iptr8
,rpte2
)
1225 pointer(iptr9
,rpte3
)
1226 pointer(iptr10
,chpte1
)
1227 pointer(iptr11
,chpte2
)
1228 pointer(iptr12
,chpte3
)
1229 pointer(iptr13
,ch8pte1
)
1230 pointer(iptr14
,ch8pte2
)
1231 pointer(iptr15
,ch8pte3
)
1242 iptr10
= loc(chtarg1
)
1243 iptr11
= loc(chtarg2
)
1244 iptr12
= loc(chtarg3
)
1245 iptr13
= loc(ch8targ1
)
1246 iptr14
= loc(ch8targ2
)
1247 iptr15
= loc(ch8targ3
)
1252 if (intne(dpte1(i
)%i1
, dtarg1(i
)%i1
)) then
1254 errors(141) = .true
.
1257 dtarg1(i
)%i1
=2*dpte1(i
)%i1
1258 if (intne(dpte1(i
)%i1
, dtarg1(i
)%i1
)) then
1260 errors(142) = .true
.
1264 if (intne(ipte1(i
), itarg1(i
))) then
1266 errors(143) = .true
.
1269 itarg1(i
) = -ipte1(i
)
1270 if (intne(ipte1(i
), itarg1(i
))) then
1272 errors(144) = .true
.
1276 if (realne(rpte1(i
), rtarg1(i
))) then
1278 errors(145) = .true
.
1281 rtarg1(i
) = i
* (-5.0)
1282 if (realne(rpte1(i
), rtarg1(i
))) then
1284 errors(146) = .true
.
1288 if (chne(chpte1(i
), chtarg1(i
))) then
1290 errors(147) = .true
.
1294 if (chne(chpte1(i
), chtarg1(i
))) then
1296 errors(148) = .true
.
1299 ch8pte1(i
) = 'aaaaaaaa'
1300 if (ch8ne(ch8pte1(i
), ch8targ1(i
))) then
1302 errors(149) = .true
.
1305 ch8targ1(i
) = 'zzzzzzzz'
1306 if (ch8ne(ch8pte1(i
), ch8targ1(i
))) then
1308 errors(150) = .true
.
1313 if (realne(dpte2(j
,i
)%r1
, dtarg2(j
,i
)%r1
)) then
1315 errors(151) = .true
.
1318 dtarg2(j
,i
)%r1
=2*dpte2(j
,i
)%r1
1319 if (realne(dpte2(j
,i
)%r1
, dtarg2(j
,i
)%r1
)) then
1321 errors(152) = .true
.
1325 if (intne(ipte2(j
,i
), itarg2(j
,i
))) then
1327 errors(153) = .true
.
1330 itarg2(j
,i
) = -ipte2(j
,i
)
1331 if (intne(ipte2(j
,i
), itarg2(j
,i
))) then
1333 errors(154) = .true
.
1336 rpte2(j
,i
) = i
* (-2.0)
1337 if (realne(rpte2(j
,i
), rtarg2(j
,i
))) then
1339 errors(155) = .true
.
1342 rtarg2(j
,i
) = i
* (-3.0)
1343 if (realne(rpte2(j
,i
), rtarg2(j
,i
))) then
1345 errors(156) = .true
.
1349 if (chne(chpte2(j
,i
), chtarg2(j
,i
))) then
1351 errors(157) = .true
.
1355 if (chne(chpte2(j
,i
), chtarg2(j
,i
))) then
1357 errors(158) = .true
.
1360 ch8pte2(j
,i
) = 'aaaaaaaa'
1361 if (ch8ne(ch8pte2(j
,i
), ch8targ2(j
,i
))) then
1363 errors(159) = .true
.
1366 ch8targ2(j
,i
) = 'zzzzzzzz'
1367 if (ch8ne(ch8pte2(j
,i
), ch8targ2(j
,i
))) then
1369 errors(160) = .true
.
1372 dpte3(k
,j
,i
)%i2(1+mod(i
,5))=i
1373 if (intne(dpte3(k
,j
,i
)%i2(1+mod(i
,5)), &
1374 dtarg3(k
,j
,i
)%i2(1+mod(i
,5)))) then
1376 errors(161) = .true
.
1379 dtarg3(k
,j
,i
)%i2(1+mod(i
,5))=2*dpte3(k
,j
,i
)%i2(1+mod(i
,5))
1380 if (intne(dpte3(k
,j
,i
)%i2(1+mod(i
,5)), &
1381 dtarg3(k
,j
,i
)%i2(1+mod(i
,5)))) then
1383 errors(162) = .true
.
1387 if (intne(ipte3(k
,j
,i
), itarg3(k
,j
,i
))) then
1389 errors(163) = .true
.
1392 itarg3(k
,j
,i
) = -ipte3(k
,j
,i
)
1393 if (intne(ipte3(k
,j
,i
), itarg3(k
,j
,i
))) then
1395 errors(164) = .true
.
1398 rpte3(k
,j
,i
) = i
* 2.0
1399 if (realne(rpte3(k
,j
,i
), rtarg3(k
,j
,i
))) then
1401 errors(165) = .true
.
1404 rtarg3(k
,j
,i
) = i
* 3.0
1405 if (realne(rpte3(k
,j
,i
), rtarg3(k
,j
,i
))) then
1407 errors(166) = .true
.
1411 if (chne(chpte3(k
,j
,i
), chtarg3(k
,j
,i
))) then
1413 errors(167) = .true
.
1416 chtarg3(k
,j
,i
) = 'z'
1417 if (chne(chpte3(k
,j
,i
), chtarg3(k
,j
,i
))) then
1419 errors(168) = .true
.
1422 ch8pte3(k
,j
,i
) = 'aaaaaaaa'
1423 if (ch8ne(ch8pte3(k
,j
,i
), ch8targ3(k
,j
,i
))) then
1425 errors(169) = .true
.
1428 ch8targ3(k
,j
,i
) = 'zzzzzzzz'
1429 if (ch8ne(ch8pte3(k
,j
,i
), ch8targ3(k
,j
,i
))) then
1431 errors(170) = .true
.
1441 common /errors
/errors(400)
1442 logical :: errors
, intne
, realne
, chne
, ch8ne
1444 integer, parameter :: n
= 9
1445 integer, parameter :: m
= 10
1446 integer, parameter :: o
= 11
1448 integer itarg2 (m
,n
)
1449 integer itarg3 (o
,m
,n
)
1453 character chtarg1(n
)
1454 character chtarg2(m
,n
)
1455 character chtarg3(o
,m
,n
)
1456 character*8 ch8targ1(n
)
1457 character*8 ch8targ2(m
,n
)
1458 character*8 ch8targ3(o
,m
,n
)
1464 type(drvd
) dtarg1(n
)
1465 type(drvd
) dtarg2(m
,n
)
1466 type(drvd
) dtarg3(o
,m
,n
)
1484 pointer(iptr1
,dpte1(*))
1485 pointer(iptr2
,dpte2(m
,*))
1486 pointer(iptr3
,dpte3(o
,m
,*))
1487 pointer(iptr4
,ipte1(*))
1488 pointer(iptr5
,ipte2 (m
,*))
1489 pointer(iptr6
,ipte3(o
,m
,*))
1490 pointer(iptr7
,rpte1(*))
1491 pointer(iptr8
,rpte2(m
,*))
1492 pointer(iptr9
,rpte3(o
,m
,*))
1493 pointer(iptr10
,chpte1(*))
1494 pointer(iptr11
,chpte2(m
,*))
1495 pointer(iptr12
,chpte3(o
,m
,*))
1496 pointer(iptr13
,ch8pte1(*))
1497 pointer(iptr14
,ch8pte2(m
,*))
1498 pointer(iptr15
,ch8pte3(o
,m
,*))
1509 iptr10
= loc(chtarg1
)
1510 iptr11
= loc(chtarg2
)
1511 iptr12
= loc(chtarg3
)
1512 iptr13
= loc(ch8targ1
)
1513 iptr14
= loc(ch8targ2
)
1514 iptr15
= loc(ch8targ3
)
1518 if (intne(dpte1(i
)%i1
, dtarg1(i
)%i1
)) then
1520 errors(171) = .true
.
1523 dtarg1(i
)%i1
=2*dpte1(i
)%i1
1524 if (intne(dpte1(i
)%i1
, dtarg1(i
)%i1
)) then
1526 errors(172) = .true
.
1530 if (intne(ipte1(i
), itarg1(i
))) then
1532 errors(173) = .true
.
1535 itarg1(i
) = -ipte1(i
)
1536 if (intne(ipte1(i
), itarg1(i
))) then
1538 errors(174) = .true
.
1542 if (realne(rpte1(i
), rtarg1(i
))) then
1544 errors(175) = .true
.
1547 rtarg1(i
) = i
* (-5.0)
1548 if (realne(rpte1(i
), rtarg1(i
))) then
1550 errors(176) = .true
.
1554 if (chne(chpte1(i
), chtarg1(i
))) then
1556 errors(177) = .true
.
1560 if (chne(chpte1(i
), chtarg1(i
))) then
1562 errors(178) = .true
.
1565 ch8pte1(i
) = 'aaaaaaaa'
1566 if (ch8ne(ch8pte1(i
), ch8targ1(i
))) then
1568 errors(179) = .true
.
1571 ch8targ1(i
) = 'zzzzzzzz'
1572 if (ch8ne(ch8pte1(i
), ch8targ1(i
))) then
1574 errors(180) = .true
.
1579 if (realne(dpte2(j
,i
)%r1
, dtarg2(j
,i
)%r1
)) then
1581 errors(181) = .true
.
1584 dtarg2(j
,i
)%r1
=2*dpte2(j
,i
)%r1
1585 if (realne(dpte2(j
,i
)%r1
, dtarg2(j
,i
)%r1
)) then
1587 errors(182) = .true
.
1591 if (intne(ipte2(j
,i
), itarg2(j
,i
))) then
1593 errors(183) = .true
.
1596 itarg2(j
,i
) = -ipte2(j
,i
)
1597 if (intne(ipte2(j
,i
), itarg2(j
,i
))) then
1599 errors(184) = .true
.
1602 rpte2(j
,i
) = i
* (-2.0)
1603 if (realne(rpte2(j
,i
), rtarg2(j
,i
))) then
1605 errors(185) = .true
.
1608 rtarg2(j
,i
) = i
* (-3.0)
1609 if (realne(rpte2(j
,i
), rtarg2(j
,i
))) then
1611 errors(186) = .true
.
1615 if (chne(chpte2(j
,i
), chtarg2(j
,i
))) then
1617 errors(187) = .true
.
1621 if (chne(chpte2(j
,i
), chtarg2(j
,i
))) then
1623 errors(188) = .true
.
1626 ch8pte2(j
,i
) = 'aaaaaaaa'
1627 if (ch8ne(ch8pte2(j
,i
), ch8targ2(j
,i
))) then
1629 errors(189) = .true
.
1632 ch8targ2(j
,i
) = 'zzzzzzzz'
1633 if (ch8ne(ch8pte2(j
,i
), ch8targ2(j
,i
))) then
1635 errors(190) = .true
.
1638 dpte3(k
,j
,i
)%i2(1+mod(i
,5))=i
1639 if (intne(dpte3(k
,j
,i
)%i2(1+mod(i
,5)), &
1640 dtarg3(k
,j
,i
)%i2(1+mod(i
,5)))) then
1642 errors(191) = .true
.
1645 dtarg3(k
,j
,i
)%i2(1+mod(i
,5))=2*dpte3(k
,j
,i
)%i2(1+mod(i
,5))
1646 if (intne(dpte3(k
,j
,i
)%i2(1+mod(i
,5)), &
1647 dtarg3(k
,j
,i
)%i2(1+mod(i
,5)))) then
1649 errors(192) = .true
.
1653 if (intne(ipte3(k
,j
,i
), itarg3(k
,j
,i
))) then
1655 errors(193) = .true
.
1658 itarg3(k
,j
,i
) = -ipte3(k
,j
,i
)
1659 if (intne(ipte3(k
,j
,i
), itarg3(k
,j
,i
))) then
1661 errors(194) = .true
.
1664 rpte3(k
,j
,i
) = i
* 2.0
1665 if (realne(rpte3(k
,j
,i
), rtarg3(k
,j
,i
))) then
1667 errors(195) = .true
.
1670 rtarg3(k
,j
,i
) = i
* 3.0
1671 if (realne(rpte3(k
,j
,i
), rtarg3(k
,j
,i
))) then
1673 errors(196) = .true
.
1677 if (chne(chpte3(k
,j
,i
), chtarg3(k
,j
,i
))) then
1679 errors(197) = .true
.
1682 chtarg3(k
,j
,i
) = 'z'
1683 if (chne(chpte3(k
,j
,i
), chtarg3(k
,j
,i
))) then
1685 errors(198) = .true
.
1688 ch8pte3(k
,j
,i
) = 'aaaaaaaa'
1689 if (ch8ne(ch8pte3(k
,j
,i
), ch8targ3(k
,j
,i
))) then
1691 errors(199) = .true
.
1694 ch8targ3(k
,j
,i
) = 'zzzzzzzz'
1695 if (ch8ne(ch8pte3(k
,j
,i
), ch8targ3(k
,j
,i
))) then
1697 errors(200) = .true
.
1706 common /errors
/errors(400)
1707 logical :: errors
, intne
, realne
, chne
, ch8ne
1709 integer, parameter :: n
= 9
1710 integer, parameter :: m
= 10
1711 integer, parameter :: o
= 11
1713 integer itarg2 (m
,n
)
1714 integer itarg3 (o
,m
,n
)
1718 character chtarg1(n
)
1719 character chtarg2(m
,n
)
1720 character chtarg3(o
,m
,n
)
1721 character*8 ch8targ1(n
)
1722 character*8 ch8targ2(m
,n
)
1723 character*8 ch8targ3(o
,m
,n
)
1729 type(drvd
) dtarg1(n
)
1730 type(drvd
) dtarg2(m
,n
)
1731 type(drvd
) dtarg3(o
,m
,n
)
1733 pointer(iptr1
,dpte1(*))
1734 pointer(iptr2
,dpte2(m
,*))
1735 pointer(iptr3
,dpte3(o
,m
,*))
1736 pointer(iptr4
,ipte1(*))
1737 pointer(iptr5
,ipte2 (m
,*))
1738 pointer(iptr6
,ipte3(o
,m
,*))
1739 pointer(iptr7
,rpte1(*))
1740 pointer(iptr8
,rpte2(m
,*))
1741 pointer(iptr9
,rpte3(o
,m
,*))
1742 pointer(iptr10
,chpte1(*))
1743 pointer(iptr11
,chpte2(m
,*))
1744 pointer(iptr12
,chpte3(o
,m
,*))
1745 pointer(iptr13
,ch8pte1(*))
1746 pointer(iptr14
,ch8pte2(m
,*))
1747 pointer(iptr15
,ch8pte3(o
,m
,*))
1774 iptr10
= loc(chtarg1
)
1775 iptr11
= loc(chtarg2
)
1776 iptr12
= loc(chtarg3
)
1777 iptr13
= loc(ch8targ1
)
1778 iptr14
= loc(ch8targ2
)
1779 iptr15
= loc(ch8targ3
)
1783 if (intne(dpte1(i
)%i1
, dtarg1(i
)%i1
)) then
1785 errors(201) = .true
.
1788 dtarg1(i
)%i1
=2*dpte1(i
)%i1
1789 if (intne(dpte1(i
)%i1
, dtarg1(i
)%i1
)) then
1791 errors(202) = .true
.
1795 if (intne(ipte1(i
), itarg1(i
))) then
1797 errors(203) = .true
.
1800 itarg1(i
) = -ipte1(i
)
1801 if (intne(ipte1(i
), itarg1(i
))) then
1803 errors(204) = .true
.
1807 if (realne(rpte1(i
), rtarg1(i
))) then
1809 errors(205) = .true
.
1812 rtarg1(i
) = i
* (-5.0)
1813 if (realne(rpte1(i
), rtarg1(i
))) then
1815 errors(206) = .true
.
1819 if (chne(chpte1(i
), chtarg1(i
))) then
1821 errors(207) = .true
.
1825 if (chne(chpte1(i
), chtarg1(i
))) then
1827 errors(208) = .true
.
1830 ch8pte1(i
) = 'aaaaaaaa'
1831 if (ch8ne(ch8pte1(i
), ch8targ1(i
))) then
1833 errors(209) = .true
.
1836 ch8targ1(i
) = 'zzzzzzzz'
1837 if (ch8ne(ch8pte1(i
), ch8targ1(i
))) then
1839 errors(210) = .true
.
1844 if (realne(dpte2(j
,i
)%r1
, dtarg2(j
,i
)%r1
)) then
1846 errors(211) = .true
.
1849 dtarg2(j
,i
)%r1
=2*dpte2(j
,i
)%r1
1850 if (realne(dpte2(j
,i
)%r1
, dtarg2(j
,i
)%r1
)) then
1852 errors(212) = .true
.
1856 if (intne(ipte2(j
,i
), itarg2(j
,i
))) then
1858 errors(213) = .true
.
1861 itarg2(j
,i
) = -ipte2(j
,i
)
1862 if (intne(ipte2(j
,i
), itarg2(j
,i
))) then
1864 errors(214) = .true
.
1867 rpte2(j
,i
) = i
* (-2.0)
1868 if (realne(rpte2(j
,i
), rtarg2(j
,i
))) then
1870 errors(215) = .true
.
1873 rtarg2(j
,i
) = i
* (-3.0)
1874 if (realne(rpte2(j
,i
), rtarg2(j
,i
))) then
1876 errors(216) = .true
.
1880 if (chne(chpte2(j
,i
), chtarg2(j
,i
))) then
1882 errors(217) = .true
.
1886 if (chne(chpte2(j
,i
), chtarg2(j
,i
))) then
1888 errors(218) = .true
.
1891 ch8pte2(j
,i
) = 'aaaaaaaa'
1892 if (ch8ne(ch8pte2(j
,i
), ch8targ2(j
,i
))) then
1894 errors(219) = .true
.
1897 ch8targ2(j
,i
) = 'zzzzzzzz'
1898 if (ch8ne(ch8pte2(j
,i
), ch8targ2(j
,i
))) then
1900 errors(220) = .true
.
1903 dpte3(k
,j
,i
)%i2(1+mod(i
,5))=i
1904 if (intne(dpte3(k
,j
,i
)%i2(1+mod(i
,5)), &
1905 dtarg3(k
,j
,i
)%i2(1+mod(i
,5)))) then
1907 errors(221) = .true
.
1910 dtarg3(k
,j
,i
)%i2(1+mod(i
,5))=2*dpte3(k
,j
,i
)%i2(1+mod(i
,5))
1911 if (intne(dpte3(k
,j
,i
)%i2(1+mod(i
,5)), &
1912 dtarg3(k
,j
,i
)%i2(1+mod(i
,5)))) then
1914 errors(222) = .true
.
1918 if (intne(ipte3(k
,j
,i
), itarg3(k
,j
,i
))) then
1920 errors(223) = .true
.
1923 itarg3(k
,j
,i
) = -ipte3(k
,j
,i
)
1924 if (intne(ipte3(k
,j
,i
), itarg3(k
,j
,i
))) then
1926 errors(224) = .true
.
1929 rpte3(k
,j
,i
) = i
* 2.0
1930 if (realne(rpte3(k
,j
,i
), rtarg3(k
,j
,i
))) then
1932 errors(225) = .true
.
1935 rtarg3(k
,j
,i
) = i
* 3.0
1936 if (realne(rpte3(k
,j
,i
), rtarg3(k
,j
,i
))) then
1938 errors(226) = .true
.
1942 if (chne(chpte3(k
,j
,i
), chtarg3(k
,j
,i
))) then
1944 errors(227) = .true
.
1947 chtarg3(k
,j
,i
) = 'z'
1948 if (chne(chpte3(k
,j
,i
), chtarg3(k
,j
,i
))) then
1950 errors(228) = .true
.
1953 ch8pte3(k
,j
,i
) = 'aaaaaaaa'
1954 if (ch8ne(ch8pte3(k
,j
,i
), ch8targ3(k
,j
,i
))) then
1956 errors(229) = .true
.
1959 ch8targ3(k
,j
,i
) = 'zzzzzzzz'
1960 if (ch8ne(ch8pte3(k
,j
,i
), ch8targ3(k
,j
,i
))) then
1962 errors(230) = .true
.
1971 common /errors
/errors(400)
1972 logical :: errors
, intne
, realne
, chne
, ch8ne
1974 integer, parameter :: n
= 9
1975 integer, parameter :: m
= 10
1976 integer, parameter :: o
= 11
1978 integer itarg2 (m
,n
)
1979 integer itarg3 (o
,m
,n
)
1983 character chtarg1(n
)
1984 character chtarg2(m
,n
)
1985 character chtarg3(o
,m
,n
)
1986 character*8 ch8targ1(n
)
1987 character*8 ch8targ2(m
,n
)
1988 character*8 ch8targ3(o
,m
,n
)
1994 type(drvd
) dtarg1(n
)
1995 type(drvd
) dtarg2(m
,n
)
1996 type(drvd
) dtarg3(o
,m
,n
)
1998 pointer(iptr1
,dpte1
)
1999 pointer(iptr2
,dpte2
)
2000 pointer(iptr3
,dpte3
)
2001 pointer(iptr4
,ipte1
)
2002 pointer(iptr5
,ipte2
)
2003 pointer(iptr6
,ipte3
)
2004 pointer(iptr7
,rpte1
)
2005 pointer(iptr8
,rpte2
)
2006 pointer(iptr9
,rpte3
)
2007 pointer(iptr10
,chpte1
)
2008 pointer(iptr11
,chpte2
)
2009 pointer(iptr12
,chpte3
)
2010 pointer(iptr13
,ch8pte1
)
2011 pointer(iptr14
,ch8pte2
)
2012 pointer(iptr15
,ch8pte3
)
2015 type(drvd
) dpte2(m
,*)
2016 type(drvd
) dpte3(o
,m
,*)
2019 integer ipte3 (o
,m
,*)
2024 character chpte2(m
,*)
2025 character chpte3(o
,m
,*)
2026 character*8 ch8pte1(*)
2027 character*8 ch8pte2(m
,*)
2028 character*8 ch8pte3(o
,m
,*)
2039 iptr10
= loc(chtarg1
)
2040 iptr11
= loc(chtarg2
)
2041 iptr12
= loc(chtarg3
)
2042 iptr13
= loc(ch8targ1
)
2043 iptr14
= loc(ch8targ2
)
2044 iptr15
= loc(ch8targ3
)
2049 if (intne(dpte1(i
)%i1
, dtarg1(i
)%i1
)) then
2051 errors(231) = .true
.
2054 dtarg1(i
)%i1
=2*dpte1(i
)%i1
2055 if (intne(dpte1(i
)%i1
, dtarg1(i
)%i1
)) then
2057 errors(232) = .true
.
2061 if (intne(ipte1(i
), itarg1(i
))) then
2063 errors(233) = .true
.
2066 itarg1(i
) = -ipte1(i
)
2067 if (intne(ipte1(i
), itarg1(i
))) then
2069 errors(234) = .true
.
2073 if (realne(rpte1(i
), rtarg1(i
))) then
2075 errors(235) = .true
.
2078 rtarg1(i
) = i
* (-5.0)
2079 if (realne(rpte1(i
), rtarg1(i
))) then
2081 errors(236) = .true
.
2085 if (chne(chpte1(i
), chtarg1(i
))) then
2087 errors(237) = .true
.
2091 if (chne(chpte1(i
), chtarg1(i
))) then
2093 errors(238) = .true
.
2096 ch8pte1(i
) = 'aaaaaaaa'
2097 if (ch8ne(ch8pte1(i
), ch8targ1(i
))) then
2099 errors(239) = .true
.
2102 ch8targ1(i
) = 'zzzzzzzz'
2103 if (ch8ne(ch8pte1(i
), ch8targ1(i
))) then
2105 errors(240) = .true
.
2110 if (realne(dpte2(j
,i
)%r1
, dtarg2(j
,i
)%r1
)) then
2112 errors(241) = .true
.
2115 dtarg2(j
,i
)%r1
=2*dpte2(j
,i
)%r1
2116 if (realne(dpte2(j
,i
)%r1
, dtarg2(j
,i
)%r1
)) then
2118 errors(242) = .true
.
2122 if (intne(ipte2(j
,i
), itarg2(j
,i
))) then
2124 errors(243) = .true
.
2127 itarg2(j
,i
) = -ipte2(j
,i
)
2128 if (intne(ipte2(j
,i
), itarg2(j
,i
))) then
2130 errors(244) = .true
.
2133 rpte2(j
,i
) = i
* (-2.0)
2134 if (realne(rpte2(j
,i
), rtarg2(j
,i
))) then
2136 errors(245) = .true
.
2139 rtarg2(j
,i
) = i
* (-3.0)
2140 if (realne(rpte2(j
,i
), rtarg2(j
,i
))) then
2142 errors(246) = .true
.
2146 if (chne(chpte2(j
,i
), chtarg2(j
,i
))) then
2148 errors(247) = .true
.
2152 if (chne(chpte2(j
,i
), chtarg2(j
,i
))) then
2154 errors(248) = .true
.
2157 ch8pte2(j
,i
) = 'aaaaaaaa'
2158 if (ch8ne(ch8pte2(j
,i
), ch8targ2(j
,i
))) then
2160 errors(249) = .true
.
2163 ch8targ2(j
,i
) = 'zzzzzzzz'
2164 if (ch8ne(ch8pte2(j
,i
), ch8targ2(j
,i
))) then
2166 errors(250) = .true
.
2169 dpte3(k
,j
,i
)%i2(1+mod(i
,5))=i
2170 if (intne(dpte3(k
,j
,i
)%i2(1+mod(i
,5)), &
2171 dtarg3(k
,j
,i
)%i2(1+mod(i
,5)))) then
2173 errors(251) = .true
.
2176 dtarg3(k
,j
,i
)%i2(1+mod(i
,5))=2*dpte3(k
,j
,i
)%i2(1+mod(i
,5))
2177 if (intne(dpte3(k
,j
,i
)%i2(1+mod(i
,5)), &
2178 dtarg3(k
,j
,i
)%i2(1+mod(i
,5)))) then
2180 errors(252) = .true
.
2184 if (intne(ipte3(k
,j
,i
), itarg3(k
,j
,i
))) then
2186 errors(253) = .true
.
2189 itarg3(k
,j
,i
) = -ipte3(k
,j
,i
)
2190 if (intne(ipte3(k
,j
,i
), itarg3(k
,j
,i
))) then
2192 errors(254) = .true
.
2195 rpte3(k
,j
,i
) = i
* 2.0
2196 if (realne(rpte3(k
,j
,i
), rtarg3(k
,j
,i
))) then
2198 errors(255) = .true
.
2201 rtarg3(k
,j
,i
) = i
* 3.0
2202 if (realne(rpte3(k
,j
,i
), rtarg3(k
,j
,i
))) then
2204 errors(256) = .true
.
2208 if (chne(chpte3(k
,j
,i
), chtarg3(k
,j
,i
))) then
2210 errors(257) = .true
.
2213 chtarg3(k
,j
,i
) = 'z'
2214 if (chne(chpte3(k
,j
,i
), chtarg3(k
,j
,i
))) then
2216 errors(258) = .true
.
2219 ch8pte3(k
,j
,i
) = 'aaaaaaaa'
2220 if (ch8ne(ch8pte3(k
,j
,i
), ch8targ3(k
,j
,i
))) then
2222 errors(259) = .true
.
2225 ch8targ3(k
,j
,i
) = 'zzzzzzzz'
2226 if (ch8ne(ch8pte3(k
,j
,i
), ch8targ3(k
,j
,i
))) then
2228 errors(260) = .true
.
2236 subroutine ptr9(nnn
,mmm
,ooo
)
2237 common /errors
/errors(400)
2238 logical :: errors
, intne
, realne
, chne
, ch8ne
2240 integer :: nnn
,mmm
,ooo
2241 integer, parameter :: n
= 9
2242 integer, parameter :: m
= 10
2243 integer, parameter :: o
= 11
2245 integer itarg2 (m
,n
)
2246 integer itarg3 (o
,m
,n
)
2250 character chtarg1(n
)
2251 character chtarg2(m
,n
)
2252 character chtarg3(o
,m
,n
)
2253 character*8 ch8targ1(n
)
2254 character*8 ch8targ2(m
,n
)
2255 character*8 ch8targ3(o
,m
,n
)
2261 type(drvd
) dtarg1(n
)
2262 type(drvd
) dtarg2(m
,n
)
2263 type(drvd
) dtarg3(o
,m
,n
)
2265 type(drvd
) dpte1(nnn
)
2266 type(drvd
) dpte2(mmm
,nnn
)
2267 type(drvd
) dpte3(ooo
,mmm
,nnn
)
2269 integer ipte2 (mmm
,nnn
)
2270 integer ipte3 (ooo
,mmm
,nnn
)
2273 real rpte3(ooo
,mmm
,nnn
)
2274 character chpte1(nnn
)
2275 character chpte2(mmm
,nnn
)
2276 character chpte3(ooo
,mmm
,nnn
)
2277 character*8 ch8pte1(nnn
)
2278 character*8 ch8pte2(mmm
,nnn
)
2279 character*8 ch8pte3(ooo
,mmm
,nnn
)
2281 pointer(iptr1
,dpte1
)
2282 pointer(iptr2
,dpte2
)
2283 pointer(iptr3
,dpte3
)
2284 pointer(iptr4
,ipte1
)
2285 pointer(iptr5
,ipte2
)
2286 pointer(iptr6
,ipte3
)
2287 pointer(iptr7
,rpte1
)
2288 pointer(iptr8
,rpte2
)
2289 pointer(iptr9
,rpte3
)
2290 pointer(iptr10
,chpte1
)
2291 pointer(iptr11
,chpte2
)
2292 pointer(iptr12
,chpte3
)
2293 pointer(iptr13
,ch8pte1
)
2294 pointer(iptr14
,ch8pte2
)
2295 pointer(iptr15
,ch8pte3
)
2306 iptr10
= loc(chtarg1
)
2307 iptr11
= loc(chtarg2
)
2308 iptr12
= loc(chtarg3
)
2309 iptr13
= loc(ch8targ1
)
2310 iptr14
= loc(ch8targ2
)
2311 iptr15
= loc(ch8targ3
)
2316 if (intne(dpte1(i
)%i1
, dtarg1(i
)%i1
)) then
2318 errors(261) = .true
.
2321 dtarg1(i
)%i1
=2*dpte1(i
)%i1
2322 if (intne(dpte1(i
)%i1
, dtarg1(i
)%i1
)) then
2324 errors(262) = .true
.
2328 if (intne(ipte1(i
), itarg1(i
))) then
2330 errors(263) = .true
.
2333 itarg1(i
) = -ipte1(i
)
2334 if (intne(ipte1(i
), itarg1(i
))) then
2336 errors(264) = .true
.
2340 if (realne(rpte1(i
), rtarg1(i
))) then
2342 errors(265) = .true
.
2345 rtarg1(i
) = i
* (-5.0)
2346 if (realne(rpte1(i
), rtarg1(i
))) then
2348 errors(266) = .true
.
2352 if (chne(chpte1(i
), chtarg1(i
))) then
2354 errors(267) = .true
.
2358 if (chne(chpte1(i
), chtarg1(i
))) then
2360 errors(268) = .true
.
2363 ch8pte1(i
) = 'aaaaaaaa'
2364 if (ch8ne(ch8pte1(i
), ch8targ1(i
))) then
2366 errors(269) = .true
.
2369 ch8targ1(i
) = 'zzzzzzzz'
2370 if (ch8ne(ch8pte1(i
), ch8targ1(i
))) then
2372 errors(270) = .true
.
2377 if (realne(dpte2(j
,i
)%r1
, dtarg2(j
,i
)%r1
)) then
2379 errors(271) = .true
.
2382 dtarg2(j
,i
)%r1
=2*dpte2(j
,i
)%r1
2383 if (realne(dpte2(j
,i
)%r1
, dtarg2(j
,i
)%r1
)) then
2385 errors(272) = .true
.
2389 if (intne(ipte2(j
,i
), itarg2(j
,i
))) then
2391 errors(273) = .true
.
2394 itarg2(j
,i
) = -ipte2(j
,i
)
2395 if (intne(ipte2(j
,i
), itarg2(j
,i
))) then
2397 errors(274) = .true
.
2400 rpte2(j
,i
) = i
* (-2.0)
2401 if (realne(rpte2(j
,i
), rtarg2(j
,i
))) then
2403 errors(275) = .true
.
2406 rtarg2(j
,i
) = i
* (-3.0)
2407 if (realne(rpte2(j
,i
), rtarg2(j
,i
))) then
2409 errors(276) = .true
.
2413 if (chne(chpte2(j
,i
), chtarg2(j
,i
))) then
2415 errors(277) = .true
.
2419 if (chne(chpte2(j
,i
), chtarg2(j
,i
))) then
2421 errors(278) = .true
.
2424 ch8pte2(j
,i
) = 'aaaaaaaa'
2425 if (ch8ne(ch8pte2(j
,i
), ch8targ2(j
,i
))) then
2427 errors(279) = .true
.
2430 ch8targ2(j
,i
) = 'zzzzzzzz'
2431 if (ch8ne(ch8pte2(j
,i
), ch8targ2(j
,i
))) then
2433 errors(280) = .true
.
2436 dpte3(k
,j
,i
)%i2(1+mod(i
,5))=i
2437 if (intne(dpte3(k
,j
,i
)%i2(1+mod(i
,5)), &
2438 dtarg3(k
,j
,i
)%i2(1+mod(i
,5)))) then
2440 errors(281) = .true
.
2443 dtarg3(k
,j
,i
)%i2(1+mod(i
,5))=2*dpte3(k
,j
,i
)%i2(1+mod(i
,5))
2444 if (intne(dpte3(k
,j
,i
)%i2(1+mod(i
,5)), &
2445 dtarg3(k
,j
,i
)%i2(1+mod(i
,5)))) then
2447 errors(282) = .true
.
2451 if (intne(ipte3(k
,j
,i
), itarg3(k
,j
,i
))) then
2453 errors(283) = .true
.
2456 itarg3(k
,j
,i
) = -ipte3(k
,j
,i
)
2457 if (intne(ipte3(k
,j
,i
), itarg3(k
,j
,i
))) then
2459 errors(284) = .true
.
2462 rpte3(k
,j
,i
) = i
* 2.0
2463 if (realne(rpte3(k
,j
,i
), rtarg3(k
,j
,i
))) then
2465 errors(285) = .true
.
2468 rtarg3(k
,j
,i
) = i
* 3.0
2469 if (realne(rpte3(k
,j
,i
), rtarg3(k
,j
,i
))) then
2471 errors(286) = .true
.
2475 if (chne(chpte3(k
,j
,i
), chtarg3(k
,j
,i
))) then
2477 errors(287) = .true
.
2480 chtarg3(k
,j
,i
) = 'z'
2481 if (chne(chpte3(k
,j
,i
), chtarg3(k
,j
,i
))) then
2483 errors(288) = .true
.
2486 ch8pte3(k
,j
,i
) = 'aaaaaaaa'
2487 if (ch8ne(ch8pte3(k
,j
,i
), ch8targ3(k
,j
,i
))) then
2489 errors(289) = .true
.
2492 ch8targ3(k
,j
,i
) = 'zzzzzzzz'
2493 if (ch8ne(ch8pte3(k
,j
,i
), ch8targ3(k
,j
,i
))) then
2495 errors(290) = .true
.
2508 if (intne(itarg3(k
,j
,i
), i
)) then
2510 errors(291) = .true
.
2513 if (realne(rtarg3(k
,j
,i
), i
+.5)) then
2515 errors(292) = .true
.
2523 subroutine ptr10(nnn
,mmm
,ooo
)
2524 common /errors
/errors(400)
2525 logical :: errors
, intne
, realne
, chne
, ch8ne
2527 integer :: nnn
,mmm
,ooo
2528 integer, parameter :: n
= 9
2529 integer, parameter :: m
= 10
2530 integer, parameter :: o
= 11
2532 integer itarg2 (m
,n
)
2533 integer itarg3 (o
,m
,n
)
2537 character chtarg1(n
)
2538 character chtarg2(m
,n
)
2539 character chtarg3(o
,m
,n
)
2540 character*8 ch8targ1(n
)
2541 character*8 ch8targ2(m
,n
)
2542 character*8 ch8targ3(o
,m
,n
)
2548 type(drvd
) dtarg1(n
)
2549 type(drvd
) dtarg2(m
,n
)
2550 type(drvd
) dtarg3(o
,m
,n
)
2568 pointer(iptr1
,dpte1(nnn
))
2569 pointer(iptr2
,dpte2(mmm
,nnn
))
2570 pointer(iptr3
,dpte3(ooo
,mmm
,nnn
))
2571 pointer(iptr4
,ipte1(nnn
))
2572 pointer(iptr5
,ipte2 (mmm
,nnn
))
2573 pointer(iptr6
,ipte3(ooo
,mmm
,nnn
))
2574 pointer(iptr7
,rpte1(nnn
))
2575 pointer(iptr8
,rpte2(mmm
,nnn
))
2576 pointer(iptr9
,rpte3(ooo
,mmm
,nnn
))
2577 pointer(iptr10
,chpte1(nnn
))
2578 pointer(iptr11
,chpte2(mmm
,nnn
))
2579 pointer(iptr12
,chpte3(ooo
,mmm
,nnn
))
2580 pointer(iptr13
,ch8pte1(nnn
))
2581 pointer(iptr14
,ch8pte2(mmm
,nnn
))
2582 pointer(iptr15
,ch8pte3(ooo
,mmm
,nnn
))
2593 iptr10
= loc(chtarg1
)
2594 iptr11
= loc(chtarg2
)
2595 iptr12
= loc(chtarg3
)
2596 iptr13
= loc(ch8targ1
)
2597 iptr14
= loc(ch8targ2
)
2598 iptr15
= loc(ch8targ3
)
2602 if (intne(dpte1(i
)%i1
, dtarg1(i
)%i1
)) then
2604 errors(293) = .true
.
2607 dtarg1(i
)%i1
=2*dpte1(i
)%i1
2608 if (intne(dpte1(i
)%i1
, dtarg1(i
)%i1
)) then
2610 errors(294) = .true
.
2614 if (intne(ipte1(i
), itarg1(i
))) then
2616 errors(295) = .true
.
2619 itarg1(i
) = -ipte1(i
)
2620 if (intne(ipte1(i
), itarg1(i
))) then
2622 errors(296) = .true
.
2626 if (realne(rpte1(i
), rtarg1(i
))) then
2628 errors(297) = .true
.
2631 rtarg1(i
) = i
* (-5.0)
2632 if (realne(rpte1(i
), rtarg1(i
))) then
2634 errors(298) = .true
.
2638 if (chne(chpte1(i
), chtarg1(i
))) then
2640 errors(299) = .true
.
2644 if (chne(chpte1(i
), chtarg1(i
))) then
2646 errors(300) = .true
.
2649 ch8pte1(i
) = 'aaaaaaaa'
2650 if (ch8ne(ch8pte1(i
), ch8targ1(i
))) then
2652 errors(301) = .true
.
2655 ch8targ1(i
) = 'zzzzzzzz'
2656 if (ch8ne(ch8pte1(i
), ch8targ1(i
))) then
2658 errors(302) = .true
.
2663 if (realne(dpte2(j
,i
)%r1
, dtarg2(j
,i
)%r1
)) then
2665 errors(303) = .true
.
2668 dtarg2(j
,i
)%r1
=2*dpte2(j
,i
)%r1
2669 if (realne(dpte2(j
,i
)%r1
, dtarg2(j
,i
)%r1
)) then
2671 errors(304) = .true
.
2675 if (intne(ipte2(j
,i
), itarg2(j
,i
))) then
2677 errors(305) = .true
.
2680 itarg2(j
,i
) = -ipte2(j
,i
)
2681 if (intne(ipte2(j
,i
), itarg2(j
,i
))) then
2683 errors(306) = .true
.
2686 rpte2(j
,i
) = i
* (-2.0)
2687 if (realne(rpte2(j
,i
), rtarg2(j
,i
))) then
2689 errors(307) = .true
.
2692 rtarg2(j
,i
) = i
* (-3.0)
2693 if (realne(rpte2(j
,i
), rtarg2(j
,i
))) then
2695 errors(308) = .true
.
2699 if (chne(chpte2(j
,i
), chtarg2(j
,i
))) then
2701 errors(309) = .true
.
2705 if (chne(chpte2(j
,i
), chtarg2(j
,i
))) then
2707 errors(310) = .true
.
2710 ch8pte2(j
,i
) = 'aaaaaaaa'
2711 if (ch8ne(ch8pte2(j
,i
), ch8targ2(j
,i
))) then
2713 errors(311) = .true
.
2716 ch8targ2(j
,i
) = 'zzzzzzzz'
2717 if (ch8ne(ch8pte2(j
,i
), ch8targ2(j
,i
))) then
2719 errors(312) = .true
.
2722 dpte3(k
,j
,i
)%i2(1+mod(i
,5))=i
2723 if (intne(dpte3(k
,j
,i
)%i2(1+mod(i
,5)), &
2724 dtarg3(k
,j
,i
)%i2(1+mod(i
,5)))) then
2726 errors(313) = .true
.
2729 dtarg3(k
,j
,i
)%i2(1+mod(i
,5))=2*dpte3(k
,j
,i
)%i2(1+mod(i
,5))
2730 if (intne(dpte3(k
,j
,i
)%i2(1+mod(i
,5)), &
2731 dtarg3(k
,j
,i
)%i2(1+mod(i
,5)))) then
2733 errors(314) = .true
.
2737 if (intne(ipte3(k
,j
,i
), itarg3(k
,j
,i
))) then
2739 errors(315) = .true
.
2742 itarg3(k
,j
,i
) = -ipte3(k
,j
,i
)
2743 if (intne(ipte3(k
,j
,i
), itarg3(k
,j
,i
))) then
2745 errors(316) = .true
.
2748 rpte3(k
,j
,i
) = i
* 2.0
2749 if (realne(rpte3(k
,j
,i
), rtarg3(k
,j
,i
))) then
2751 errors(317) = .true
.
2754 rtarg3(k
,j
,i
) = i
* 3.0
2755 if (realne(rpte3(k
,j
,i
), rtarg3(k
,j
,i
))) then
2757 errors(318) = .true
.
2761 if (chne(chpte3(k
,j
,i
), chtarg3(k
,j
,i
))) then
2763 errors(319) = .true
.
2766 chtarg3(k
,j
,i
) = 'z'
2767 if (chne(chpte3(k
,j
,i
), chtarg3(k
,j
,i
))) then
2769 errors(320) = .true
.
2772 ch8pte3(k
,j
,i
) = 'aaaaaaaa'
2773 if (ch8ne(ch8pte3(k
,j
,i
), ch8targ3(k
,j
,i
))) then
2775 errors(321) = .true
.
2778 ch8targ3(k
,j
,i
) = 'zzzzzzzz'
2779 if (ch8ne(ch8pte3(k
,j
,i
), ch8targ3(k
,j
,i
))) then
2781 errors(322) = .true
.
2794 if (intne(itarg3(k
,j
,i
), i
)) then
2796 errors(323) = .true
.
2799 if (realne(rtarg3(k
,j
,i
), i
+.5)) then
2801 errors(324) = .true
.
2806 end subroutine ptr10
2808 subroutine ptr11(nnn
,mmm
,ooo
)
2809 common /errors
/errors(400)
2810 logical :: errors
, intne
, realne
, chne
, ch8ne
2812 integer :: nnn
,mmm
,ooo
2813 integer, parameter :: n
= 9
2814 integer, parameter :: m
= 10
2815 integer, parameter :: o
= 11
2817 integer itarg2 (m
,n
)
2818 integer itarg3 (o
,m
,n
)
2822 character chtarg1(n
)
2823 character chtarg2(m
,n
)
2824 character chtarg3(o
,m
,n
)
2825 character*8 ch8targ1(n
)
2826 character*8 ch8targ2(m
,n
)
2827 character*8 ch8targ3(o
,m
,n
)
2833 type(drvd
) dtarg1(n
)
2834 type(drvd
) dtarg2(m
,n
)
2835 type(drvd
) dtarg3(o
,m
,n
)
2837 pointer(iptr1
,dpte1(nnn
))
2838 pointer(iptr2
,dpte2(mmm
,nnn
))
2839 pointer(iptr3
,dpte3(ooo
,mmm
,nnn
))
2840 pointer(iptr4
,ipte1(nnn
))
2841 pointer(iptr5
,ipte2 (mmm
,nnn
))
2842 pointer(iptr6
,ipte3(ooo
,mmm
,nnn
))
2843 pointer(iptr7
,rpte1(nnn
))
2844 pointer(iptr8
,rpte2(mmm
,nnn
))
2845 pointer(iptr9
,rpte3(ooo
,mmm
,nnn
))
2846 pointer(iptr10
,chpte1(nnn
))
2847 pointer(iptr11
,chpte2(mmm
,nnn
))
2848 pointer(iptr12
,chpte3(ooo
,mmm
,nnn
))
2849 pointer(iptr13
,ch8pte1(nnn
))
2850 pointer(iptr14
,ch8pte2(mmm
,nnn
))
2851 pointer(iptr15
,ch8pte3(ooo
,mmm
,nnn
))
2878 iptr10
= loc(chtarg1
)
2879 iptr11
= loc(chtarg2
)
2880 iptr12
= loc(chtarg3
)
2881 iptr13
= loc(ch8targ1
)
2882 iptr14
= loc(ch8targ2
)
2883 iptr15
= loc(ch8targ3
)
2887 if (intne(dpte1(i
)%i1
, dtarg1(i
)%i1
)) then
2889 errors(325) = .true
.
2892 dtarg1(i
)%i1
=2*dpte1(i
)%i1
2893 if (intne(dpte1(i
)%i1
, dtarg1(i
)%i1
)) then
2895 errors(326) = .true
.
2899 if (intne(ipte1(i
), itarg1(i
))) then
2901 errors(327) = .true
.
2904 itarg1(i
) = -ipte1(i
)
2905 if (intne(ipte1(i
), itarg1(i
))) then
2907 errors(328) = .true
.
2911 if (realne(rpte1(i
), rtarg1(i
))) then
2913 errors(329) = .true
.
2916 rtarg1(i
) = i
* (-5.0)
2917 if (realne(rpte1(i
), rtarg1(i
))) then
2919 errors(330) = .true
.
2923 if (chne(chpte1(i
), chtarg1(i
))) then
2925 errors(331) = .true
.
2929 if (chne(chpte1(i
), chtarg1(i
))) then
2931 errors(332) = .true
.
2934 ch8pte1(i
) = 'aaaaaaaa'
2935 if (ch8ne(ch8pte1(i
), ch8targ1(i
))) then
2937 errors(333) = .true
.
2940 ch8targ1(i
) = 'zzzzzzzz'
2941 if (ch8ne(ch8pte1(i
), ch8targ1(i
))) then
2943 errors(334) = .true
.
2948 if (realne(dpte2(j
,i
)%r1
, dtarg2(j
,i
)%r1
)) then
2950 errors(335) = .true
.
2953 dtarg2(j
,i
)%r1
=2*dpte2(j
,i
)%r1
2954 if (realne(dpte2(j
,i
)%r1
, dtarg2(j
,i
)%r1
)) then
2956 errors(336) = .true
.
2960 if (intne(ipte2(j
,i
), itarg2(j
,i
))) then
2962 errors(337) = .true
.
2965 itarg2(j
,i
) = -ipte2(j
,i
)
2966 if (intne(ipte2(j
,i
), itarg2(j
,i
))) then
2968 errors(338) = .true
.
2971 rpte2(j
,i
) = i
* (-2.0)
2972 if (realne(rpte2(j
,i
), rtarg2(j
,i
))) then
2974 errors(339) = .true
.
2977 rtarg2(j
,i
) = i
* (-3.0)
2978 if (realne(rpte2(j
,i
), rtarg2(j
,i
))) then
2980 errors(340) = .true
.
2984 if (chne(chpte2(j
,i
), chtarg2(j
,i
))) then
2986 errors(341) = .true
.
2990 if (chne(chpte2(j
,i
), chtarg2(j
,i
))) then
2992 errors(342) = .true
.
2995 ch8pte2(j
,i
) = 'aaaaaaaa'
2996 if (ch8ne(ch8pte2(j
,i
), ch8targ2(j
,i
))) then
2998 errors(343) = .true
.
3001 ch8targ2(j
,i
) = 'zzzzzzzz'
3002 if (ch8ne(ch8pte2(j
,i
), ch8targ2(j
,i
))) then
3004 errors(344) = .true
.
3007 dpte3(k
,j
,i
)%i2(1+mod(i
,5))=i
3008 if (intne(dpte3(k
,j
,i
)%i2(1+mod(i
,5)), &
3009 dtarg3(k
,j
,i
)%i2(1+mod(i
,5)))) then
3011 errors(345) = .true
.
3014 dtarg3(k
,j
,i
)%i2(1+mod(i
,5))=2*dpte3(k
,j
,i
)%i2(1+mod(i
,5))
3015 if (intne(dpte3(k
,j
,i
)%i2(1+mod(i
,5)), &
3016 dtarg3(k
,j
,i
)%i2(1+mod(i
,5)))) then
3018 errors(346) = .true
.
3022 if (intne(ipte3(k
,j
,i
), itarg3(k
,j
,i
))) then
3024 errors(347) = .true
.
3027 itarg3(k
,j
,i
) = -ipte3(k
,j
,i
)
3028 if (intne(ipte3(k
,j
,i
), itarg3(k
,j
,i
))) then
3030 errors(348) = .true
.
3033 rpte3(k
,j
,i
) = i
* 2.0
3034 if (realne(rpte3(k
,j
,i
), rtarg3(k
,j
,i
))) then
3036 errors(349) = .true
.
3039 rtarg3(k
,j
,i
) = i
* 3.0
3040 if (realne(rpte3(k
,j
,i
), rtarg3(k
,j
,i
))) then
3042 errors(350) = .true
.
3046 if (chne(chpte3(k
,j
,i
), chtarg3(k
,j
,i
))) then
3048 errors(351) = .true
.
3051 chtarg3(k
,j
,i
) = 'z'
3052 if (chne(chpte3(k
,j
,i
), chtarg3(k
,j
,i
))) then
3054 errors(352) = .true
.
3057 ch8pte3(k
,j
,i
) = 'aaaaaaaa'
3058 if (ch8ne(ch8pte3(k
,j
,i
), ch8targ3(k
,j
,i
))) then
3060 errors(353) = .true
.
3063 ch8targ3(k
,j
,i
) = 'zzzzzzzz'
3064 if (ch8ne(ch8pte3(k
,j
,i
), ch8targ3(k
,j
,i
))) then
3066 errors(354) = .true
.
3079 if (intne(itarg3(k
,j
,i
), i
)) then
3081 errors(355) = .true
.
3084 if (realne(rtarg3(k
,j
,i
), i
+.5)) then
3086 errors(356) = .true
.
3091 end subroutine ptr11
3093 subroutine ptr12(nnn
,mmm
,ooo
)
3094 common /errors
/errors(400)
3095 logical :: errors
, intne
, realne
, chne
, ch8ne
3097 integer :: nnn
,mmm
,ooo
3098 integer, parameter :: n
= 9
3099 integer, parameter :: m
= 10
3100 integer, parameter :: o
= 11
3102 integer itarg2 (m
,n
)
3103 integer itarg3 (o
,m
,n
)
3107 character chtarg1(n
)
3108 character chtarg2(m
,n
)
3109 character chtarg3(o
,m
,n
)
3110 character*8 ch8targ1(n
)
3111 character*8 ch8targ2(m
,n
)
3112 character*8 ch8targ3(o
,m
,n
)
3118 type(drvd
) dtarg1(n
)
3119 type(drvd
) dtarg2(m
,n
)
3120 type(drvd
) dtarg3(o
,m
,n
)
3122 pointer(iptr1
,dpte1
)
3123 pointer(iptr2
,dpte2
)
3124 pointer(iptr3
,dpte3
)
3125 pointer(iptr4
,ipte1
)
3126 pointer(iptr5
,ipte2
)
3127 pointer(iptr6
,ipte3
)
3128 pointer(iptr7
,rpte1
)
3129 pointer(iptr8
,rpte2
)
3130 pointer(iptr9
,rpte3
)
3131 pointer(iptr10
,chpte1
)
3132 pointer(iptr11
,chpte2
)
3133 pointer(iptr12
,chpte3
)
3134 pointer(iptr13
,ch8pte1
)
3135 pointer(iptr14
,ch8pte2
)
3136 pointer(iptr15
,ch8pte3
)
3138 type(drvd
) dpte1(nnn
)
3139 type(drvd
) dpte2(mmm
,nnn
)
3140 type(drvd
) dpte3(ooo
,mmm
,nnn
)
3142 integer ipte2 (mmm
,nnn
)
3143 integer ipte3 (ooo
,mmm
,nnn
)
3146 real rpte3(ooo
,mmm
,nnn
)
3147 character chpte1(nnn
)
3148 character chpte2(mmm
,nnn
)
3149 character chpte3(ooo
,mmm
,nnn
)
3150 character*8 ch8pte1(nnn
)
3151 character*8 ch8pte2(mmm
,nnn
)
3152 character*8 ch8pte3(ooo
,mmm
,nnn
)
3163 iptr10
= loc(chtarg1
)
3164 iptr11
= loc(chtarg2
)
3165 iptr12
= loc(chtarg3
)
3166 iptr13
= loc(ch8targ1
)
3167 iptr14
= loc(ch8targ2
)
3168 iptr15
= loc(ch8targ3
)
3173 if (intne(dpte1(i
)%i1
, dtarg1(i
)%i1
)) then
3175 errors(357) = .true
.
3178 dtarg1(i
)%i1
=2*dpte1(i
)%i1
3179 if (intne(dpte1(i
)%i1
, dtarg1(i
)%i1
)) then
3181 errors(358) = .true
.
3185 if (intne(ipte1(i
), itarg1(i
))) then
3187 errors(359) = .true
.
3190 itarg1(i
) = -ipte1(i
)
3191 if (intne(ipte1(i
), itarg1(i
))) then
3193 errors(360) = .true
.
3197 if (realne(rpte1(i
), rtarg1(i
))) then
3199 errors(361) = .true
.
3202 rtarg1(i
) = i
* (-5.0)
3203 if (realne(rpte1(i
), rtarg1(i
))) then
3205 errors(362) = .true
.
3209 if (chne(chpte1(i
), chtarg1(i
))) then
3211 errors(363) = .true
.
3215 if (chne(chpte1(i
), chtarg1(i
))) then
3217 errors(364) = .true
.
3220 ch8pte1(i
) = 'aaaaaaaa'
3221 if (ch8ne(ch8pte1(i
), ch8targ1(i
))) then
3223 errors(365) = .true
.
3226 ch8targ1(i
) = 'zzzzzzzz'
3227 if (ch8ne(ch8pte1(i
), ch8targ1(i
))) then
3229 errors(366) = .true
.
3234 if (realne(dpte2(j
,i
)%r1
, dtarg2(j
,i
)%r1
)) then
3236 errors(367) = .true
.
3239 dtarg2(j
,i
)%r1
=2*dpte2(j
,i
)%r1
3240 if (realne(dpte2(j
,i
)%r1
, dtarg2(j
,i
)%r1
)) then
3242 errors(368) = .true
.
3246 if (intne(ipte2(j
,i
), itarg2(j
,i
))) then
3248 errors(369) = .true
.
3251 itarg2(j
,i
) = -ipte2(j
,i
)
3252 if (intne(ipte2(j
,i
), itarg2(j
,i
))) then
3254 errors(370) = .true
.
3257 rpte2(j
,i
) = i
* (-2.0)
3258 if (realne(rpte2(j
,i
), rtarg2(j
,i
))) then
3260 errors(371) = .true
.
3263 rtarg2(j
,i
) = i
* (-3.0)
3264 if (realne(rpte2(j
,i
), rtarg2(j
,i
))) then
3266 errors(372) = .true
.
3270 if (chne(chpte2(j
,i
), chtarg2(j
,i
))) then
3272 errors(373) = .true
.
3276 if (chne(chpte2(j
,i
), chtarg2(j
,i
))) then
3278 errors(374) = .true
.
3281 ch8pte2(j
,i
) = 'aaaaaaaa'
3282 if (ch8ne(ch8pte2(j
,i
), ch8targ2(j
,i
))) then
3284 errors(375) = .true
.
3287 ch8targ2(j
,i
) = 'zzzzzzzz'
3288 if (ch8ne(ch8pte2(j
,i
), ch8targ2(j
,i
))) then
3290 errors(376) = .true
.
3293 dpte3(k
,j
,i
)%i2(1+mod(i
,5))=i
3294 if (intne(dpte3(k
,j
,i
)%i2(1+mod(i
,5)), &
3295 dtarg3(k
,j
,i
)%i2(1+mod(i
,5)))) then
3297 errors(377) = .true
.
3300 dtarg3(k
,j
,i
)%i2(1+mod(i
,5))=2*dpte3(k
,j
,i
)%i2(1+mod(i
,5))
3301 if (intne(dpte3(k
,j
,i
)%i2(1+mod(i
,5)), &
3302 dtarg3(k
,j
,i
)%i2(1+mod(i
,5)))) then
3304 errors(378) = .true
.
3308 if (intne(ipte3(k
,j
,i
), itarg3(k
,j
,i
))) then
3310 errors(379) = .true
.
3313 itarg3(k
,j
,i
) = -ipte3(k
,j
,i
)
3314 if (intne(ipte3(k
,j
,i
), itarg3(k
,j
,i
))) then
3316 errors(380) = .true
.
3319 rpte3(k
,j
,i
) = i
* 2.0
3320 if (realne(rpte3(k
,j
,i
), rtarg3(k
,j
,i
))) then
3322 errors(381) = .true
.
3325 rtarg3(k
,j
,i
) = i
* 3.0
3326 if (realne(rpte3(k
,j
,i
), rtarg3(k
,j
,i
))) then
3328 errors(382) = .true
.
3332 if (chne(chpte3(k
,j
,i
), chtarg3(k
,j
,i
))) then
3334 errors(383) = .true
.
3337 chtarg3(k
,j
,i
) = 'z'
3338 if (chne(chpte3(k
,j
,i
), chtarg3(k
,j
,i
))) then
3340 errors(384) = .true
.
3343 ch8pte3(k
,j
,i
) = 'aaaaaaaa'
3344 if (ch8ne(ch8pte3(k
,j
,i
), ch8targ3(k
,j
,i
))) then
3346 errors(385) = .true
.
3349 ch8targ3(k
,j
,i
) = 'zzzzzzzz'
3350 if (ch8ne(ch8pte3(k
,j
,i
), ch8targ3(k
,j
,i
))) then
3352 errors(386) = .true
.
3365 if (intne(itarg3(k
,j
,i
), i
)) then
3367 errors(387) = .true
.
3370 if (realne(rtarg3(k
,j
,i
), i
+.5)) then
3372 errors(388) = .true
.
3378 end subroutine ptr12
3381 subroutine ptr13(nnn
,mmm
)
3382 common /errors
/errors(400)
3383 logical :: errors
, intne
, realne
, chne
, ch8ne
3386 integer, parameter :: n
= 9
3387 integer, parameter :: m
= 10
3389 integer itarg2 (m
,n
)
3399 dimension rpte2(mmm
,nnn
)
3401 pointer(iptr4
,ipte1
)
3402 pointer(iptr5
,ipte2
)
3403 pointer(iptr7
,rpte1
)
3404 pointer(iptr8
,rpte2
)
3406 dimension ipte2(mmm
,nnn
)
3416 if (intne(ipte1(i
), itarg1(i
))) then
3418 errors(389) = .true
.
3421 itarg1(i
) = -ipte1(i
)
3422 if (intne(ipte1(i
), itarg1(i
))) then
3424 errors(390) = .true
.
3428 if (realne(rpte1(i
), rtarg1(i
))) then
3430 errors(391) = .true
.
3433 rtarg1(i
) = i
* (-5.0)
3434 if (realne(rpte1(i
), rtarg1(i
))) then
3436 errors(392) = .true
.
3441 if (intne(ipte2(j
,i
), itarg2(j
,i
))) then
3443 errors(393) = .true
.
3446 itarg2(j
,i
) = -ipte2(j
,i
)
3447 if (intne(ipte2(j
,i
), itarg2(j
,i
))) then
3449 errors(394) = .true
.
3452 rpte2(j
,i
) = i
* (-2.0)
3453 if (realne(rpte2(j
,i
), rtarg2(j
,i
))) then
3455 errors(395) = .true
.
3458 rtarg2(j
,i
) = i
* (-3.0)
3459 if (realne(rpte2(j
,i
), rtarg2(j
,i
))) then
3461 errors(396) = .true
.
3466 end subroutine ptr13
3469 ! Test the passing of pointers and pointees as parameters
3471 integer, parameter :: n
= 12
3472 integer, parameter :: m
= 13
3478 ! write(*,*) "loc(iarray)",loc(iarray)
3479 call parmptr(ipt
,iarray
,n
,m
)
3480 ! write(*,*) "loc(iptee)",loc(iptee)
3481 call parmpte(iptee
,iarray
,n
,m
)
3482 end subroutine parmtest
3484 subroutine parmptr(ipointer
,intarr
,n
,m
)
3485 common /errors
/errors(400)
3486 logical :: errors
, intne
3489 pointer (ipointer
,newpte
)
3491 ! write(*,*) "loc(newpte)",loc(newpte)
3492 ! write(*,*) "loc(intarr)",loc(intarr)
3493 ! write(*,*) "loc(newpte(1,1))",loc(newpte(1,1))
3495 ! write(*,*) "newpte(1,1)=",newpte(1,1)
3496 ! write(*,*) "intarr(1,1)=",intarr(1,1)
3500 if (intne(newpte(j
,i
),intarr(j
,i
))) then
3502 errors(397) = .true
.
3505 call donothing(newpte(j
,i
),intarr(j
,i
))
3506 intarr(j
,i
) = -newpte(j
,i
)
3507 if (intne(newpte(j
,i
),intarr(j
,i
))) then
3509 errors(398) = .true
.
3513 end subroutine parmptr
3515 subroutine parmpte(pointee
,intarr
,n
,m
)
3516 common /errors
/errors(400)
3517 logical :: errors
, intne
3519 integer pointee (m
,n
)
3520 integer intarr (m
,n
)
3521 ! write(*,*) "loc(pointee)",loc(pointee)
3522 ! write(*,*) "loc(intarr)",loc(intarr)
3523 ! write(*,*) "loc(pointee(1,1))",loc(pointee(1,1))
3525 ! write(*,*) "pointee(1,1)=",pointee(1,1)
3526 ! write(*,*) "intarr(1,1)=",intarr(1,1)
3531 if (intne(pointee(j
,i
),intarr(j
,i
))) then
3533 errors(399) = .true
.
3536 intarr(j
,i
) = 2*pointee(j
,i
)
3537 call donothing(pointee(j
,i
),intarr(j
,i
))
3538 if (intne(pointee(j
,i
),intarr(j
,i
))) then
3540 errors(400) = .true
.
3544 end subroutine parmpte
3546 ! Separate function calls to break Cray pointer-indifferent optimization
3547 logical function intne(ii
,jj
)
3554 write (*,*) ii
," doesn't equal ",jj
3558 logical function realne(r1
,r2
)
3565 write (*,*) r1
," doesn't equal ",r2
3569 logical function chne(ch1
,ch2
)
3570 character :: ch1
, ch2
3576 write (*,*) ch1
," doesn't equal ",ch2
3580 logical function ch8ne(ch1
,ch2
)
3581 character*8 :: ch1
, ch2
3587 write (*,*) ch1
," doesn't equal ",ch2
3591 subroutine donothing(ii
,jj
)
3593 integer :: ii
,jj
,foo
3602 ! print *,"Test did not run correctly"
3605 end subroutine donothing