source: codes/icosagcm/trunk/src/field.f90 @ 15

MODULE field_mod
  USE genmod
  
  INTEGER,PARAMETER :: field_T=1
  INTEGER,PARAMETER :: field_U=2
  INTEGER,PARAMETER :: field_Z=3

  INTEGER,PARAMETER :: type_integer=1
  INTEGER,PARAMETER :: type_real=2
  INTEGER,PARAMETER :: type_logical=3
    
  TYPE t_field
    REAL(rstd),POINTER :: rval2d(:)
    REAL(rstd),POINTER :: rval3d(:,:)
    REAL(rstd),POINTER :: rval4d(:,:,:)

    INTEGER,POINTER :: ival2d(:)
    INTEGER,POINTER :: ival3d(:,:)
    INTEGER,POINTER :: ival4d(:,:,:)
    
    LOGICAL,POINTER :: lval2d(:)
    LOGICAL,POINTER :: lval3d(:,:)
    LOGICAL,POINTER :: lval4d(:,:,:)

    INTEGER :: ndim
    INTEGER :: field_type
    INTEGER :: data_type 
  END TYPE t_field   

  INTERFACE get_val
    MODULE PROCEDURE getval_r2d,getval_r3d,getval_r4d, &
                     getval_i2d,getval_i3d,getval_i4d, &
                     getval_l2d,getval_l3d,getval_l4d
  END INTERFACE
                   
  INTERFACE ASSIGNMENT(=)
    MODULE PROCEDURE getval_r2d,getval_r3d,getval_r4d, &
                     getval_i2d,getval_i3d,getval_i4d, &
                     getval_l2d,getval_l3d,getval_l4d 
  END INTERFACE


