prismtrs_drv_exchange_util.F90

Go to the documentation of this file.

!-----------------------------------------------------------------------
! Copyright 2008-2010, DKRZ, Hamburg, Germany.
! All rights reserved. Use is subject to OASIS4 license terms.
!-----------------------------------------------------------------------
!
! !DESCRIPTION
! Subroutines "prismdrv_[enqueue,dequeue]_in_[field,sum]_*" handle memory
! managment for the trans_in_fields and global sums buffered by 
! the driver
!
! !REVISED HISTORY
!   Date      Programmer   Description
! ----------  ----------   -----------
! 30/11/2009  M. Hanke     Creation

subroutine prismtrs_enqueue_in_field_dble(field, field_size, exchange_id, ierror)
   use PRISMDrv, dummy_interface => prismtrs_enqueue_in_field_dble
   implicit none
   
   integer, intent(in)       :: field_size  ! size of the field * nbr_fields
   double precision, intent(in) 
                             :: field(field_size)! data that needs to be added to
                                            ! the array of fields
   integer, intent(in)       :: exchange_id ! exchange id...
   integer, intent(out)      :: ierror

   double precision, pointer :: field_array(:) ! array that contains all fields,
                                               ! which are waiting to be received 
                                               ! by a prism_get
   integer                   :: status         ! number of fields - 1 that are
                                               ! currently in the array
   integer                   :: allocated_fields ! number of fields, that would
                                               ! fit into allocated memory
   double precision, pointer :: temp(:)        ! temporary variable for memory allocation

   integer                   :: ierrp(2)

! Initialisation
   status           = Drv_Exchanges(exchange_id)%trans_in_status
   allocated_fields = Drv_Exchanges(exchange_id)%trans_in_nbr_allocated_fields


! If there is not enough memory allocated for another additional field

   if (status .eq. allocated_fields+1) then

      allocate(temp(field_size*(allocated_fields+1)), stat=ierror)
      if (ierror > 0) then
         ierrp (1) = ierror
         ierrp (2) = field_size*(allocated_fields+1)
         call psmile_error_common ( PRISM_Error_Alloc, 'enqueue_in_field', &
                                    ierrp, 2, __FILE__, __LINE__ )

         return
      endif

      ! copy old field array into new array (if there is data)
      if (allocated_fields .gt.0) then
         temp(1:field_size*allocated_fields) = &
            Drv_Exchanges(exchange_id)%trans_in_field_dble
         deallocate(Drv_Exchanges(exchange_id)%trans_in_field_dble, stat=ierror)
         if (ierror > 0) then
            ierrp (1) = ierror
            call psmile_error_common(PRISM_Error_Dealloc,'enqueue_in_field',&
                                       ierrp, 1, __FILE__, __LINE__ )
            return
         endif
      endif

      Drv_Exchanges(exchange_id)%trans_in_nbr_allocated_fields&
                = allocated_fields +1

      ! set new field array
      Drv_Exchanges(exchange_id)%trans_in_field_dble => temp

   else if (status .gt. allocated_fields+1) then ! this should never happen

      ierrp (1) = status
      ierrp (2) = allocated_fields
      call psmile_error_common(PRISM_Error_Arg, 'enqueue_in_field_dble', &
                      ierrp, 1, __FILE__, __LINE__ )
      return
   endif

   field_array => Drv_Exchanges(exchange_id)%trans_in_field_dble

!  copy new field into field array
   field_array(field_size*(status-1)+1: &
               field_size*status) = &
               field

end subroutine prismtrs_enqueue_in_field_dble

subroutine prismtrs_enqueue_in_field_real(field, field_size, exchange_id, ierror)
   use PRISMDrv, dummy_interface => prismtrs_enqueue_in_field_real
   implicit none
   
   integer, intent(in)       :: field_size  ! size of the field * nbr_fields
   real, intent(in)          :: field(field_size)! data that needs to be added to
                                            ! the array of fields
   integer, intent(in)       :: exchange_id ! exchange id...
   integer, intent(out)      :: ierror

   real, pointer             :: field_array(:) ! array that contains all fields,
                                               ! which are waiting to be received 
                                               ! by a prism_get
   integer                   :: status         ! number of fields - 1 that are
                                               ! currently in the array
   integer                   :: allocated_fields ! number of fields, that would
                                               ! fit into allocated memory
   real, pointer             :: temp(:)        ! temporary variable for memory allocation

   integer                   :: ierrp(2)

