psmile_sel_grid_range_dble.F90

Go to the documentation of this file.
00001 !-----------------------------------------------------------------------
00002 ! Copyright 2007-2010, NEC Europe Ltd., London, UK.
00003 ! All rights reserved. Use is subject to OASIS4 license terms.
00004 !-----------------------------------------------------------------------
00005 !BOP
00006 !
00007 ! !ROUTINE: PSMILe_Sel_grid_range_dble
00008 !
00009 ! !INTERFACE:
00010 
00011       subroutine psmile_sel_grid_range_dble (grid_id, dinter, &
00012                                                    inter, ierror)
00013 !
00014 ! !USES:
00015 !
00016       use PRISM_constants
00017 !
00018       use PSMILe, dummy_interface => PSMILe_Sel_grid_range_dble
00019 
00020       implicit none
00021 !
00022 ! !INPUT PARAMETERS:
00023 !
00024       integer, Intent (In)                :: grid_id
00025 
00026 !     Specifies the handle to the grid information.
00027 
00028       Real (PSMILe_float_kind), Intent (In) :: dinter (2, ndim_3d)
00029 
00030 !     Specifies the intersection with grid "grid_id"
00031 !
00032 ! !OUTPUT PARAMETERS:
00033 !
00034       Integer, Intent (Out)               :: inter (2, ndim_3d)
00035 
00036 !     Returns the sub-array of grid "grid_id" which contains "dinter"
00037 
00038       integer, Intent (Out)               :: ierror
00039 
00040 !     Returns the error code of PSMILe_Sel_grid_range_dble;
00041 !             ierror = 0 : No error
00042 !             ierror > 0 : Severe error
00043 !
00044 ! !DEFINED PARAMETERS:
00045 !
00046       integer, parameter                  :: nc_reg = 2
00047 
00048 !    Number of corners for regular directions
00049 !
00050 ! !LOCAL VARIABLES
00051 !
00052       Type (Corner_Block), Pointer        :: corner_pointer
00053 !
00054       Double Precision                    :: r_inter (2, ndim_3d)
00055 !
00056       integer, parameter                  :: nerrp = 1
00057       integer                             :: ierrp (nerrp)
00058 !
00059 ! !DESCRIPTION:
00060 !
00061 ! Subroutine "PSMILe_Sel_grid_range_dble" computes the subarray of grid id
00062 ! "grid_id"  which contains the range_dble "dinter".
00063 !
00064 !
00065 ! !REVISION HISTORY:
00066 !
00067 !   Date      Programmer   Description
00068 ! ----------  ----------   -----------
00069 ! 03.06.17    H. Ritzdorf  created
00070 !
00071 !EOP
00072 !----------------------------------------------------------------------
00073 !
00074 ! $Id: psmile_sel_grid_range_dble.F90 2687 2010-10-28 15:15:52Z coquart $
00075 ! $Author: coquart $
00076 !
00077    Character(len=len_cvs_string), save :: mycvs = 
00078        '$Id: psmile_sel_grid_range_dble.F90 2687 2010-10-28 15:15:52Z coquart $'
00079 !
00080 !----------------------------------------------------------------------
00081 
00082 #ifdef VERBOSE
00083       print *, trim(ch_id), ': PSMILe_Sel_grid_range_dble: grid_id', grid_id
00084 
00085       call psmile_flushstd
00086 #endif /* VERBOSE */
00087 !
00088 !  Initialization
00089 !
00090       ierror = 0
00091 
00092       corner_pointer => Grids(grid_id)%corner_pointer
00093 
00094 #ifdef PRISM_ASSERTION
00095 
00096 !    Internal control: Is the data really available
00097 
00098       if (.not. Associated(corner_pointer%corners_dble(1)%vector) ) then
00099          call psmile_assert ( __FILE__, __LINE__, &
00100                 'Pointer corners_dble(1)%vector is not set')
00101       endif
00102 
00103       if (.not. Associated(corner_pointer%corners_dble(2)%vector) ) then
00104          call psmile_assert ( __FILE__, __LINE__, &
00105                 'Pointer corners_dble(2)%vector is not set')
00106       endif
00107 
00108       if (.not. Associated(corner_pointer%corners_dble(3)%vector) ) then
00109          call psmile_assert ( __FILE__, __LINE__, &
00110                 'Pointer corners_dble(3)%vector is not set')
00111       endif
00112 #endif /* PRISM_ASSERTION */
00113 !
00114       r_inter (1:2,1:ndim_3d) = dinter (1:2, 1:ndim_3d)
00115 
00116       select case ( Grids(grid_id)%grid_type )
00117 
00118 ! -----------------------------------------------------------------------
00119 !      Regular in all directions
00120 !      ===> Number of corners in all directions = 2
00121 !           (cf. prism_set_corners_3d_double.F90)
00122 ! -----------------------------------------------------------------------
00123 !
00124       case (PRISM_Reglonlatvrt)
00125 !
00126          call psmile_range_subgrid_1d_dble (   &
00127                 corner_pointer%corners_dble(1)%vector,     &
00128                 corner_pointer%corner_shape(1,1), &
00129                 corner_pointer%corner_shape(2,1), &
00130                 nc_reg,                           &
00131                 Grids(grid_id)%grid_shape (1,1),  &
00132                 Grids(grid_id)%grid_shape (2,1),  &
00133                 r_inter (1,1), inter (1,1), ierror)
00134          if (ierror > 0) return
00135 !
00136          call psmile_range_subgrid_1d_dble (&
00137                 corner_pointer%corners_dble(2)%vector,     &
00138                 corner_pointer%corner_shape(1,2), &
00139                 corner_pointer%corner_shape(2,2), &
00140                 nc_reg,                           &
00141                 Grids(grid_id)%grid_shape (1,2),  &
00142                 Grids(grid_id)%grid_shape (2,2),  &
00143                 r_inter (1,2), inter (1,2), ierror)
00144          if (ierror > 0) return
00145 !
00146          call psmile_range_subgrid_1d_dble (&
00147                 corner_pointer%corners_dble(3)%vector,     &
00148                 corner_pointer%corner_shape(1,3), &
00149                 corner_pointer%corner_shape(2,3), &
00150                 nc_reg,                           &
00151                 Grids(grid_id)%grid_shape (1,3),  &
00152                 Grids(grid_id)%grid_shape (2,3),  &
00153                 r_inter (1,3), inter (1,3), ierror)
00154          if (ierror > 0) return
00155 !
00156 ! -----------------------------------------------------------------------
00157 !    Irregular in lonlat   direction
00158 !      Regular in vertical direction
00159 !      ===> Number of corners in vertical direction = 2
00160 !           (cf. prism_set_corners_3d_double.F90)
00161 ! -----------------------------------------------------------------------
00162 !
00163       case (PRISM_Irrlonlat_regvrt)
00164 !
00165          call psmile_range_subgrid_2d_dble ( &
00166                 corner_pointer%corners_dble(1)%vector,       &
00167                 corner_pointer%corners_dble(2)%vector,       &
00168                 corner_pointer%corner_shape(1,1),   &
00169                 corner_pointer%corner_shape(2,1),   &
00170                 corner_pointer%corner_shape(1,2),   &
00171                 corner_pointer%corner_shape(2,2),   &
00172                 corner_pointer%nbr_corners/nc_reg,  &
00173                 Grids(grid_id)%grid_shape (1,1),    &
00174                 Grids(grid_id)%grid_shape (2,1),    &
00175                 Grids(grid_id)%grid_shape (1,2),    &
00176                 Grids(grid_id)%grid_shape (2,2),    &
00177                 r_inter (1,1), inter (1,1), ierror)
00178          if (ierror > 0) return
00179 !
00180          call psmile_range_subgrid_1d_dble (&
00181                 corner_pointer%corners_dble(3)%vector,     &
00182                 corner_pointer%corner_shape(1,3), &
00183                 corner_pointer%corner_shape(2,3), &
00184                 nc_reg,                           &
00185                 Grids(grid_id)%grid_shape (1,3),  &
00186                 Grids(grid_id)%grid_shape (2,3),  &
00187                 r_inter (1,3), inter (1,3), ierror)
00188          if (ierror > 0) return
00189 !
00190 ! -----------------------------------------------------------------------
00191 !       Irregular in lonlat   and vertical direction
00192 ! -----------------------------------------------------------------------
00193 !
00194       case (PRISM_Irrlonlatvrt)
00195 
00196          call psmile_range_subgrid_3d_dble ( &
00197                 corner_pointer%corners_dble(1)%vector,       &
00198                 corner_pointer%corners_dble(2)%vector,       &
00199                 corner_pointer%corners_dble(3)%vector,       &
00200                 corner_pointer%corner_shape(1,1),   &
00201                 corner_pointer%corner_shape(2,1),   &
00202                 corner_pointer%corner_shape(1,2),   &
00203                 corner_pointer%corner_shape(2,2),   &
00204                 corner_pointer%corner_shape(1,3),   &
00205                 corner_pointer%corner_shape(2,3),   &
00206                 corner_pointer%nbr_corners,         &
00207                 Grids(grid_id)%grid_shape,          &
00208                 r_inter, inter, ierror)
00209          if (ierror > 0) return
00210 !
00211 ! -----------------------------------------------------------------------
00212 !      Gauss reduced in horizontal, Regular in vertical directions
00213 !      ===> Number of corners in all directions = 2
00214 !           (cf. prism_set_corners_3d_double.F90)
00215 ! -----------------------------------------------------------------------
00216 !
00217       case (PRISM_Gaussreduced_regvrt)
00218 !
00219          call psmile_range_subgrid_2d_dble (   &
00220                 corner_pointer%corners_dble(1)%vector,     &
00221                 corner_pointer%corners_dble(2)%vector,     &
00222                 corner_pointer%corner_shape(1,1), &
00223                 corner_pointer%corner_shape(2,1), &
00224                 corner_pointer%corner_shape(1,2), &
00225                 corner_pointer%corner_shape(2,2), &
00226                 nc_reg,                           &
00227                 Grids(grid_id)%grid_shape (1,1),  &
00228                 Grids(grid_id)%grid_shape (2,1),  &
00229                 Grids(grid_id)%grid_shape (1,2),  &
00230                 Grids(grid_id)%grid_shape (2,2),  &
00231                 r_inter (1,1), inter (1,1), ierror)
00232          if (ierror > 0) return
00233 !
00234          inter(:,2) = 1
00235 
00236          call psmile_range_subgrid_1d_dble (&
00237                 corner_pointer%corners_dble(3)%vector,     &
00238                 corner_pointer%corner_shape(1,3), &
00239                 corner_pointer%corner_shape(2,3), &
00240                 nc_reg,                           &
00241                 Grids(grid_id)%grid_shape (1,3),  &
00242                 Grids(grid_id)%grid_shape (2,3),  &
00243                 r_inter (1,3), inter (1,3), ierror)
00244          if (ierror > 0) return
00245 !
00246 ! -----------------------------------------------------------------------
00247 !        Error: unsupported grid type
00248 ! -----------------------------------------------------------------------
00249 !
00250       case DEFAULT
00251 !
00252           ierrp (1) = Grids(grid_id)%grid_type
00253 
00254           ierror = PRISM_Error_Internal
00255 
00256           call psmile_error ( ierror, 'unsupported grid generation type', &
00257                               ierrp, 1, __FILE__, __LINE__ )
00258 
00259       end select
00260 !
00261 !===> All done
00262 !
00263 #ifdef VERBOSE
00264       print *, trim(ch_id), ': PSMILe_Sel_grid_range_dble eof: grid_id',&
00265                              grid_id, ', ierror =', ierror
00266 !                            , '; inter  =', inter
00267 
00268       call psmile_flushstd
00269 #endif /* VERBOSE */
00270 !
00271       end subroutine PSMILe_Sel_grid_range_dble