psmile_field2grid.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.
!-----------------------------------------------------------------------
!
#ifdef DONT_HAVE_STDMPI2
#undef PRISM_with_MPI2
#endif
!
!BOP
!
! !ROUTINE: PSMILe_Field2grid
!
! !INTERFACE:

      subroutine psmile_field2grid (ierror)
!
! !USES:
!
      use PRISM_constants
!
      use PSMILe, dummy_interface => PSMILe_Field2grid

      implicit none
!
! !INPUT PARAMETERS:
!
! !OUTPUT PARAMETERS:
!
      Integer,            Intent (Out) :: ierror

!     Returns the error code of PSMILe_Field2grid;
!             ierror = 0 : No error
!             ierror > 0 : Severe error
!
! !LOCAL VARIABLES
!
!  ... for fields

      Integer                      :: i, j, var_min, var_max
      Integer                      :: global_var_min, global_var_max
!
#ifndef PRISM_with_MPI2
      Integer, Allocatable         :: field2grid_in (:)
#endif

!  ... for error parameters:

      Integer, Parameter           :: nerrp = 3
      Integer                      :: ierrp (nerrp)
!
! !DESCRIPTION:
!
! Subroutine "PSMILe_Field2grid" determines the mapping of
! global transi id's (of Out Channel) to global grid id's.
! This info is used by routine "PSMILe_find_intersect" in order
! to determine grids to be controlled.
!
! !REVISION HISTORY:
!
!   Date      Programmer   Description
! ----------  ----------   -----------
! 13.10.05    H. Ritzdorf  created
!
!EOP
!----------------------------------------------------------------------
!
! $Id: psmile_field2grid.F90 2687 2010-10-28 15:15:52Z coquart $
! $Author: coquart $
!
   Character(len=len_cvs_string), save :: mycvs = 
       '$Id: psmile_field2grid.F90 2687 2010-10-28 15:15:52Z coquart $'
!
!----------------------------------------------------------------------

#ifdef VERBOSE
      print 9990, trim(ch_id)
      call psmile_flushstd
#endif /* VERBOSE */
!
!  Initialization
!
      ierror = 0
!
!-----------------------------------------------------------------------
!  Determine mapping of global var id's to global grid id's
!  for variables which are used coupling.
!-----------------------------------------------------------------------
!
!     Get min/max values of var id's locally
!
      var_min = huge (var_max)
      var_max = -1
!
!cdir vector
         do i = 1, Number_of_Fields_allocated
         if ( Fields(i)%status  == PSMILe_status_defined .and. &
              Fields(i)%used_for_coupling                .and. &
              Associated(Fields(i)%Taskout) ) then

            do j = 1, size (Fields(i)%Taskout)
            var_min = min (var_min, Fields(i)%Taskout(j)%global_transi_id)
            var_max = max (var_max, Fields(i)%Taskout(j)%global_transi_id)
            end do
         endif
         end do
!
!     Get min/max values of var id's globally
!
      call MPI_Allreduce (var_min, global_var_min, 1, MPI_INTEGER, &
                          MPI_MIN, comm_psmile, ierror)
      if ( ierror /= MPI_SUCCESS ) then
         ierrp (1) = ierror
         ierror = PRISM_Error_MPI

         call psmile_error ( ierror, 'MPI_Allreduce', &
                             ierrp, 1, __FILE__, __LINE__ )
         return
      endif 
!
      call MPI_Allreduce (var_max, global_var_max, 1, MPI_INTEGER, &
                          MPI_MAX, comm_psmile, ierror)
      if ( ierror /= MPI_SUCCESS ) then
         ierrp (1) = ierror
         ierror = PRISM_Error_MPI

         call psmile_error ( ierror, 'MPI_Allreduce', &
                             ierrp, 1, __FILE__, __LINE__ )
         return
      endif 
