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

MODULE mod_zoom
  USE mod_xmlio_parameters
  USE mod_sorted_list

  IMPLICIT NONE

  TYPE,PUBLIC :: zoom
    CHARACTER(len=str_len)      :: id
    LOGICAL                     :: has_id
    CHARACTER(len=str_len)      :: name
    LOGICAL                     :: has_name
    CHARACTER(len=str_len)      :: description
    LOGICAL                     :: has_description
    INTEGER                     :: ni_glo
    LOGICAL                     :: has_ni_glo
    INTEGER                     :: nj_glo
    LOGICAL                     :: has_nj_glo
    INTEGER                     :: ibegin_glo
    LOGICAL                     :: has_ibegin_glo
    INTEGER                     :: jbegin_glo
    LOGICAL                     :: has_jbegin_glo
    INTEGER                     :: ni_loc
    INTEGER                     :: nj_loc
    INTEGER                     :: ibegin_loc
    INTEGER                     :: jbegin_loc
  END TYPE zoom    

  INCLUDE 'vector_zoom_def.inc'

  TYPE(vector_zoom),POINTER,SAVE             :: zoom_Ids
  TYPE(sorted_list),POINTER,SAVE,PRIVATE     :: Ids 

  INTERFACE zoom__set_attribut
    MODULE PROCEDURE zoom__set_attribut_id,zoom__set_attribut_pt
  END INTERFACE
  
CONTAINS
  
  INCLUDE 'vector_zoom_contains.inc'

  SUBROUTINE zoom__swap_context(saved_zoom_Ids,saved_Ids)
  IMPLICIT NONE
    TYPE(vector_zoom),POINTER          :: saved_zoom_Ids
    TYPE(sorted_list),POINTER          :: saved_Ids 
    
    zoom_ids=>saved_zoom_ids
    ids=>saved_ids
  END SUBROUTINE zoom__swap_context


  SUBROUTINE zoom__init
  IMPLICIT NONE

    CALL vector_zoom__new(zoom_Ids)
    CALL sorted_list__new(Ids)
    
  END SUBROUTINE zoom__init
  

  SUBROUTINE zoom__new(pt_zoom,Id)
  USE string_function
  IMPLICIT NONE
    TYPE(zoom),POINTER :: pt_zoom
    CHARACTER(LEN=*),OPTIONAL     :: Id
    INTEGER   :: Pos 
      
    pt_zoom%has_id=.FALSE.
    pt_zoom%has_name=.FALSE.
    pt_zoom%has_description=.FALSE.
    pt_zoom%has_ni_glo=.FALSE.
    pt_zoom%has_nj_glo=.FALSE.
    pt_zoom%has_ibegin_glo=.FALSE.
    pt_zoom%has_jbegin_glo=.FALSE.
     
    IF (PRESENT(Id)) THEN
      Pt_zoom%id=TRIM(ADJUSTL(Id))
      Pt_zoom%has_id=.TRUE.
     CALL vector_zoom__set_new(zoom_Ids,Pt_zoom,Pos)
     CALL sorted_list__Add(Ids,hash(id),Pos)
    ENDIF
   
  END SUBROUTINE zoom__new
   
  SUBROUTINE zoom__set(pt_zoom,name,description,ni_glo,nj_glo,ibegin_glo,jbegin_glo)
  IMPLICIT NONE
    TYPE(zoom),POINTER                   :: pt_zoom
    CHARACTER(len=*),OPTIONAL            :: name
    CHARACTER(len=*),OPTIONAL            :: description
    INTEGER,OPTIONAL                     :: ni_glo
    INTEGER,OPTIONAL                     :: nj_glo
    INTEGER,OPTIONAL                     :: ibegin_glo
    INTEGER,OPTIONAL                     :: jbegin_glo
    
    IF (PRESENT(name)) THEN
      pt_zoom%name=TRIM(ADJUSTL(name))
      pt_zoom%has_name=.TRUE.
    ENDIF
    
    IF (PRESENT(description)) THEN
      pt_zoom%name=TRIM(ADJUSTL(description))
      pt_zoom%has_description=.TRUE.
    ENDIF
    
    IF (PRESENT(ni_glo)) THEN
      pt_zoom%ni_glo=ni_glo
      pt_zoom%has_ni_glo=.TRUE.
    ENDIF

    IF (PRESENT(nj_glo)) THEN
      pt_zoom%nj_glo=nj_glo
      pt_zoom%has_nj_glo=.TRUE.
    ENDIF

    IF (PRESENT(ibegin_glo)) THEN
      pt_zoom%ibegin_glo=ibegin_glo
      pt_zoom%has_ibegin_glo=.TRUE.
    ENDIF
    
    IF (PRESENT(jbegin_glo)) THEN
      pt_zoom%jbegin_glo=jbegin_glo
      pt_zoom%has_ibegin_glo=.TRUE.
    ENDIF
               
   END SUBROUTINE zoom__set   

  SUBROUTINE zoom__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(zoom),POINTER              :: Pt_zoom
    INTEGER                         :: Pos
    LOGICAL                         :: success
    
    CALL sorted_list__find(Ids,hash(Id),Pos,success)
    IF (success) THEN
      Pt_zoom=>zoom_ids%at(Pos)%Pt
      CALL zoom__set_attribut_pt(Pt_zoom,attrib)
      IF (PRESENT(OK)) OK=.TRUE.
    ELSE
      IF (.NOT.PRESENT(OK)) THEN
        WRITE(message,*) 'zoom id :',id,'is undefined'
        CALL error('mod_zoom::zoom__set_attribut')
      ELSE
        OK=.FALSE.
      ENDIF
    ENDIF  
  
  END SUBROUTINE zoom__set_attribut_id
      
  SUBROUTINE zoom__set_attribut_pt(Pt_zoom,attrib)
  USE mod_attribut
  USE mod_zoom_attribut
  USE error_msg
  IMPLICIT NONE
    TYPE(zoom),POINTER        :: Pt_zoom
    TYPE(attribut),INTENT(IN) :: attrib
    
    SELECT CASE(attrib%name)
      CASE (zoom__name)
        IF (attrib%type==string0) CALL  zoom__set(pt_zoom,name=attrib%string0_ptr) ; RETURN
      CASE (zoom__description)
        IF (attrib%type==string0) CALL  zoom__set(pt_zoom,description=attrib%string0_ptr) ; RETURN
      CASE (zoom__ni)
        IF (attrib%type==integer0) CALL  zoom__set(pt_zoom,ni_glo=attrib%integer0_ptr) ; RETURN
      CASE (zoom__nj)
        IF (attrib%type==integer0) CALL  zoom__set(pt_zoom,nj_glo=attrib%integer0_ptr) ; RETURN
      CASE (zoom__ibegin)
        IF (attrib%type==integer0) CALL  zoom__set(pt_zoom,ibegin_glo=attrib%integer0_ptr) ; RETURN
      CASE (zoom__jbegin)
        IF (attrib%type==integer0) CALL  zoom__set(pt_zoom,jbegin_glo=attrib%integer0_ptr) ; RETURN
     END SELECT

     WRITE(message,*) 'zoom attribut ',attrib%name,' : type :',attrib%type,   &
                      ' : Attribute type is incompatible with the provided value'
     CALL error('mod_zoom::zoom__set_attribut')
    
  END SUBROUTINE zoom__set_attribut_pt

  SUBROUTINE zoom__get(Id,pt_zoom)
  USE string_function
  IMPLICIT NONE
    CHARACTER(LEN=*),INTENT(IN)     :: Id
    TYPE(zoom),POINTER              :: Pt_zoom

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

END MODULE mod_zoom