| Line | Branch | Exec | Source |
|---|---|---|---|
| 1 | submodule(athena__misc_types) athena__misc_types_submodule | ||
| 2 | !! Submodule containing implementations for derived types | ||
| 3 | use coreutils, only: stop_program, print_warning | ||
| 4 | |||
| 5 | |||
| 6 | |||
| 7 | contains | ||
| 8 | |||
| 9 | !############################################################################### | ||
| 10 | − | pure module function create_attribute(name, type, val) result(attribute) | |
| 11 | !! Function to create an ONNX attribute | ||
| 12 | implicit none | ||
| 13 | |||
| 14 | ! Arguments | ||
| 15 | character(*), intent(in) :: name | ||
| 16 | !! Name of the attribute | ||
| 17 | character(*), intent(in) :: type | ||
| 18 | !! Type of the attribute | ||
| 19 | character(*), intent(in) :: val | ||
| 20 | !! Value of the attribute as a string | ||
| 21 | |||
| 22 | type(onnx_attribute_type) :: attribute | ||
| 23 | !! Resulting ONNX attribute | ||
| 24 | |||
| 25 | − | if(len_trim(name) .gt. 64)then | |
| 26 | − | attribute%name = name(1:64) | |
| 27 | else | ||
| 28 | − | attribute%name = trim(name) | |
| 29 | end if | ||
| 30 | |||
| 31 | − | if(len_trim(type) .gt. 10)then | |
| 32 | − | attribute%type = type(1:10) | |
| 33 | else | ||
| 34 | − | attribute%type = trim(type) | |
| 35 | end if | ||
| 36 | |||
| 37 | − | attribute%val = trim(val) | |
| 38 | − | end function create_attribute | |
| 39 | !############################################################################### | ||
| 40 | |||
| 41 | |||
| 42 | !############################################################################### | ||
| 43 | − | module subroutine print_to_unit_actv(this, unit, identifier) | |
| 44 | !! Interface for printing activation function details | ||
| 45 | implicit none | ||
| 46 | |||
| 47 | ! Arguments | ||
| 48 | class(base_actv_type), intent(in) :: this | ||
| 49 | !! Instance of the activation type | ||
| 50 | integer, intent(in) :: unit | ||
| 51 | !! Unit number for output | ||
| 52 | character(*), intent(in), optional :: identifier | ||
| 53 | !! Optional identifier for the activation function | ||
| 54 | |||
| 55 | ! Local variables | ||
| 56 | integer :: i | ||
| 57 | !! Loop index | ||
| 58 | − | type(onnx_attribute_type), allocatable, dimension(:) :: attributes | |
| 59 | !! Array of ONNX attributes | ||
| 60 | |||
| 61 | |||
| 62 | − | attributes = this%export_attributes() | |
| 63 | |||
| 64 | − | if(present(identifier)) then | |
| 65 | − | write(unit,'(3X,"ACTIVATION: ",A)') trim(identifier) | |
| 66 | else | ||
| 67 | − | write(unit,'(3X,"ACTIVATION")') | |
| 68 | end if | ||
| 69 | − | do i = 1, size(attributes) | |
| 70 | write(unit,'(6X,A," = ",A)') & | ||
| 71 | − | trim(attributes(i)%name), trim(attributes(i)%val) | |
| 72 | end do | ||
| 73 | − | write(unit,'(3X,"END ACTIVATION")') | |
| 74 | |||
| 75 | − | end subroutine print_to_unit_actv | |
| 76 | !############################################################################### | ||
| 77 | |||
| 78 | |||
| 79 | !############################################################################### | ||
| 80 | − | module subroutine setup_bounds(this, length, pad, imethod) | |
| 81 | !! Set up replication bounds for facets | ||
| 82 | implicit none | ||
| 83 | |||
| 84 | ! Arguments | ||
| 85 | class(facets_type), intent(inout) :: this | ||
| 86 | !! Instance of the facets type | ||
| 87 | integer, dimension(this%rank), intent(in) :: length, pad | ||
| 88 | !! Length of the shape and padding | ||
| 89 | integer, intent(in) :: imethod | ||
| 90 | !! Method for padding: | ||
| 91 | !! 3 - circular, 4 - reflection, 5 - replication | ||
| 92 | |||
| 93 | ! Local variables | ||
| 94 | integer :: i, j, k, l, facet_idx, idim | ||
| 95 | !! Loop indices and facet index | ||
| 96 | logical :: btest_k0, btest_k1 | ||
| 97 | !! Binary test variables for edge cases | ||
| 98 | |||
| 99 | |||
| 100 | ! Calculate number of facets based on rank and number of fixed dimensions | ||
| 101 | !--------------------------------------------------------------------------- | ||
| 102 | ! For rank n, we have: | ||
| 103 | ! nfixed_dims = 1: n choose 1 * 2 facets (faces, 2 per dimension) | ||
| 104 | ! nfixed_dims = 2: n choose 2 * 4 facets (edges, 4 per dimension pair) | ||
| 105 | ! nfixed_dims = 3: n choose 3 * 8 facets (corners, 8 for 3D) | ||
| 106 | − | select case(this%nfixed_dims) | |
| 107 | case(1) | ||
| 108 | − | this%type = "face" | |
| 109 | − | this%num = 2 * this%rank | |
| 110 | case(2) | ||
| 111 | − | this%type = "edge" | |
| 112 | this%num = 4 * nint( & | ||
| 113 | gamma(real(this%rank + 1)) / ( & | ||
| 114 | gamma(2.0 + 1.0) * gamma(real(this%rank - 2 + 1)) & | ||
| 115 | ) & | ||
| 116 | − | ) | |
| 117 | case(3) | ||
| 118 | − | this%type = "corner" | |
| 119 | − | this%num = 8 | |
| 120 | case default | ||
| 121 | − | call stop_program("Invalid number of fixed dimensions") | |
| 122 | − | return | |
| 123 | end select | ||
| 124 | − | if(this%rank .lt. this%nfixed_dims) then | |
| 125 | − | call stop_program("Number of fixed dimensions exceeds rank") | |
| 126 | − | return | |
| 127 | end if | ||
| 128 | |||
| 129 | |||
| 130 | ! Allocate arrays | ||
| 131 | !--------------------------------------------------------------------------- | ||
| 132 | − | if (allocated(this%dim)) deallocate(this%dim) | |
| 133 | − | if (allocated(this%orig_bound)) deallocate(this%orig_bound) | |
| 134 | − | if (allocated(this%dest_bound)) deallocate(this%dest_bound) | |
| 135 | |||
| 136 | − | allocate(this%dim(this%num)) | |
| 137 | − | allocate(this%orig_bound(2, this%rank, this%num)) | |
| 138 | − | allocate(this%dest_bound(2, this%rank, this%num)) | |
| 139 | |||
| 140 | |||
| 141 | ! Initialise all bounds to 1 | ||
| 142 | !--------------------------------------------------------------------------- | ||
| 143 | − | this%orig_bound = 1 | |
| 144 | |||
| 145 | ! Set up replication bounds | ||
| 146 | !--------------------------------------------------------------------------- | ||
| 147 | − | select case(this%nfixed_dims) | |
| 148 | case(1) ! Faces | ||
| 149 | − | facet_idx = 0 | |
| 150 | − | do i = 1, this%rank | |
| 151 | − | do j = 1, 2 ! Two faces per dimension | |
| 152 | − | facet_idx = facet_idx + 1 | |
| 153 | − | this%dim(facet_idx) = i | |
| 154 | − | do l = 1, this%rank | |
| 155 | − | this%orig_bound(:,l,facet_idx) = [ 1, length(l) ] | |
| 156 | − | this%dest_bound(:,l,facet_idx) = [ pad(l) + 1, pad(l) + length(l) ] | |
| 157 | end do | ||
| 158 | |||
| 159 | ! Set origin bounds | ||
| 160 | − | select case(imethod) | |
| 161 | case(3) ! circular | ||
| 162 | − | if(j .eq. 1) then | |
| 163 | − | this%orig_bound(:,i,facet_idx) = & | |
| 164 | − | [ length(i) - pad(i) + 1, length(i) ] | |
| 165 | else | ||
| 166 | − | this%orig_bound(:,i,facet_idx) = [ 1, pad(i) ] | |
| 167 | end if | ||
| 168 | case(4) ! reflection | ||
| 169 | − | if(j .eq. 1) then | |
| 170 | − | this%orig_bound(:,i,facet_idx) = [ pad(i) + 1, 2 ] | |
| 171 | else | ||
| 172 | − | this%orig_bound(:,i,facet_idx) = & | |
| 173 | − | [ length(i) - 1, length(i) - pad(i) ] | |
| 174 | end if | ||
| 175 | case(5) ! replication | ||
| 176 | − | if(j .ne. 1) this%orig_bound(:,i,facet_idx) = length(i) | |
| 177 | end select | ||
| 178 | |||
| 179 | ! Set destination bounds | ||
| 180 | − | if(j .eq. 1) then | |
| 181 | − | this%dest_bound(:,i,facet_idx) = [1, pad(i)] | |
| 182 | else | ||
| 183 | − | this%dest_bound(:,i,facet_idx) = & | |
| 184 | − | [length(i) + pad(i) + 1, length(i) + pad(i) * 2] | |
| 185 | end if | ||
| 186 | end do | ||
| 187 | end do | ||
| 188 | case(2) ! Edges | ||
| 189 | − | facet_idx = 0 | |
| 190 | − | idim = 0 | |
| 191 | − | do j = this%rank, 2, -1 | |
| 192 | − | do i = j-1, 1, -1 | |
| 193 | − | idim = idim + 1 | |
| 194 | − | do k = 0, 3 ! Four combinations per dimension pair | |
| 195 | − | facet_idx = facet_idx + 1 | |
| 196 | − | this%dim(facet_idx) = idim | |
| 197 | − | btest_k0 = btest(k,0) | |
| 198 | − | btest_k1 = btest(k,1) | |
| 199 | − | do l = 1, this%rank | |
| 200 | − | this%orig_bound(:,l,facet_idx) = [ 1, length(l) ] | |
| 201 | − | this%dest_bound(:,l,facet_idx) = [ pad(l) + 1, pad(l) + length(l) ] | |
| 202 | end do | ||
| 203 | |||
| 204 | ! Set original bounds using binary pattern | ||
| 205 | − | select case(imethod) | |
| 206 | case(3) ! circular | ||
| 207 | − | if(btest_k1) then | |
| 208 | − | this%orig_bound(:,i,facet_idx) = & | |
| 209 | − | [ 1, pad(i) ] | |
| 210 | else | ||
| 211 | − | this%orig_bound(:,i,facet_idx) = & | |
| 212 | − | [ length(i) - pad(i) + 1, length(i) ] | |
| 213 | end if | ||
| 214 | − | if(btest_k0) then | |
| 215 | − | this%orig_bound(:,j,facet_idx) = & | |
| 216 | − | [ 1, pad(j) ] | |
| 217 | else | ||
| 218 | − | this%orig_bound(:,j,facet_idx) = & | |
| 219 | − | [ length(j) - pad(j) + 1, length(j) ] | |
| 220 | end if | ||
| 221 | case(4) ! reflection | ||
| 222 | − | this%orig_bound(:,i,facet_idx) = & | |
| 223 | − | [ length(i) - 1, length(i) - pad(i) ] | |
| 224 | − | this%orig_bound(:,j,facet_idx) = & | |
| 225 | − | [ length(j) - 1, length(j) - pad(j) ] | |
| 226 | case(5) ! replication | ||
| 227 | − | if(btest_k1) this%orig_bound(:,i,facet_idx) = length(i) | |
| 228 | − | if(btest_k0) this%orig_bound(:,j,facet_idx) = length(j) | |
| 229 | end select | ||
| 230 | |||
| 231 | ! Set destination bounds | ||
| 232 | − | this%dest_bound(:,i,facet_idx) = & | |
| 233 | merge(& | ||
| 234 | − | [ length(i) + pad(i) + 1, length(i) + pad(i) * 2 ], & | |
| 235 | − | [ 1, pad(i) ], & | |
| 236 | btest_k1 & | ||
| 237 | − | ) | |
| 238 | − | this%dest_bound(:,j,facet_idx) = & | |
| 239 | merge( & | ||
| 240 | − | [ length(j) + pad(j) + 1, length(j) + pad(j) * 2 ], & | |
| 241 | − | [ 1, pad(j) ], & | |
| 242 | btest_k0 & | ||
| 243 | − | ) | |
| 244 | end do | ||
| 245 | end do | ||
| 246 | end do | ||
| 247 | case(3) ! Corners (3D only) | ||
| 248 | − | do i = 1, 8 | |
| 249 | − | this%dim(i) = 0 ! All dimensions are fixed | |
| 250 | ! Use binary pattern for all three dimensions | ||
| 251 | − | do j = 1, this%rank | |
| 252 | − | if(btest(i-1, this%rank-j)) then | |
| 253 | − | this%orig_bound(:,j,i) = length(j) | |
| 254 | − | this%dest_bound(:,j,i) = & | |
| 255 | − | [ length(j) + pad(j) + 1, length(j) + pad(j) * 2 ] | |
| 256 | else | ||
| 257 | − | this%orig_bound(:,j,i) = 1 | |
| 258 | − | this%dest_bound(:,j,i) = [1, pad(j)] | |
| 259 | end if | ||
| 260 | end do | ||
| 261 | end do | ||
| 262 | end select | ||
| 263 | |||
| 264 | end subroutine setup_bounds | ||
| 265 | !############################################################################### | ||
| 266 | |||
| 267 | end submodule athena__misc_types_submodule | ||
| 268 |