psmile_locations_alloc.F90

Go to the documentation of this file.

!-----------------------------------------------------------------------
! Copyright 2006-2010, NEC Europe Ltd., London, UK.
! All rights reserved. Use is subject to OASIS4 license terms.
!-----------------------------------------------------------------------
!BOP
!
! !ROUTINE: PSMILe_Locations_alloc
!
! !INTERFACE:

      subroutine psmile_locations_alloc (send_info, ierror)
!
! !USES:
!
      use PRISM_constants
!
      use PSMILe, dummy_interface => PSMILe_Locations_alloc

      implicit none
!
! !INPUT PARAMETERS:
 
      Type(Send_information), Intent(Inout) :: send_info

!     Send information

! !OUTPUT PARAMETERS:
!
      Integer, Intent (Out)           :: ierror

!     Returns the error code of PSMILe_Locations_alloc;
!             ierror = 0 : No error
!             ierror > 0 : Severe error
!
! !LOCAL VARIABLES
!
!     ... for simplicity
!
      Integer                         :: nvec, nparts
!
!     ... loop indices
!
      Integer                         :: i, j
!
!     ... for error handling
!
      Integer, parameter              :: nerrp = 2
      Integer                         :: ierrp (nerrp)
!
! !DESCRIPTION:
!
! Subroutine "PSMILe_Locations_alloc" allocates the vectors for the send
! information.
!
! !REVISION HISTORY:
!
!   Date      Programmer   Description
! ----------  ----------   -----------
! 03.07.21    H. Ritzdorf  created
!
!EOP
!----------------------------------------------------------------------
!
!  $Id: psmile_locations_alloc.F90 2936 2011-02-03 09:36:47Z hanke $
!  $Author: hanke $
!
   Character(len=len_cvs_string), save :: mycvs = 
       '$Id: psmile_locations_alloc.F90 2936 2011-02-03 09:36:47Z hanke $'
!
!----------------------------------------------------------------------
!
!  Initialization
!
#ifdef VERBOSE
      print 9990, trim(ch_id)

      call psmile_flushstd
#endif /* VERBOSE */
!
      ierror = 0
!
      nvec   = send_info%nvec
      nparts = send_info%nparts
!
#ifdef PRISM_ASSERTION
      if ( min (nvec, nparts) <= 0 ) then
         print *, trim(ch_id), ', nvec, nparts', nvec, nparts
         call psmile_assert (__FILE__, __LINE__, "nvec or nparts <= 0")
      endif
#endif
!
!===> Allocate
!
     Allocate (send_info%npoints(nvec, nparts), &
               send_info%nars   (nvec, nparts), &
               send_info%srcars (nvec, nparts), &
               send_info%srclocs(nvec, nparts), &
               send_info%msklocs(nvec, nparts), STAT = ierror)

     if ( ierror > 0 ) then
        ierrp (1) = ierror 
        ierrp (2) = nvec * nparts * 5
 
        ierror = PRISM_Error_Alloc
        call psmile_error ( ierror, 'send_info%{npoints,nars,srcars,srclocs,msklocs}', &
                            ierrp, 2, __FILE__, __LINE__ )
        return
     endif
!
!===> Initialize
!
     send_info%npoints = 0
     send_info%nars    = 0
!
        do j = 1, nparts
           do i = 1, nvec
           Nullify (send_info%msklocs(i, j)%vector)
           Nullify (send_info%srclocs(i, j)%vector)
           Nullify (send_info%srcars (i, j)%vector)
           end do
        end do
!
     Nullify (send_info%virtual)
     Nullify (send_info%dstijk)
     Nullify (send_info%list_entries)
!
!===> All done
!
#ifdef VERBOSE
      print 9980, trim(ch_id), ierror

      call psmile_flushstd
#endif /* VERBOSE */
!
!  Formats:
!

#ifdef VERBOSE

9990 format (1x, a, ': psmile_locations_alloc:')
9980 format (1x, a, ': psmile_locations_alloc: eof ierror =', i3)

#endif /* VERBOSE */

      end subroutine PSMILe_Locations_alloc