1!*** Copyright (c) 1998-2019, 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! Test recursive calls with pointer arguments 16! 17module factorize 18 type factors 19 integer :: x 20 type(factors),pointer:: left,right 21 end type 22contains 23 recursive subroutine factor(p,n) 24 type(factors),pointer:: p 25 integer n 26 integer i,j 27 allocate(p) 28 p%x = n 29 nullify(p%left) 30 nullify(p%right) 31 do i = int(dsqrt(dble(n))),2,-1 32 j = n/i 33 if( j*i .eq. n )then 34 call factor( p%left, j ) 35 call factor( p%right, i ) 36 return 37 endif 38 enddo 39 end subroutine 40 recursive subroutine fill( p, x, i ) 41 type(factors) :: p 42 integer x(:),i 43 if( associated(p%left) .and. associated(p%right) )then 44 call fill( p%left, x, i ) 45 call fill( p%right, x, i ) 46 else if( associated(p%left) .or. associated(p%right) )then 47 print *,'fill: error at ',p%x 48 print *,associated(p%left), ' = associated(p%left)' 49 print *,associated(p%right), ' = associated(p%right)' 50 else 51 i = i + 1 52 x(i) = p%x 53 endif 54 end subroutine 55 recursive function count( p ) result(res) 56 type(factors) :: p 57 integer :: res 58 if( associated(p%left) .and. associated(p%right) )then 59 res = count( p%left ) 60 res = res + count( p%right ) 61 else if( associated(p%left) .or. associated(p%right) )then 62 print *,'count: error at ',p%x 63 print *,associated(p%left), ' = associated(p%left)' 64 print *,associated(p%right), ' = associated(p%right)' 65 res = 0 66 else 67 res = 1 68 endif 69 end function 70end module 71 use factorize 72 type(factors),pointer:: f 73 integer,allocatable::x(:) 74 integer values(5), nn 75 data values / 77, 100, 31, 128, 362880 / 76 integer result(10), expect(10) 77 data expect / 77, 2, 100, 4, 31, 1, 128, 7, 362880, 13 / 78 do i = 1,5 79 call factor( f, values(i) ) 80 n = count( f ) 81 allocate (x(n)) 82 nn = 0 83 call fill( f, x, nn ) 84! print *,x 85 nn = product(x) 86 if( nn .ne. values(i) )then 87 print *,nn,' is result, should be ',values(i) 88 endif 89! print *,nn,n 90 result(2*i-1) = nn 91 result(2*i) = n 92 deallocate (x) !4/16/2000 - can't allocate if already allocated. 93 enddo 94 call check( result, expect, 10 ) 95end 96