CONTAINS

  SUBROUTINE allocate_field(field,field_type,data_type,dim1,dim2)
  USE domain_mod
  IMPLICIT NONE
    TYPE(t_field),POINTER :: field(:)
    INTEGER,INTENT(IN) :: field_type
    INTEGER,INTENT(IN) :: data_type
    INTEGER,OPTIONAL :: dim1,dim2
    INTEGER :: ind
    INTEGER :: ii_size,jj_size

    ALLOCATE(field(ndomain))    

    DO ind=1,ndomain
  
      IF (PRESENT(dim2)) THEN
        field(ind)%ndim=4 
      ELSE IF (PRESENT(dim1)) THEN
        field(ind)%ndim=3
      ELSE
        field(ind)%ndim=2
      ENDIF
    
    
      field(ind)%data_type=data_type
      field(ind)%field_type=field_type
    
      IF (field_type==field_T) THEN 
        jj_size=domain(ind)%jjm
      ELSE IF (field_type==field_U) THEN 
        jj_size=3*domain(ind)%jjm
      ELSE IF (field_type==field_Z) THEN 
        jj_size=2*domain(ind)%jjm
      ENDIF
      
      ii_size=domain(ind)%iim
        
      IF (field(ind)%ndim==4) THEN
        IF (data_type==type_integer) ALLOCATE(field(ind)%ival4d(ii_size*jj_size,dim1,dim2))
        IF (data_type==type_real)    ALLOCATE(field(ind)%rval4d(ii_size*jj_size,dim1,dim2))
        IF (data_type==type_logical) ALLOCATE(field(ind)%lval4d(ii_size*jj_size,dim1,dim2))
      ELSE IF (field(ind)%ndim==3) THEN
        IF (data_type==type_integer) ALLOCATE(field(ind)%ival3d(ii_size*jj_size,dim1))
        IF (data_type==type_real)    ALLOCATE(field(ind)%rval3d(ii_size*jj_size,dim1))
        IF (data_type==type_logical) ALLOCATE(field(ind)%lval3d(ii_size*jj_size,dim1))
      ELSE IF (field(ind)%ndim==2) THEN
        IF (data_type==type_integer) ALLOCATE(field(ind)%ival2d(ii_size*jj_size))
        IF (data_type==type_real)    ALLOCATE(field(ind)%rval2d(ii_size*jj_size))
        IF (data_type==type_logical) ALLOCATE(field(ind)%lval2d(ii_size*jj_size))
      ENDIF
      
   ENDDO
   
  END SUBROUTINE allocate_field
  
  SUBROUTINE getval_r2d(field_pt,field)
  IMPLICIT NONE  
    REAL(rstd),POINTER,INTENT(INOUT) :: field_pt(:)
    TYPE(t_field),INTENT(IN) :: field
    
    IF (field%ndim/=2 .OR. field%data_type/=type_real) STOP 'get_val_r2d : bad pointer assignation'        
    field_pt=>field%rval2d
  END SUBROUTINE  getval_r2d

  SUBROUTINE getval_r3d(field_pt,field)
  IMPLICIT NONE  
    REAL(rstd),POINTER,INTENT(INOUT) :: field_pt(:,:)
    TYPE(t_field),INTENT(IN) :: field
    
    IF (field%ndim/=3 .OR. field%data_type/=type_real) STOP 'get_val_r3d : bad pointer assignation'        
    field_pt=>field%rval3d
  END SUBROUTINE  getval_r3d

  SUBROUTINE getval_r4d(field_pt,field)
  IMPLICIT NONE  
    REAL(rstd),POINTER,INTENT(INOUT) :: field_pt(:,:,:)
    TYPE(t_field),INTENT(IN) :: field
    
    IF (field%ndim/=4 .OR. field%data_type/=type_real) STOP 'get_val_r4d : bad pointer assignation'        
    field_pt=>field%rval4d
  END SUBROUTINE  getval_r4d
  

  
  SUBROUTINE getval_i2d(field_pt,field)
  IMPLICIT NONE  
    INTEGER,POINTER,INTENT(INOUT) :: field_pt(:)
    TYPE(t_field),INTENT(IN) :: field
    
    IF (field%ndim/=2 .OR. field%data_type/=type_integer) STOP 'get_val_i2d : bad pointer assignation'        
    field_pt=>field%ival2d
  END SUBROUTINE  getval_i2d

  SUBROUTINE getval_i3d(field_pt,field)
  IMPLICIT NONE  
    INTEGER,POINTER,INTENT(INOUT) :: field_pt(:,:)
    TYPE(t_field),INTENT(IN) :: field
    
    IF (field%ndim/=3 .OR. field%data_type/=type_integer) STOP 'get_val_i3d : bad pointer assignation'        
    field_pt=>field%ival3d
  END SUBROUTINE  getval_i3d

  SUBROUTINE getval_i4d(field_pt,field)
  IMPLICIT NONE  
    INTEGER,POINTER,INTENT(INOUT) :: field_pt(:,:,:)
    TYPE(t_field),INTENT(IN) :: field
    
    IF (field%ndim/=4 .OR. field%data_type/=type_integer) STOP 'get_val_i4d : bad pointer assignation'        
    field_pt=>field%ival4d
  END SUBROUTINE  getval_i4d

  SUBROUTINE getval_l2d(field_pt,field)
  IMPLICIT NONE  
    LOGICAL,POINTER,INTENT(INOUT) :: field_pt(:)
    TYPE(t_field),INTENT(IN) :: field
    
    IF (field%ndim/=2 .OR. field%data_type/=type_logical) STOP 'get_val_l2d : bad pointer assignation'        
    field_pt=>field%lval2d
  END SUBROUTINE  getval_l2d

  SUBROUTINE getval_l3d(field_pt,field)
  IMPLICIT NONE  
    LOGICAL,POINTER,INTENT(INOUT) :: field_pt(:,:)
    TYPE(t_field),INTENT(IN) :: field
    
    IF (field%ndim/=3 .OR. field%data_type/=type_logical) STOP 'get_val_l3d : bad pointer assignation'        
    field_pt=>field%lval3d
  END SUBROUTINE  getval_l3d

  SUBROUTINE getval_l4d(field_pt,field)
  IMPLICIT NONE  
    LOGICAL,POINTER,INTENT(INOUT) :: field_pt(:,:,:)
    TYPE(t_field),INTENT(IN) :: field
    
    IF (field%ndim/=4 .OR. field%data_type/=type_logical) STOP 'get_val_l4d : bad pointer assignation'        
    field_pt=>field%lval4d
  END SUBROUTINE  getval_l4d    

END MODULE field_mod