!
!     Allocate fields to grid mapping
!
      if (global_var_min <= global_var_max) then

         Allocate (field2grid (global_var_min:global_var_max), &
                   STAT = ierror)

         if (ierror > 0) then
            ierrp (1) = ierror
            ierrp (2) = global_var_max - global_var_min + 1

            ierror = PRISM_Error_Alloc

            call psmile_error ( ierror, 'field2grid', &
                                ierrp, 2, __FILE__, __LINE__ )
            return
         endif
!
         field2grid (:) = PSMILE_undef
!
!cdir vector
            do i = 1, Number_of_Fields_allocated
            if ( Fields(i)%status  == PSMILe_status_defined .and. &
                 Fields(i)%used_for_coupling                .and. &
                 Associated(Fields(i)%Taskout) ) then

               do j = 1, size (Fields(i)%Taskout)
               field2grid(Fields(i)%Taskout(j)%global_transi_id) = &
                  Grids(Methods(Fields(i)%method_id)%grid_id)%global_grid_id
               end do
            endif
            end do
!
!        Get global mapping
!
#ifdef PRISM_with_MPI2
         call MPI_Allreduce (MPI_IN_PLACE, field2grid, &
                          global_var_max-global_var_min+1, MPI_INTEGER, &
                          MPI_MAX, comm_psmile, ierror)
#else
         Allocate (field2grid_in (global_var_min:global_var_max), &
                   STAT = ierror)

         if (ierror > 0) then
            ierrp (1) = ierror
            ierrp (2) = global_var_max - global_var_min + 1

            ierror = PRISM_Error_Alloc

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

         field2grid_in = field2grid

         call MPI_Allreduce (field2grid_in, field2grid, &
                             global_var_max-global_var_min+1, MPI_INTEGER, &
                             MPI_MAX, comm_psmile, ierror)

         Deallocate (field2grid_in)
#endif
         if ( ierror /= MPI_SUCCESS ) then
            ierrp (1) = ierror
            ierror = PRISM_Error_MPI

            call psmile_error ( ierror, 'MPI_Allreduce', &
                                ierrp, 1, __FILE__, __LINE__ )
            return
         endif 
!
#ifdef PRISM_ASSERTION
!
!        Control local info
!
!cdir vector
            do i = 1, Number_of_Fields_allocated
            if ( Fields(i)%status  == PSMILe_status_defined .and. &
                 Fields(i)%used_for_coupling                .and. &
                 Associated(Fields(i)%Taskout) ) then

               do j = 1, size (Fields(i)%Taskout)
               if (field2grid(Fields(i)%Taskout(j)%global_transi_id) /=  &
                   Grids(Methods(Fields(i)%method_id)%grid_id)%global_grid_id) exit
               end do

               if (j < size (Fields(i)%Taskout)) then
                  print *, 'i, j, field2grid(Fields(i)%Taskout(j)%global_transi_id, Grids(Fields(i)%grid_id)%global_grid_id', &
                            i, j, field2grid(Fields(i)%Taskout(j)%global_transi_id), &
                            Grids(Methods(Fields(i)%method_id)%grid_id)%global_grid_id
                  call psmile_assert ( __FILE__, __LINE__, & 
                    'Inconsistent infos in field2grid')
               endif
            endif
            end do
!
#endif
!
      endif
!
!===> All done
!
#ifdef VERBOSE
         do i = global_var_min, global_var_max
         print 9970, i, field2grid(i) 
         end do
!
      print 9980, trim(ch_id), ierror
      call psmile_flushstd
#endif /* VERBOSE */
!
!  Formats
!
#ifdef VERBOSE
9990 format (1x, a, ': psmile_Field2grid')
9980 format (1x, a, ': psmile_Field2grid: eof ierror =', i3)
9970 format (1x, 'field2grid: global transi_id out', i4, '; global grid id', i4)
#endif /* VERBOSE */
!
      end subroutine PSMILe_Field2grid