1! Copyright (c) 2010, NVIDIA CORPORATION. All rights reserved. 2! 3! Licensed under the Apache License, Version 2.0 (the "License"); 4! you may not use this file except in compliance with the License. 5! You may obtain a copy of the License at 6! 7! http://www.apache.org/licenses/LICENSE-2.0 8! 9! Unless required by applicable law or agreed to in writing, software 10! distributed under the License is distributed on an "AS IS" BASIS, 11! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 12! See the License for the specific language governing permissions and 13! limitations under the License. 14! 15 16module shape_mod 17 18type shape 19 integer :: color 20 logical :: filled 21 integer :: x 22 integer :: y 23 !integer,pointer :: p=>null() 24contains 25 procedure :: write => write_shape 26 procedure :: draw => draw_shape 27 procedure :: func => shape_func 28end type shape 29 30type, EXTENDS ( shape ) :: rectangle 31 integer :: the_length 32 integer :: the_width 33contains 34 procedure,pass(this) :: write => write_rec 35 procedure :: draw => draw_rectangle 36end type rectangle 37 38type, extends (rectangle) :: square 39contains 40 procedure :: draw => draw_sq 41 procedure :: write => write_sq 42 procedure,pass(this) :: write2 => write_sq2 43 procedure :: write3 => write_sq3 44 45end type square 46 47type poly_data 48 class(shape),allocatable :: data 49end type poly_data 50 51contains 52 53 subroutine write_shape(this,results,i) 54 class (shape) :: this 55 logical results(:) 56 integer i 57 type(shape) :: sh 58 !results(i) = same_type_as(sh,this) 59 select type(this) 60 type is(shape) 61 results(i) = .true. 62 class default 63 results(i) = .false. 64 end select 65 end subroutine write_shape 66 67 subroutine write_rec(this,results,i) 68 class (rectangle) :: this 69 logical results(:) 70 integer i 71 type(shape) :: sh 72 !results(i) = same_type_as(sh,this) 73 select type(this) 74 type is(rectangle) 75 results(i) = .false. 76 class default 77 results(i) = .true. 78 end select 79 end subroutine write_rec 80 81 subroutine draw_shape(this,results,i) 82 class (shape) :: this 83 logical results(:) 84 integer i 85 print *, 'draw shape!' 86 end subroutine draw_shape 87 88 subroutine draw_rectangle(this,results,i) 89 class (rectangle) :: this 90 logical results(:) 91 integer i 92 type(rectangle) :: rec 93 !results(i) = extends_type_of(this,rec) 94 select type (this) 95 class is (rectangle) 96 results(i) = .true. 97 class default 98 results(i) = .false. 99 end select 100 end subroutine draw_rectangle 101 102 subroutine write_sq(this,results,i) 103 class (square) :: this 104 logical results(:) 105 integer i 106 type(rectangle) :: rec 107 !results(i) = extends_type_of(this,rec) 108 select type (this) 109 type is (square) 110 results(i) = .true. 111 class default 112 results(i) = .false. 113 end select 114 end subroutine write_sq 115 116 subroutine draw_sq(this,results,i) 117 class (square) :: this 118 logical results(:) 119 integer i 120 type(rectangle) :: rec 121 print *, 'draw sq' 122 !results(i) = extends_type_of(this,rec) 123 select type (this) 124 class is (square) 125 results(i) = .true. 126 class default 127 results(i) = .false. 128 end select 129 end subroutine draw_sq 130 131 subroutine write_sq2(i,this,results) 132 class (square) :: this 133 integer i 134 logical results(:) 135 type(rectangle) :: rec 136 !results(i) = extends_type_of(this,rec) 137 select type (this) 138 class is (square) 139 results(i) = .true. 140 class default 141 results(i) = .false. 142 end select 143 end subroutine write_sq2 144 145 logical function write_sq3(this) 146 class (square) :: this 147 type(rectangle) :: rec 148 !write_sq3 = extends_type_of(this,rec) 149 print *, 'write_sq3' 150 select type (this) 151 class is (square) 152 write_sq3 = .true. 153 class default 154 write_sq3 = .false. 155 end select 156 end function 157 158 logical function shape_func(this) result(RSLT) 159 class(shape) :: this 160 print *, 'shape func',this%color 161 162 select type (z=>this) 163 class is (rectangle) 164 z%color = -1 165 z%the_width = 66 166 rslt = .true. 167 class default 168 rslt = .false. 169 end select 170 171 print *, 'shape func',this%color 172 end function 173 174 175end module shape_mod 176 177program p 178USE CHECK_MOD 179use shape_mod 180 181logical l 182logical results(8) 183logical expect(8) 184class(square),allocatable :: s 185class(shape),allocatable :: sh 186type(rectangle) :: r 187type(square),allocatable :: sq 188type(poly_data) :: pd 189 190results = .false. 191expect = .true. 192 193allocate(s) 194call s%write2(1,results) 195call s%write(results,2) 196call s%draw(results,3) 197 198allocate(sq) 199results(5) = sq%write3() 200 201allocate(sh) 202call write_shape(sh,results,4) 203 204 205allocate(square::pd%data) 206 207pd%data%y = 99 208select type(pds => pd%data) 209class is (rectangle) 210pds%y = 101 211results(6) = .true. 212class default 213results(6) = .false. 214end select 215 216pd%data%color = 77 217results(8) = pd%data%func() 218 219select type(pds => pd%data) 220type is (square) 221results(7) = pds%write3() 222end select 223 224call check(results,expect,8) 225 226end 227 228 229