[8] | 1 | MODULE mod_field_group |
---|
| 2 | |
---|
| 3 | USE mod_field |
---|
| 4 | USE mod_xmlio_parameters |
---|
| 5 | |
---|
| 6 | IMPLICIT NONE |
---|
| 7 | |
---|
| 8 | TYPE field_group |
---|
| 9 | CHARACTER(LEN=str_len) :: id |
---|
| 10 | LOGICAL :: has_id |
---|
| 11 | TYPE(vector_field_group), POINTER :: groups |
---|
| 12 | TYPE(vector_field),POINTER :: fields |
---|
| 13 | TYPE(field), POINTER :: default_attribut |
---|
| 14 | END TYPE field_group |
---|
| 15 | |
---|
| 16 | INCLUDE "vector_field_group_def.inc" |
---|
| 17 | |
---|
[26] | 18 | TYPE(vector_field_group),SAVE,POINTER :: field_group_Ids |
---|
| 19 | TYPE(sorted_list),POINTER,SAVE,PRIVATE :: Ids |
---|
[8] | 20 | |
---|
[42] | 21 | INTERFACE field_group__set_attribut |
---|
| 22 | MODULE PROCEDURE field_group__set_attribut_id,field_group__set_attribut_pt |
---|
| 23 | END INTERFACE |
---|
| 24 | |
---|
[8] | 25 | CONTAINS |
---|
| 26 | |
---|
| 27 | INCLUDE "vector_field_group_contains.inc" |
---|
| 28 | |
---|
[26] | 29 | |
---|
| 30 | SUBROUTINE field_group__swap_context(saved_field_group_ids, saved_ids) |
---|
| 31 | IMPLICIT NONE |
---|
| 32 | TYPE(vector_field_group),POINTER :: saved_field_group_Ids |
---|
| 33 | TYPE(sorted_list),POINTER :: saved_Ids |
---|
| 34 | |
---|
| 35 | field_group_ids=>saved_field_group_ids |
---|
| 36 | ids=>saved_ids |
---|
| 37 | |
---|
| 38 | END SUBROUTINE field_group__swap_context |
---|
| 39 | |
---|
[8] | 40 | SUBROUTINE field_group__init |
---|
| 41 | IMPLICIT NONE |
---|
| 42 | |
---|
| 43 | CALL vector_field_group__new(field_group_Ids) |
---|
| 44 | CALL sorted_list__new(Ids) |
---|
| 45 | |
---|
| 46 | END SUBROUTINE field_group__init |
---|
| 47 | |
---|
| 48 | SUBROUTINE field_group__get(Id,Pt_fg) |
---|
| 49 | USE string_function |
---|
| 50 | IMPLICIT NONE |
---|
| 51 | CHARACTER(LEN=*),INTENT(IN) :: Id |
---|
| 52 | TYPE(field_group),POINTER :: Pt_fg |
---|
| 53 | |
---|
| 54 | INTEGER :: Pos |
---|
| 55 | LOGICAL :: success |
---|
| 56 | |
---|
| 57 | CALL sorted_list__find(Ids,hash(Id),Pos,success) |
---|
| 58 | IF (success) THEN |
---|
| 59 | Pt_fg=>field_group_ids%at(Pos)%Pt |
---|
| 60 | ELSE |
---|
| 61 | Pt_fg=>NULL() |
---|
| 62 | ENDIF |
---|
| 63 | |
---|
| 64 | END SUBROUTINE field_group__get |
---|
[42] | 65 | |
---|
| 66 | SUBROUTINE field_group__set_attribut_id(id,attrib,Ok) |
---|
| 67 | USE mod_attribut |
---|
| 68 | USE error_msg |
---|
| 69 | IMPLICIT NONE |
---|
| 70 | CHARACTER(LEN=*),INTENT(IN) :: id |
---|
| 71 | TYPE(attribut),INTENT(IN) :: attrib |
---|
| 72 | LOGICAL,OPTIONAL,INTENT(out) :: Ok |
---|
[8] | 73 | |
---|
[42] | 74 | TYPE(field_group),POINTER :: Pt_fg |
---|
| 75 | INTEGER :: Pos |
---|
| 76 | LOGICAL :: success |
---|
| 77 | |
---|
| 78 | CALL sorted_list__find(Ids,hash(Id),Pos,success) |
---|
| 79 | IF (success) THEN |
---|
| 80 | Pt_fg=>field_group_ids%at(Pos)%Pt |
---|
| 81 | CALL field_group__set_attribut(Pt_fg,attrib) |
---|
| 82 | IF (PRESENT(OK)) ok=.TRUE. |
---|
| 83 | ELSE |
---|
| 84 | IF (.NOT.PRESENT(OK)) THEN |
---|
| 85 | WRITE(message,*) 'Field group id :',id,'is undefined' |
---|
| 86 | CALL error('mod_field_group::field_group__set_attribut') |
---|
| 87 | ELSE |
---|
| 88 | OK=.FALSE. |
---|
| 89 | ENDIF |
---|
| 90 | ENDIF |
---|
| 91 | |
---|
| 92 | END SUBROUTINE field_group__set_attribut_id |
---|
| 93 | |
---|
| 94 | SUBROUTINE field_group__set_attribut_pt(pt_fg,attrib) |
---|
| 95 | USE mod_attribut |
---|
| 96 | USE mod_object |
---|
| 97 | IMPLICIT NONE |
---|
| 98 | TYPE(field_group),POINTER :: Pt_fg |
---|
| 99 | TYPE(attribut),INTENT(IN) :: attrib |
---|
| 100 | |
---|
| 101 | IF (attrib%object==field_object) THEN |
---|
| 102 | CALL field__set_attribut(Pt_fg%default_attribut,attrib) |
---|
| 103 | ENDIF |
---|
| 104 | |
---|
| 105 | END SUBROUTINE field_group__set_attribut_pt |
---|
| 106 | |
---|
| 107 | |
---|
[8] | 108 | RECURSIVE SUBROUTINE field_group__new(Pt_fg,Id) |
---|
| 109 | USE string_function |
---|
| 110 | IMPLICIT NONE |
---|
| 111 | TYPE(field_group),POINTER :: Pt_fg |
---|
| 112 | CHARACTER(LEN=*),OPTIONAL,INTENT(IN) :: Id |
---|
| 113 | |
---|
| 114 | INTEGER :: Pos |
---|
| 115 | |
---|
| 116 | ALLOCATE(Pt_fg%groups) |
---|
| 117 | ALLOCATE(Pt_fg%fields) |
---|
| 118 | ALLOCATE(Pt_fg%default_attribut) |
---|
| 119 | |
---|
| 120 | CALL vector_field_group__new(Pt_fg%groups) |
---|
| 121 | CALL vector_field__new(Pt_fg%fields) |
---|
| 122 | CALL field__new(Pt_fg%default_attribut) |
---|
| 123 | Pt_fg%has_id=.FALSE. |
---|
| 124 | |
---|
| 125 | IF (PRESENT(Id)) THEN |
---|
| 126 | Pt_fg%id=TRIM(Id) |
---|
| 127 | Pt_fg%has_id=.TRUE. |
---|
| 128 | CALL vector_field_group__set_new(field_group_Ids,Pt_fg,Pos) |
---|
| 129 | CALL sorted_list__Add(Ids,hash(id),Pos) |
---|
| 130 | ENDIF |
---|
| 131 | |
---|
| 132 | END SUBROUTINE field_group__new |
---|
| 133 | |
---|
| 134 | |
---|
| 135 | SUBROUTINE field_group__get_new_group(Pt_fg,Pt_fg_out,Id) |
---|
| 136 | IMPLICIT NONE |
---|
| 137 | TYPE(field_group),POINTER :: Pt_fg |
---|
| 138 | TYPE(field_group),POINTER :: Pt_fg_out |
---|
| 139 | CHARACTER(LEN=*),OPTIONAL :: Id |
---|
| 140 | |
---|
| 141 | CALL vector_field_group__get_new(Pt_fg%groups,Pt_fg_out) |
---|
| 142 | |
---|
| 143 | IF (PRESENT(id)) THEN |
---|
| 144 | CALL field_group__new(Pt_fg_out,Id) |
---|
| 145 | ELSE |
---|
| 146 | CALL field_group__new(Pt_fg_out) |
---|
| 147 | ENDIF |
---|
| 148 | |
---|
| 149 | END SUBROUTINE field_group__get_new_group |
---|
| 150 | |
---|
| 151 | |
---|
| 152 | SUBROUTINE field_group__get_new_field(Pt_fg,Pt_f_out,Id) |
---|
| 153 | IMPLICIT NONE |
---|
| 154 | TYPE(field_group),POINTER :: Pt_fg |
---|
| 155 | TYPE(field),POINTER :: Pt_f_out |
---|
| 156 | CHARACTER(LEN=*),OPTIONAL :: Id |
---|
| 157 | |
---|
| 158 | CALL vector_field__get_new(Pt_fg%fields,Pt_f_out) |
---|
| 159 | |
---|
| 160 | IF (PRESENT(id)) THEN |
---|
| 161 | CALL field__new(Pt_f_out,Id) |
---|
| 162 | ELSE |
---|
| 163 | CALL field__new(Pt_f_out) |
---|
| 164 | ENDIF |
---|
| 165 | |
---|
| 166 | END SUBROUTINE field_group__get_new_field |
---|
| 167 | |
---|
| 168 | |
---|
[17] | 169 | SUBROUTINE field_group__get_default_attrib(Pt_fg,Pt_f) |
---|
[8] | 170 | IMPLICIT NONE |
---|
| 171 | TYPE(field_group),POINTER :: Pt_fg |
---|
| 172 | TYPE(field),POINTER :: Pt_f |
---|
| 173 | |
---|
| 174 | Pt_f=>Pt_fg%default_attribut |
---|
[17] | 175 | END SUBROUTINE field_group__get_default_attrib |
---|
[8] | 176 | |
---|
| 177 | |
---|
| 178 | RECURSIVE SUBROUTINE field_group__apply_default(Pt_fg,default) |
---|
| 179 | IMPLICIT NONE |
---|
| 180 | TYPE(field_group),POINTER :: Pt_fg |
---|
| 181 | TYPE(field),POINTER,OPTIONAL :: default |
---|
| 182 | |
---|
| 183 | INTEGER :: i |
---|
| 184 | |
---|
| 185 | IF (PRESENT(default)) THEN |
---|
| 186 | CALL field__apply_default(default,Pt_fg%default_attribut,Pt_fg%default_attribut) |
---|
| 187 | ENDIF |
---|
| 188 | |
---|
| 189 | DO i=1,Pt_fg%groups%size |
---|
| 190 | CALL field_group__apply_default(Pt_fg%groups%at(i)%pt,Pt_fg%default_attribut) |
---|
| 191 | ENDDO |
---|
| 192 | |
---|
| 193 | DO i=1,Pt_fg%fields%size |
---|
| 194 | CALL field__apply_default(Pt_fg%default_attribut,Pt_fg%fields%at(i)%pt,Pt_fg%fields%at(i)%pt) |
---|
| 195 | ENDDO |
---|
| 196 | |
---|
| 197 | END SUBROUTINE field_group__apply_default |
---|
| 198 | |
---|
| 199 | SUBROUTINE field_group__solve_ref(pt_fg) |
---|
| 200 | IMPLICIT NONE |
---|
| 201 | TYPE(field_group),POINTER :: Pt_fg |
---|
| 202 | |
---|
| 203 | CALL field_group__solve_field_ref(Pt_fg) |
---|
| 204 | CALL field_group__solve_axis_ref(Pt_fg) |
---|
| 205 | CALL field_group__solve_grid_ref(Pt_fg) |
---|
[29] | 206 | CALL field_group__solve_zoom_ref(Pt_fg) |
---|
[8] | 207 | |
---|
| 208 | END SUBROUTINE field_group__solve_ref |
---|
| 209 | |
---|
| 210 | RECURSIVE SUBROUTINE field_group__solve_field_ref(Pt_fg) |
---|
| 211 | IMPLICIT NONE |
---|
| 212 | TYPE(field_group),POINTER :: Pt_fg |
---|
| 213 | |
---|
| 214 | INTEGER :: i |
---|
| 215 | |
---|
| 216 | DO i=1,Pt_fg%groups%size |
---|
| 217 | CALL field_group__solve_field_ref(Pt_fg%groups%at(i)%pt) |
---|
| 218 | ENDDO |
---|
| 219 | |
---|
| 220 | DO i=1,Pt_fg%fields%size |
---|
| 221 | CALL field__solve_field_ref(Pt_fg%fields%at(i)%pt) |
---|
| 222 | ENDDO |
---|
| 223 | |
---|
| 224 | END SUBROUTINE field_group__solve_field_ref |
---|
| 225 | |
---|
| 226 | RECURSIVE SUBROUTINE field_group__solve_axis_ref(Pt_fg) |
---|
| 227 | IMPLICIT NONE |
---|
| 228 | TYPE(field_group),POINTER :: Pt_fg |
---|
| 229 | |
---|
| 230 | INTEGER :: i |
---|
| 231 | |
---|
| 232 | DO i=1,Pt_fg%groups%size |
---|
| 233 | CALL field_group__solve_axis_ref(Pt_fg%groups%at(i)%pt) |
---|
| 234 | ENDDO |
---|
| 235 | |
---|
| 236 | DO i=1,Pt_fg%fields%size |
---|
| 237 | CALL field__solve_axis_ref(Pt_fg%fields%at(i)%pt) |
---|
| 238 | ENDDO |
---|
| 239 | |
---|
| 240 | END SUBROUTINE field_group__solve_axis_ref |
---|
| 241 | |
---|
| 242 | RECURSIVE SUBROUTINE field_group__solve_grid_ref(Pt_fg) |
---|
| 243 | IMPLICIT NONE |
---|
| 244 | TYPE(field_group),POINTER :: Pt_fg |
---|
| 245 | |
---|
| 246 | INTEGER :: i |
---|
| 247 | |
---|
| 248 | DO i=1,Pt_fg%groups%size |
---|
| 249 | CALL field_group__solve_grid_ref(Pt_fg%groups%at(i)%pt) |
---|
| 250 | ENDDO |
---|
| 251 | |
---|
| 252 | DO i=1,Pt_fg%fields%size |
---|
| 253 | CALL field__solve_grid_ref(Pt_fg%fields%at(i)%pt) |
---|
| 254 | ENDDO |
---|
| 255 | |
---|
| 256 | END SUBROUTINE field_group__solve_grid_ref |
---|
[29] | 257 | |
---|
| 258 | RECURSIVE SUBROUTINE field_group__solve_zoom_ref(Pt_fg) |
---|
| 259 | IMPLICIT NONE |
---|
| 260 | TYPE(field_group),POINTER :: Pt_fg |
---|
| 261 | |
---|
| 262 | INTEGER :: i |
---|
| 263 | |
---|
| 264 | DO i=1,Pt_fg%groups%size |
---|
| 265 | CALL field_group__solve_zoom_ref(Pt_fg%groups%at(i)%pt) |
---|
| 266 | ENDDO |
---|
| 267 | |
---|
| 268 | DO i=1,Pt_fg%fields%size |
---|
| 269 | CALL field__solve_zoom_ref(Pt_fg%fields%at(i)%pt) |
---|
| 270 | ENDDO |
---|
[8] | 271 | |
---|
[29] | 272 | END SUBROUTINE field_group__solve_zoom_ref |
---|
| 273 | |
---|
[8] | 274 | RECURSIVE SUBROUTINE field_group__print(Pt_fg) |
---|
| 275 | IMPLICIT NONE |
---|
| 276 | TYPE(field_group),POINTER :: Pt_fg |
---|
| 277 | |
---|
| 278 | INTEGER :: i |
---|
| 279 | |
---|
| 280 | PRINT *,"--- FIELD GROUP ---" |
---|
| 281 | IF (Pt_fg%has_id) THEN |
---|
| 282 | PRINT *,"id :",TRIM(Pt_fg%id) |
---|
| 283 | ELSE |
---|
| 284 | PRINT *,"id undefined" |
---|
| 285 | ENDIF |
---|
| 286 | |
---|
| 287 | PRINT *,"field default attribut :" |
---|
| 288 | CALL field__print(Pt_fg%default_attribut) |
---|
| 289 | |
---|
| 290 | PRINT *,"owned field groups :",Pt_fg%groups%size |
---|
| 291 | DO i=1,Pt_fg%groups%size |
---|
| 292 | CALL field_group__print(Pt_fg%groups%at(i)%pt) |
---|
| 293 | ENDDO |
---|
| 294 | |
---|
| 295 | PRINT *,"owned field :",Pt_fg%fields%size |
---|
| 296 | DO i=1,Pt_fg%fields%size |
---|
| 297 | CALL field__print(Pt_fg%fields%at(i)%pt) |
---|
| 298 | ENDDO |
---|
| 299 | |
---|
| 300 | PRINT *,"------------" |
---|
| 301 | |
---|
| 302 | END SUBROUTINE field_group__print |
---|
| 303 | |
---|
| 304 | END MODULE mod_field_group |
---|