summaryrefslogtreecommitdiff
path: root/gcc/testsuite/gfortran.dg/class_37.f03
blob: f951ea1f8e01833ef9b958e8a52fdba20c74325a (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
! { dg-do compile }
! Test fix for PR47082, in which an ICE in the ALLOCATE at line 248.
!
! Contributed by Salvatore Filippone  <salvatore.filippone@uniroma2.it>
!
module psb_penv_mod

  interface psb_init
    module procedure  psb_init
  end interface

  interface psb_exit
    module procedure  psb_exit
  end interface

  interface psb_info
    module procedure psb_info
  end interface

  integer, private, save :: nctxt=0



contains


  subroutine psb_init(ictxt,np,basectxt,ids)
    implicit none 
    integer, intent(out) :: ictxt
    integer, intent(in), optional :: np, basectxt, ids(:)


    ictxt = nctxt
    nctxt = nctxt + 1

  end subroutine psb_init

  subroutine psb_exit(ictxt,close)
    implicit none 
    integer, intent(inout) :: ictxt
    logical, intent(in), optional :: close

    nctxt = max(0, nctxt - 1)    

  end subroutine psb_exit


  subroutine psb_info(ictxt,iam,np)

    implicit none 

    integer, intent(in)  :: ictxt
    integer, intent(out) :: iam, np

    iam = 0
    np  = 1

  end subroutine psb_info


end module psb_penv_mod


module psb_indx_map_mod

  type      :: psb_indx_map

    integer :: state          = -1
    integer :: ictxt          = -1
    integer :: mpic           = -1
    integer :: global_rows    = -1
    integer :: global_cols    = -1
    integer :: local_rows     = -1
    integer :: local_cols     = -1


  end type psb_indx_map

end module psb_indx_map_mod



module psb_gen_block_map_mod
  use psb_indx_map_mod
  
  type, extends(psb_indx_map) :: psb_gen_block_map
    integer :: min_glob_row   = -1
    integer :: max_glob_row   = -1
    integer, allocatable :: loc_to_glob(:), srt_l2g(:,:), vnl(:)
  contains

    procedure, pass(idxmap)  :: gen_block_map_init => block_init

  end type psb_gen_block_map

  private ::  block_init

contains

  subroutine block_init(idxmap,ictxt,nl,info)
    use psb_penv_mod
    implicit none 
    class(psb_gen_block_map), intent(inout) :: idxmap
    integer, intent(in)  :: ictxt, nl
    integer, intent(out) :: info
    !  To be implemented
    integer :: iam, np, i, j, ntot
    integer, allocatable :: vnl(:)

    info = 0
    call psb_info(ictxt,iam,np) 
    if (np < 0) then 
      info = -1
      return
    end if
    
    allocate(vnl(0:np),stat=info)
    if (info /= 0)  then
      info = -2
      return
    end if
    
    vnl(:)   = 0
    vnl(iam) = nl
    ntot = sum(vnl)
    vnl(1:np) = vnl(0:np-1)
    vnl(0) = 0
    do i=1,np
      vnl(i) = vnl(i) + vnl(i-1)
    end do
    if (ntot /= vnl(np)) then 
! !$      write(0,*) ' Mismatch in block_init ',ntot,vnl(np)
    end if
    
    idxmap%global_rows  = ntot
    idxmap%global_cols  = ntot
    idxmap%local_rows   = nl
    idxmap%local_cols   = nl
    idxmap%ictxt        = ictxt
    idxmap%state        = 1

    idxmap%min_glob_row = vnl(iam)+1
    idxmap%max_glob_row = vnl(iam+1) 
    call move_alloc(vnl,idxmap%vnl)
    allocate(idxmap%loc_to_glob(nl),stat=info) 
    if (info /= 0)  then
      info = -2
      return
    end if
    
  end subroutine block_init

end module psb_gen_block_map_mod


module psb_descriptor_type
  use psb_indx_map_mod

  implicit none


  type psb_desc_type
    integer, allocatable  :: matrix_data(:)
    integer, allocatable  :: halo_index(:)
    integer, allocatable  :: ext_index(:)
    integer, allocatable  :: ovrlap_index(:)
    integer, allocatable  :: ovrlap_elem(:,:)
    integer, allocatable  :: ovr_mst_idx(:)
    integer, allocatable  :: bnd_elem(:)
    class(psb_indx_map), allocatable :: indxmap
    integer, allocatable  :: lprm(:)
    type(psb_desc_type), pointer     :: base_desc => null()
    integer, allocatable  :: idx_space(:)
  end type psb_desc_type


end module psb_descriptor_type

module psb_cd_if_tools_mod

  use psb_descriptor_type
  use psb_gen_block_map_mod

  interface psb_cdcpy
    subroutine psb_cdcpy(desc_in, desc_out, info)
      use psb_descriptor_type

      implicit none
      !....parameters...

      type(psb_desc_type), intent(in)  :: desc_in
      type(psb_desc_type), intent(out) :: desc_out
      integer, intent(out)             :: info
    end subroutine psb_cdcpy
  end interface


end module psb_cd_if_tools_mod

module psb_cd_tools_mod

  use psb_cd_if_tools_mod

  interface psb_cdall

    subroutine psb_cdall(ictxt, desc, info,mg,ng,vg,vl,flag,nl,repl, globalcheck)
      use psb_descriptor_type
      implicit None
      Integer, intent(in)               :: mg,ng,ictxt, vg(:), vl(:),nl
      integer, intent(in)               :: flag
      logical, intent(in)               :: repl, globalcheck
      integer, intent(out)              :: info
      type(psb_desc_type), intent(out)  :: desc
      
      optional :: mg,ng,vg,vl,flag,nl,repl, globalcheck
    end subroutine psb_cdall
   
  end interface

end module psb_cd_tools_mod
module psb_base_tools_mod
  use psb_cd_tools_mod
end module psb_base_tools_mod

subroutine psb_cdall(ictxt, desc, info,mg,ng,vg,vl,flag,nl,repl, globalcheck)
  use psb_descriptor_type
  use psb_gen_block_map_mod
  use psb_base_tools_mod, psb_protect_name => psb_cdall
  implicit None
  Integer, intent(in)               :: mg,ng,ictxt, vg(:), vl(:),nl
  integer, intent(in)               :: flag
  logical, intent(in)               :: repl, globalcheck
  integer, intent(out)              :: info
  type(psb_desc_type), intent(out)  :: desc

  optional :: mg,ng,vg,vl,flag,nl,repl, globalcheck
  integer :: err_act, n_, flag_, i, me, np, nlp, nnv, lr
  integer, allocatable :: itmpsz(:) 



  info = 0
  desc%base_desc => null() 
  if (allocated(desc%indxmap)) then 
    write(0,*) 'Allocated on an intent(OUT) var?'
  end if

  allocate(psb_gen_block_map :: desc%indxmap, stat=info)
  if (info == 0) then 
    select type(aa => desc%indxmap) 
    type is (psb_gen_block_map) 
      call aa%gen_block_map_init(ictxt,nl,info)
    class default 
        ! This cannot happen 
      info = -1
    end select
  end if

  return

end subroutine psb_cdall