psmile_move0_neighbors.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_Move0_neighbors
!
! !INTERFACE:

      subroutine psmile_move0_neighbors (neighbors, nloc, num_neigh, &
                                         ierror)
!
! !USES:
!
      use PRISM_constants
!
      use PSMILe, dummy_interface => PSMILe_Move0_neighbors

      implicit none
!
! !INPUT PARAMETERS:

      Integer, Intent (In)            :: nloc
!
!     Number of locations
!
      Integer, Intent (In)            :: num_neigh
!
!     Last dimension of neighbors array "neighbors"
!
! !INPUT/OUTPUT PARAMETERS:
!
      Integer, Intent (InOut)         :: neighbors (nloc, num_neigh)
!
!     1D-Indices of neighbor locations (interpolation bases)
!
! !OUTPUT PARAMETERS:
!
      Integer, Intent (Out)           :: ierror

!     Returns the error code of PSMILE_Move0_neighbors;
!             ierror = 0 : No error
!             ierror > 0 : Severe error !
! !LOCAL VARIABLES
!
!     ... 
!
      Integer                         :: i, j, n
      Integer                         :: ibeg, jbeg, jend, num1
!
! !DESCRIPTION:
!
! Subroutine "PSMILe_Move0_neighbors" moves the 0 entries (code for no 
! interpolation base) of 1d-indices to the end of the neighbour list.
!
!
! !REVISION HISTORY:
!
!   Date      Programmer   Description
! ----------  ----------   -----------
! 03.07.21    H. Ritzdorf  created
!
!EOP
!----------------------------------------------------------------------
!
!  $Id: psmile_move0_neighbors.F90 2325 2010-04-21 15:00:07Z valcke $
!  $Author: valcke $
!
   Character(len=len_cvs_string), save :: mycvs = 
       '$Id: psmile_move0_neighbors.F90 2325 2010-04-21 15:00:07Z valcke $'
!
!----------------------------------------------------------------------
!
!  Initialization
!
#ifdef VERBOSE
      print 9990, trim(ch_id)

      call psmile_flushstd
#endif /* VERBOSE */
!
#ifdef PRISM_ASSERTION
#endif
!
      ierror = 0
!
!===> Move 0 entries at the end of neighbours
!
      num1 = num_neigh - 1
!
         do n = num_neigh-1, 1, -1
            ibeg = 1
!
            do while ( ibeg <= nloc ) 
!cdir vector
               do i = ibeg, nloc
               if (neighbors (i,n) == 0) exit
               end do
!
               if (i <= nloc) then
!
!===> ... Must elements to be changed ?
!
                     do j = 1, num1
                     if (neighbors (i,j) == 0 .and. neighbors (i,j+1) > 0) exit
                     end do
!
                  if (j <= num1) then
!
!===> ...... Find first 0 (at jbeg) to be moved
!
                     jbeg = 1
                     jend = num_neigh
!
                         do while ( jbeg <= jend ) 
!
                            do j = jbeg, jend
                            if (neighbors (i,j) == 0) exit
                            end do
!
                         if (j > jend) exit
                         jbeg = j
!
!===> ...... Find last significant number to be moved
!
                            do j = jend, jbeg+1, -1
                            if (neighbors (i,j) > 0) exit
                            end do
!
                         if (j < jbeg + 1) exit
!
                         neighbors (i, jbeg) = neighbors (i, j)
                         neighbors (i, j) = 0
!
                         jend = j - 1
                         jbeg = jbeg + 1
                     end do
                  endif
               endif
!
               ibeg = i + 1
            end do ! while
!
         end do ! n = num_neigh-1, 1, -1
!
!===> All done
!
#ifdef VERBOSE
      print 9980, trim(ch_id)

      call psmile_flushstd
#endif /* VERBOSE */
!
!  Formats:
!
9990 format (1x, a, ': psmile_move0_neigbors')
9980 format (1x, a, ': psmile_move0_neigbors: eof')

      end subroutine PSMILe_Move0_neighbors