! Initialisation
   status           = Drv_Exchanges(exchange_id)%trans_in_status
   allocated_fields = Drv_Exchanges(exchange_id)%trans_in_nbr_allocated_fields

! If there is not enough memory allocated for another additional field
   if (status .eq. allocated_fields+1) then

      allocate(temp(field_size*(allocated_fields+1)), stat=ierror)
      if (ierror > 0) then
         ierrp (1) = ierror
         ierrp (2) = field_size*(allocated_fields+1)
         call psmile_error_common ( PRISM_Error_Alloc, 'enqueue_in_field', &
                                    ierrp, 2, __FILE__, __LINE__ )

         return
      endif

      ! copy old field array into new array (if there is data)
      if (allocated_fields .gt.0) then
         temp(1:field_size*allocated_fields) = &
            Drv_Exchanges(exchange_id)%trans_in_field_real
         deallocate(Drv_Exchanges(exchange_id)%trans_in_field_real, stat=ierror)
         if (ierror > 0) then
            ierrp (1) = ierror
            call psmile_error_common(PRISM_Error_Dealloc,'enqueue_in_field',&
                                    ierrp, 1, __FILE__, __LINE__ )
            return
         endif
      endif

      Drv_Exchanges(exchange_id)%trans_in_nbr_allocated_fields&
                = allocated_fields +1
      ! set new field array
      Drv_Exchanges(exchange_id)%trans_in_field_real => temp

   else if (status .gt. allocated_fields+1) then ! this should never happen

      ierrp (1) = status
      ierrp (2) = allocated_fields
      call psmile_error_common(PRISM_Error_Arg, 'enqueue_in_field_real', &
                      ierrp, 1, __FILE__, __LINE__ )
      return
   endif

   field_array => Drv_Exchanges(exchange_id)%trans_in_field_real

!  copy new field into field array
   field_array(field_size*(status-1)+1: &
               field_size*status) = &
               field

end subroutine prismtrs_enqueue_in_field_real

subroutine prismtrs_enqueue_in_field_int(field, field_size, exchange_id, ierror)
   use PRISMDrv, dummy_interface => prismtrs_enqueue_in_field_int
   implicit none
   
   integer, intent(in)       :: field_size  ! size of the field * nbr_fields
   integer, intent(in)       :: field(field_size)! data that needs to be added to
                                            ! the array of fields
   integer, intent(in)       :: exchange_id ! exchange id...
   integer, intent(out)      :: ierror

   integer, pointer          :: field_array(:) ! array that contains all fields,
                                               ! which are waiting to be received 
                                               ! by a prism_get
   integer                   :: status         ! number of fields - 1 that are
                                               ! currently in the array
   integer                   :: allocated_fields ! number of fields, that would
                                               ! fit into allocated memory
   integer, pointer          :: temp(:)        ! temporary variable for memory allocation

   integer                   :: ierrp(2)

! Initialisation
   status           = Drv_Exchanges(exchange_id)%trans_in_status
   allocated_fields = Drv_Exchanges(exchange_id)%trans_in_nbr_allocated_fields

! If there is not enough memory allocated for another additional field
   if (status .eq. allocated_fields+1) then

      allocate(temp(field_size*(allocated_fields+1)), stat=ierror)
      if (ierror > 0) then
         ierrp (1) = ierror
         ierrp (2) = field_size*(allocated_fields+1)
         call psmile_error_common ( PRISM_Error_Alloc, 'enqueue_in_field', &
                                    ierrp, 2, __FILE__, __LINE__ )

         return
      endif

      ! copy old field array into new array (if there is data)
      if (allocated_fields .gt.0) then
         temp(1:field_size*allocated_fields) = &
            Drv_Exchanges(exchange_id)%trans_in_field_int
         deallocate(Drv_Exchanges(exchange_id)%trans_in_field_int, stat=ierror)
         if (ierror > 0) then
            ierrp (1) = ierror
            call psmile_error_common(PRISM_Error_Dealloc,'enqueue_in_field',&
                                       ierrp, 1, __FILE__, __LINE__ )
            return
         endif
      endif

      Drv_Exchanges(exchange_id)%trans_in_nbr_allocated_fields&
                = allocated_fields +1

      ! set new field array
      Drv_Exchanges(exchange_id)%trans_in_field_int => temp

   else if (status .gt. allocated_fields+1) then ! this should never happen

      ierrp (1) = status
      ierrp (2) = allocated_fields
      call psmile_error_common(PRISM_Error_Arg, 'enqueue_in_field_int', &
                      ierrp, 1, __FILE__, __LINE__ )
      return
   endif

   field_array => Drv_Exchanges(exchange_id)%trans_in_field_int

