w3metamd.F90

Go to the documentation of this file.

 
!/ ------------------------------------------------------------------- /
!/
!/ ------------------------------------------------------------------- /
MODULE w3metamd
  !/
  !/                  +-----------------------------------+
  !/                  | WAVEWATCH III           NOAA/NCEP |
  !/                  |           C. Bunney               |
  !/                  |                                   |
  !/                  |                        FORTRAN 90 |
  !/                  | Last update :         16-Dec-2020 |
  !/                  +-----------------------------------+
  !/
  !/    16-Dec-2020 : Creation                            ( version 7.12 )
  !/
  !  1. Purpose :
  !
  !     Provides types for handling "meta data" (attribute/value pairs)
  !     and a linked list construct for dynamic storage.
  !/ ------------------------------------------------------------------- /
 
  CHARACTER(LEN=*), PARAMETER :: unsetc = "unset"
  REAL, PARAMETER             :: unsetr = huge(1.0)
 
  TYPE meta_pair_t
    CHARACTER(LEN=64)  :: attname = unsetc  
    CHARACTER(LEN=120) :: attval = unsetc   
    CHARACTER          :: TYPE = 'c'
    TYPE(meta_pair_t), POINTER  :: next
  END TYPE meta_pair_t
 
  TYPE meta_list_t
    TYPE (meta_pair_t), POINTER :: head => null(), tail => null()
    INTEGER                     :: n = 0
  END TYPE meta_list_t
 
  INTERFACE meta_list_append
    MODULE PROCEDURE meta_list_append_m 
    MODULE PROCEDURE meta_list_append_r 
    MODULE PROCEDURE meta_list_append_i 
    MODULE PROCEDURE meta_list_append_c 
  END INTERFACE meta_list_append
 
