psmile_def_var.F90

Go to the documentation of this file.

!-----------------------------------------------------------------------
! Copyright 2006-2010, CERFACS, Toulouse, France.
! Copyright 2006-2010, SGI Germany, Munich, Germany.
! Copyright 2006-2010, NEC Europe Ltd., London, UK.
! All rights reserved. Use is subject to OASIS4 license terms.
!-----------------------------------------------------------------------
!BOP
!
! !ROUTINE: psmile_def_var
!
! !INTERFACE:
!
      subroutine psmile_def_var ( var_id, name, grid_id, method_id, mask_id, &
                                 var_nodims, var_actual_shape, var_type, ierror )
!
! !USES:
!
      use PRISM
!
      use PSMILe, dummy => psmile_def_var
      use PSMILe_SMIOC, only : sga_smioc_comp, transient, transient_out, PSMILe_in_origin
!
      implicit none
!
! !INPUT PARAMETERS:
!
      character (len=*), intent (In)      :: name

!     character identifier for the variable for identification in the SMIOC/SCC:

      integer, intent (In)                :: mask_id

!     Specifies handle to the mask information created by routine
!     prism_def_mask:
!     May be PRISM_UNDEFINED if a mask is not available.

      integer, intent (In)                :: method_id

!     Specifies handle to the grid information created by routine
!     prism_set_point:

      integer, intent (In)                :: grid_id

!     Specifies handle to the grid information created by routine
!     prism_def_grid:

      integer, intent (In)                :: var_nodims(2)

!     var_nodims(1): the overall number of dimensions of array that is going
!                    to be transferred with var_id, i.e. same than grid_nodims
!                    except for bundle variables for which it is one more.
!     var_nodims(2): number of bundles. Since var_nodims(2) may be specified as 0
!                    the maximum of var_nodims(2) and 1 is used internally to
!                    set sizes and shapes.

      integer, intent (in) :: var_actual_shape(1:2,1:var_nodims(1))

!     Dimension of the block

!     var_actual_shape (1,        1) = Lowest  first   index of block
!     var_actual_shape (2,        1) = Highest first   index of block
!     var_actual_shape (1,        2) = Lowest  second  index of block
!     var_actual_shape (2,        2) = Highest second  index of block
!        ...
!     var_actual_shape (1,        i) = Lowest  i-th    index of block
!     var_actual_shape (2,        i) = Highest i-th    index of block
!     var_actual_shape (1, var_nodims(1)) = Lowest  ndim-th index of block
!     var_actual_shape (2, var_nodims(1)) = Highest ndim-th index of block

      integer, intent (In)                :: var_type

!     type of array PRISM_INT, PRISM_REAL or PRISM_DOUBLE, needed since
!     we will not overload prism_put and prism_get for performance reasons.
!
! !OUTPUT PARAMETERS:
!
      integer, intent (Out)               :: var_id

!     Returns the handle to the variable information created.

      integer, intent (Out)               :: ierror

!     Returns the error code of PRISM_DefineBlock;
!             ierror = 0 : No error
!             ierror > 0 : Severe error
!
! !LOCAL VARIABLES
!
      integer            :: i, ii, point_id, length

      integer            :: bundle_field
      integer            :: vector_field
      integer            :: test_dim
      integer            :: nodims(2)

      type (Grid),         pointer :: gp
      type (GridFunction), pointer :: fp
      type (Coords_Block), pointer :: coords_pointer
!
!  ... SMIOC info
!
      integer            :: nb_transi_out
      integer            :: nb_transi_in
      integer            :: s_ptr
      integer            :: smioc_loc
!
      type (PSMILe_in_origin), pointer :: sga_in_orig (:)
      type (transient),        pointer :: sga_smioc_transi (:)
      type (transient_out),    pointer :: sga_transi_out(:)
!
!  ... Error parameters
!
      integer, parameter :: nerrp = 2
      integer            :: ierrp (nerrp)
!
! !DESCRIPTION:
!
! Subroutine "psmile_def_var" defines a n-dimensional variable.
!     Currently it is assumed that the grid is 3-d. var_nodims(1)
!     therefore must be ndim_3d for ordinary variables or ndim_3d+1
!     for vectors and bundles.
!
!
! !REVISION HISTORY:
!
!   Date      Programmer   Description
! ----------  ----------   -----------
! 02.09.02    R. Redler    created
! 09.01.03    R. Vogelsang added the call of psmile_def_metadata
! 19.11.03    R. Redler    major revision, several checks added
!
!EOP
!----------------------------------------------------------------------
!
! $Id: psmile_def_var.F90 2803 2010-12-06 17:28:25Z hanke $
! $Author: hanke $
!
  character(len=len_cvs_string), save :: mycvs = 
      '$Id: psmile_def_var.F90 2803 2010-12-06 17:28:25Z hanke $'
!
!----------------------------------------------------------------------

#ifdef VERBOSE
      print *, trim(ch_id), ': psmile_def_var: start'
      print *, trim(ch_id), ': psmile_def_var: grid_id =', grid_id,   &
                                          'method_id = ', method_id, &
                                          'mask_id = ', mask_id

      call psmile_flushstd
#endif /* VERBOSE */

!-----------------------------------------------------------------------
!  1st   Control Grid id
!-----------------------------------------------------------------------

      if (grid_id < 1 .or. &
          grid_id > Number_of_Grids_allocated) then

         ierrp (1) = grid_id
         ierrp (2) = Number_of_Grids_allocated

         ierror = PRISM_Error_Arg

         call psmile_error ( ierror, 'grid_id', &
                             ierrp, 2, __FILE__, __LINE__ )
         return
      endif
