psmile_get_userdef_handle.F90

Go to the documentation of this file.

!-----------------------------------------------------------------------
! Copyright 2006, C&C Research Laboratories, NEC Europe Ltd., St. Augustin, Germany.
! All rights reserved. Use is subject to OASIS4 license terms.
!-----------------------------------------------------------------------
!BOP
!
! !ROUTINE: PSMILe_Get_userdef_handle
!
! !INTERFACE:

      subroutine PSMILe_Get_userdef_handle (userdef_id, ierror)
!
! !USES:
!
      use PRISM_constants
      use PSMILe, dummy_interface => PSMILe_Get_userdef_handle
      implicit none
!
!
! !OUTPUT PARAMETERS:
!
      integer, Intent (Out)               :: userdef_id

!     Returns the handle to the userdef information created.

      integer, Intent (Out)               :: ierror

!     Returns the error code of PRISM_Init;
!             ierror = 0 : No error
!             ierror > 0 : Severe error
!
!
! !LOCAL VARIABLES
!
      integer             :: i, new_dim

      integer, parameter  :: nerrp = 2
      integer             :: ierrp (nerrp)

      type (Userdef), Dimension(:), Pointer :: New_Userdefs
!
!
! !DESCRIPTION:
!
! Subroutine "PSMILe_Get_userdef_handle" returns a handle to a userdef
! structure.
!
!
! !REVISION HISTORY:
!
!   Date      Programmer    Description
! ----------  -----------   -----------
! 21.10.09    J. Latour     created
!
!EOP
!----------------------------------------------------------------------
!
! $Id: psmile_get_userdef_handle.F90 1194 2009-10-21 09:10:21Z latour $
! $Author: Latour $
!
   Character(len=len_cvs_string), save :: mycvs = 
       '$Id: psmile_get_userdef_handle.F90 1194 2009-10-21 09:07:12Z redler $'
!
!----------------------------------------------------------------------

#ifdef VERBOSE
      print *, trim(ch_id), ': PSMILe_Get_userdef_handle: start'
      call PSMILe_Flushstd
#endif /* VERBOSE */

!
!   Initialization
!
      ierror = 0
!
!   Search for a free userdef index
!
      do i = 1, Number_of_Userdefs_allocated
         if (Userdefs(i)%status == PSMILe_status_free) exit
      end do
!
      if (i <= Number_of_Userdefs_allocated) then
         userdef_id = i
         Userdefs(userdef_id)%status = PSMILe_status_defined

#ifdef VERBOSE
      print *, TRIM(ch_id),': PSMILe_Get_userdef_handle: eof = ',userdef_id,ierror
      call PSMILe_Flushstd
#endif /*VERBOSE */
         return
      endif
!
!   All Userdefs allocated are busy , then
!   Allocate new Userdefs vector and copy old vector
!
      new_dim = Number_of_Userdefs_allocated + 8
!
      Allocate (New_Userdefs (new_dim), STAT = ierror)
      if (ierror > 0) then
         ierrp (1) = ierror
         ierrp (2) = new_dim
         ierror = PRISM_Error_Alloc

         call PSMILe_Error ( ierror, 'New_Fields', &
                             ierrp, 2, __FILE__, __LINE__ )
         return
      endif
!
      New_Userdefs (1:Number_of_Userdefs_allocated) = &
          Userdefs (1:Number_of_Userdefs_allocated)

      New_Userdefs(Number_of_Userdefs_allocated+1:new_dim)%status = &
          PSMILe_status_free

      do i = Number_of_Userdefs_allocated+1, new_dim
         Nullify ( New_Userdefs(i)%dga_wght )
         Nullify ( New_Userdefs(i)%iga_igl )
!
!     Initialize further values of Userdefs
!
         New_Userdefs(i)%ig_transi_side = PRISM_Undefined
         New_Userdefs(i)%ig_nb_links = 0
      enddo
!
!   De-allocate Userdefs vector
!
      Deallocate (Userdefs, STAT = ierror)
      if (ierror > 0) then
         ierrp (1) = ierror
         ierror = PRISM_Error_Dealloc

         call PSMILe_Error ( ierror, 'Userdefs', &
                             ierrp, 1, __FILE__, __LINE__ )
         return
      endif
!
!   Update Number of Userdefs
!
      Userdefs => New_Userdefs
!
      userdef_id = Number_of_Userdefs_allocated + 1
      Number_of_Userdefs_allocated = new_dim

      Userdefs(userdef_id)%status = PSMILe_status_defined
!
#ifdef VERBOSE
      print *, TRIM(ch_id),': PSMILe_Get_userdef_handle: eof = ',userdef_id,ierror
      call PSMILe_Flushstd
#endif /*VERBOSE */
!
      return
!
      end subroutine PSMILe_Get_userdef_handle