prismtrs_apply_weights.F90

Go to the documentation of this file.

!------------------------------------------------------------------------
! Copyright 2006-2010, CERFACS, Toulouse, France.
! Copyright 2006-2010, NEC High Performance Computing, Duesseldorf, Germany.
! All rights reserved. Use is subject to OASIS4 license terms.
!-----------------------------------------------------------------------
!BOP
!
! !ROUTINE: PRISMTrs_Apply_weights
!
! !INTERFACE
subroutine prismtrs_apply_weights(il_src_size,         &
                                  dda_trans_out,       &
                                  il_tgt_size,         &
                                  dda_trans_in,        &
                                  ida_mask,            &
                                  id_nb_neighbors,     &  
                                  ida_neighbors,       &
                                  dda_weights,         &
                                  nbr_fields,          &
                                  id_err)
!
! !USES:
!
  USE PRISMDrv, dummy_interface => PRISMTrs_Apply_weights

  IMPLICIT NONE

!
! !PARAMETERS:
!
! size of the source transient
  INTEGER, INTENT (IN)                              :: il_src_size

! Nbr of bundle components
  INTEGER, INTENT (IN)                              :: nbr_fields

! source transient field
  DOUBLE PRECISION, DIMENSION(il_src_size*nbr_fields), INTENT(IN) :: dda_trans_out
 
! size of the target transient
  INTEGER, INTENT (IN)                              :: il_tgt_size

! target transient mask
  INTEGER, DIMENSION(il_tgt_size), INTENT(IN)       :: ida_mask
  

! number of neighbors involved in the interpolation
  INTEGER, INTENT (IN)                              :: id_nb_neighbors
 
! Neighbors and associated weights
  INTEGER, DIMENSION(il_tgt_size,id_nb_neighbors), INTENT (IN) :: 
     ida_neighbors
  DOUBLE PRECISION, DIMENSION(il_tgt_size,id_nb_neighbors), INTENT(IN) :: dda_weights

!
! ! RETURN VALUE
!
! target transient field
  DOUBLE PRECISION, DIMENSION(il_tgt_size*nbr_fields), INTENT (Out) :: dda_trans_in

  INTEGER, INTENT (Out)               :: id_err   ! error value

! !DESCRIPTION
! Subroutine "PRISMTrs_Interp_Apply_weights" performs the matrix vector
! computation to get the field on the target grid.
!
! !REVISED HISTORY
!   Date      Programmer   Description
! ----------  ----------   -----------
! 06/12/2002  D. Declat    Creation
! 06/03/2008  J. Charles   Modifications added for the use of bundle fields
!
! EOP
!----------------------------------------------------------------------
! $Id: prismtrs_apply_weights.F90 2963 2011-02-17 14:52:53Z coquart $
! $Author: coquart $
!----------------------------------------------------------------------
!
! Local declarations
!
  CHARACTER(LEN=len_cvs_string), SAVE  :: mycvs = 
     '$Id: prismtrs_apply_weights.F90 2963 2011-02-17 14:52:53Z coquart $'

  INTEGER :: ib, ib_bis, i
  INTEGER :: il_count_neighbors
#ifdef SX
  INTEGER,DIMENSION (il_tgt_size) :: il_count_neighborsh
#endif
!
! ---------------------------------------------------------------------
!
#ifdef VERBOSE
  PRINT *, '| | | | | | | Enter PRISMTrs_Apply_weights'
  call psmile_flushstd
#endif
!
  id_err = 0
!
! 1. For each non masked target point Apply the weights on the source field 
!    to get the target field
!
  dda_trans_in(:) = 0.
#ifndef SX
  DO i = 1, nbr_fields
     
     DO ib = 1, il_tgt_size
        
        il_count_neighbors = 0

        DO ib_bis = 1, id_nb_neighbors
           IF (ida_neighbors(ib,ib_bis) /= 0) THEN
              dda_trans_in(ib+(i-1)*il_tgt_size) = dda_trans_in(ib+(i-1)*il_tgt_size) +    &
                   dda_weights(ib,ib_bis) *              &
                   dda_trans_out(ida_neighbors(ib,ib_bis)+(i-1)*il_src_size)
#ifdef DEBUGX
              IF ( (ib == 30) .OR. (ib == 1667) ) THEN
                  PRINT*, '+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++'
                  PRINT*, 'weights(ib,ib_bis) for EPIOT number ib, ib_bis :',ib,ib_bis
                  PRINT*, '+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++'
                  PRINT*, dda_weights(ib,ib_bis)
              ENDIF
#endif
           ELSE
              il_count_neighbors = il_count_neighbors + 1
           END IF

        END DO

        IF (il_count_neighbors == id_nb_neighbors) &
             dda_trans_in(ib+(i-1)*il_tgt_size) = PSMILe_dundef
#ifdef DEBUGX
              IF ( (ib == 105) .OR. (ib == 315) ) THEN
                  PRINT*, '+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++'
                  PRINT*, 'dda_trans_in for EPIOT number ib :',ib
                  PRINT*, 'ida_neighbors(ib,:)'
                  PRINT*, '+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++'
                  PRINT*, dda_trans_in(ib+(i-1)*il_tgt_size)
                  PRINT*, ida_neighbors(ib,:)
              ENDIF
#endif

     END DO

  END DO

#else

  il_count_neighborsh=0
  DO ib = 1, il_tgt_size
    DO ib_bis = 1, id_nb_neighbors
      IF (ida_mask(ib) == 1 .AND. ida_neighbors(ib,ib_bis) == 0) THEN
          il_count_neighborsh(ib) = il_count_neighborsh(ib) + 1
      ENDIF
    ENDDO
  ENDDO
    
  DO i = 1, nbr_fields
     DO ib_bis = 1, id_nb_neighbors
        DO ib = 1, il_tgt_size
      
           IF (ida_mask(ib) == 1) THEN
          
              IF (ida_neighbors(ib,ib_bis) /= 0) THEN
                 dda_trans_in(ib+(i-1)*il_tgt_size) = dda_trans_in(ib+(i-1)*il_tgt_size) +    &
                      dda_weights(ib,ib_bis) *          &
                      dda_trans_out(ida_neighbors(ib,ib_bis)+(i-1)*il_src_size)
              END IF
          
           ELSE
          
              !
              ! 2. Else give the mask value to the point
              !
          
              dda_trans_in(ib+(i-1)*il_tgt_size) = PSMILe_dundef
              
           END IF
        END DO
     END DO

     DO ib = 1, il_tgt_size
        IF (il_count_neighborsh(ib) == id_nb_neighbors) &
             dda_trans_in(ib+(i-1)*il_tgt_size) = PSMILe_dundef
     END DO

  ENDDO

#endif
!
#ifdef VERBOSE
  PRINT *, '| | | | | | | Quit PRISMTrs_Apply_weights'
  call psmile_flushstd
#endif

END SUBROUTINE PRISMTrs_Apply_weights