!
      if (Grids(grid_id)%status == PSMILe_status_free) then

         ierrp (1) = grid_id

         ierror = PRISM_Error_Arg

         call psmile_error ( PRISM_Error_Arg, 'grid_id (not active)', &
                             ierrp, 1, __FILE__, __LINE__ )
         return
      endif

!-----------------------------------------------------------------------
!  2nd)  Initialization
!-----------------------------------------------------------------------

      ierror        = 0

      test_dim      = 0
      nb_transi_out = 0
      nb_transi_in  = 0

      nodims        = var_nodims
#ifdef DEBUG
            print *, trim(ch_id), ': var_nodims = ',nodims
#endif

      gp            => Grids(grid_id)
      sga_smioc_transi => sga_smioc_comp(gp%comp_id)%sga_smioc_transi

!-----------------------------------------------------------------------
!  3rd)  Check whether the field name was specified in the XML file
!-----------------------------------------------------------------------

!
! ... check whether the field name was specified in the XML file
!
      do smioc_loc = 1, size(sga_smioc_transi)
         if ( trim(sga_smioc_transi(smioc_loc)%cg_local_name) == trim(adjustl(name)) ) then
#ifdef DEBUG
            print *, trim(ch_id), ': psmile_def_var compared name   ', &
                                     trim(adjustl(name))
            print *, trim(ch_id), ': psmile_def_var with smioc name ', &
                                     trim(sga_smioc_transi(smioc_loc)%cg_local_name)
#endif
            exit
         endif
      enddo

!-----------------------------------------------------------------------
!  4th)  Control other input arguments
!-----------------------------------------------------------------------

#ifdef DEBUG
      print *, trim(ch_id), ': psmile_def_var called with name            ', &
                               trim(adjustl(name))
      print *, trim(ch_id), ': psmile_def_var associated sga_smioc_transi ', &
                               associated(sga_smioc_transi)
      print *, trim(ch_id), ': psmile_def_var size of sga_smioc_transi    ', &
                               size(sga_smioc_transi)
#endif

!-----------------------------------------------------------------------
!  a)   Control Method id
!-----------------------------------------------------------------------

      if ( method_id == PRISM_UNDEFINED ) then

             ierrp (1) = method_id

             ierror = PRISM_Error_Arg

             call psmile_error ( PRISM_Error_Arg, 'method_id (is not defined)', &
                             ierrp, 1, __FILE__, __LINE__ )
             return
      else

          if (method_id < 1 .or. &
              method_id > Number_of_Methods_allocated ) then

             ierrp (1) = method_id
             ierrp (2) = Number_of_Methods_allocated

             ierror = PRISM_Error_Arg

             call psmile_error ( ierror, 'method_id', &
                                 ierrp, 2, __FILE__, __LINE__ )
             return
          endif
!
          if (Methods(method_id)%status == PSMILe_status_free) then

             ierrp (1) = method_id

             ierror = PRISM_Error_Arg

             call psmile_error ( PRISM_Error_Arg, 'method_id (not active)', &
                             ierrp, 1, __FILE__, __LINE__ )
             return
          endif

          if (Methods(method_id)%grid_id /= grid_id) then

             ierrp (1) = method_id

             ierror = PRISM_Error_Arg

             call psmile_error ( PRISM_Error_Arg, 'method has wrong grid_id', &
                             ierrp, 1, __FILE__, __LINE__ )
             return
          endif

      endif

!-----------------------------------------------------------------------
!  b)   Control Grid id for vector fields 
!-----------------------------------------------------------------------

      if ( Associated(Methods(method_id)%vector_pointer) ) then
         do i = 1, 3
            point_id=Methods(method_id)%vector_pointer%array_of_point_ids(i)
            if ( Methods(point_id)%grid_id /= grid_id ) then 
 
              ierrp (1) = grid_id
              ierrp (2) = Methods(point_id)%grid_id

              ierror = PRISM_Error_Arg

              call psmile_error ( ierror, 'inconsistent grid_ids for vector component', &
                                  ierrp, 2, __FILE__, __LINE__ )
              return
            endif
          enddo
      endif

!-----------------------------------------------------------------------
!  c)   Control Mask Id
!-----------------------------------------------------------------------

      if ( mask_id /= PRISM_UNDEFINED ) then
         if ( mask_id < 0 .or. &
              mask_id > Number_of_Masks_allocated ) then
            ierrp (1) = mask_id
            ierrp (2) = Number_of_Masks_allocated

            ierror = PRISM_Error_Arg

            call psmile_error ( ierror, 'mask_id', &
                 ierrp, 2, __FILE__, __LINE__ )
            return
         endif

         if (Masks(mask_id)%status == PSMILe_status_free ) then
            ierrp (1) = mask_id

            ierror = PRISM_Error_Arg

            call psmile_error ( PRISM_Error_Arg, 'mask_id (not active)', &
                 ierrp, 1, __FILE__, __LINE__ )
            return
         endif

         if (Masks(mask_id)%grid_id /= grid_id ) then
            ierrp (1) = mask_id

            ierror = PRISM_Error_Arg

            call psmile_error ( PRISM_Error_Arg, 'mask has wrong grid_id', &
                 ierrp, 1, __FILE__, __LINE__ )
            return
         endif

      endif

!-----------------------------------------------------------------------
!  d)   Control dimensions
!-----------------------------------------------------------------------

      if (nodims(1) < 1 .or. nodims(1) > max_dim) then
         ierror = PRISM_Error_Arg
         ierrp (1) = nodims(1)
         ierrp (2) = max_dim

         call psmile_error ( ierror, 'nodims (1)', &
                             ierrp, 2, __FILE__, __LINE__ )
         return
      endif
