source: branches/nemo_v3_3_beta/NEMOGCM/EXTERNAL/XMLIO_SERVER/src/XMLIO/mod_axis_group.f90 @ 2281

MODULE mod_axis_group
  USE mod_axis
  USE mod_xmlio_parameters

  IMPLICIT NONE

  TYPE axis_group
    CHARACTER(LEN=str_len)                    :: id
    LOGICAL                                   :: has_id
    TYPE(vector_axis_group), POINTER          :: groups
    TYPE(vector_axis),POINTER                 :: axis     
    TYPE(axis), POINTER                       :: default_attribut
  END TYPE axis_group

  INCLUDE "vector_axis_group_def.inc"  

  TYPE(vector_axis_group),POINTER       :: axis_group_Ids
  TYPE(sorted_list),POINTER,PRIVATE     :: Ids 

  INTERFACE axis_group__set_attribut
    MODULE PROCEDURE axis_group__set_attribut_id,axis_group__set_attribut_pt
  END INTERFACE

CONTAINS

  INCLUDE "vector_axis_group_contains.inc"

  SUBROUTINE axis_group__swap_context(saved_axis_group_Ids,saved_ids)
  IMPLICIT NONE
  TYPE(vector_axis_group),POINTER       :: saved_axis_group_Ids
  TYPE(sorted_list),POINTER             :: saved_Ids 
   
   axis_group_ids=>saved_axis_group_ids
   ids=>saved_ids
   
  END SUBROUTINE axis_group__swap_context

  SUBROUTINE axis_group__init
  IMPLICIT NONE
    
    CALL vector_axis_group__new(axis_group_Ids)
    CALL sorted_list__new(Ids)
   
  END SUBROUTINE axis_group__init

  SUBROUTINE axis_group__get(Id,Pt_ag)
  USE string_function
  IMPLICIT NONE
    CHARACTER(LEN=*),INTENT(IN)     :: Id
    TYPE(axis_group),POINTER        :: Pt_ag

    INTEGER                         :: Pos
    LOGICAL                         :: success
    
    CALL sorted_list__find(Ids,hash(Id),Pos,success)
    IF (success) THEN
      Pt_ag=>axis_group_ids%at(Pos)%Pt
    ELSE
      Pt_ag=>NULL()
    ENDIF
    
  END SUBROUTINE axis_group__get


  SUBROUTINE axis_group__set_attribut_id(id,attrib,Ok)
  USE mod_attribut
  USE error_msg
  IMPLICIT NONE
    CHARACTER(LEN=*),INTENT(IN) :: id
    TYPE(attribut),INTENT(IN) :: attrib
    LOGICAL,OPTIONAL,INTENT(out)  :: Ok
    
    TYPE(axis_group),POINTER             :: Pt_ag
    INTEGER                         :: Pos
    LOGICAL                         :: success
    
    CALL sorted_list__find(Ids,hash(Id),Pos,success)
    IF (success) THEN
      Pt_ag=>axis_group_ids%at(Pos)%Pt
      CALL axis_group__set_attribut(Pt_ag,attrib)
      IF (PRESENT(OK)) ok=.TRUE.
    ELSE
      IF (.NOT.PRESENT(OK)) THEN
        WRITE(message,*) 'axis group id :',id,'is undefined'
        CALL error('mod_axis_group::axis_group__set_attribut')
      ELSE
        OK=.FALSE.
      ENDIF
    ENDIF 
    
  END SUBROUTINE axis_group__set_attribut_id
  
  SUBROUTINE axis_group__set_attribut_pt(pt_ag,attrib)
  USE mod_attribut
  USE mod_object
  IMPLICIT NONE
    TYPE(axis_group),POINTER :: Pt_ag
    TYPE(attribut),INTENT(IN) :: attrib
     
    IF (attrib%object==axis_object) THEN
      CALL axis__set_attribut(pt_ag%default_attribut,attrib)
    ENDIF
    
  END SUBROUTINE axis_group__set_attribut_pt
      
  RECURSIVE SUBROUTINE axis_group__new(Pt_ag,Id)
  USE string_function
  IMPLICIT NONE
    TYPE(axis_group),POINTER                :: Pt_ag
    CHARACTER(LEN=*),OPTIONAL,INTENT(IN)     :: Id
    
    INTEGER :: Pos
    
    ALLOCATE(Pt_ag%groups)
    ALLOCATE(Pt_ag%axis)
    ALLOCATE(Pt_ag%default_attribut)
    
    CALL vector_axis_group__new(Pt_ag%groups)
    CALL vector_axis__new(Pt_ag%axis)
    CALL axis__new(Pt_ag%default_attribut)
    Pt_ag%has_id=.FALSE.
      
    IF (PRESENT(Id)) THEN
      Pt_ag%id=TRIM(Id)
      Pt_ag%has_id=.TRUE.
      CALL vector_axis_group__set_new(axis_group_Ids,Pt_ag,Pos)
      CALL sorted_list__Add(Ids,hash(id),Pos)
    ENDIF

  END SUBROUTINE axis_group__new

      
  SUBROUTINE axis_group__get_new_group(Pt_ag,Pt_ag_out,Id)
  IMPLICIT NONE
    TYPE(axis_group),POINTER             :: Pt_ag
    TYPE(axis_group),POINTER             :: Pt_ag_out
    CHARACTER(LEN=*),OPTIONAL      :: Id
    
    CALL vector_axis_group__get_new(Pt_ag%groups,Pt_ag_out)
    CALL axis_group__new(Pt_ag_out)

    IF (PRESENT(id)) THEN
      CALL axis_group__new(Pt_ag_out,Id)
    ELSE
      CALL axis_group__new(Pt_ag_out)
    ENDIF
    
  END SUBROUTINE axis_group__get_new_group

  
  SUBROUTINE axis_group__get_new_axis(Pt_ag,Pt_a_out,Id)
  IMPLICIT NONE
    TYPE(axis_group),POINTER            :: Pt_ag
    TYPE(axis),POINTER                  :: Pt_a_out
    CHARACTER(LEN=*),OPTIONAL      :: Id
    
    CALL vector_axis__get_new(Pt_ag%axis,Pt_a_out)
    
    IF (PRESENT(id)) THEN
      CALL axis__new(Pt_a_out,Id)
    ELSE
      CALL axis__new(Pt_a_out)
    ENDIF
    
  END SUBROUTINE axis_group__get_new_axis
  
  
  SUBROUTINE axis_group__get_default_attrib(Pt_ag,Pt_a)
  IMPLICIT NONE
    TYPE(axis_group),POINTER  :: Pt_ag
    TYPE(axis),POINTER        :: Pt_a
    
    Pt_a=>Pt_ag%default_attribut
  END SUBROUTINE axis_group__get_default_attrib
  
  RECURSIVE SUBROUTINE axis_group__apply_default(Pt_ag,default)
  IMPLICIT NONE
    TYPE(axis_group),POINTER           :: Pt_ag
    TYPE(axis),POINTER,OPTIONAL        :: default
    INTEGER :: i
    
    IF (PRESENT(default)) THEN
      CALL axis__apply_default(default,Pt_ag%default_attribut,Pt_ag%default_attribut)
    ENDIF
      
    DO i=1,Pt_ag%groups%size
      CALL axis_group__apply_default(Pt_ag%groups%at(i)%pt,Pt_ag%default_attribut)
    ENDDO
    
    DO i=1,Pt_ag%axis%size
      CALL axis__apply_default(Pt_ag%default_attribut,Pt_ag%axis%at(i)%pt,Pt_ag%axis%at(i)%pt)
    ENDDO
  
  END SUBROUTINE axis_group__apply_default

  RECURSIVE SUBROUTINE axis_group__print(Pt_ag)
  IMPLICIT NONE
    TYPE(axis_group),POINTER  :: Pt_ag
   
    INTEGER :: i
    
    PRINT *,"--- AXIS GROUP ---"
    IF (pt_ag%has_id) THEN
      PRINT *,"id = ",TRIM(pt_ag%id)
    ELSE
      PRINT *,"id undefined"
    ENDIF
    
    PRINT *,"axis default attribut :"
    CALL axis__print(Pt_ag%default_attribut)    

    PRINT *,"owned axis groups :",Pt_ag%groups%size      
    DO i=1,Pt_ag%groups%size
      CALL axis_group__print(Pt_ag%groups%at(i)%pt)
    ENDDO

    PRINT *,"owned axis :",Pt_ag%axis%size      
    DO i=1,Pt_ag%axis%size
      CALL axis__print(Pt_ag%axis%at(i)%pt)
    ENDDO
    PRINT *,"------------"
    
  END SUBROUTINE axis_group__print

  RECURSIVE SUBROUTINE axis_group__Check(Pt_ag)
  IMPLICIT NONE
  
    TYPE(axis_group),POINTER  :: Pt_ag
    INTEGER :: i
   
    DO i=1,Pt_ag%groups%size
      CALL axis_group__check(pt_ag%groups%at(i)%pt)
    ENDDO

    DO i=1,Pt_ag%axis%size
      CALL axis__check(pt_ag%axis%at(i)%pt)
    ENDDO
  
  END SUBROUTINE axis_group__check     
   
END MODULE mod_axis_group