CONTAINS
 
 
  !/ ------------------------------------------------------------------- /
  !/ ------------------------------------------------------------------- /
  SUBROUTINE del_meta_list(LIST)
 
    IMPLICIT NONE
 
    TYPE(meta_list_t), INTENT(INOUT) :: LIST
    !/ ------------------------------------------------------------------- /
    !/ Local parameters
    !/
    TYPE(meta_pair_t), POINTER :: P
 
    IF(.NOT. ASSOCIATED(list%HEAD)) RETURN
 
    DO
      NULLIFY(p)
      IF(ASSOCIATED(list%HEAD%NEXT)) p => list%HEAD%NEXT
      DEALLOCATE(list%HEAD)
      IF(.NOT. ASSOCIATED(p)) EXIT
      list%HEAD => p
    ENDDO
 
    NULLIFY(list%HEAD)
    NULLIFY(list%TAIL)
    list%N = 0
 
  END SUBROUTINE del_meta_list
 
 
  !/ ------------------------------------------------------------------- /
  !/ ------------------------------------------------------------------- /
  FUNCTION copy_meta_list(LIST) RESULT(COPY)
 
    IMPLICIT NONE
 
    TYPE(meta_list_t), INTENT(IN) :: list
    TYPE(meta_list_t)             :: copy
    !/ ------------------------------------------------------------------- /
    !/ Local parameters
    !/
    TYPE(meta_pair_t), POINTER :: p
 
    NULLIFY(copy%HEAD)
    NULLIFY(copy%TAIL)
    copy%N = 0
    IF(list%N .EQ. 0) RETURN
 
    ! Deep copy list
    p => list%HEAD
    DO
      CALL meta_list_append_m(copy, p)
      IF(.NOT. ASSOCIATED(p%NEXT)) EXIT
      p => p%NEXT
    ENDDO
 
  END FUNCTION copy_meta_list
 
 
  !/ ------------------------------------------------------------------- /
  !/ ------------------------------------------------------------------- /
  SUBROUTINE print_meta_list(LIST)
 
    IMPLICIT NONE
 
    TYPE(meta_list_t), INTENT(IN) :: LIST
    !/ ------------------------------------------------------------------- /
    !/ Local parameters
    !/
    TYPE(meta_pair_t), POINTER :: P
 
    IF(.NOT. ASSOCIATED(list%HEAD)) THEN
      WRITE(*,*) 'List empty.'
      RETURN
    ENDIF
 
    p => list%HEAD
    DO
      WRITE(*, '(A," [",A1,"] : ", A)') trim(p%ATTNAME), p%TYPE,      &
           trim(p%ATTVAL)
      IF(.NOT. ASSOCIATED(p%NEXT)) EXIT
      p => p%NEXT
    ENDDO
 
  END SUBROUTINE print_meta_list
 
 
  !/ ------------------------------------------------------------------- /
  !/ ------------------------------------------------------------------- /
  SUBROUTINE meta_list_append_m(LIST, META)
 
    IMPLICIT NONE
 
    TYPE(meta_list_t), INTENT(INOUT) :: LIST
    TYPE(meta_pair_t), INTENT(IN) :: META
    !/ ------------------------------------------------------------------- /
    !/ Local parameters
    !/
    TYPE(meta_pair_t), POINTER :: P
 
    ALLOCATE(p)
 
    ! Empty list?
    IF(list%N .EQ. 0) THEN
      !IF(.NOT. ASSOCIATED(LIST%HEAD)) THEN
      list%HEAD => p
    ELSE
      list%TAIL%NEXT => p
    ENDIF
    list%TAIL => p
 
    p%ATTNAME = meta%ATTNAME
    p%ATTVAL = meta%ATTVAL
    p%TYPE = meta%TYPE
 
    NULLIFY(p%NEXT)
 
    list%N = list%N + 1
 
  END SUBROUTINE meta_list_append_m
 
 
  !/ ------------------------------------------------------------------- /
  !/ ------------------------------------------------------------------- /
  SUBROUTINE meta_list_append_r(LIST, ATTNAME, RVAL)
 
    IMPLICIT NONE
 
    TYPE(meta_list_t), INTENT(INOUT) :: LIST
    CHARACTER(*), INTENT(IN)         :: ATTNAME
    REAL, INTENT(IN)                 :: RVAL
    !/ ------------------------------------------------------------------- /
    !/ Local parameters
    !/
    TYPE(meta_pair_t) :: META
 
    meta%ATTNAME = attname
    WRITE(meta%ATTVAL,*) rval
    meta%TYPE = 'r'
    CALL meta_list_append(list, meta)
 
  END SUBROUTINE meta_list_append_r
 
 
  !/ ------------------------------------------------------------------- /
  !/ ------------------------------------------------------------------- /
  SUBROUTINE meta_list_append_i(LIST, ATTNAME, IVAL)
 
    IMPLICIT NONE
 
    TYPE(meta_list_t), INTENT(INOUT) :: LIST
    CHARACTER(*), INTENT(IN)         :: ATTNAME
    INTEGER, INTENT(IN)              :: IVAL
    !/ ------------------------------------------------------------------- /
    !/ Local parameters
    !/
    TYPE(meta_pair_t) :: META
 
    meta%ATTNAME = attname
    WRITE(meta%ATTVAL,*) ival
    meta%TYPE = 'i'
    CALL meta_list_append(list, meta)
 
  END SUBROUTINE meta_list_append_i
 
 
  !/ ------------------------------------------------------------------- /
  !/ ------------------------------------------------------------------- /
  SUBROUTINE meta_list_append_c(LIST, ATTNAME, SVAL)
 
    IMPLICIT NONE
 
    TYPE(meta_list_t), INTENT(INOUT) :: LIST
    CHARACTER(*), INTENT(IN)         :: ATTNAME, SVAL
    !/ ------------------------------------------------------------------- /
    !/ Local parameters
    !/
    TYPE(meta_pair_t) :: META
 
    meta%ATTNAME = attname
    meta%ATTVAL = sval
    meta%TYPE = 'c'
    CALL meta_list_append(list, meta)
 
  END SUBROUTINE meta_list_append_c
 
 
  !/ ------------------------------------------------------------------- /
  !/ ------------------------------------------------------------------- /
  SUBROUTINE meta_list_find_attr(LIST, ATTN, META, ERR)
    IMPLICIT NONE
 
    TYPE(meta_list_t), INTENT(IN)           :: LIST
    CHARACTER(*), INTENT(IN)                :: ATTN
    TYPE(meta_pair_t), POINTER, INTENT(OUT) :: META
    INTEGER, INTENT(OUT)                    :: ERR
 
    err = 0
 
    ! Empty list?
    IF(.NOT. ASSOCIATED(list%HEAD)) THEN
      err = 1
      RETURN
    ENDIF
 
    meta => list%HEAD
 
    DO
      IF(trim(meta%ATTNAME) == trim(attn)) RETURN
      IF(.NOT. ASSOCIATED(meta%NEXT)) EXIT
      meta => meta%NEXT
    ENDDO
 
    ! Not found
    NULLIFY(meta)
    err = 2
 
  END SUBROUTINE meta_list_find_attr
 
 
  !/ ------------------------------------------------------------------- /
  !/ ------------------------------------------------------------------- /
  FUNCTION meta_list_has_attr(LIST, ATTN) RESULT(FOUND)
 
    IMPLICIT NONE
 
    TYPE(meta_list_t), INTENT(IN)           :: list
    CHARACTER(*), INTENT(IN)                :: attn
    LOGICAL                                 :: found
    !/ ------------------------------------------------------------------- /
    !/ Local parameters
    !/
    TYPE(meta_pair_t), POINTER :: p
 
    found = .false.
 
    ! Empty list?
    IF(.NOT. ASSOCIATED(list%HEAD)) THEN
      RETURN
    ENDIF
 
    p => list%HEAD
 
    DO
      IF(trim(p%ATTNAME) == trim(attn)) THEN
        found = .true.
        RETURN
      ENDIF
 
      IF(.NOT. ASSOCIATED(p%NEXT)) EXIT
      p => p%NEXT
    ENDDO
 
  END FUNCTION meta_list_has_attr
 
  !/ ------------------------------------------------------------------- /
END MODULE w3metamd
!/ ------------------------------------------------------------------- /