mo_memory_base.f90
MODULE mo_memory_base
! Definition of data type 'memory_type' holding pointers to
! fields and metadata required for I/O.
5: !
! This module only defines the data type and basic operations.
! A specific instance should be declared in another module.
USE mo_kind, ONLY : dp
10: USE mo_doctor, ONLY: nout
USE mo_exception
USE mo_linked_list
USE mo_netCDF, ONLY: IO_get_varindx
15: IMPLICIT NONE
PRIVATE
PUBLIC :: gptr
20: TYPE gptr
REAL(dp), POINTER :: x(:,:,:)
END TYPE gptr
PUBLIC :: create_list ! construct empty list
25: PUBLIC :: delete_list ! destruct list
PUBLIC :: print_memory_table ! print list/memory information
PUBLIC :: print_memory_use ! print used memory
PUBLIC :: print_sinfo ! print short information
30:
PUBLIC :: new_entry ! create/allocate a new list entry
PUBLIC :: get_entry ! obtain reference to existing list entry
PUBLIC :: get_info ! obtain meta data of list entry
35: PUBLIC :: set_info_restart ! set restart flag
PUBLIC :: memory_info ! meta data structure
INTERFACE new_entry
40: MODULE PROCEDURE new_list_entry_4d ! create a new list entry
MODULE PROCEDURE new_list_entry_3d
MODULE PROCEDURE new_list_entry_2d
MODULE PROCEDURE new_list_entry_1d
END INTERFACE
45:
INTERFACE get_entry
MODULE PROCEDURE get_list_entry_4d ! obtain reference to a list entry
MODULE PROCEDURE get_list_entry_3d
MODULE PROCEDURE get_list_entry_2d
50: MODULE PROCEDURE get_list_entry_1d
END INTERFACE
CONTAINS
55: SUBROUTINE create_list (this_list)
TYPE (list) :: this_list
CALL construct_list (this_list)
60:
END SUBROUTINE create_list
SUBROUTINE delete_list (this_list)
65: TYPE (list) :: this_list
CALL destruct_list (this_list)
END SUBROUTINE delete_list
70:
SUBROUTINE get_info (this_list, name, info)
TYPE (list) , INTENT(in) :: this_list ! list
CHARACTER (*) , INTENT(in) :: name ! name of variable
TYPE (memory_info), INTENT(out) :: info ! variable meta data
75:
TYPE (list_element), POINTER :: requested_list_element
! obtain info
80: requested_list_element => find_list_element (this_list, name)
info = requested_list_element%field%info
END SUBROUTINE get_info
85:
SUBROUTINE set_info_restart (this_list, name, restart)
TYPE (list) , INTENT(in) :: this_list ! list
CHARACTER (*) , INTENT(in) :: name ! name of variable
LOGICAL , INTENT(in) :: restart
90:
TYPE (list_element), POINTER :: requested_list_element
! obtain info
95: requested_list_element => find_list_element (this_list, name)
! set restart flag
requested_list_element%field%info%restart = restart
100:
END SUBROUTINE set_info_restart
SUBROUTINE new_list_entry_4d (this_list, name, ptr, ldims, gdims, &
gribcode, gribtable, outint, accumulate, restart, dimnames)
105:
TYPE (list) , INTENT(inout) :: this_list ! list
CHARACTER (*) , INTENT(in) :: name ! name of variable
REAL(dp) , POINTER :: ptr(:,:,:,:) ! reference to allocated field
INTEGER , INTENT(in) :: ldims(4) ! shape of array to allocate
110: INTEGER , INTENT(in) :: gdims(4) ! global size of field
CHARACTER (*), OPTIONAL , INTENT(in) :: dimnames(4) ! dimension names
INTEGER, OPTIONAL, INTENT(in) :: gribcode ! gribcode number
115: INTEGER, OPTIONAL, INTENT(in) :: gribtable ! gribcode table number
INTEGER, OPTIONAL, INTENT(in) :: outint ! output interval (time steps)
LOGICAL, OPTIONAL, INTENT(in) :: accumulate ! accumulation flag
LOGICAL, OPTIONAL, INTENT(in) :: restart ! restart file flag
120:
! create (allocate) a new table entry
! optionally obtain pointer to 4d-field
! optionally overwrite default meta data
125: TYPE (list_element), POINTER :: new_list_element
! add list entry
CALL add_list_element (this_list, new_list_element)
130:
! and set meta data
new_list_element%field%info%name = name
135: ALLOCATE (new_list_element%field%ptr(ldims(1),ldims(2), &
ldims(3),ldims(4)))
new_list_element%field%ptr=0.
140: this_list%memory_used = this_list%memory_used &
+8*SIZE(new_list_element%field%ptr)
new_list_element%field%info%dim_1 = ldims(1)
new_list_element%field%info%dim_2 = ldims(2)
145: new_list_element%field%info%dim_3 = ldims(3)
new_list_element%field%info%dim_4 = ldims(4)
new_list_element%field%info%gdim_1 = gdims(1)
new_list_element%field%info%gdim_2 = gdims(2)
150: new_list_element%field%info%gdim_3 = gdims(3)
new_list_element%field%info%gdim_4 = gdims(4)
new_list_element%field%info%ndim = 4
155: ptr => new_list_element%field%ptr
! pass optional arguments
IF (PRESENT(dimnames)) THEN
160: new_list_element%field%info%IO_var_indx(1) = IO_get_varindx(dimnames(1))
new_list_element%field%info%IO_var_indx(2) = IO_get_varindx(dimnames(2))
new_list_element%field%info%IO_var_indx(3) = IO_get_varindx(dimnames(3))
new_list_element%field%info%IO_var_indx(4) = IO_get_varindx(dimnames(4))
END IF
165:
IF (PRESENT(gribtable)) new_list_element%field%info%gribtable = gribtable
IF (PRESENT(gribcode)) new_list_element%field%info%gribcode = gribcode
IF (PRESENT(outint)) new_list_element%field%info%outint = outint
IF (PRESENT(accumulate)) new_list_element%field%info%accumulate = accumulate
170: IF (PRESENT(restart)) new_list_element%field%info%restart = restart
END SUBROUTINE new_list_entry_4d
SUBROUTINE new_list_entry_3d (this_list, name, ptr, ldims, gdims, &
175: gribcode, gribtable, outint, accumulate, restart, dimnames)
TYPE (list) , INTENT(inout) :: this_list ! list
CHARACTER (*) , INTENT(in) :: name ! name of variable
REAL(dp) , POINTER :: ptr(:,:,:) ! reference to allocated field
180: INTEGER , INTENT(in) :: ldims(3) ! shape of array to allocate
INTEGER , INTENT(in) :: gdims(3) ! global size of field
CHARACTER (*), OPTIONAL , INTENT(in) :: dimnames(3) ! dimension names
185: INTEGER, OPTIONAL, INTENT(in) :: gribcode ! gribcode number
INTEGER, OPTIONAL, INTENT(in) :: gribtable ! gribcode table number
INTEGER, OPTIONAL, INTENT(in) :: outint ! output interval (time steps)
LOGICAL, OPTIONAL, INTENT(in) :: accumulate ! accumulation flag
190: LOGICAL, OPTIONAL, INTENT(in) :: restart ! restart file flag
! create (allocate) a new table entry
! optionally obtain pointer to 3d-field
! optionally overwrite default meta data
195:
TYPE (list_element), POINTER :: new_list_element
! add list entry
200: CALL add_list_element (this_list, new_list_element)
! and set meta data
new_list_element%field%info%name = name
205:
ALLOCATE (new_list_element%field%ptr(ldims(1),ldims(2), &
ldims(3),1))
new_list_element%field%ptr=0.
210:
this_list%memory_used = this_list%memory_used &
+8*SIZE(new_list_element%field%ptr)
new_list_element%field%info%dim_1 = ldims(1)
215: new_list_element%field%info%dim_2 = ldims(2)
new_list_element%field%info%dim_3 = ldims(3)
new_list_element%field%info%dim_4 = 1
new_list_element%field%info%gdim_1 = gdims(1)
220: new_list_element%field%info%gdim_2 = gdims(2)
new_list_element%field%info%gdim_3 = gdims(3)
new_list_element%field%info%gdim_4 = 1
new_list_element%field%info%ndim = 3
225:
ptr => new_list_element%field%ptr(:,:,:,1)
! pass optional arguments
230: IF (PRESENT(dimnames)) THEN
new_list_element%field%info%IO_var_indx(1) = IO_get_varindx(dimnames(1))
new_list_element%field%info%IO_var_indx(2) = IO_get_varindx(dimnames(2))
new_list_element%field%info%IO_var_indx(3) = IO_get_varindx(dimnames(3))
END IF
235:
IF (PRESENT(gribtable)) new_list_element%field%info%gribtable = gribtable
IF (PRESENT(gribcode)) new_list_element%field%info%gribcode = gribcode
IF (PRESENT(outint)) new_list_element%field%info%outint = outint
IF (PRESENT(accumulate)) new_list_element%field%info%accumulate = accumulate
240: IF (PRESENT(restart)) new_list_element%field%info%restart = restart
END SUBROUTINE new_list_entry_3d
SUBROUTINE new_list_entry_2d (this_list, name, ptr, ldims, gdims, &
245: gribcode, gribtable, outint, accumulate, restart, dimnames)
TYPE (list) , INTENT(inout) :: this_list ! list
CHARACTER (*) , INTENT(in) :: name ! name of variable
REAL(dp) , POINTER :: ptr(:,:) ! reference to allocated field
250: INTEGER , INTENT(in) :: ldims(2) ! shape of array to allocate
INTEGER , INTENT(in) :: gdims(2) ! global size of field
CHARACTER (*), OPTIONAL , INTENT(in) :: dimnames(2) ! dimension names
255: INTEGER, OPTIONAL, INTENT(in) :: gribcode ! gribcode number
INTEGER, OPTIONAL, INTENT(in) :: gribtable ! gribcode table number
INTEGER, OPTIONAL, INTENT(in) :: outint ! output interval (time steps)
LOGICAL, OPTIONAL, INTENT(in) :: accumulate ! accumulation flag
260: LOGICAL, OPTIONAL, INTENT(in) :: restart ! restart file flag
! create (allocate) a new table entry
! optionally obtain pointer to 2d-field
! optionally overwrite default meta data
265:
TYPE (list_element), POINTER :: new_list_element
! add list entry
270: CALL add_list_element (this_list, new_list_element)
! and set meta data
new_list_element%field%info%name = name
275: ALLOCATE (new_list_element%field%ptr(ldims(1),ldims(2),1,1))
new_list_element%field%ptr=0.
this_list%memory_used = this_list%memory_used &
280: +8*SIZE(new_list_element%field%ptr)
new_list_element%field%info%dim_1 = ldims(1)
new_list_element%field%info%dim_2 = ldims(2)
new_list_element%field%info%dim_3 = 1
285: new_list_element%field%info%dim_4 = 1
new_list_element%field%info%gdim_1 = gdims(1)
new_list_element%field%info%gdim_2 = gdims(2)
new_list_element%field%info%gdim_3 = 1
290: new_list_element%field%info%gdim_4 = 1
new_list_element%field%info%ndim = 2
ptr => new_list_element%field%ptr(:,:,1,1)
295:
! pass optional arguments
IF (PRESENT(dimnames)) THEN
new_list_element%field%info%IO_var_indx(1) = IO_get_varindx(dimnames(1))
300: new_list_element%field%info%IO_var_indx(2) = IO_get_varindx(dimnames(2))
END IF
IF (PRESENT(gribtable)) new_list_element%field%info%gribtable = gribtable
IF (PRESENT(gribcode)) new_list_element%field%info%gribcode = gribcode
305: IF (PRESENT(outint)) new_list_element%field%info%outint = outint
IF (PRESENT(accumulate)) new_list_element%field%info%accumulate = accumulate
IF (PRESENT(restart)) new_list_element%field%info%restart = restart
END SUBROUTINE new_list_entry_2d
310:
SUBROUTINE new_list_entry_1d (this_list, name, ptr, ldims, gdims, &
gribcode, gribtable, outint, accumulate, restart, dimnames)
TYPE (list) , INTENT(inout) :: this_list ! list
315: CHARACTER (*) , INTENT(in) :: name ! name of variable
REAL(dp) , POINTER :: ptr(:) ! reference to allocated field
INTEGER , INTENT(in) :: ldims(1) ! shape of array to allocate
INTEGER , INTENT(in) :: gdims(1) ! global size of field
320: CHARACTER (*), OPTIONAL , INTENT(in) :: dimnames(1) ! dimension names
INTEGER, OPTIONAL, INTENT(in) :: gribcode ! gribcode number
INTEGER, OPTIONAL, INTENT(in) :: gribtable ! gribcode table number
325: INTEGER, OPTIONAL, INTENT(in) :: outint ! output interval (time steps)
LOGICAL, OPTIONAL, INTENT(in) :: accumulate ! accumulation flag
LOGICAL, OPTIONAL, INTENT(in) :: restart ! restart file flag
! create (allocate) a new table entry
330: ! optionally obtain pointer to 1d-field
! optionally overwrite default meta data
TYPE (list_element), POINTER :: new_list_element
335: ! add list entry
CALL add_list_element (this_list, new_list_element)
! and set meta data
340:
new_list_element%field%info%name = name
ALLOCATE (new_list_element%field%ptr(ldims(1),1,1,1))
new_list_element%field%ptr=0.
345:
this_list%memory_used = this_list%memory_used &
+8*SIZE(new_list_element%field%ptr)
new_list_element%field%info%dim_1 = ldims(1)
350: new_list_element%field%info%dim_2 = 1
new_list_element%field%info%dim_3 = 1
new_list_element%field%info%dim_4 = 1
new_list_element%field%info%gdim_1 = gdims(1)
355: new_list_element%field%info%gdim_2 = 1
new_list_element%field%info%gdim_3 = 1
new_list_element%field%info%gdim_4 = 1
new_list_element%field%info%ndim = 1
360:
ptr => new_list_element%field%ptr(:,1,1,1)
! pass optional arguments
365: IF (PRESENT(dimnames)) THEN
new_list_element%field%info%IO_var_indx(1) = IO_get_varindx(dimnames(1))
END IF
IF (PRESENT(gribtable)) new_list_element%field%info%gribtable = gribtable
370: IF (PRESENT(gribcode)) new_list_element%field%info%gribcode = gribcode
IF (PRESENT(outint)) new_list_element%field%info%outint = outint
IF (PRESENT(accumulate)) new_list_element%field%info%accumulate = accumulate
IF (PRESENT(restart)) new_list_element%field%info%restart = restart
375: END SUBROUTINE new_list_entry_1d
SUBROUTINE get_list_entry_4d (this_list, name, ptr)
TYPE (list) :: this_list ! list
380: CHARACTER (*), INTENT(in) :: name ! name of variable
REAL(dp) , POINTER :: ptr(:,:,:,:) ! reference to allocated field
TYPE (list_element), POINTER :: requested_list_element
385: ! obtain pointer to 4d-field
requested_list_element => find_list_element (this_list, name)
ptr => requested_list_element%field%ptr
390:
END SUBROUTINE get_list_entry_4d
SUBROUTINE get_list_entry_3d (this_list, name, ptr)
395: TYPE (list) :: this_list ! list
CHARACTER (*), INTENT(in) :: name ! name of variable
REAL(dp) , POINTER :: ptr(:,:,:) ! reference to allocated field
TYPE (list_element), POINTER :: requested_list_element
400:
! obtain pointer to 3d-field
requested_list_element => find_list_element (this_list, name)
405: ptr => requested_list_element%field%ptr(:,:,:,1)
END SUBROUTINE get_list_entry_3d
SUBROUTINE get_list_entry_2d (this_list, name, ptr)
410:
TYPE (list) , INTENT(in) :: this_list ! list
CHARACTER (*) , INTENT(in) :: name ! name of variable
REAL(dp) , POINTER :: ptr(:,:) ! reference to allocated field
415: TYPE (list_element), POINTER :: requested_list_element
! obtain pointer to 2d-field
requested_list_element => find_list_element (this_list, name)
420:
ptr => requested_list_element%field%ptr(:,:,1,1)
END SUBROUTINE get_list_entry_2d
425: SUBROUTINE get_list_entry_1d (this_list, name, ptr)
TYPE (list) , INTENT(in) :: this_list ! list
CHARACTER (*), INTENT(in) :: name ! name of variable
REAL(dp) , POINTER :: ptr(:) ! reference to allocated field
430:
TYPE (list_element), POINTER :: requested_list_element
! obtain pointer to 1d-field
435: requested_list_element => find_list_element (this_list, name)
ptr => requested_list_element%field%ptr(:,1,1,1)
END SUBROUTINE get_list_entry_1d
440:
SUBROUTINE print_memory_use (this_list)
TYPE (list) , INTENT(in) :: this_list ! list
445: WRITE (nout,'(a,i10,a,i4,a)') &
'Memory in use: ', this_list%memory_used, ' bytes in ', &
this_list%list_elements, ' fields.'
END SUBROUTINE print_memory_use
450:
SUBROUTINE print_memory_table (this_list)
TYPE (list), INTENT(in) :: this_list ! list
455: ! print current memory table
WRITE (nout,'(/,/,a,/)') &
'Status of base memory:'
460: CALL print_linked_list (this_list)
END SUBROUTINE print_memory_table
SUBROUTINE print_sinfo (this_list)
465:
TYPE (list), INTENT(in) :: this_list ! list
! print current stat table
470: WRITE (nout,'(/,/,a,/)') &
'Statistic of base memory:'
CALL print_sinfo_list (this_list)
475: END SUBROUTINE print_sinfo
END MODULE mo_memory_base
Info Section
uses: mo_doctor, mo_exception, mo_kind, mo_linked_list, mo_netcdf
calls: add_list_element, construct_list, destruct_list, print_linked_list, print_sinfo_list
back to top
ECHAM 4 vf90 (C) 1998 Max-Planck-Institut für Meteorologie, Hamburg
Wed Nov 24 01:25:21 CST 1999
HTML derived from FORTRAN source by f2html.pl v0.3 (C) 1997,98 Beroud Jean-Marc.