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