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

MODULE mod_grid_group
  USE mod_grid
  USE mod_xmlio_parameters

  IMPLICIT NONE

  TYPE grid_group
    CHARACTER(LEN=str_len)                    :: id
    LOGICAL                                   :: has_id
    TYPE(vector_grid_group), POINTER          :: groups
    TYPE(vector_grid),POINTER                 :: grids     
    TYPE(grid), POINTER                       :: default_attribut
  END TYPE grid_group

  INCLUDE "vector_grid_group_def.inc"  

  TYPE(vector_grid_group),POINTER,SAVE       :: grid_group_Ids
  TYPE(sorted_list),POINTER,SAVE,PRIVATE     :: Ids 

  INTERFACE grid_group__set_attribut
    MODULE PROCEDURE grid_group__set_attribut_id,grid_group__set_attribut_pt
  END INTERFACE

CONTAINS

  INCLUDE "vector_grid_group_contains.inc"

  SUBROUTINE grid_group__swap_context(saved_grid_group_Ids,saved_ids)
  IMPLICIT NONE
  TYPE(vector_grid_group),POINTER       :: saved_grid_group_Ids
  TYPE(sorted_list),POINTER             :: saved_Ids 
   
   grid_group_ids=>saved_grid_group_ids
   ids=>saved_ids
   
  END SUBROUTINE grid_group__swap_context
   
  SUBROUTINE grid_group__init
  IMPLICIT NONE
    
    CALL vector_grid_group__new(grid_group_Ids)
    CALL sorted_list__new(Ids)
   
  END SUBROUTINE grid_group__init

  SUBROUTINE grid_group__get(Id,Pt_gg)
  USE string_function
  IMPLICIT NONE
    CHARACTER(LEN=*),INTENT(IN)     :: Id
    TYPE(grid_group),POINTER        :: Pt_gg

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


  SUBROUTINE grid_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(grid_group),POINTER             :: Pt_gg
    INTEGER                         :: Pos
    LOGICAL                         :: success
    
    CALL sorted_list__find(Ids,hash(Id),Pos,success)
    IF (success) THEN
      Pt_gg=>grid_group_ids%at(Pos)%Pt
      CALL grid_group__set_attribut(Pt_gg,attrib)
      IF (PRESENT(OK)) ok=.TRUE.
    ELSE
      IF (.NOT.PRESENT(OK)) THEN
        WRITE(message,*) 'grid group id :',id,'is undefined'
        CALL error('mod_grid_group::grid_group__set_attribut')
      ELSE
        OK=.FALSE.
      ENDIF
    ENDIF 
    
  END SUBROUTINE grid_group__set_attribut_id
  
  SUBROUTINE grid_group__set_attribut_pt(pt_gg,attrib)
  USE mod_attribut
  USE mod_object
  IMPLICIT NONE
    TYPE(grid_group),POINTER :: Pt_gg
    TYPE(attribut),INTENT(IN) :: attrib
     
    IF (attrib%object==grid_object) THEN
      CALL grid__set_attribut(pt_gg%default_attribut,attrib)
    ENDIF
    
  END SUBROUTINE grid_group__set_attribut_pt    



  RECURSIVE SUBROUTINE grid_group__new(Pt_gg,Id)
  USE string_function
  IMPLICIT NONE
    TYPE(grid_group),POINTER                :: Pt_gg
    CHARACTER(LEN=*),OPTIONAL,INTENT(IN)     :: Id
    
    INTEGER :: Pos
    
    ALLOCATE(Pt_gg%groups)
    ALLOCATE(Pt_gg%grids)
    ALLOCATE(Pt_gg%default_attribut)
    
    CALL vector_grid_group__new(Pt_gg%groups)
    CALL vector_grid__new(Pt_gg%grids)
    CALL grid__new(Pt_gg%default_attribut)
    Pt_gg%has_id=.FALSE.
      
    IF (PRESENT(Id)) THEN
      Pt_gg%id=TRIM(Id)
      Pt_gg%has_id=.TRUE.
      CALL vector_grid_group__set_new(grid_group_Ids,Pt_gg,Pos)
      CALL sorted_list__Add(Ids,hash(id),Pos)
    ENDIF

  END SUBROUTINE grid_group__new

      
  SUBROUTINE grid_group__get_new_group(Pt_gg,Pt_gg_out,Id)
  IMPLICIT NONE
    TYPE(grid_group),POINTER             :: Pt_gg
    TYPE(grid_group),POINTER             :: Pt_gg_out
    CHARACTER(LEN=*),OPTIONAL            :: Id
    
    CALL vector_grid_group__get_new(Pt_gg%groups,Pt_gg_out)
    CALL grid_group__new(Pt_gg_out)

    IF (PRESENT(id)) THEN
      CALL grid_group__new(Pt_gg_out,Id)
    ELSE
      CALL grid_group__new(Pt_gg_out)
    ENDIF
    
  END SUBROUTINE grid_group__get_new_group

  
  SUBROUTINE grid_group__get_new_grid(Pt_gg,Pt_g_out,Id)
  IMPLICIT NONE
    TYPE(grid_group),POINTER            :: Pt_gg
    TYPE(grid),POINTER                  :: Pt_g_out
    CHARACTER(LEN=*),OPTIONAL      :: Id
    
    CALL vector_grid__get_new(Pt_gg%grids,Pt_g_out)
    
    IF (PRESENT(id)) THEN
      CALL grid__new(Pt_g_out,Id)
    ELSE
      CALL grid__new(Pt_g_out)
    ENDIF
    
  END SUBROUTINE grid_group__get_new_grid
  
  
  SUBROUTINE grid_group__get_default_attrib(Pt_gg,Pt_g)
  IMPLICIT NONE
    TYPE(grid_group),POINTER  :: Pt_gg
    TYPE(grid),POINTER        :: Pt_g
    
    Pt_g=>Pt_gg%default_attribut
  END SUBROUTINE grid_group__get_default_attrib
  
  RECURSIVE SUBROUTINE grid_group__apply_default(Pt_gg,default)
  IMPLICIT NONE
    TYPE(grid_group),POINTER      :: Pt_gg
    TYPE(grid),POINTER,OPTIONAL   :: default
    
    INTEGER :: i
    
    IF (PRESENT(default)) THEN
      CALL grid__apply_default(default,Pt_gg%default_attribut,Pt_gg%default_attribut)
    ENDIF
      
    DO i=1,Pt_gg%groups%size
      CALL grid_group__apply_default(Pt_gg%groups%at(i)%pt,Pt_gg%default_attribut)
    ENDDO
    
    DO i=1,Pt_gg%grids%size
      CALL grid__apply_default(Pt_gg%default_attribut,Pt_gg%grids%at(i)%pt,Pt_gg%grids%at(i)%pt)
    ENDDO
  
  END SUBROUTINE grid_group__apply_default

  RECURSIVE SUBROUTINE grid_group__Process_domain(Pt_gg)
  IMPLICIT NONE
  TYPE(grid_group),POINTER  :: Pt_gg
    INTEGER :: i
    
    DO i=1,pt_gg%groups%size
      CALL grid_group__process_domain(pt_gg%groups%at(i)%pt)
    ENDDO
    
    DO i=1,pt_gg%grids%size
      CALL grid__process_domain(pt_gg%grids%at(i)%pt)
    ENDDO
    
  END SUBROUTINE grid_group__Process_domain
      

  RECURSIVE SUBROUTINE grid_group__print(Pt_gg)
  IMPLICIT NONE
    TYPE(grid_group),POINTER  :: Pt_gg
   
    INTEGER :: i
    
    PRINT *,"--- GRID GROUP ---"
    IF (pt_gg%has_id) THEN
      PRINT *,"id  ",TRIM(pt_gg%id)
    ELSE
      PRINT *,"id undefined"
    ENDIF
    
    PRINT *,"grid default attribut :"
    CALL grid__print(Pt_gg%default_attribut)    

    PRINT *,"owned grid groups : ",Pt_gg%groups%size      
    DO i=1,Pt_gg%groups%size
      CALL grid_group__print(Pt_gg%groups%at(i)%pt)
    ENDDO

    PRINT *,"owned grid : ",Pt_gg%grids%size     
    DO i=1,Pt_gg%grids%size
      CALL grid__print(Pt_gg%grids%at(i)%pt)
    ENDDO
    PRINT *,"------------"
  
  END SUBROUTINE grid_group__print
     
END MODULE mod_grid_group