1#ifdef COMMENTS
2! For LICENSE, see README.md
3#endif
4#include "settings.inc"
5subroutine ROUTINE(assign_set,VAR)(this,rhs,dealloc)
6  type(variable_t), intent(inout) :: this
7  VAR_TYPE, intent(in)DIMS :: rhs
8  logical, intent(in), optional :: dealloc
9  logical :: ldealloc
10  type :: pt
11    VAR_TYPE, pointer DIMS :: p => null()
12  end type
13  type(pt) :: p
14  ! ASSIGNMENT in fortran is per default destructive
15  ldealloc = .true.
16  if(present(dealloc))ldealloc = dealloc
17  if (ldealloc) then
18     call delete(this)
19  else
20     call nullify(this)
21  end if
22  ! With pointer transfer we need to deallocate
23  ! else bounds might change...
24  this%t = STR(VAR)
25  ALLOC(p%p,rhs) ! allocate space
26  p%p = rhs ! copy data over
27  allocate(this%enc(size(transfer(p, local_enc_type)))) ! allocate encoding
28  this%enc(:) = transfer(p, local_enc_type) ! transfer pointer type to the encoding
29  ! We already have shipped it
30  nullify(p%p)
31end subroutine ROUTINE(assign_set,VAR)
32
33subroutine ROUTINE(assign_get,VAR)(lhs,this,success)
34  VAR_TYPE, intent(out)DIMS :: lhs
35  type(variable_t), intent(in) :: this
36  logical, intent(out), optional :: success
37  logical :: lsuccess
38  type :: pt
39    VAR_TYPE, pointer DIMS :: p => null()
40  end type
41  type(pt) :: p
42  lsuccess = this%t == STR(VAR)
43#if DIM > 0
44  if (lsuccess) then
45    p = transfer(this%enc,p) ! retrieve pointer encoding
46    lsuccess = all(shape(p%p)==shape(lhs))   !&
47     !     .and. all((lbound(p%p) == lbound(lhs))) &
48     !     .and. all((ubound(p%p) == ubound(lhs)))
49
50  end if
51#endif
52  if (present(success)) success = lsuccess
53  if (.not. lsuccess) return
54#if DIM == 0
55  p = transfer(this%enc,p) ! retrieve pointer encoding
56#endif
57  lhs = p%p
58end subroutine ROUTINE(assign_get,VAR)
59
60subroutine ROUTINE(associate_get,VAR)(lhs,this,dealloc,success)
61  VAR_TYPE, pointer DIMS :: lhs
62  type(variable_t), intent(in) :: this
63  logical, intent(in), optional :: dealloc
64  logical, intent(out), optional :: success
65  logical :: ldealloc, lsuccess
66  type :: pt
67    VAR_TYPE, pointer DIMS :: p => null()
68  end type
69  type(pt) :: p
70  lsuccess = this%t == STR(VAR)
71  if (present(success)) success = lsuccess
72  ! ASSOCIATION in fortran is per default non-destructive
73  ldealloc = .false.
74  if(present(dealloc))ldealloc = dealloc
75  ! there is one problem, say if lhs is not nullified...
76  if (ldealloc.and.associated(lhs)) then
77     deallocate(lhs)
78     nullify(lhs)
79  end if
80  if (.not. lsuccess ) return
81  p = transfer(this%enc,p) ! retrieve pointer encoding
82  lhs => p%p
83end subroutine ROUTINE(associate_get,VAR)
84subroutine ROUTINE(associate_set,VAR)(this,rhs,dealloc)
85  type(variable_t), intent(inout) :: this
86#ifdef COMMENTS
87  ! Setting the intent(inout) ensures that no constants
88  ! will be able to be passed.
89  ! However, the dictionary type does not allow
90  ! this due to OPERATORS, hence we keep it as this
91  ! and proclaim that any user creating a pointer
92  ! to a constant is insane...
93#endif
94  VAR_TYPE, intent(in)DIMS, target :: rhs
95  logical, intent(in), optional :: dealloc
96  logical :: ldealloc
97  type :: pt
98    VAR_TYPE, pointer DIMS :: p => null()
99  end type
100  type(pt) :: p
101  ! ASSOCIATION in fortran is per default non-destructive
102  ldealloc = .false.
103  if(present(dealloc))ldealloc = dealloc
104  if (ldealloc) then
105     call delete(this)
106  else
107     call nullify(this)
108  end if
109  this%t = STR(VAR)
110  p%p => rhs
111  allocate(this%enc(size(transfer(p, local_enc_type)))) ! allocate encoding
112  this%enc(:) = transfer(p, local_enc_type) ! transfer pointer type to the encoding
113end subroutine ROUTINE(associate_set,VAR)
114
115pure function ROUTINE(associatd_l,VAR)(lhs,this) result(ret)
116  VAR_TYPE, pointer DIMS :: lhs
117  type(variable_t), intent(in) :: this
118  logical :: ret
119  type :: pt
120    VAR_TYPE, pointer DIMS :: p
121  end type
122  type(pt) :: p
123  ret = this%t == STR(VAR)
124  if (ret) then
125     nullify(p%p)
126     p = transfer(this%enc,p)
127     ret = associated(lhs,p%p)
128  endif
129end function ROUTINE(associatd_l,VAR)
130pure function ROUTINE(associatd_r,VAR)(this,rhs) result(ret)
131  type(variable_t), intent(in) :: this
132  VAR_TYPE, pointer DIMS :: rhs
133  logical :: ret
134  type :: pt
135    VAR_TYPE, pointer DIMS :: p
136  end type
137  type(pt) :: p
138  ret = this%t == STR(VAR)
139  if (ret) then
140     nullify(p%p)
141     p = transfer(this%enc,p)
142     ret = associated(p%p,rhs)
143  endif
144end function ROUTINE(associatd_r,VAR)
145
146! All boolean functions
147#ifdef BOOLEANS
148function ROUTINE(eq_l,VAR)(this,rhs) result(ret)
149  type(variable_t), intent(in) :: this
150  VAR_TYPE, intent(in)DIMS :: rhs
151  logical :: ret
152  ret = this%t == STR(VAR)
153  if (.not. ret) return
154  ret = all(THIS(VAR) == rhs)
155end function ROUTINE(eq_l,VAR)
156
157function ROUTINE(eq_r,VAR)(lhs,this) result(ret)
158  VAR_TYPE, intent(in)DIMS :: lhs
159  type(variable_t), intent(in) :: this
160  logical :: ret
161  ret = this == lhs
162end function ROUTINE(eq_r,VAR)
163
164function ROUTINE(ne_l,VAR)(this,rhs) result(ret)
165  type(variable_t), intent(in) :: this
166  VAR_TYPE, intent(in)DIMS :: rhs
167  logical :: ret
168  ret = .not. this == rhs
169end function ROUTINE(ne_l,VAR)
170
171function ROUTINE(ne_r,VAR)(lhs,this) result(ret)
172  VAR_TYPE, intent(in)DIMS :: lhs
173  type(variable_t), intent(in) :: this
174  logical :: ret
175  ret = .not. this == lhs
176end function ROUTINE(ne_r,VAR)
177
178function ROUTINE(gt_l,VAR)(this,rhs) result(ret)
179  type(variable_t), intent(in) :: this
180  VAR_TYPE, intent(in)DIMS :: rhs
181  logical :: ret
182  ret = this%t == STR(VAR)
183  if (.not. ret) return
184  ret = all(THIS(VAR) > rhs)
185end function ROUTINE(gt_l,VAR)
186function ROUTINE(gt_r,VAR)(lhs,this) result(ret)
187  VAR_TYPE, intent(in)DIMS :: lhs
188  type(variable_t), intent(in) :: this
189  logical :: ret
190  ret = this%t == STR(VAR)
191  if (.not. ret) return
192  ret = all(lhs > THIS(VAR))
193end function ROUTINE(gt_r,VAR)
194
195function ROUTINE(lt_l,VAR)(this,rhs) result(ret)
196  type(variable_t), intent(in) :: this
197  VAR_TYPE, intent(in)DIMS :: rhs
198  logical :: ret
199  ret = rhs > this
200end function ROUTINE(lt_l,VAR)
201function ROUTINE(lt_r,VAR)(lhs,this) result(ret)
202  VAR_TYPE, intent(in)DIMS :: lhs
203  type(variable_t), intent(in) :: this
204  logical :: ret
205  ret = this > lhs
206end function ROUTINE(lt_r,VAR)
207
208function ROUTINE(ge_l,VAR)(this,rhs) result(ret)
209  type(variable_t), intent(in) :: this
210  VAR_TYPE, intent(in)DIMS :: rhs
211  logical :: ret
212  ret = .not. this < rhs
213end function ROUTINE(ge_l,VAR)
214function ROUTINE(ge_r,VAR)(lhs,this) result(ret)
215  VAR_TYPE, intent(in)DIMS :: lhs
216  type(variable_t), intent(in) :: this
217  logical :: ret
218  ret = .not. lhs < this
219end function ROUTINE(ge_r,VAR)
220
221function ROUTINE(le_l,VAR)(this,rhs) result(ret)
222  type(variable_t), intent(in) :: this
223  VAR_TYPE, intent(in)DIMS :: rhs
224  logical :: ret
225  ret = .not. this > rhs
226end function ROUTINE(le_l,VAR)
227function ROUTINE(le_r,VAR)(lhs,this) result(ret)
228  VAR_TYPE, intent(in)DIMS :: lhs
229  type(variable_t), intent(in) :: this
230  logical :: ret
231  ret = .not. lhs > this
232end function ROUTINE(le_r,VAR)
233#endif
234