!
      do i = 1, nodims(1)
         if (var_actual_shape(1,i) > var_actual_shape(2,i)) exit
      enddo
!
      if (i <= nodims(1)) then
         ierror = PRISM_Error_Arg
         ierrp (1) = var_actual_shape(1,i)
         ierrp (2) = var_actual_shape(2,i)

         call psmile_error ( ierror, 'var_actual_shape', &
                             ierrp, 2, __FILE__, __LINE__ )
         return
      endif

!-----------------------------------------------------------------------
!  5th  Get handle Id and Nullify the pointer
!-----------------------------------------------------------------------

      call psmile_get_field_handle (var_id, ierror)
      if (ierror > 0) return
!
      fp => Fields(var_id)

!-----------------------------------------------------------------------
!  6th  Detect whether the field was activated by the user.
!       Set the location to undefined when nothing was found.
!       Else determine whether it was activated for any output
!       or input and set it to undefined when no action was 
!       activated.
!-----------------------------------------------------------------------

!
      fp%global_var_id = sga_smioc_transi(smioc_loc)%ig_transi_id

      fp%smioc_loc     = PRISM_UNDEFINED

      do ii = 1, sga_smioc_transi(smioc_loc)%ig_nb_transi_out
         if ( sga_smioc_transi(smioc_loc)%sga_transi_out(ii)%ig_dest_type > 0 ) exit
      enddo

      if ( ii > sga_smioc_transi(smioc_loc)%ig_nb_transi_out .and. &
           sga_smioc_transi(smioc_loc)%sg_transi_in%ig_nb_in_orig < 1 ) then
         fp%smioc_loc = PRISM_UNDEFINED
      else if ( smioc_loc <= size(sga_smioc_transi) ) then
         fp%smioc_loc = smioc_loc
         s_ptr                    = smioc_loc
      endif

!-----------------------------------------------------------------------
! ... in case  fp%smioc_loc == PRISM_UNDEFINED we have to
!     return here since the field has not been activated by the user 
!     and s_ptr would point to nowhere and the following actions will
!     not be well defined.
!-----------------------------------------------------------------------

      fp%local_name = trim(adjustl(name))

      if ( fp%smioc_loc == PRISM_UNDEFINED ) then
         ierrp (1) = var_id
         call psmile_warning ( PRISM_UNDEFINED, 'Field name is not activated. We return', &
                      ierrp, 1, __FILE__, __LINE__ )
         return
      endif

#ifdef DEBUG
      print *, trim(ch_id), ': We point to ', fp%smioc_loc, ' in SMIOC struct.'
#endif


!-----------------------------------------------------------------------
!  7th  Check whether it is a vector, bundle or scalar field
!-----------------------------------------------------------------------

      select case ( sga_smioc_transi(s_ptr)%ig_transi_type )

      case ( PSMILe_bunvec )
          bundle_field = 1
          vector_field = 1
          fp%transi_type = PSMILe_bunvec
          if ( .not. Associated(Methods(method_id)%vector_pointer) ) then
            ierror = PRISM_Error_Arg
            ierrp (1) = method_id
            ierrp (2) = sga_smioc_transi(s_ptr)%ig_transi_type
            call psmile_error ( ierror, 'Variable not declared as vector', &
                                ierrp, 1, __FILE__, __LINE__ )
            return
          endif
          if ( nodims(2) < 1 ) then
            ierror = PRISM_Error_Arg
            ierrp (1) = nodims(2)
            ierrp (2) = sga_smioc_transi(s_ptr)%ig_transi_type
            call psmile_error ( ierror, 'Bundle dim must be > 0', &
                                ierrp, 1, __FILE__, __LINE__ )
            return
          endif

      case ( PSMILe_bundle )
          bundle_field = 1
          vector_field = 0
          fp%transi_type = PSMILe_bundle
          if ( nodims(2) < 1 ) then
            ierror = PRISM_Error_Arg
            ierrp (1) = nodims(2)
            ierrp (2) = sga_smioc_transi(s_ptr)%ig_transi_type
            call psmile_error ( ierror, 'Bundle dim must be > 0', &
                                ierrp, 1, __FILE__, __LINE__ )
            return
          endif

      case ( PSMILe_vector )
          nodims(2) = 3
          bundle_field  = 0
          vector_field  = 1
          fp%transi_type = PSMILe_vector
          if ( .not. Associated(Methods(method_id)%vector_pointer) ) then
            ierror = PRISM_Error_Arg
            ierrp (1) = method_id
            ierrp (2) = sga_smioc_transi(s_ptr)%ig_transi_type
            call psmile_error ( ierror, 'Variable not declared as vector', &
                                ierrp, 1, __FILE__, __LINE__ )
            return
          endif

      case ( PSMILe_single )
          nodims(2) = 0
          bundle_field  = 0
          vector_field  = 0
          fp%transi_type = PSMILe_single

      case DEFAULT
          ! PSMILe_single
          ! Since this argument will become mandatory in the SMIOC
          ! the default should be replaced by an error handling in future.
          nodims(2) = 0
          bundle_field  = 0
          vector_field  = 0
          fp%transi_type = PSMILe_single

      end select

