source: branches/DEV_r1879_FCM/NEMOGCM/EXTERNAL/XMLIO_SERVER/src/XMLIO/mod_domain.f90 @ 1916

MODULE mod_domain
   USE mod_xmlio_parameters
   INTEGER, PARAMETER :: box=1
   INTEGER, PARAMETER :: orange=2
   
  TYPE domain
    INTEGER :: rank
    INTEGER :: ni
    INTEGER :: nj
    INTEGER :: ibegin
    INTEGER :: iend
    INTEGER :: jbegin
    INTEGER :: jend
    REAL,POINTER :: lon(:,:)
    REAL,POINTER :: lat(:,:)
    
    INTEGER         :: type
    LOGICAL,POINTER :: mask(:)
    INTEGER,POINTER :: i_index(:)
    INTEGER,POINTER :: j_index(:)
    INTEGER         :: nbp
    LOGICAL         :: is_defined
  END TYPE domain
 
  INCLUDE 'vector_domain_def.inc'

CONTAINS

  INCLUDE 'vector_domain_contains.inc'

  SUBROUTINE domain__new(Pt_domain)
  IMPLICIT NONE
    TYPE(domain),POINTER  :: Pt_domain
    
    Pt_domain%is_defined=.FALSE.
    
  END SUBROUTINE domain__new
  
  SUBROUTINE domain__set(Pt_domain,rank,ni,nj,ibegin,jbegin,lon,lat)
  IMPLICIT NONE
    TYPE(domain),POINTER  :: Pt_domain
    INTEGER,INTENT(IN) :: rank
    INTEGER,INTENT(IN) :: ni
    INTEGER,INTENT(IN) :: nj
    INTEGER,INTENT(IN) :: ibegin
    INTEGER,INTENT(IN) :: jbegin
    REAL,INTENT(IN)    :: lon(ni,nj)
    REAL,INTENT(IN)    :: lat(ni,nj)

    Pt_domain%rank=rank
    Pt_domain%ni=ni
    Pt_domain%nj=nj
    Pt_domain%ibegin=ibegin
    Pt_domain%jbegin=jbegin   
    Pt_domain%iend=ibegin+ni-1
    Pt_domain%jend=jbegin+nj-1
    ALLOCATE(Pt_domain%lon(ni,nj))
    ALLOCATE(Pt_domain%lat(ni,nj))
    Pt_domain%lon(:,:)=lon(:,:)
    Pt_domain%lat(:,:)=lat(:,:)
    Pt_domain%is_defined=.TRUE.
  END SUBROUTINE domain__set


  SUBROUTINE domain__set_type_box(Pt_domain,mask)
  USE error_msg
  IMPLICIT NONE
    TYPE(domain),POINTER  :: Pt_domain
    LOGICAL,INTENT(IN),OPTIONAL :: mask(:,:)
    INTEGER                     :: i,j
  
    Pt_domain%type=box
    pt_domain%nbp=pt_domain%ni*pt_domain%nj
    ALLOCATE(Pt_domain%i_index(pt_domain%nbp))
    ALLOCATE(Pt_domain%j_index(pt_domain%nbp))
    ALLOCATE(pt_domain%mask(pt_domain%nbp))

    IF (PRESENT(mask)) THEN
      IF ( size(mask,1)==pt_domain%ni .AND. size(mask,2)==pt_domain%nj) THEN
        DO i=1,pt_domain%ni
          DO j=1,pt_domain%nj
            pt_domain%mask((j-1)*pt_domain%ni+i)=mask(i,j)
          ENDDO
        ENDDO
      ELSE
        WRITE (message,*) "mask dimensions are not compliant with domain dimensions :",   &
                           size(mask,1),",",size(mask,2),"/=",Pt_domain%ni,",",Pt_domain%nj
        CALL error("domain__set_type_box")
      ENDIF
    ELSE
      pt_domain%mask(:)=.TRUE.
    ENDIF
    
    DO i=1,pt_domain%ni
      DO j=1,pt_domain%nj
        pt_domain%i_index((j-1)*pt_domain%ni+i) = i
        pt_domain%j_index((j-1)*pt_domain%ni+i) = j
      ENDDO
    ENDDO

  END SUBROUTINE domain__set_type_box


  SUBROUTINE domain__set_type_orange(Pt_domain,nbp,offset,opt_index)
  IMPLICIT NONE
    TYPE(domain),POINTER        :: Pt_domain
    INTEGER,INTENT(IN)          :: nbp
    INTEGER,INTENT(IN)          :: offset
    INTEGER,INTENT(IN),OPTIONAL :: opt_index(:)
    
    INTEGER  :: index(nbp)
    INTEGER  :: i
    
    Pt_domain%type=orange
    
    IF (PRESENT(opt_index)) THEN
      index(:)=opt_index(:)       
    ELSE
      DO i=1,nbp
        index(i)=i
      ENDDO
    ENDIF

    pt_domain%nbp=nbp
    ALLOCATE(pt_domain%i_index(nbp))
    ALLOCATE(pt_domain%j_index(nbp))
    ALLOCATE(pt_domain%mask(nbp))
        
    DO i=1,nbp
!      Pt_domain%i_index(i)=(index(i)+offset)/pt_domain%ni+1+pt_domain%ibegin-1
!      Pt_domain%j_index(i)=MOD(index(i)+offset,pt_domain%ni)+1+pt_domain%jbegin-1
      Pt_domain%i_index(i)=MOD(index(i)+offset-1,pt_domain%ni)+1
      Pt_domain%j_index(i)=(index(i)+offset-1)/pt_domain%ni+1
      
    ENDDO

    Pt_domain%mask(:)=.TRUE.

  END SUBROUTINE domain__set_type_orange


    
  SUBROUTINE domain__print(pt_domain)
  IMPLICIT NONE
    TYPE(domain),POINTER   :: Pt_domain

    PRINT *,"---- DOMAIN ----"
    
    IF (pt_domain%is_defined) THEN
      PRINT *,"rank :",pt_domain%rank
      PRINT *,"ni :",pt_domain%ni
      PRINT *,"nj :",pt_domain%nj
      PRINT *,"ibegin",pt_domain%ibegin
      PRINT *,"iend",pt_domain%iend
    ELSE
      PRINT *,"  ---> domain undefined"
    ENDIF
    
    PRINT *,"-----------------"
  END SUBROUTINE domain__print
  
  SUBROUTINE domain__copy(Pt_in,pt_out)
  IMPLICIT NONE
    TYPE(domain),POINTER   :: Pt_in
    TYPE(domain),POINTER   :: Pt_out
  
    IF (pt_in%is_defined) THEN
      CALL domain__set(pt_out,pt_in%rank,pt_in%ni,pt_in%nj,pt_in%ibegin,pt_in%jbegin,pt_in%lon,pt_in%lat)
    ENDIF
  END SUBROUTINE domain__copy
  
END MODULE mod_domain