!  copy new field into field array
   field_array(field_size*(status-1)+1: &
               field_size*status) = &
               field

end subroutine prismtrs_enqueue_in_field_int

subroutine prismtrs_dequeue_in_field_dble(field_size, exchange_id, ierror)
   use PRISMDrv, dummy_interface => prismtrs_dequeue_in_field_dble
   implicit none
   
   integer, intent(in)       :: field_size  ! size of the field * nbr_fields
   integer, intent(in)       :: exchange_id ! exchange id...
   integer, intent(out)      :: ierror

   double precision, pointer :: field_array(:) ! array that contains all fields,
                                               ! which are waiting to be received 
                                               ! by a prism_get
   integer                   :: status         ! number of fields - 1 that are
                                               ! currently in the array
   integer                   :: i
   integer                   :: ierrp(2)

! Initialisation
   status      =  Drv_Exchanges(exchange_id)%trans_in_status
   field_array => Drv_Exchanges(exchange_id)%trans_in_field_dble

!  if there are still other fields in the array that need to be received by a prism_get
   do i=1, status
      field_array((i-1)*field_size+1:i*field_size) =&
         field_array(i*field_size+1:(i+1)*field_size)
   end do
end subroutine prismtrs_dequeue_in_field_dble

subroutine prismtrs_dequeue_in_field_real(field_size, exchange_id, ierror)
   use PRISMDrv, dummy_interface => prismtrs_dequeue_in_field_real
   implicit none
   
   integer, intent(in)       :: field_size  ! size of the field * nbr_fields
   integer, intent(in)       :: exchange_id ! exchange id...
   integer, intent(out)      :: ierror

   real, pointer             :: field_array(:) ! array that contains all fields,
                                               ! which are waiting to be received 
                                               ! by a prism_get
   integer                   :: status         ! number of fields - 1 that are
                                               ! currently in the array
   integer                   :: i
   integer                   :: ierrp(2)

! Initialisation
   status      =  Drv_Exchanges(exchange_id)%trans_in_status
   field_array => Drv_Exchanges(exchange_id)%trans_in_field_real

!  if there are still other fields in the array that need to be received by a prism_get
   do i=1, status
      field_array((i-1)*field_size+1:i*field_size) =&
         field_array(i*field_size+1:(i+1)*field_size)
   end do
end subroutine prismtrs_dequeue_in_field_real

subroutine prismtrs_dequeue_in_field_int(field_size, exchange_id, ierror)
   use PRISMDrv, dummy_interface => prismtrs_dequeue_in_field_int
   implicit none
   
   integer, intent(in)       :: field_size  ! size of the field * nbr_fields
   integer, intent(in)       :: exchange_id ! exchange id...
   integer, intent(out)      :: ierror

   integer, pointer          :: field_array(:) ! array that contains all fields,
                                               ! which are waiting to be received 
                                               ! by a prism_get
   integer                   :: status         ! number of fields - 1 that are
                                               ! currently in the array
   integer                   :: i
   integer                   :: ierrp(2)

! Initialisation
   status      =  Drv_Exchanges(exchange_id)%trans_in_status
   field_array => Drv_Exchanges(exchange_id)%trans_in_field_int

!  if there are still other fields in the array that need to be received by a prism_get
   do i=1, status
      field_array((i-1)*field_size+1:i*field_size) =&
         field_array(i*field_size+1:(i+1)*field_size)
   end do
end subroutine prismtrs_dequeue_in_field_int

subroutine prismtrs_enqueue_glob_sum_dble(global_sum, nbr_fields, exchange_id, ierror)
   use PRISMDrv, dummy_interface => prismtrs_enqueue_glob_sum_dble
   implicit none

   integer, intent(in)       :: nbr_fields  ! number of fields(one sum per field)
   double complex, intent(in):: global_sum(nbr_fields)
                                            ! global sum of the field
   integer, intent(in)       :: exchange_id ! exchange id...
   integer, intent(out)      :: ierror

   double complex, pointer   :: sum_array(:)   ! array that contains all sums,
                                               ! which are waiting to be received 
                                               ! by a prism_get
   integer                   :: status         ! number of fields - 1 that are
                                               ! currently in the array
   integer                   :: allocated_sums ! number of sums, that would
                                               ! fit into allocated memory
   double complex, pointer   :: temp(:)        ! temporary variable for memory allocation

   integer                   :: ierrp(2)