!-----------------------------------------------------------------------
!  8th  Check for correct nodims(1) depending on grid_type
!-----------------------------------------------------------------------

      select case ( gp%grid_type )

      case ( PRISM_Unstructlonlatvrt )
         if ( nodims(1) /= 1+bundle_field+vector_field ) then
            ierror = PRISM_Error_Arg
            ierrp (1) = nodims(1)
            ierrp (2) = 1+bundle_field+vector_field

            call psmile_error ( ierror, 'nodims(1)', &
                                ierrp, 2, __FILE__, __LINE__ )
            return
         endif

      case ( PRISM_Unstructlonlat_regvrt )
         if ( nodims(1) /= 2+bundle_field+vector_field ) then
            ierror = PRISM_Error_Arg
            ierrp (1) = nodims(1)
            ierrp (2) = 1+bundle_field+vector_field

            call psmile_error ( ierror, 'nodims(1)', &
                                ierrp, 2, __FILE__, __LINE__ )
            return
         endif

      case ( PRISM_Gaussreduced_regvrt )
 
         if ( nodims(1) /= 2+bundle_field+vector_field ) then
            ierror = PRISM_Error_Arg
            ierrp (1) = nodims(1)
            ierrp (2) = 1+bundle_field+vector_field

            call psmile_error ( ierror, 'nodims(1)', &
                                ierrp, 2, __FILE__, __LINE__ )
            return
         endif

      case ( PRISM_Unstructlonlat_sigmavrt )
         if ( nodims(1) /= 2+bundle_field+vector_field ) then
            ierror = PRISM_Error_Arg
            ierrp (1) = nodims(1)
            ierrp (2) = 1+bundle_field+vector_field

            call psmile_error ( ierror, 'nodims(1)', &
                                ierrp, 2, __FILE__, __LINE__ )
            return
         endif

      case DEFAULT
         if ( nodims(1) /= 3+bundle_field+vector_field ) then
            ierror = PRISM_Error_Arg
            ierrp (1) = nodims(1)
            ierrp (2) = 1+bundle_field+vector_field

            call psmile_error ( ierror, 'nodims(1)', &
                                ierrp, 2, __FILE__, __LINE__ )
            return
         endif

      end select

#ifdef VERBOSE
      print '(" ",a,a,i8,a1,a,a)', trim(ch_id), ': psmile_def_var: var_id ', &
                      var_id, ' ', trim(name), ' specified as '
      if ( bundle_field == 1 ) print *, trim(ch_id), ':   - bundle'
      if ( vector_field == 1 ) print *, trim(ch_id), ':   - vector'
      if ( bundle_field == 0 .and. &
           vector_field == 0 ) print *, trim(ch_id), ':   - scalar'

      call psmile_flushstd
#endif /* VERBOSE */

!-----------------------------------------------------------------------
!  9th  Check whether the vector part has the appropriate shape. Only
!       full 3-d vector components are supported. One component for
!       each of the three dimensions is required.
!-----------------------------------------------------------------------

      if ( vector_field == 1 .and. &
         ( var_actual_shape(1,nodims(1)-bundle_field) /= 1 .or. &
         ( var_actual_shape(2,nodims(1)-bundle_field) /= 3 ))) then

         ierror = PRISM_Error_Arg
         ierrp (1) = var_actual_shape(1,nodims(1)-bundle_field)
         ierrp (2) = var_actual_shape(2,nodims(1)-bundle_field)

         call psmile_error ( ierror, 'var_actual_shape', &
                             ierrp, 2, __FILE__, __LINE__ )
         return
      endif

!-----------------------------------------------------------------------
!  10th  Initialize and store shapes (see also prism_def_partition)
!-----------------------------------------------------------------------

      fp%var_shape = 1

      select case ( gp%grid_type )

      case ( PRISM_Unstructlonlatvrt )
         fp%var_shape(1:2,1:1) = var_actual_shape (1:2,1:1)
         if ( bundle_field == 1 ) &
         fp%var_shape(2,nodims(1)) = max(nodims(2),1) ! nbr of bundles

      case ( PRISM_Unstructlonlat_regvrt )
         fp%var_shape(1:2,1:2) = var_actual_shape (1:2,1:2)
         if ( bundle_field == 1 ) &
         fp%var_shape(2,nodims(1)) = max(nodims(2),1) ! nbr of bundles

      case ( PRISM_Unstructlonlat_sigmavrt )
         fp%var_shape(1:2,1:2) = var_actual_shape (1:2,1:2)
         if ( bundle_field == 1 ) &
         fp%var_shape(2,nodims(1)) = max(nodims(2),1) ! nbr of bundles

      case ( PRISM_Gaussreduced_regvrt )
         nodims(1) = nodims(1) + 1
         fp%var_shape(1:2,1) = var_actual_shape (1:2,1)
         fp%var_shape(1:2,2) = 1
         fp%var_shape(1:2,3) = var_actual_shape (1:2,2)
         if ( bundle_field == 1 ) &
         fp%var_shape(2,nodims(1)) = max(nodims(2),1) ! nbr of bundles

      case DEFAULT
         fp%var_shape(1:2,1:ndim_3d) = var_actual_shape (1:2,1:ndim_3d)
         if ( bundle_field == 1 ) &
         fp%var_shape(2,nodims(1)) = max(nodims(2),1) ! nbr of bundles

      end select

!-----------------------------------------------------------------------
!  11th  Determine the total length of input data 
!-----------------------------------------------------------------------

      length = 1
      do i = 1, nodims(1)
         length = length * ( fp%var_shape(2,i) - &
                             fp%var_shape(1,i) + 1 )
      enddo

