source: vendors/XMLIO_SERVER/current/src/XMLIO/mod_file_group.f90 @ 1897

MODULE mod_file_group
  USE mod_file
  USE mod_xmlio_parameters

  IMPLICIT NONE

  TYPE file_group
    CHARACTER(LEN=str_len)                    :: id
    LOGICAL                                   :: has_id
    TYPE(vector_file_group), POINTER          :: groups
    TYPE(vector_file),POINTER                 :: files     
    TYPE(file), POINTER                       :: default_attribut
  END TYPE file_group

  INCLUDE "vector_file_group_def.inc"  

  TYPE(vector_file_group),POINTER,SAVE       :: file_group_Ids
  TYPE(sorted_list),POINTER,PRIVATE,SAVE     :: Ids 

  INTERFACE file_group__set_attribut
    MODULE PROCEDURE file_group__set_attribut_id,file_group__set_attribut_pt
  END INTERFACE

CONTAINS

  INCLUDE "vector_file_group_contains.inc"

  SUBROUTINE file_group__swap_context(saved_file_group_ids,saved_ids)
  IMPLICIT NONE
    TYPE(vector_file_group),POINTER      :: saved_file_group_Ids
    TYPE(sorted_list),POINTER            :: saved_Ids
    
    file_group_ids=>saved_file_group_ids
    ids=>saved_ids 
 
  END SUBROUTINE file_group__swap_context

  SUBROUTINE file_group__init
  IMPLICIT NONE
    
    CALL vector_file_group__new(file_group_Ids)
    CALL sorted_list__new(Ids)
   
  END SUBROUTINE file_group__init

  SUBROUTINE file_group__get(Id,Pt_fg)
  USE string_function
  IMPLICIT NONE
    CHARACTER(LEN=*),INTENT(IN)     :: Id
    TYPE(file_group),POINTER        :: Pt_fg

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

  SUBROUTINE file_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(file_group),POINTER             :: Pt_fg
    INTEGER                         :: Pos
    LOGICAL                         :: success
    
    CALL sorted_list__find(Ids,hash(Id),Pos,success)
    IF (success) THEN
      Pt_fg=>file_group_ids%at(Pos)%Pt
      CALL file_group__set_attribut(Pt_fg,attrib)
      IF (PRESENT(OK)) ok=.TRUE.
    ELSE
      IF (.NOT.PRESENT(OK)) THEN
        WRITE(message,*) 'file group id :',id,' is undefined'
        CALL error('mod_file_group::file_group__set_attribut')
      ELSE
        OK=.FALSE.
      ENDIF
    ENDIF 
    
  END SUBROUTINE file_group__set_attribut_id
  
  SUBROUTINE file_group__set_attribut_pt(pt_fg,attrib)
  USE mod_attribut
  USE mod_object
  IMPLICIT NONE
    TYPE(file_group),POINTER :: Pt_fg
    TYPE(attribut),INTENT(IN) :: attrib
     
    IF (attrib%object==file_object) THEN
      CALL file__set_attribut(Pt_fg%default_attribut,attrib)
    ENDIF
    
  END SUBROUTINE file_group__set_attribut_pt
  
      
  RECURSIVE SUBROUTINE file_group__new(Pt_fg,Id)
  USE string_function
  IMPLICIT NONE
    TYPE(file_group),POINTER                :: Pt_fg
    CHARACTER(LEN=*),OPTIONAL,INTENT(IN)     :: Id
    
    INTEGER :: Pos
    
    ALLOCATE(Pt_fg%groups)
    ALLOCATE(Pt_fg%files)
    ALLOCATE(Pt_fg%default_attribut)
    
    CALL vector_file_group__new(Pt_fg%groups)
    CALL vector_file__new(Pt_fg%files)
    CALL file__new(Pt_fg%default_attribut)
    Pt_fg%has_id=.FALSE.
      
    IF (PRESENT(Id)) THEN
      Pt_fg%id=TRIM(Id)
      Pt_fg%has_id=.TRUE.
      CALL vector_file_group__set_new(file_group_Ids,Pt_fg,Pos)
      CALL sorted_list__Add(Ids,hash(id),Pos)
    ENDIF

  END SUBROUTINE file_group__new

      
  SUBROUTINE file_group__get_new_group(Pt_fg,Pt_fg_out,Id)
  IMPLICIT NONE
    TYPE(file_group),POINTER             :: Pt_fg
    TYPE(file_group),POINTER             :: Pt_fg_out
    CHARACTER(LEN=*),OPTIONAL      :: Id
    
    CALL vector_file_group__get_new(Pt_fg%groups,Pt_fg_out)
    CALL file_group__new(Pt_fg_out)

    IF (PRESENT(id)) THEN
      CALL file_group__new(Pt_fg_out,Id)
    ELSE
      CALL file_group__new(Pt_fg_out)
    ENDIF
    
  END SUBROUTINE file_group__get_new_group

  
  SUBROUTINE file_group__get_new_file(Pt_fg,Pt_f_out,Id)
  IMPLICIT NONE
    TYPE(file_group),POINTER            :: Pt_fg
    TYPE(file),POINTER                  :: Pt_f_out
    CHARACTER(LEN=*),OPTIONAL      :: Id
    
    CALL vector_file__get_new(Pt_fg%files,Pt_f_out)
    
    IF (PRESENT(id)) THEN
      CALL file__new(Pt_f_out,Id)
    ELSE
      CALL file__new(Pt_f_out)
    ENDIF
    
  END SUBROUTINE file_group__get_new_file
  
  
  SUBROUTINE file_group__get_default_attrib(Pt_fg,Pt_f)
  IMPLICIT NONE
    TYPE(file_group),POINTER  :: Pt_fg
    TYPE(file),POINTER        :: Pt_f
    
    Pt_f=>Pt_fg%default_attribut
  END SUBROUTINE file_group__get_default_attrib
  
  RECURSIVE SUBROUTINE file_group__apply_default(Pt_fg,default)
  IMPLICIT NONE
    TYPE(file_group),POINTER  :: Pt_fg
    TYPE(file),POINTER,OPTIONAL        :: default
    
    INTEGER :: i
    
    IF (PRESENT(default)) THEN
      CALL file__apply_default(default,Pt_fg%default_attribut,Pt_fg%default_attribut)
    ENDIF
      
    DO i=1,Pt_fg%groups%size
      CALL file_group__apply_default(Pt_fg%groups%at(i)%pt,Pt_fg%default_attribut)
    ENDDO
    
    DO i=1,Pt_fg%files%size
      CALL file__apply_default(Pt_fg%default_attribut,Pt_fg%files%at(i)%pt,Pt_fg%files%at(i)%pt)
    ENDDO
  
  END SUBROUTINE file_group__apply_default

  RECURSIVE SUBROUTINE file_group__solve_field_ref(pt_fg)
  IMPLICIT NONE
    TYPE(file_group),POINTER  :: Pt_fg

    INTEGER :: i

    DO i=1,Pt_fg%groups%size
      CALL file_group__solve_field_ref(Pt_fg%groups%at(i)%pt)
    ENDDO
    
    DO i=1,Pt_fg%files%size
      CALL file__solve_field_ref(Pt_fg%files%at(i)%pt)
    ENDDO
  
  END SUBROUTINE file_group__solve_field_ref
  
  
  RECURSIVE SUBROUTINE file_group__print(Pt_fg)
  IMPLICIT NONE
    TYPE(file_group),POINTER  :: Pt_fg
   
    INTEGER :: i
    
    PRINT *,"--- FILE GROUP ---"
    IF (Pt_fg%has_id) THEN
      PRINT *,"id :",TRIM(Pt_fg%id)
    ELSE
      PRINT *,"id undefined"
    ENDIF
    
    PRINT *,"file default attribut :"
    CALL file__print(Pt_fg%default_attribut)    

    PRINT *,"owned file groups :"      
    DO i=1,Pt_fg%groups%size
      CALL file_group__print(Pt_fg%groups%at(i)%pt)
    ENDDO

    PRINT *,"owned file :"      
    DO i=1,Pt_fg%files%size
      CALL file__print(Pt_fg%files%at(i)%pt)
    ENDDO
  
  END SUBROUTINE file_group__print     

  RECURSIVE SUBROUTINE file_group__Check(Pt_fg)
  IMPLICIT NONE
  
    TYPE(file_group),POINTER  :: Pt_fg
    INTEGER :: i
   
    DO i=1,Pt_fg%groups%size
      CALL file_group__check(pt_fg%groups%at(i)%pt)
    ENDDO

    DO i=1,Pt_fg%files%size
      CALL file__check(pt_fg%files%at(i)%pt)
    ENDDO
  
  END SUBROUTINE file_group__check     
          
END MODULE mod_file_group