source: XMLIO_SERVER/trunk/src/XMLIO/mod_axis.f90 @ 26

MODULE mod_axis

  USE mod_xmlio_parameters
  USE mod_sorted_list

  
  IMPLICIT NONE

  TYPE, PUBLIC :: axis
    CHARACTER(len=str_len)      :: id
    LOGICAL                     :: has_id
    CHARACTER(len=str_len)      :: name
    LOGICAL                     :: has_name
    INTEGER                     :: size
    LOGICAL                     :: has_size
    CHARACTER(len=str_len)      :: description
    LOGICAL                     :: has_description
    CHARACTER(len=str_len)      :: unit
    LOGICAL                     :: has_unit
    REAL, DIMENSION(:), POINTER :: values
    LOGICAL                     :: has_values

  END TYPE axis

  INCLUDE 'vector_axis_def.inc'
  
  TYPE(vector_axis),POINTER,SAVE             :: axis_Ids
  TYPE(sorted_list),POINTER,SAVE,PRIVATE     :: Ids 

CONTAINS
  INCLUDE 'vector_axis_contains.inc'

  SUBROUTINE axis__swap_context(saved_axis_Ids,saved_Ids)
  IMPLICIT NONE
    TYPE(vector_axis),POINTER          :: saved_axis_Ids
    TYPE(sorted_list),POINTER          :: saved_Ids 
    
    axis_ids=>saved_axis_ids
    ids=>saved_ids
    
  END SUBROUTINE axis__swap_context

  SUBROUTINE axis__init
  IMPLICIT NONE
    
    CALL vector_axis__new(axis_Ids)
    CALL sorted_list__new(Ids)
   
  END SUBROUTINE axis__init
  
  SUBROUTINE axis__get(Id,Pt_axis)
  USE string_function
  IMPLICIT NONE
    CHARACTER(LEN=*),INTENT(IN)     :: Id
    TYPE(axis),POINTER              :: Pt_axis

    INTEGER                         :: Pos
    LOGICAL                         :: success
    
    CALL sorted_list__find(Ids,hash(Id),Pos,success)
    IF (success) THEN
      Pt_axis=>axis_ids%at(Pos)%Pt
    ELSE
      Pt_axis=>NULL()
    ENDIF
    
  END SUBROUTINE axis__get
  
  SUBROUTINE axis__new(pt_axis,Id)
  USE string_function
  IMPLICIT NONE
   TYPE(axis), POINTER           :: pt_axis
   CHARACTER(LEN=*),OPTIONAL     :: Id
   INTEGER                       :: Pos
   
   pt_axis%has_id         = .FALSE.
   pt_axis%has_name        = .FALSE.
   pt_axis%has_size        = .FALSE.
   pt_axis%has_description = .FALSE.
   pt_axis%has_unit        = .FALSE.
   pt_axis%has_values      = .FALSE.
   
   IF (PRESENT(Id)) THEN
     Pt_axis%id=TRIM(ADJUSTL(Id))
     Pt_axis%has_id=.TRUE.
     CALL vector_axis__set_new(axis_Ids,Pt_axis,Pos)
     CALL sorted_list__Add(Ids,hash(id),Pos)
   ENDIF

 END SUBROUTINE axis__new

  SUBROUTINE axis__set(pt_axis, name, description, unit, a_size, values)
  IMPLICIT NONE
    TYPE(axis), POINTER         :: pt_axis
    CHARACTER(len=*)  ,OPTIONAL :: name
    CHARACTER(len=*)  ,OPTIONAL :: description
    CHARACTER(len=*)  ,OPTIONAL :: unit
    INTEGER           ,OPTIONAL :: a_size
    REAL, DIMENSION(:),OPTIONAL :: values

    IF (PRESENT(name)) THEN
        pt_axis%name=TRIM(ADJUSTL(name))
        pt_axis%has_name = .TRUE.
    ENDIF

    IF (PRESENT(description)) THEN
        pt_axis%description=TRIM(ADJUSTL(description))
        pt_axis%has_description = .TRUE.
    ENDIF
 
    IF (PRESENT(unit)) then
        pt_axis%unit=TRIM(ADJUSTL(unit))
        pt_axis%has_unit = .TRUE.
    ENDIF

    IF (PRESENT(a_size)) then
        pt_axis%size=a_size
        pt_axis%has_size = .TRUE.
    ENDIF
    
    IF (PRESENT(values)) then
        IF (pt_axis%has_values) DEALLOCATE(pt_axis%values)  
        ALLOCATE(pt_axis%values(size(values)))
        pt_axis%values(:)=values(:)
        pt_axis%has_values = .TRUE.
    ENDIF

  END SUBROUTINE axis__set

  SUBROUTINE axis__print(pt_axis)
  IMPLICIT NONE
    TYPE(axis), POINTER         :: pt_axis

    PRINT *,"---- AXIS ----"
    IF (pt_axis%has_id) THEN
      PRINT *,"id = ",TRIM(pt_axis%id)
    ELSE
      PRINT *,"id undefined"
    ENDIF
    
    IF (pt_axis%has_name) THEN
      PRINT *,"name = ",TRIM(pt_axis%name)
    ELSE
      PRINT *,"name undefined"
    ENDIF
    
    IF (pt_axis%has_description) THEN
      PRINT *,"description = ",TRIM(pt_axis%description)
    ELSE
      PRINT *,"description undefined"
    ENDIF
 
    IF (pt_axis%has_unit) THEN
      PRINT *,"unit = ",TRIM(pt_axis%unit)
    ELSE
      PRINT *,"unit undefined"
    ENDIF

    IF (pt_axis%has_size) THEN
      PRINT *,"size = ",pt_axis%size
    ELSE
      PRINT *,"size undefined"
    ENDIF

    IF (pt_axis%has_values) THEN
      PRINT *,"values = ",pt_axis%values
    ELSE
      PRINT *,"values undefined"
    ENDIF

  END SUBROUTINE axis__print


  SUBROUTINE axis__apply_default(pt_axis_default, pt_axis_in, pt_axis_out)

    TYPE(axis), POINTER :: pt_axis_default, pt_axis_in, pt_axis_out

    IF (pt_axis_in%has_name) THEN
        pt_axis_out%name=pt_axis_in%name
        pt_axis_out%has_name=.TRUE.
    ELSE IF ( pt_axis_default%has_name) THEN
        pt_axis_out%name=pt_axis_default%name
        pt_axis_out%has_name=.TRUE.
    ELSE
        pt_axis_out%has_name=.FALSE.
    ENDIF
        
    IF (pt_axis_in%has_description) THEN
        pt_axis_out%description=pt_axis_in%description
        pt_axis_out%has_description=.TRUE.
    ELSE IF ( pt_axis_default%has_description ) THEN
        pt_axis_out%description=pt_axis_default%description
        pt_axis_out%has_description=.TRUE.
    ELSE
        pt_axis_out%has_description=.FALSE.
    ENDIF

    IF (pt_axis_in%has_unit) THEN
        pt_axis_out%unit=pt_axis_in%unit
        pt_axis_out%has_unit=.TRUE.
    ELSE IF ( pt_axis_default%has_unit ) THEN
        pt_axis_out%unit=pt_axis_default%unit
        pt_axis_out%has_unit=.TRUE.
    ELSE
        pt_axis_out%has_unit=.FALSE.
    ENDIF

    IF (pt_axis_in%has_size) THEN
        pt_axis_out%size=pt_axis_in%size
        pt_axis_out%has_size=.TRUE.
    ELSE IF ( pt_axis_default%has_size ) THEN
        pt_axis_out%size=pt_axis_default%size
        pt_axis_out%has_size=.TRUE.
    ELSE
        pt_axis_out%has_size=.FALSE.
    ENDIF

    IF (pt_axis_in%has_values) THEN
        pt_axis_out%values(:)=pt_axis_in%values(:)
        pt_axis_out%has_values=.TRUE.
    ELSE IF ( pt_axis_default%has_values ) THEN
        pt_axis_out%values(:)=pt_axis_default%values(:)
        pt_axis_out%has_values=.TRUE.
    ELSE
        pt_axis_out%has_values=.FALSE.
    ENDIF
    
  END SUBROUTINE axis__apply_default

  SUBROUTINE axis__check(pt_axis)
  USE error_msg
  IMPLICIT NONE
    TYPE(axis), POINTER :: pt_axis
      
    IF (.NOT. pt_axis%has_name) THEN
      IF (pt_axis%has_id) THEN
        pt_axis%name=TRIM(pt_axis%id)
      ELSE
        WRITE(message,*) "Axis has no name and no id" 
        CALL error("mod_axis::axis__check")
      ENDIF 
    ENDIF
 
 END SUBROUTINE axis__Check

END MODULE mod_axis