#ifdef VERBOSE
  print *, trim(ch_id), ': psmile_def_var: ndim_3d = ',ndim_3d
  print *, '    : psmile_def_var: size var_shape dim 1 = ',size(var_actual_shape(:,:),DIM=1)
  print *, '    : psmile_def_var: size var_shape dim 2 = ',size(var_actual_shape(:,:),DIM=2)
  print *, '    : psmile_def_var: var_shape = ',var_actual_shape
  print *, '    : psmile_def_var: length = ',length
  print *, '    : psmile_def_var: var_type = ',var_type
#endif
!-----------------------------------------------------------------------
!  12th Store other field data
!-----------------------------------------------------------------------

      fp%status      = PSMILe_status_defined
      fp%comp_id     = gp%comp_id
      fp%method_id   = method_id
      fp%mask_id     = mask_id
      fp%size        = length
      fp%dataType    = var_type

!-----------------------------------------------------------------------
!  a)   Transient in 
!-----------------------------------------------------------------------

      fp%Taskin%Judate_Lbnd%days = huge(fp%Taskin%Judate_Ubnd%days)
      fp%Taskin%Judate_Lbnd%secs = huge(fp%Taskin%Judate_Ubnd%days)

      fp%Taskin%Judate_Ubnd%days = huge(fp%Taskin%Judate_Ubnd%days)
      fp%Taskin%Judate_Ubnd%secs = huge(fp%Taskin%Judate_Ubnd%days)

      if ( sga_smioc_transi(s_ptr)%ig_datatype /= var_type ) then

            ierror    = PRISM_Error_Arglist
            ierrp (1) = sga_smioc_transi(s_ptr)%ig_datatype
            ierrp (2) = var_type

            call psmile_error ( ierror, &
                 "var_type in SMIOC does not match var_type given by component.", &
                 ierrp, 2, __FILE__, __LINE__ )
      endif

      nb_transi_in = sga_smioc_transi(s_ptr)%sg_transi_in%ig_nb_in_orig

      fp%Taskin%nbr_inchannels = nb_transi_in

      if ( nb_transi_in > 0 ) then

         Allocate (fp%Taskin%In_channel(nb_transi_in))
         if ( ierror /= 0 ) then
            ierrp (1) = nb_transi_in
            ierror = PRISM_Error_Alloc
            call psmile_error ( ierror, 'Fields(var_id)%Taskin%In_channel', &
                 ierrp, 1, __FILE__, __LINE__ )
            return
         endif

         sga_in_orig => sga_smioc_transi(s_ptr)%sg_transi_in%sga_in_orig

         do i = 1, nb_transi_in

!-----------------------------------------------------------------------
! ... ids concerning the input channels
!-----------------------------------------------------------------------

            fp%Taskin%In_channel(i)%origin_type = &
               sga_in_orig(i)%ig_orig_type

            fp%Taskin%In_channel(i)%remote_transi_id = &
               sga_in_orig(i)%ig_orig_transi_id

            fp%Taskin%In_channel(i)%global_transi_id = &
               sga_in_orig(i)%ig_transi_in_id

            fp%Taskin%In_channel(i)%remote_comp_id = &
               sga_in_orig(i)%ig_orig_comp_id

            fp%Taskin%In_channel(i)%assoc_var_id = PSMILe_undef

            fp%Taskin%In_channel(i)%userdef_id = PSMILe_undef

!-----------------------------------------------------------------------
! ... information on interpolation
!-----------------------------------------------------------------------

            fp%Taskin%In_channel(i)%interp%interp_type = &
               sga_in_orig(i)%sg_interp%ig_interp_type

            fp%Taskin%In_channel(i)%interp%interp_meth = &
               sga_in_orig(i)%sg_interp%iga_interp_meth

            fp%Taskin%In_channel(i)%interp%arg1 = &
               sga_in_orig(i)%sg_interp%iga_arg1

            fp%Taskin%In_channel(i)%interp%arg2 = &
               sga_in_orig(i)%sg_interp%iga_arg2

            fp%Taskin%In_channel(i)%interp%arg3 = &
               sga_in_orig(i)%sg_interp%iga_arg3

            fp%Taskin%In_channel(i)%interp%arg4 = &
               sga_in_orig(i)%sg_interp%iga_arg4

            fp%Taskin%In_channel(i)%interp%arg5 = &
               sga_in_orig(i)%sg_interp%iga_arg5

            fp%Taskin%In_channel(i)%interp%arg6 = &
               sga_in_orig(i)%sg_interp%iga_arg6

            fp%Taskin%In_channel(i)%interp%arg7 = &
               sga_in_orig(i)%sg_interp%iga_arg7

            fp%Taskin%In_channel(i)%interp%arg8 = &
               sga_in_orig(i)%sg_interp%dg_arg8

            fp%Taskin%In_channel(i)%interp%arg9 = &
               sga_in_orig(i)%sg_interp%cg_arg9

            fp%Taskin%In_channel(i)%interp%arg10 = &
               sga_in_orig(i)%sg_interp%sg_arg10

!-----------------------------------------------------------------------
! ... information on combination
!-----------------------------------------------------------------------

            fp%Taskin%In_channel(i)%combi%combi_name = &
               sga_in_orig(i)%sg_combi%cg_combi_name

            fp%Taskin%In_channel(i)%combi%ext_mask_name = &
               sga_in_orig(i)%sg_combi%cg_ext_mask_name

