prismtrs_store_link_cnsrv.F90

Go to the documentation of this file.

!------------------------------------------------------------------------
! Copyright 2007-2010, CERFACS, Toulouse, France.
! All rights reserved. Use is subject to OASIS4 license terms.
!-----------------------------------------------------------------------
!BOP
! !ROUTINE: PRISMTrs_store_link_cnsrv
!
      subroutine prismtrs_store_link_cnsrv(add1, add2, lcl_weights, id_action, id_epio_id, num_wts)

!-----------------------------------------------------------------------
!
!     input variables
!
!-----------------------------------------------------------------------
      USE PRISMDrv, dummy_INTERFACE => PRISMTrs_store_link_cnsrv
      IMPLICIT NONE
      integer, intent(in) :: 
              add1,   ! address on grid1
              add2,   ! address on grid2
              id_action,  ! 0 if first call, 2 if last call, 1 otherwise
              id_epio_id, 
              num_wts ! Number of weights for 2D conservative remapping


      DOUBLE PRECISION, dimension(2*num_wts), intent(in) :: 
              lcl_weights ! array of remapping lcl_weights for this link
!
! !DESCRIPTION
!
! SUBROUTINE PRISMTrs_store_link_cnsrv stores the address and weight for 
! this link in the appropriate address and weight arrays and resizes those
! arrays if necessary. This routine comes from the SCRIP 1.4 library 
! available from Los Alamos National Laboratory.
!
! !REVISED HISTORY
!   Date      Programmer   Description
! ----------  ----------   -----------
! 21/03/2007  S. Valcke    Duplicated from the SCRIP library
!
! EOP
!----------------------------------------------------------------------
! $Id: prismtrs_store_link_cnsrv.F90 2082 2009-10-21 13:31:19Z hanke $
! $Author: hanke $
!----------------------------------------------------------------------
!
!-----------------------------------------------------------------------
!
!     local variables
!
      CHARACTER(LEN=len_cvs_string), SAVE  :: mycvs = 
     '$Id: prismtrs_store_link_cnsrv.F90 2082 2009-10-21 13:31:19Z hanke $'

      integer :: nlink, min_link, max_link ! link index
      integer :: il_num_links_map1
      integer, dimension(:,:), allocatable, save :: 
              link_add1,   ! min,max link add to restrict search
              link_add2   ! min,max link add to restrict search

#ifdef DEBUGX
  PRINT *, '| | | | | | | Enter PRISMTrs_store_link_cnsrv'
  call psmile_flushstd
#endif
!-----------------------------------------------------------------------
!
!     if all lcl_weights are zero, do not bother storing the link
!
!-----------------------------------------------------------------------

      !For oasis4, we keep next line as fracnnei is not an option in oasis4
#ifdef DEBUGX
  IF (add2 == 4848) THEN
      WRITE(88,*), 'Enter PRISMTrs_store_link_cnsrv'
      WRITE(88,*) 'add1, add2, id_action, lcl_weights =', add1,add2,id_action, lcl_weights(:)
  ENDIF
      call psmile_flushstd
#endif
      ! If store_link_cnsrv is called only for deallocation, do it
      IF (id_action == 2) THEN
          DEALLOCATE(link_add1, link_add2)
          RETURN
      ENDIF
!-----------------------------------------------------------------------
!
!     restrict the range of links to search for existing links
!
!-----------------------------------------------------------------------
      ! if (first_call) then
      if (id_action == 0) then
        ! if (.not. first_conserv) then
        !  deallocate(link_add1, link_add2)
        ! endif
        allocate(link_add1(2,Drv_Epios(id_epio_id)%src_size), &
           link_add2(2,Drv_Epios(id_epio_id)%tgt_size))
        link_add1 = 0
        link_add2 = 0
        ! first_call = .false.
        min_link = 1
        max_link = 0

        if (all(lcl_weights == zero)) return

      else

        if (all(lcl_weights == zero)) return

        min_link = min(link_add1(1,add1),link_add2(1,add2))
        max_link = max(link_add1(2,add1),link_add2(2,add2))
        if (min_link == 0) then
          min_link = 1
          max_link = 0
        endif
      endif

!-----------------------------------------------------------------------
!
!     if the link already exists, add the weight to the current weight
!     arrays
!
!-----------------------------------------------------------------------
      do nlink=min_link,max_link
        if (add1 ==  Drv_Epios(id_epio_id)%grid1_add_map1(nlink)) then
        if (add2 ==  Drv_Epios(id_epio_id)%grid2_add_map1(nlink)) then

          Drv_Epios(id_epio_id)%wts_map1(:,nlink) = &
             Drv_Epios(id_epio_id)%wts_map1(:,nlink) + lcl_weights(1:num_wts)
          return

        endif
        endif
      end do

!-----------------------------------------------------------------------
!
!     if the link does not yet exist, increment number of links and 
!     check to see if remap arrays need to be increased to accomodate 
!     the new link.  then store the link.
!
!-----------------------------------------------------------------------
      il_num_links_map1 = Drv_Epios(id_epio_id)%num_links_map1 + 1
      if (il_num_links_map1 > Drv_Epios(id_epio_id)%max_links_map1)  &
         call prismtrs_resize_remap_vars(Drv_Epios(id_epio_id)%resize_increment, id_epio_id, num_wts)
      Drv_Epios(id_epio_id)%grid1_add_map1(il_num_links_map1) = add1
      Drv_Epios(id_epio_id)%grid2_add_map1(il_num_links_map1) = add2
      Drv_Epios(id_epio_id)%wts_map1    (:,il_num_links_map1) = lcl_weights(1:num_wts)

      if (link_add1(1,add1) == 0) link_add1(1,add1) = il_num_links_map1
      if (link_add2(1,add2) == 0) link_add2(1,add2) = il_num_links_map1
      link_add1(2,add1) = il_num_links_map1
      link_add2(2,add2) = il_num_links_map1

      Drv_Epios(id_epio_id)%num_links_map1  = il_num_links_map1

#ifdef DEBUGX
  PRINT *, '| | | | | | | Quit PRISMTrs_store_link_cnsrv'
  call psmile_flushstd
#endif
!-----------------------------------------------------------------------

      end subroutine PRISMTrs_store_link_cnsrv