prismtrs_linear_weight_for_2d1d.F90

Go to the documentation of this file.
00001 !------------------------------------------------------------------------
00002 ! Copyright 2006-2010, CERFACS, Toulouse, France.
00003 ! Copyright 2006-2010, NEC High Performance Computing, Duesseldorf, Germany.
00004 ! All rights reserved. Use is subject to OASIS4 license terms.
00005 !-----------------------------------------------------------------------
00006 !BOP
00007 !
00008 ! !ROUTINE: PRISMTrs_Linear_weight_for_2d1d
00009 !
00010 ! !INTERFACE
00011 subroutine prismtrs_linear_weight_for_2d1d(id_src_size,         &
00012                                            dda_src_z,           &
00013                        id_tgt_size,         &
00014                        dda_tgt_z,           &
00015                        ida_tgt_mask,        &
00016                        id_nb_neighbors,     & 
00017                        ida_neighbor_index,  &
00018                        dda_weights,         &
00019                        id_err)
00020 
00021 !
00022 ! !USES:
00023 !
00024   USE PRISMDrv, dummy_interface => PRISMTrs_Linear_weight_for_2d1d
00025 
00026   IMPLICIT NONE
00027 
00028 !
00029 ! !PARAMETERS:
00030 !
00031 ! size of the source and target grid to interpolate
00032   INTEGER, INTENT (IN)                         :: id_src_size
00033   INTEGER, INTENT (IN)                         :: id_tgt_size
00034  
00035 ! z coordinates of the source grid
00036   DOUBLE PRECISION, DIMENSION(id_src_size)     :: dda_src_z
00037 
00038 ! z coordinates of the target grid
00039   DOUBLE PRECISION, DIMENSION(id_tgt_size)     :: dda_tgt_z
00040 
00041   INTEGER, DIMENSION(id_tgt_size), INTENT (IN) :: ida_tgt_mask
00042 
00043 ! number of neighbors
00044   INTEGER, INTENT (IN)                         :: id_nb_neighbors
00045 
00046 ! indices of the foud neighbors on the source grid for each target point
00047   INTEGER, DIMENSION(id_tgt_size,id_nb_neighbors), INTENT(INOUT) :: 
00048      ida_neighbor_index
00049 
00050 !
00051 ! ! RETURN VALUE
00052 !
00053 ! bilinear weights for four corners
00054   DOUBLE PRECISION, DIMENSION(id_tgt_size, id_nb_neighbors), INTENT (InOut) :: 
00055      dda_weights
00056 
00057   INTEGER, INTENT (Out)                        :: id_err   ! error value
00058 
00059 ! !DESCRIPTION
00060 ! Subroutine "PRISMTrs_Linear_weight_for_2d1d" computes the weights for 
00061 ! the linear interpolation method on the vertical axes.
00062 ! The inputs are the results of the 2D weights computation.
00063 !
00064 ! !REVISED HISTORY
00065 !   Date      Programmer   Description
00066 ! ----------  ----------   -----------
00067 ! 17/07/2004  D. Declat    Creation
00068 !
00069 ! EOP
00070 !----------------------------------------------------------------------
00071 ! $Id: prismtrs_linear_weight_for_2d1d.F90 2685 2010-10-28 14:05:10Z coquart $
00072 ! $Author: coquart $
00073 !----------------------------------------------------------------------
00074 !
00075 ! Local declarations
00076 !
00077   CHARACTER(LEN=len_cvs_string), SAVE  :: mycvs = 
00078      '$Id: prismtrs_linear_weight_for_2d1d.F90 2685 2010-10-28 14:05:10Z coquart $'
00079 
00080 ! loop indices
00081   INTEGER                 :: ib, ib_bis
00082 
00083 ! vectors of lon and lat of the source points used to compute the weights
00084   DOUBLE PRECISION        :: dl_weight_up, dl_weight_down 
00085 
00086 !
00087 ! ---------------------------------------------------------------------
00088 !
00089 #ifdef VERBOSE
00090   PRINT *, '| | | | | | | Enter PRISMTrs_Linear_weight_for_2d1d'
00091   call psmile_flushstd
00092 #endif
00093 
00094   id_err = 0
00095 
00096 !
00097 ! 1. In the loop
00098 !
00099   DO ib = 1, id_tgt_size
00100 
00101     IF (ida_tgt_mask(ib) .eq. 1) THEN
00102 
00103     dl_weight_down = (abs(dda_src_z(ida_neighbor_index(ib,1))-  &
00104        dda_tgt_z(ib)))/ &
00105        (abs(dda_src_z(ida_neighbor_index(ib,1)) - &
00106        dda_src_z(ida_neighbor_index(ib,1+id_nb_neighbors/2))))
00107        
00108     dl_weight_up = (abs(dda_src_z(ida_neighbor_index(ib,1+id_nb_neighbors/2))- &
00109        dda_tgt_z(ib)))/ &
00110        (abs(dda_src_z(ida_neighbor_index(ib,1)) - &
00111        dda_src_z(ida_neighbor_index(ib,1+id_nb_neighbors/2))))
00112 
00113     dl_weight_down = 1 - dl_weight_down
00114     dl_weight_up = 1 - dl_weight_up
00115 
00116     DO ib_bis = 1, id_nb_neighbors/2
00117 
00118       dda_weights(ib,ib_bis) = dl_weight_down * dda_weights(ib,ib_bis)
00119       dda_weights(ib,ib_bis+id_nb_neighbors/2) = &
00120          dl_weight_up * dda_weights(ib,ib_bis+id_nb_neighbors/2)
00121 
00122     END DO
00123 
00124     END IF
00125     
00126   END DO
00127 !
00128 #ifdef VERBOSE
00129   PRINT *, '| | | | | | | Quit PRISMTrs_Linear_weight_for_2d1d'
00130   call psmile_flushstd
00131 #endif
00132 
00133 END SUBROUTINE PRISMTrs_Linear_weight_for_2d1d
00134 
00135 
00136 
00137 
00138