!!$            fp%Taskin%In_channel(i)%combi%ext_mask_file = &
!!$               sga_in_orig(i)%sg_combi%sg_ext_mask_file 

            fp%Taskin%In_channel(i)%combi%combi_param = &
               sga_in_orig(i)%sg_combi%dg_combi_param

            fp%Taskin%In_channel(i)%combi%scalar = &
               sga_in_orig(i)%sg_combi%dg_scalar

            fp%Taskin%In_channel(i)%combi%location = &
               sga_in_orig(i)%sg_combi%ig_location

            fp%Taskin%In_channel(i)%combi%operand = &
               sga_in_orig(i)%sg_combi%ig_operand

            fp%Taskin%In_channel(i)%combi%mask_type = &
               sga_in_orig(i)%sg_combi%ig_mask_type

            fp%Taskin%In_channel(i)%combi%combi_meth = &
               sga_in_orig(i)%sg_combi%ig_combi_meth
#ifdef DEBUG
            print '(" ",a,a)', trim(ch_id), ': psmile_def_var: transient IN:'
            print '(" ",a,a,2i8)', trim(ch_id), ': psmile_def_var: local varid, global varid:    ', &
                           var_id, fp%global_var_id
            print '(" ",a,a,2i8)', trim(ch_id), ': psmile_def_var: local varid, global varid in: ', &
                           var_id, fp%Taskin%In_channel(i)%global_transi_id
            print '(" ",a,a,2i8)', trim(ch_id), ': psmile_def_var: local varid, remote varid in: ', &
                           var_id, fp%Taskin%In_channel(i)%remote_transi_id
            print '(" ",a,a,2i8)', trim(ch_id), ': psmile_def_var: local varid, origin type in:  ', &
                           var_id, fp%Taskin%In_channel(i)%origin_type
            print '(" ",a,a,2i8)', trim(ch_id), ': psmile_def_var: local varid, remote compid in:', &
                           var_id, fp%Taskin%In_channel(i)%remote_comp_id
            print '(a,a,i5,a40)', trim(ch_id), ': psmile_def_var: local varid, weights and add file: ', &
                           var_id, trim(fp%Taskin%In_channel(i)%interp%arg10%cg_file_name)
            print '(a,a,i5,i10)', trim(ch_id), ': psmile_def_var: local varid, file format: ', &
                           var_id, fp%Taskin%In_channel(i)%interp%arg10%ig_file_format
#endif
         enddo

      else

         nullify (fp%Taskin%In_channel)

      endif

!-----------------------------------------------------------------------
!  b)   Transient out
!-----------------------------------------------------------------------

      nb_transi_out = sga_smioc_transi(s_ptr)%ig_nb_transi_out

      if ( nb_transi_out > 0 ) then
         Allocate (fp%Taskout(nb_transi_out), STAT=ierror )
         if ( ierror /= 0 ) then
            ierrp (1) = nb_transi_out

            ierror = PRISM_Error_Alloc

            call psmile_error ( ierror, 'Fields(var_id)%Taskout', &
                 ierrp, 1, __FILE__, __LINE__ )
            return
         endif

         do i = 1, nb_transi_out
           fp%Taskout(i)%n_send_direct        = 0
           fp%Taskout(i)%n_send_coupler       = 0
           fp%Taskout(i)%n_send_appl          = 0
           fp%Taskout(i)%n_alloc_send_direct  = 0
           fp%Taskout(i)%n_alloc_send_coupler = 0
           fp%Taskout(i)%n_alloc_send_appl    = 0
         end do

         do i = 1, nb_transi_out
           nullify ( fp%Taskout(i)%send_coupler)
           nullify ( fp%Taskout(i)%send_direct )
           nullify ( fp%Taskout(i)%send_appl   )
           nullify ( fp%Taskout(i)%buffer_int  )
           nullify ( fp%Taskout(i)%buffer_real )
           nullify ( fp%Taskout(i)%buffer_dble )
#if defined ( PRISM_QUAD_TYPE )
           nullify ( fp%Taskout(i)%buffer_quad )
#endif
           nullify ( fp%Taskout(i)%Judate_Axis )
         end do

!-----------------------------------------------------------------------
! ... ids concerning the output channels
!-----------------------------------------------------------------------

         sga_transi_out => sga_smioc_transi(s_ptr)%sga_transi_out

         do i = 1, nb_transi_out
           fp%Taskout(i)%origin_type = &
           sga_transi_out(i)%ig_dest_type

           fp%Taskout(i)%remote_transi_id = &
           sga_transi_out(i)%ig_dest_transi_id

           fp%Taskout(i)%global_transi_id = &
           sga_transi_out(i)%ig_transi_out_id

           fp%Taskout(i)%remote_comp_id = &
           sga_transi_out(i)%ig_dest_comp_id

           fp%Taskout(i)%assoc_var_id = PSMILe_undef

           fp%Taskout(i)%userdef_id = PSMILe_undef

!-----------------------------------------------------------------------
! ... information on interpolation
!-----------------------------------------------------------------------

           fp%Taskout(i)%interp%interp_type = &
           sga_transi_out(i)%sg_interp%ig_interp_type

           fp%Taskout(i)%interp%interp_meth = &
           sga_transi_out(i)%sg_interp%iga_interp_meth

           fp%Taskout(i)%interp%arg1 = &
           sga_transi_out(i)%sg_interp%iga_arg1

           fp%Taskout(i)%interp%arg2 = &
           sga_transi_out(i)%sg_interp%iga_arg2

           fp%Taskout(i)%interp%arg3 = &
           sga_transi_out(i)%sg_interp%iga_arg3

           fp%Taskout(i)%interp%arg4 = &
           sga_transi_out(i)%sg_interp%iga_arg4

           fp%Taskout(i)%interp%arg5 = &
           sga_transi_out(i)%sg_interp%iga_arg5

           fp%Taskout(i)%interp%arg6 = &
           sga_transi_out(i)%sg_interp%iga_arg6

           fp%Taskout(i)%interp%arg7 = &
           sga_transi_out(i)%sg_interp%iga_arg7

           fp%Taskout(i)%interp%arg8 = &
           sga_transi_out(i)%sg_interp%dg_arg8

           fp%Taskout(i)%interp%arg9 = &
           sga_transi_out(i)%sg_interp%cg_arg9

           fp%Taskout(i)%interp%arg10 = &
           sga_transi_out(i)%sg_interp%sg_arg10

