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