tem_load_oneCanonicalND

private subroutine tem_load_oneCanonicalND(me, transform, conf, thandle, reqSegments)

Read one canonical object definition into a tem_canonicalND_type from a lua table.
Arguments

Type	Intent	Optional		Name
type(tem_canonicalND_type),	intent(out)		::	me	contains canonicalND data
type(tem_transformation_type),	intent(in)		::	transform	transformation for spatial object
type(flu_State)			::	conf	lua state
integer,	intent(in)		::	thandle	lua table identification
logical,	intent(in),	optional	::	reqSegments	Is true if use_get_point is true in output table
Called by

Help
Source Code

  subroutine tem_load_oneCanonicalND(me, transform, conf, thandle, reqSegments)
    ! --------------------------------------------------------------------------
    !> contains canonicalND data
    type(tem_canonicalND_type), intent(out) :: me
    !> transformation for spatial object
    type(tem_transformation_type), intent(in) :: transform
    !> lua state
    type(flu_state) :: conf
    !> lua table identification
    integer, intent(in) :: thandle
    !> Is true if use_get_point is true in output table
    logical, optional, intent(in) :: reqSegments
    !> output messages?
    ! --------------------------------------------------------------------------
    ! error identifiers
    integer :: iError
    integer :: vError(3), errfatal(3)
    ! counter and total number of vectors
    integer :: iVec, nVecs
    ! lua handles
    integer :: vec_thandle, halfvec_thandle, single_thandle, halfsingle_thandle
    real(kind=rk), allocatable :: local_vecs(:,:)
    real(kind=rk) :: local_length
    real(kind=rk) :: vecAbsSum
    character(len=labelLen) :: buffer
    logical :: reqSegments_loc
    ! --------------------------------------------------------------------------

    ! Load segments only if reqSegments is true i.e. use_get_point in output 
    ! table is true
    if (present(reqSegments)) then
      reqSegments_loc = reqSegments
    else
      reqSegments_loc = .false.
    end if

    errfatal = aotErr_Fatal

    ! initialize the array of vectors and the array of segments
    me%vec = 0._rk

    ! open the vec and halvec table and get its size
    call aot_table_open( L       = conf,                                       &
      &                  parent  = thandle,                                    &
      &                  thandle = vec_thandle,                                &
      &                  key     = 'vec' )
    call aot_table_open( L       = conf,                                       &
      &                  parent  = thandle,                                    &
      &                  thandle = halfvec_thandle,                            &
      &                  key     = 'halfvec' )
    ! check if the vec table is given
    if( vec_thandle .ne. 0 ) then
      nVecs = aot_table_length( L = conf, thandle = vec_thandle )

      ! Now check, if the first entry is a table itself:
      call aot_table_open( L       = conf,                                     &
        &                  parent  = vec_thandle,                              &
        &                  thandle = single_thandle,                           &
        &                  pos     = 1 )

      if (single_thandle == 0) then
        ! The entries are not tables themselves, try to interpret it as
        ! single vector.
        call aot_table_close( L = conf, thandle = single_thandle )
        nVecs = 1
        allocate(local_vecs( 3, nVecs ))
        local_vecs = 0._rk
        call aot_get_val( L       = conf,                                      &
          &               thandle = thandle,                                   &
          &               val     = local_vecs(:,1),                           &
          &               key     = 'vec',                                     &
          &               ErrCode = vError )
        if( any( btest( vError, errFatal ))) then
          write(logUnit(1),*)' FATAL ERROR: in loading vec'
          write(logUnit(1),*)' You should provide 3 numbers for this vector.'
          call tem_abort()
        end if
      else
        ! First entry is a table, assume all others are also tables,
        ! and properly define canonicalNDs coordinates, go on reading them.
        call aot_table_close( L = conf, thandle = single_thandle )
        allocate( local_vecs( 3, nVecs ))
        local_vecs = 0._rk
        do iVec=1, nVecs
          call aot_get_val( L       = conf,                                    &
            &               thandle = vec_thandle,                             &
            &               val     = local_vecs(:,iVec),                      &
            &               pos     = iVec,                                    &
            &               ErrCode = vError )
        end do
      end if
      if( any( btest( vError, errFatal ))) then
        write(logUnit(1),*) ' FATAL ERROR: in loading vec'
        call tem_abort()
      endif
    ! if vec table is not set try to read halfvec
    else if( halfvec_thandle /= 0 ) then
      call aot_table_open( L       = conf,                                     &
        &                  parent  = halfvec_thandle,                          &
        &                  thandle = halfsingle_thandle,                       &
        &                  pos     = 1 )
      nVecs = aot_table_length( L = conf, thandle = halfvec_thandle )
      if( halfsingle_thandle == 0 ) then
        ! The entries are not tables themselves, try to interpret it as
        ! single vector.
        call aot_table_close( L = conf, thandle = halfsingle_thandle )
        nVecs = 1
        allocate( local_vecs( 3, nVecs ))
        local_vecs = 0._rk
        call aot_get_val( L       = conf,                                      &
          &               thandle = thandle,                                   &
          &               val     = local_vecs(:,1),                           &
          &               key     = 'halfvec',                                 &
          &               ErrCode = vError )
        local_vecs = local_vecs * 2._rk
      else
        ! First entry is a table, assume all others are also tables,
        ! and properly define canonicalNDs coordinates, go on reading them.
        call aot_table_close( L = conf, thandle = halfsingle_thandle )
        allocate( local_vecs( 3, nVecs ))
        local_vecs = 0._rk
        do iVec=1, nVecs
          call aot_get_val( L       = conf,                                    &
            &               thandle = halfvec_thandle,                         &
            &               val     = local_vecs(:,iVec),                      &
            &               pos     = iVec,                                    &
            &               ErrCode = vError )
        end do
        local_vecs = local_vecs * 2._rk
      end if
      if( any( btest( vError, errFatal ))) then
        write(logUnit(1),*) ' FATAL ERROR: in loading halfvec'
        call tem_abort()
      endif
    ! if vec and halfvec table is not set, try to read length (for a cube)
    else
      call aot_get_val( L       = conf,                                        &
        &               thandle = thandle,                                     &
        &               val     = local_length,                                &
        &               key     = 'length',                                    &
        &               default = 0.0_rk,                                      &
        &               ErrCode = iError )
      ! set the axis parallel entries of local_vecs to local_length
      nVecs = 3
      allocate( local_vecs( 3, nVecs ))
      local_vecs = 0._rk
      local_vecs(1,1) = local_length
      local_vecs(2,2) = local_length
      local_vecs(3,3) = local_length
    end if

    call aot_table_close( L = conf, thandle = vec_thandle )
    call aot_table_close( L = conf, thandle = halfvec_thandle )


    ! copy back the information from the local vector array
    me%vec(:,:nVecs) = local_vecs
    me%vec(:,nVecs+1:) = 0.0_rk

    ! read origin of the canonicalND
    call aot_get_val( L       = conf,                                          &
      &               thandle = thandle,                                       &
      &               val     = me%origin,                                     &
      &               key     = 'origin',                                      &
      &               ErrCode = vError )
    if( any( btest( vError, errFatal ))) then
      call aot_get_val( L       = conf,                                        &
        &               thandle = thandle,                                     &
        &               val     = me%origin,                                   &
        &               key     = 'center',                                    &
        &               ErrCode = vError )
      if (any(btest( vError, errFatal )) ) then
        write(logUnit(1),*) 'ERROR reading the canonical objects, '//          &
          &             'origin/center is not well defined. STOPPING'
        call tem_abort()
      endif
      me%origin = me%origin - me%vec(:,1)/2.0_rk - me%vec(:,2)/2.0_rk -        &
        &         me%vec(:,3)/2.0_rk
    end if

    call aot_get_val( L       = conf,                                          &
      &               thandle = thandle,                                       &
      &               val     = me%distribution,                               &
      &               ErrCode = iError,                                        &
      &               key     = 'distribution',                                &
      &               default = 'equal' )

    me%active = .false.
    me%nDim = 0

    ! check the kind and the active vectors
    do iVec = 1, 3
      vecAbsSum = abs(me%vec(1,iVec)) + abs(me%vec(2,iVec)) &
        &       + abs(me%vec(3,iVec))
      if (vecAbsSum .fne. 0._rk) then
        me%active(iVec) = .true.
        me%nDim = me%nDim + 1
      end if
    end do

    if(me%nDim == 0) me%kind = 'point'
    if(me%nDim == 1) me%kind = 'line'
    if(me%nDim == 2) me%kind = 'plane'
    if(me%nDim == 3) me%kind = 'box'

    ! Load segments for objects other than point if reqSegments is true
    if (trim(me%kind) == 'point') then
      ! set default segments to 1
      me%segments = 1
    else
      if (reqSegments_loc) then
        ! set segments to 1 in all dimensions as default
        me%segments = 1
        ! try loading segments as integer if fails try
        ! to loading segments as vector integer
        call aot_get_val( L       = conf,           &
          &               thandle = thandle,        &
          &               val     = me%segments(1), &
          &               key     = 'segments',     &
          &               ErrCode = iError          )
        if ( btest(iError, aoterr_Fatal) ) then
          call aot_get_val( L       = conf,                &
            &               thandle = thandle,             &
            &               val     = me%segments(:nVecs), &
            &               key     = 'segments',          &
            &               ErrCode = vError(:nVecs)       )
          if ( any( btest(vError(:nVecs), errFatal(:nVecs)) ) ) then
            write(logUnit(1),*) ' FATAL ERROR: in loading segments'
            write(logUnit(1), '(A)') '  "segments" are not defined in ' &
              &                      // 'shape.object table.'
            call tem_abort('Segments are required for output.use_get_point.')
          end if
        end if
      else
        ! segments are not required setting it to -1 for error detection
        me%segments = -1
      end if
    end if

    ! if canonical object is box then check for only_surface
    if( me%kind == 'box' ) then
      call aot_get_val( L       = conf,                                        &
        &               thandle = thandle,                                     &
        &               val     = me%only_surface,                             &
        &               ErrCode = iError,                                      &
        &               key     = 'only_surface',                              &
        &               pos     = 4,                                           &
        &               default = .false. )

      if (btest(iError, aoterr_WrongType)) then
        write(logUnit(1),*) 'Error occured, while retrieving canonical box '// &
          &             'only_surface'
        write(logUnit(1),*) 'Variable has wrong type!'
        write(logUnit(1),*) 'Should be a LOGICAL!'
        call tem_abort()
      endif
    endif

    ! if tranformation is defined then tranform canoND before converting them
    ! into their respective shapes
    call tem_transformCanoND(canoND = me, transform = transform)
    ! Convert canonical shape to respective kind
    select case(upper_to_lower(trim(me%kind)))
    case('point')
      me%point%coord = me%origin
    case('line')
      me%line%origin = me%origin
      me%line%vec = me%vec(:,1)
    case('plane')
      call tem_createPlane(me     = me%plane,    &
        &                  origin = me%origin,   &
        &                  vecA   = me%vec(:,1), &
        &                  vecB   = me%vec(:,2)  )
    case('box')
      call tem_createBox(me           = me%box,        &
        &                origin       = me%origin,     &
        &                vecA         = me%vec(:,1),   &
        &                vecB         = me%vec(:,2),   &
        &                vecC         = me%vec(:,3),   &
        &                only_surface = me%only_surface)
    case default
      call tem_abort('Unknown canonical kind')
    end select

    ! @todo: DEB: Update this when converting arrays to strings is available
    write(logUnit(6),"(A)") ' kind: '//trim( me%kind )
    write(logUnit(6),*) ' origin:', me%origin(1:3)
    do iVec=1,me%nDim
      write(buffer,"(A,I0,A)") ' vec ', iVec, ': '
      write(logUnit(6),*) trim(buffer), me%vec(:,iVec)
    enddo
    if (trim(me%kind) == 'plane') then
      write(logUnit(6),*) '   unit normal: '                             &
        &             // trim(tem_toStr(me%plane%unitNormal(1)))         &
        &             // ', ' // trim(tem_toStr(me%plane%unitNormal(2))) &
        &             // ', ' // trim(tem_toStr(me%plane%unitNormal(3)))
    end if
    write(logUnit(6),*) ' only_surface: ', me%only_surface
    do iVec=1,me%nDim
      write(buffer,"(A,I0,A)") 'segments ', iVec, ': '
      write(logUnit(6),"(A,I0)") trim(buffer), me%segments(iVec)
    enddo
    write(logUnit(6),"(A)") ' distribution: '//trim( me%distribution )

  end subroutine tem_load_oneCanonicalND
tem_load_oneCanonicalND Subroutine

Contents

Source Code

private subroutine tem_load_oneCanonicalND(me, transform, conf, thandle, reqSegments)

Arguments

Calls

Called by

Source Code