!-----------------------------------------------------------------------
! ... information on combination
!-----------------------------------------------------------------------

           fp%Taskout(i)%combi%combi_name = &
           sga_transi_out(i)%sg_combi%cg_combi_name

           fp%Taskout(i)%combi%ext_mask_name = &
           sga_transi_out(i)%sg_combi%cg_ext_mask_name

!!$           fp%Taskout(i)%combi%ext_mask_file = &
!!$           sga_transi_out(i)%sg_combi%sg_ext_mask_file

           fp%Taskout(i)%combi%combi_param = &
           sga_transi_out(i)%sg_combi%dg_combi_param

           fp%Taskout(i)%combi%scalar = &
           sga_transi_out(i)%sg_combi%dg_scalar

           fp%Taskout(i)%combi%location = &
           sga_transi_out(i)%sg_combi%ig_location

           fp%Taskout(i)%combi%operand = &
           sga_transi_out(i)%sg_combi%ig_operand

           fp%Taskout(i)%combi%mask_type = &
           sga_transi_out(i)%sg_combi%ig_mask_type

           fp%Taskout(i)%combi%combi_meth = &
           sga_transi_out(i)%sg_combi%ig_combi_meth

#ifdef DEBUG
            print '(" ",a,a)', trim(ch_id), ': psmile_def_var: transient OUT: '
            print '(" ",a,a,2i8)', trim(ch_id), ': psmile_def_var: local varid, global varid:     ', &
                           var_id, fp%global_var_id
            print '(" ",a,a,2i8)', trim(ch_id), ': psmile_def_var: local varid, global varid out: ', &
                           var_id, fp%Taskout(i)%global_transi_id

            print '(" ",a,a,2i8)', trim(ch_id), ': psmile_def_var: local varid, remote varid out: ', &
                           var_id, fp%Taskout(i)%remote_transi_id

            print '(" ",a,a,2i8)', trim(ch_id), ': psmile_def_var: local varid, origin type out:  ', &
                           var_id, fp%Taskout(i)%origin_type

            print '(" ",a,a,2i8)', trim(ch_id), ': psmile_def_var: local varid, remote compid out:', &
                           var_id, fp%Taskout(i)%remote_comp_id
            print '(a,a,i5,a)', trim(ch_id), ': psmile_def_var: local varid, weights and add file: ', &
                           var_id, trim(fp%Taskout(i)%interp%arg10%cg_file_name)
            print '(a,a,i5,i10)', trim(ch_id), ': psmile_def_var: local varid, file format: ', &
                           var_id, fp%Taskout(i)%interp%arg10%ig_file_format
#endif
         enddo

         do i = 1, nb_transi_out
            fp%Taskout(i)%Judate_Lbnd%days = huge(fp%Taskin%Judate_Ubnd%days)
            fp%Taskout(i)%Judate_Lbnd%secs = huge(fp%Taskin%Judate_Ubnd%days)
            fp%Taskout(i)%Judate_Ubnd%days = huge(fp%Taskin%Judate_Ubnd%days)
            fp%Taskout(i)%Judate_Ubnd%secs = huge(fp%Taskin%Judate_Ubnd%days)
         enddo
      endif

!-----------------------------------------------------------------------
!  13th Check whether this field is used for coupling and set flags
!-----------------------------------------------------------------------

      fp%used_for_coupling     = .false.
      fp%used_for_io           = .false.

      do i = 1, nb_transi_out
         if ( sga_transi_out(i)%ig_dest_type == PSMILe_comp ) exit
      enddo

      if (i <= nb_transi_out) then
         gp%used_for_coupling     = .true.
         fp%used_for_coupling     = .true.
         Methods(method_id)%used_for_coupling = .true.
      endif

      do i = 1, nb_transi_in
         if ( sga_in_orig(i)%ig_orig_type == PSMILe_comp ) exit
      enddo

      if (i <= nb_transi_in) then
         gp%used_for_coupling     = .true.
         fp%used_for_coupling     = .true.
         Methods(method_id)%used_for_coupling = .true.
      endif


      do i = 1, nb_transi_out
        if ( sga_transi_out(i)%ig_dest_type == PSMILe_file ) exit
      enddo

      if (i <= nb_transi_out) then
#ifdef DEBUG
          print*, 'Component sends data in a file'
          call psmile_flushstd
#endif
          gp%used_for_io     = .true.
          fp%used_for_io     = .true.
      endif

      do i = 1, nb_transi_in
        if ( sga_in_orig(i)%ig_orig_type == PSMILe_file ) exit
      enddo

      if (i <= nb_transi_in) then
#ifdef DEBUG
          print*, 'Component receives data from a file'
          call psmile_flushstd
#endif
          gp%used_for_io     = .true.
          fp%used_for_io     = .true.
      endif

