psmile_get_grid_extent_dble.F90

Go to the documentation of this file.
00001 !-----------------------------------------------------------------------
00002 ! Copyright 2006-2010, NEC Europe Ltd., London, UK.
00003 ! All rights reserved. Use is subject to OASIS4 license terms.
00004 !-----------------------------------------------------------------------
00005 !BOP
00006 !
00007 ! !ROUTINE: PSMILe_Get_Grid_Extent_dble
00008 !
00009 ! !INTERFACE:
00010 
00011       subroutine psmile_get_grid_extent_dble (grid_id, extent, ierror)
00012 
00013 !
00014 ! !USES:
00015 !
00016       use PRISM_constants
00017       use PSMILe, dummy_interface => PSMILe_Get_Grid_Extent_dble
00018 !
00019       implicit none
00020 !
00021 ! !INPUT PARAMETERS:
00022 !
00023       Integer, Intent (In)                   :: grid_id
00024 !
00025 !     Specifies the handle to the grid information.
00026 !
00027 ! !OUTPUT PARAMETERS:
00028 !
00029       Real (PSMILe_float_kind), Intent (Out) :: extent (2, ndim_3d)
00030 !
00031 !     Returns the extent of grid "grid_id"
00032 
00033       Integer, Intent (Out)                  :: ierror
00034 
00035 !     Returns the error code of PSMILe_Get_Grid_Extent_dble;
00036 !             ierror = 0 : No error
00037 !             ierror > 0 : Severe error
00038 !
00039 !
00040 ! !DEFINED PARAMETERS:
00041 !
00042       Integer, parameter            :: nc_reg = 2
00043 
00044 !     Number of corners for regular directions
00045 !
00046 ! !LOCAL VARIABLES
00047 !
00048       Type (Corner_Block), Pointer :: corner_pointer
00049 
00050       Double Precision             :: r_extent (2)
00051 
00052       Integer, Parameter           :: nerrp = 2
00053       Integer                      :: ierrp (nerrp)
00054 !
00055 ! !DESCRIPTION:
00056 !
00057 ! Subroutine "PSMILe_Get_Grid_Extent_dble" computes the extent
00058 ! of the grid "grid_id".
00059 !
00060 !
00061 ! !REVISION HISTORY:
00062 !
00063 !   Date      Programmer   Description
00064 ! ----------  ----------   -----------
00065 ! 01.12.03    H. Ritzdorf  created
00066 !
00067 !EOP
00068 !----------------------------------------------------------------------
00069 !
00070 !  $Id: psmile_get_grid_extent_dble.F90 2325 2010-04-21 15:00:07Z valcke $
00071 !  $Author: valcke $
00072 !
00073    Character(len=len_cvs_string), save :: mycvs = 
00074        '$Id: psmile_get_grid_extent_dble.F90 2325 2010-04-21 15:00:07Z valcke $'
00075 !
00076 !----------------------------------------------------------------------
00077 
00078 #ifdef VERBOSE
00079       print *, trim(ch_id), ': PSMILe_Get_Grid_Extent_dble: grid_id', grid_id
00080 
00081       call psmile_flushstd
00082 #endif /* VERBOSE */
00083 !
00084 !  Initialization
00085 !
00086       ierror = 0
00087 
00088       if ( Grids(grid_id)%grid_type == PRISM_Gaussreduced_regvrt ) then
00089          corner_pointer => Grids(grid_id)%gcorner_pointer
00090       else
00091          corner_pointer => Grids(grid_id)%corner_pointer
00092       endif
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       select case ( Grids(grid_id)%grid_type )
00115 
00116 ! -----------------------------------------------------------------------
00117 !     Regular in all directions
00118 !     ===> Number of corners in all directions = 2
00119 !          (cf. prism_set_corners_3d_double.F90)
00120 ! -----------------------------------------------------------------------
00121 !
00122       case (PRISM_Reglonlatvrt)
00123 
00124          call psmile_extent_subgrid_1d_dble (&
00125                 corner_pointer%corners_dble(1)%vector,     &
00126                 corner_pointer%corner_shape(1,1), &
00127                 corner_pointer%corner_shape(2,1), &
00128                 nc_reg,                           &
00129                 Grids(grid_id)%grid_shape (1,1),  &
00130                 Grids(grid_id)%grid_shape (2,1),  &
00131                 r_extent, ierror)
00132          if (ierror > 0) return
00133 !
00134          extent (1, 1) = r_extent (1)
00135          extent (2, 1) = r_extent (2)
00136 !
00137          call psmile_extent_subgrid_1d_dble (&
00138              corner_pointer%corners_dble(2)%vector,     &
00139              corner_pointer%corner_shape(1,2), &
00140              corner_pointer%corner_shape(2,2), &
00141              nc_reg,                           &
00142              Grids(grid_id)%grid_shape (1,2),  &
00143              Grids(grid_id)%grid_shape (2,2),  &
00144              r_extent, ierror)
00145          if (ierror > 0) return
00146 !
00147          extent (1, 2) = r_extent (1)
00148          extent (2, 2) = r_extent (2)
00149 !
00150          call psmile_extent_subgrid_1d_dble (&
00151              corner_pointer%corners_dble(3)%vector,     &
00152              corner_pointer%corner_shape(1,3), &
00153              corner_pointer%corner_shape(2,3), &
00154              nc_reg,                           &
00155              Grids(grid_id)%grid_shape (1,3),  &
00156              Grids(grid_id)%grid_shape (2,3),  &
00157              r_extent, ierror)
00158          if (ierror > 0) return
00159 !
00160          extent (1, 3) = r_extent (1)
00161          extent (2, 3) = r_extent (2)
00162 !
00163 ! -----------------------------------------------------------------------
00164 !     Irregular in lonlat   direction
00165 !       Regular in vertical direction
00166 !       ===> Number of corners in vertical direction = 2
00167 !            (cf. prism_set_corners_3d_double.F90)
00168 ! -----------------------------------------------------------------------
00169 !
00170       case (PRISM_Irrlonlat_regvrt)
00171 
00172          call psmile_extent_subgrid_2d_dble ( &
00173                 corner_pointer%corners_dble(1)%vector,       &
00174                 corner_pointer%corner_shape(1,1),   &
00175                 corner_pointer%corner_shape(2,1),   &
00176                 corner_pointer%corner_shape(1,2),   &
00177                 corner_pointer%corner_shape(2,2),   &
00178                 corner_pointer%nbr_corners/nc_reg,  &
00179                 Grids(grid_id)%grid_shape (1,1),    &
00180                 Grids(grid_id)%grid_shape (2,1),    &
00181                 Grids(grid_id)%grid_shape (1,2),    &
00182                 Grids(grid_id)%grid_shape (2,2),    &
00183                 r_extent, ierror)
00184          if (ierror > 0) return
00185 !
00186          extent (1, 1) = r_extent (1)
00187          extent (2, 1) = r_extent (2)
00188 
00189          call psmile_extent_subgrid_2d_dble ( &
00190                 corner_pointer%corners_dble(2)%vector,       &
00191                 corner_pointer%corner_shape(1,1),   &
00192                 corner_pointer%corner_shape(2,1),   &
00193                 corner_pointer%corner_shape(1,2),   &
00194                 corner_pointer%corner_shape(2,2),   &
00195                 corner_pointer%nbr_corners/nc_reg,  &
00196                 Grids(grid_id)%grid_shape (1,1),    &
00197                 Grids(grid_id)%grid_shape (2,1),    &
00198                 Grids(grid_id)%grid_shape (1,2),    &
00199                 Grids(grid_id)%grid_shape (2,2),    &
00200                 r_extent, ierror)
00201          if (ierror > 0) return
00202 !
00203          extent (1, 2) = r_extent (1)
00204          extent (2, 2) = r_extent (2)
00205 !
00206          call psmile_extent_subgrid_1d_dble (&
00207                 corner_pointer%corners_dble(3)%vector,     &
00208                 corner_pointer%corner_shape(1,3), &
00209                 corner_pointer%corner_shape(2,3), &
00210                 nc_reg,                           &
00211                 Grids(grid_id)%grid_shape (1,3),  &
00212                 Grids(grid_id)%grid_shape (2,3),  &
00213                 r_extent, ierror)
00214          if (ierror > 0) return
00215 !
00216          extent (1, 3) = r_extent (1)
00217          extent (2, 3) = r_extent (2)
00218 !
00219 ! -----------------------------------------------------------------------
00220 !    Irregular in lonlat   and vertical direction
00221 ! -----------------------------------------------------------------------
00222 !
00223       case (PRISM_Irrlonlatvrt)
00224 
00225          call psmile_extent_subgrid_3d_dble ( &
00226                 corner_pointer%corners_dble(1)%vector,       &
00227                 corner_pointer%corner_shape(1,1),   &
00228                 corner_pointer%corner_shape(2,1),   &
00229                 corner_pointer%corner_shape(1,2),   &
00230                 corner_pointer%corner_shape(2,2),   &
00231                 corner_pointer%corner_shape(1,3),   &
00232                 corner_pointer%corner_shape(2,3),   &
00233                 corner_pointer%nbr_corners,         &
00234                 Grids(grid_id)%grid_shape,          &
00235                 r_extent, ierror)
00236          if (ierror > 0) return
00237 !
00238          extent (1, 1) = r_extent (1)
00239          extent (2, 1) = r_extent (2)
00240 
00241          call psmile_extent_subgrid_3d_dble ( &
00242                 corner_pointer%corners_dble(2)%vector,       &
00243                 corner_pointer%corner_shape(1,1),   &
00244                 corner_pointer%corner_shape(2,1),   &
00245                 corner_pointer%corner_shape(1,2),   &
00246                 corner_pointer%corner_shape(2,2),   &
00247                 corner_pointer%corner_shape(1,3),   &
00248                 corner_pointer%corner_shape(2,3),   &
00249                 corner_pointer%nbr_corners,         &
00250                 Grids(grid_id)%grid_shape,          &
00251                 r_extent, ierror)
00252          if (ierror > 0) return
00253 !
00254          extent (1, 2) = r_extent (1)
00255          extent (2, 2) = r_extent (2)
00256 
00257          call psmile_extent_subgrid_3d_dble ( &
00258                 corner_pointer%corners_dble(3)%vector,       &
00259                 corner_pointer%corner_shape(1,1),   &
00260                 corner_pointer%corner_shape(2,1),   &
00261                 corner_pointer%corner_shape(1,2),   &
00262                 corner_pointer%corner_shape(2,2),   &
00263                 corner_pointer%corner_shape(1,3),   &
00264                 corner_pointer%corner_shape(2,3),   &
00265                 corner_pointer%nbr_corners,         &
00266                 Grids(grid_id)%grid_shape,          &
00267                 r_extent, ierror)
00268          if (ierror > 0) return
00269 !
00270          extent (1, 3) = r_extent (1)
00271          extent (2, 3) = r_extent (2)
00272 !
00273 ! -----------------------------------------------------------------------
00274 !     Gauss reduce in horizontal, regular in the vertical
00275 !     ===> Number of corners in all directions = 2
00276 !          (cf. prism_set_corners_3d_double.F90)
00277 ! -----------------------------------------------------------------------
00278 !
00279       case (PRISM_Gaussreduced_regvrt)
00280 
00281          call psmile_extent_subgrid_1d_dble (&
00282                 corner_pointer%corners_dble(1)%vector,     &
00283                 corner_pointer%corner_shape(1,1), &
00284                 corner_pointer%corner_shape(2,1), &
00285                 nc_reg,                           &
00286                 corner_pointer%corner_shape(1,1), &
00287                 corner_pointer%corner_shape(2,1), &
00288                 r_extent, ierror)
00289          if (ierror > 0) return
00290 !
00291          extent (1, 1) = r_extent (1)
00292          extent (2, 1) = r_extent (2)
00293 !
00294          call psmile_extent_subgrid_1d_dble (&
00295              corner_pointer%corners_dble(2)%vector,     &
00296              corner_pointer%corner_shape(1,2), &
00297              corner_pointer%corner_shape(2,2), &
00298              nc_reg,                           &
00299              corner_pointer%corner_shape(1,2), &
00300              corner_pointer%corner_shape(2,2), &
00301              r_extent, ierror)
00302          if (ierror > 0) return
00303 !
00304          extent (1, 2) = r_extent (1)
00305          extent (2, 2) = r_extent (2)
00306 !
00307          call psmile_extent_subgrid_1d_dble (&
00308              corner_pointer%corners_dble(3)%vector,     &
00309              corner_pointer%corner_shape(1,3), &
00310              corner_pointer%corner_shape(2,3), &
00311              nc_reg,                           &
00312              corner_pointer%corner_shape(1,3), &
00313              corner_pointer%corner_shape(2,3), &
00314              r_extent, ierror)
00315          if (ierror > 0) return
00316 !
00317          extent (1, 3) = r_extent (1)
00318          extent (2, 3) = r_extent (2)
00319 !
00320 ! -----------------------------------------------------------------------
00321 !        Error: unsupported grid type
00322 ! -----------------------------------------------------------------------
00323 !
00324       case DEFAULT
00325 !
00326           ierrp (1) = Grids(grid_id)%grid_type
00327 
00328           ierror = PRISM_Error_Internal
00329 
00330           call psmile_error ( ierror, 'unsupported grid generation type', &
00331                               ierrp, 1, __FILE__, __LINE__ )
00332 
00333       end select
00334 !
00335 !===> All done
00336 !
00337 #ifdef VERBOSE
00338       print *, trim(ch_id), ': PSMILe_Get_Grid_Extent_dble eof: grid_id',&
00339                             grid_id, ', ierror =', ierror
00340 
00341       call psmile_flushstd
00342 #endif /* VERBOSE */
00343 !
00344       end subroutine PSMILe_Get_Grid_Extent_dble