! Initialisation
   status           = Drv_Exchanges(exchange_id)%trans_in_status
   allocated_sums = Drv_Exchanges(exchange_id)%trans_in_nbr_allocated_sums

! If there is not enough memory allocated for another additional global sum
   if (status .eq. allocated_sums+1) then

      allocate(temp((allocated_sums+1)*nbr_fields), stat=ierror)
      if (ierror > 0) then
         ierrp (1) = ierror
         ierrp (2) = (allocated_sums+1)*nbr_fields
         call psmile_error_common ( PRISM_Error_Alloc, 'enqueue_glob_sum', &
                                    ierrp, 2, __FILE__, __LINE__ )

         return
      endif

      ! copy old sum array into new array (if there is data)
      if (allocated_sums .gt.0) then
         temp(1:allocated_sums*nbr_fields) =&
            Drv_Exchanges(exchange_id)%global_sum_dble

         deallocate(Drv_Exchanges(exchange_id)%global_sum_dble, stat=ierror)
         if (ierror > 0) then
            ierrp (1) = ierror
            call psmile_error_common(PRISM_Error_Dealloc,'enqueue_glob_sum',&
                                    ierrp, 1, __FILE__, __LINE__ )
            return
         endif
      endif

      Drv_Exchanges(exchange_id)%trans_in_nbr_allocated_sums&
                = allocated_sums +1

      ! set new field array
      Drv_Exchanges(exchange_id)%global_sum_dble => temp

   else if (status .gt. allocated_sums+1) then ! this should never happen

      ierrp (1) = status
      ierrp (2) = allocated_sums
      call psmile_error_common(PRISM_Error_Arg, 'enqueue_glob_sum', &
                      ierrp, 1, __FILE__, __LINE__ )
      return
   endif

   sum_array => Drv_Exchanges(exchange_id)%global_sum_dble
!  copy new field into field array
   sum_array((status-1)*nbr_fields+1:&
              status*nbr_fields) = global_sum

end subroutine prismtrs_enqueue_glob_sum_dble

subroutine prismtrs_enqueue_glob_sum_int(global_sum, nbr_fields, exchange_id, ierror)
   use PRISMDrv, dummy_interface => prismtrs_enqueue_glob_sum_int
   implicit none

   integer, intent(in)       :: nbr_fields  ! number of fields(one sum per field)
   integer, intent(in)       :: global_sum(nbr_fields)
                                            ! global sum of the field
   integer, intent(in)       :: exchange_id ! exchange id...
   integer, intent(out)      :: ierror

   integer, pointer          :: sum_array(:)   ! array that contains all sums,
                                               ! which are waiting to be received 
                                               ! by a prism_get
   integer                   :: status         ! number of fields - 1 that are
                                               ! currently in the array
   integer                   :: allocated_sums ! number of sums, that would
                                               ! fit into allocated memory
   integer, pointer          :: temp(:)        ! temporary variable for memory allocation

   integer                   :: ierrp(2)

! Initialisation
   status           = Drv_Exchanges(exchange_id)%trans_in_status
   allocated_sums = Drv_Exchanges(exchange_id)%trans_in_nbr_allocated_sums