!-----------------------------------------------------------------------
!  14th Check whether this field is a candidate for gathering/scattering
!       In case that field does not match shape of points specified we test
!       whether the given mask allows for scattering or gathering, else we
!       are lost. 
!-----------------------------------------------------------------------

      test_dim = nodims(1) - bundle_field - vector_field

      length = 1

      do i = 1, test_dim
         length = length * ( fp%var_shape(2,i) - &
                             fp%var_shape(1,i) + 1 )
      enddo

      if ( test_dim < gp%n_dim ) then

         !-----------------------------------------------------------------
         !  ... candidate for scattering or gathering
         !-----------------------------------------------------------------

         if ( length /= count(Masks(mask_id)%mask_array) ) then

            ierror = PRISM_Error_Arglist

            ierrp (1) = mask_id
            ierrp (2) = method_id

            call psmile_error ( ierror, &
                 "Specified shape and mask does not allow scatter or gather", &
                 ierrp, 2, __FILE__, __LINE__ )
         endif

         !-----------------------------------------------------------------
         !  ... Check whether gathering is specified for input
         !           fields in the SMIOC file
         !-----------------------------------------------------------------

         i = 0

         do i = 1, nb_transi_in
           if ( sga_smioc_transi(s_ptr)%sg_transi_in%sg_tgt_local_trans%ig_gather == PSMILe_true ) exit
         enddo

         if ( i > nb_transi_in ) then

            ierror = PRISM_Error_Arglist

            ierrp (1) = var_id
            ierrp (2) = method_id

            call psmile_error ( ierror, &
                 "Gathering is required but not specified in smioc for input", &
                 ierrp, 2, __FILE__, __LINE__ )
         endif
         
         !-----------------------------------------------------------------
         !  ... Check whether scattering is specified for output
         !           fields in the SMIOC file
         !-----------------------------------------------------------------

         i = 0

         do i = 1, nb_transi_out
           if ( sga_transi_out(i)%sg_src_local_trans%ig_scatter == PSMILe_true ) exit
         enddo

         if ( i > nb_transi_out ) then

            ierror = PRISM_Error_Arglist

            ierrp (1) = var_id
            ierrp (2) = method_id

            call psmile_error ( ierror, &
                 "Scattering is required but not specified in smioc for out", &
                 ierrp, 2, __FILE__, __LINE__ )
         endif

      endif

!-----------------------------------------------------------------------
!  15th Finally test whether shapes are the same
!-----------------------------------------------------------------------

      if ( Associated(Methods(method_id)%vector_pointer) ) then

         do i = 1, 3

            point_id = Methods(method_id)%vector_pointer%array_of_point_ids(i)

            coords_pointer => Methods(point_id)%coords_pointer
!
#ifdef PRISM_ASSERTION
            if (.not. Associated(coords_pointer) ) then
               print *, 'i, point_id, method_id', i, point_id, method_id
               call psmile_assert ( __FILE__, __LINE__, &
                                   'coords_pointer is not associated for method')
            endif
#endif /* PRISM_ASSERTION */

            do ii = 1, gp%n_dim
               if (fp%var_shape(1,ii) > coords_pointer%actual_shape(1,ii) .and. &
                   fp%var_shape(2,ii) < coords_pointer%actual_shape(2,ii)) exit
            enddo

            if ( ii <= gp%n_dim ) then

               ierror = PRISM_Error_Arglist

               call psmile_error ( PRISM_Error_Arglist, &
                    'fp%var_shape for vector too small', &
                     fp%var_shape, nodims(1)*2, &
                    __FILE__, __LINE__ )
               return
            endif

         enddo

      else

         coords_pointer => Methods(method_id)%coords_pointer
!
#ifdef PRISM_ASSERTION
        if (.not. Associated(coords_pointer) ) then
            print *, 'i, method_id', i, method_id
            call psmile_assert ( __FILE__, __LINE__, &
                                'coords_pointer is not associated for method')
         endif
#endif /* PRISM_ASSERTION */

         do i = 1, gp%n_dim
#if 1
! Die Variables muessen nur im grid_shape definiert sein
! Oder wird fuer overlap regions noch etwas beseonderes gemacht ?
            if (fp%var_shape(1,i) > gp%grid_shape(1, i) .and. &
                fp%var_shape(2,i) < gp%grid_shape(2, i)) exit
#else
            if (fp%var_shape(1,i) > coords_pointer%actual_shape(1,i) .and. &
                fp%var_shape(2,i) < coords_pointer%actual_shape(2,i)) exit
#endif
         enddo

         if ( i <= gp%n_dim ) then

            ierror = PRISM_Error_Arglist

            call psmile_error ( PRISM_Error_Arglist, &
                 'fp%var_shape too small', &
                 fp%var_shape, nodims(1)*2, &
                 __FILE__, __LINE__ )
            return
         endif

      endif

!-----------------------------------------------------------------------
!  16th Create time axis arrays for I/O and coupling actions
!-----------------------------------------------------------------------

      call psmile_create_timeaxis ( var_id, ierror )

      if ( ierror == PRISM_Error_Date ) then
         ierrp(1) = var_id
         call psmile_error ( ierror, ' comming from XML file ', &
         ierrp, 1, __FILE__, __LINE__ )
      endif

#ifdef  __PSMILE_WITH_IO

!-----------------------------------------------------------------------
!  17th Define metadata for I/O
!-----------------------------------------------------------------------
   
      call psmile_def_metadata(var_id,ierror)
#endif

!-----------------------------------------------------------------------
!  18th Epilogue
!-----------------------------------------------------------------------

#ifdef VERBOSE
      print *, trim(ch_id), ': psmile_def_var: eof ierror =', &
               ierror, '; grid_id =', grid_id, ', var_id', var_id

      call psmile_flushstd
#endif /* VERBOSE */

      end subroutine psmile_def_var