! If there is not enough memory allocated for another additional global sum
   if (status .eq. allocated_sums+1) then

      allocate(temp((allocated_sums+1)*nbr_fields), stat=ierror)
      if (ierror > 0) then
         ierrp (1) = ierror
         ierrp (2) = (allocated_sums+1)*nbr_fields
         call psmile_error_common ( PRISM_Error_Alloc, 'enqueue_glob_sum', &
                                    ierrp, 2, __FILE__, __LINE__ )

         return
      endif

      ! copy old sum array into new array (if there is data)
      if (allocated_sums .gt.0) then
         temp(1:allocated_sums*nbr_fields) =&
            Drv_Exchanges(exchange_id)%global_sum_int

         deallocate(Drv_Exchanges(exchange_id)%global_sum_dble, stat=ierror)
         if (ierror > 0) then
            ierrp (1) = ierror
            call psmile_error_common(PRISM_Error_Dealloc,'enqueue_glob_sum',&
                                    ierrp, 1, __FILE__, __LINE__ )
            return
         endif
      endif

      Drv_Exchanges(exchange_id)%trans_in_nbr_allocated_sums&
                = allocated_sums +1

      ! set new field array
      Drv_Exchanges(exchange_id)%global_sum_int => temp

   else if (status .gt. allocated_sums+1) then ! this should never happen

      ierrp (1) = status
      ierrp (2) = allocated_sums
      call psmile_error_common(PRISM_Error_Arg, 'enqueue_glob_sum', &
                      ierrp, 1, __FILE__, __LINE__ )
      return
   endif

   sum_array => Drv_Exchanges(exchange_id)%global_sum_int
!  copy new field into field array
   sum_array((status-1)*nbr_fields+1:&
              status*nbr_fields) = global_sum

end subroutine prismtrs_enqueue_glob_sum_int

subroutine prismtrs_dequeue_glob_sum_dble(nbr_fields, exchange_id, ierror)
   use PRISMDrv, dummy_interface => prismtrs_dequeue_glob_sum_dble
   implicit none

   integer, intent(in)       :: nbr_fields
   integer, intent(in)       :: exchange_id ! exchange id...
   integer, intent(out)      :: ierror

   double complex, pointer   :: sum_array(:)   ! array that contains all sums,
                                               ! which are waiting to be received 
                                               ! by a prism_get
   integer                   :: status         ! number of fields - 1 that are
                                               ! currently in the array
   integer                   :: ierrp(2)

!  Initialisation
   status    =  Drv_Exchanges(exchange_id)%trans_in_status
   sum_array => Drv_Exchanges(exchange_id)%global_sum_dble

!  if there are still other sums in the array copy which still need to be processes,
!  copy them to an index which is lower by -1
   if (status > 0) sum_array(1:status*nbr_fields) = sum_array(nbr_fields+1:(status+1)*nbr_fields)

end subroutine prismtrs_dequeue_glob_sum_dble

subroutine prismtrs_dequeue_glob_sum_int(nbr_fields, exchange_id, ierror)
   use PRISMDrv, dummy_interface => prismtrs_dequeue_glob_sum_int
   implicit none

   integer, intent(in)       :: nbr_fields
   integer, intent(in)       :: exchange_id ! exchange id...
   integer, intent(out)      :: ierror

   integer, pointer          :: sum_array(:)   ! array that contains all sums,
                                               ! which are waiting to be received 
                                               ! by a prism_get
   integer                   :: status         ! number of fields - 1 that are
                                               ! currently in the array
   integer                   :: ierrp(2)

!  Initialisation
   status    =  Drv_Exchanges(exchange_id)%trans_in_status
   sum_array => Drv_Exchanges(exchange_id)%global_sum_int

!  if there are still other sums in the array copy which still need to be processes,
!  copy them to an index which is lower by -1
   if (status > 0) sum_array(1:status*nbr_fields) = sum_array(nbr_fields+1:(status+1)*nbr_fields)

end subroutine prismtrs_dequeue_glob_sum_int

subroutine prismdrv_init_Drv_Exchange(exchange_id)
   use PRISMDrv, dummy_interface => prismdrv_init_Drv_Exchange
   implicit none

   integer, intent(in) :: exchange_id

   type(Drv_Exchange), pointer  :: exchange

   exchange => Drv_Exchanges(exchange_id)

   exchange%epio_id = PSMILe_trans_unset
   exchange%interp_status = PSMILe_trans_notbegun
   exchange%transf_id = PSMILe_trans_unset
   exchange%transf_status = PSMILe_trans_notbegun
   exchange%trans_in_request = PSMILe_trans_notrequested
   exchange%trans_in_status = 0
   exchange%trans_in_nbr_allocated_fields = 0
   exchange%trans_in_nbr_allocated_sums = 0

   Nullify(exchange%trans_in_field_dble)
   Nullify(exchange%trans_in_field_real)
   Nullify(exchange%trans_in_field_int)

   Nullify(exchange%global_sum_dble)
   Nullify(exchange%global_sum_int)

end subroutine prismdrv_init_Drv_Exchange