psmile_mg_get_cyclic_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_MG_get_cyclic_dble
00008 !
00009 ! !INTERFACE:
00010 
00011       subroutine psmile_mg_get_cyclic_dble ( grid_id, range, rtol, ierror)
00012 !
00013 ! !USES:
00014 !
00015       use PRISM_constants
00016       use psmile_grid, only : common_grid_range
00017       use PSMILe, dummy_interface => PSMILe_MG_get_cyclic_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       Integer, Intent (In)                :: range (2, ndim_3d)
00028 !
00029 !     Range for which MG sequence should be setup
00030 ! 
00031       Double Precision, Intent (In)       :: rtol
00032 !
00033 !     Search tolerance
00034 !
00035 ! !OUTPUT PARAMETERS:
00036 !
00037       integer, Intent (Out)               :: ierror
00038 !
00039 !     Returns the error code of PSMILe_MG_get_cyclic_dble;
00040 !             ierror = 0 : No error
00041 !             ierror > 0 : Severe error
00042 !
00043 ! !LOCAL VARIABLES
00044 !
00045 !     ... corners
00046 !
00047       Integer                             :: i
00048       Type (Corner_Block), Pointer        :: corner_pointer
00049 !
00050 !     ... multigrid parameters
00051 !
00052       Integer                             :: nlev
00053 !
00054 !     ... for possibe cyclic directions
00055 !
00056       Integer                             :: periodic
00057       Logical                             :: control (ndim_2d)
00058       Double Precision                    :: len_cyclic (ndim_2d)
00059 !
00060 !     ... for error parameters
00061 !
00062       Integer, parameter                  :: nerrp = 3
00063       Integer                             :: ierrp (nerrp)
00064 !
00065 ! !DESCRIPTION:
00066 !
00067 ! Subroutine "PSMILe_MG_get_cyclic_dble" determines whether the
00068 ! directions of the block/grid are cyclic.
00069 !
00070 ! !REVISION HISTORY:
00071 !
00072 !   Date      Programmer   Description
00073 ! ----------  ----------   -----------
00074 ! 03.06.25    H. Ritzdorf  created
00075 !
00076 !EOP
00077 !----------------------------------------------------------------------
00078 !
00079 !  $Id: psmile_mg_get_cyclic_dble.F90 2687 2010-10-28 15:15:52Z coquart $
00080 !  $Autor: $
00081 !
00082    Character(len=len_cvs_string), save :: mycvs = 
00083        '$Id: psmile_mg_get_cyclic_dble.F90 2687 2010-10-28 15:15:52Z coquart $'
00084 !
00085 !----------------------------------------------------------------------
00086 
00087 #ifdef VERBOSE
00088       print 9990, trim(ch_id), grid_id
00089 
00090       call psmile_flushstd
00091 #endif /* VERBOSE */
00092 !
00093 !  Initialization
00094 !
00095       corner_pointer => Grids(grid_id)%corner_pointer
00096 !
00097       nlev = Grids(grid_id)%nlev
00098 !
00099 #ifdef PRISM_ASSERTION
00100       if (corner_pointer%corner_datatype /= MPI_DOUBLE_PRECISION) then
00101          call psmile_assert ( __FILE__, __LINE__, &
00102                              'Corner type is not MPI_DOUBLE_PRECISION')
00103       endif
00104 
00105       if (Grids(grid_id)%mg_infos(nlev)%levdim(1) /= 0 .or. &
00106           Grids(grid_id)%mg_infos(nlev)%levdim(2) /= 0 .or. &
00107           Grids(grid_id)%mg_infos(nlev)%levdim(3) /= 0) then
00108 
00109          call psmile_assert (__FILE__, __LINE__, &
00110                              "coarsest level dim != 0")
00111       endif
00112 #endif /* PRISM_ASSERTION */
00113 !
00114 !===> Is there a possibility of a cyclic index ?
00115 !     lon lat range for cyclic indices is 360 or 180 degrees, respectively.
00116 !
00117 ! Note: On this level, chmin%vector and chmax%vector are vectors from
00118 !       (1:levdim+1) instead of (0:levdim).
00119 !
00120       len_cyclic (1:ndim_2d) = common_grid_range(2,1:ndim_2d) - &
00121                                common_grid_range(1,1:ndim_2d)
00122 !
00123       do i = 1, ndim_2d
00124 
00125          control (i) = (Grids(grid_id)%mg_infos(nlev)%double_arrays%chmax(i)%vector(1) - &
00126                         Grids(grid_id)%mg_infos(nlev)%double_arrays%chmin(i)%vector(1))  &
00127                        >= len_cyclic (i)
00128          Grids(grid_id)%cyclic(i) = control (i)
00129 
00130          if ( Grids(grid_id)%grid_type == PRISM_Gaussreduced_regvrt) then
00131               periodic = Grids(grid_id)%periodic(1)
00132          else
00133               periodic = Grids(grid_id)%periodic(i)
00134          endif             
00135 
00136          if ( Grids(grid_id)%cyclic(i) .and. periodic /= PSMILE_True ) then
00137             Grids(grid_id)%cyclic(i) = .false.
00138 
00139 !           ierror = PRISM_Warn_Grid_Periodic
00140             ierrp (1) = grid_id
00141             ierrp (2) = Grids(grid_id)%comp_id
00142             ierrp (3) = periodic
00143 
00144             call psmile_warning ( PRISM_Warn_Grid_Periodic, &
00145                 'detected periodic grid w/o appropriate SMIOC entry', &
00146                 ierrp, 3, __FILE__, __LINE__ )
00147          endif
00148 
00149       end do
00150 !
00151 !===>
00152 !
00153       if (Grids(grid_id)%grid_type == PRISM_Reglonlatvrt .or. &
00154           Grids(grid_id)%grid_type == PRISM_Reglonlat_sigmavrt .or. &
00155           Grids(grid_id)%grid_type == PRISM_Gaussreduced_regvrt) then
00156 
00157 #ifdef TODO
00158          do i = 1, ndim_2d
00159          if (control (i)) then
00160          call psmile_get_cyclic_dir_1d_dble (                               &
00161             corner_pointer%corners_dble(i)%vector,                          &
00162             corner_pointer%corner_shape, 2,                                 &
00163             Grids(grid_id)%grid_shape, i, Grids(grid_id)%cyclic(i), ierror)
00164          endif
00165          end do
00166 #endif
00167 
00168       else if ( Grids(grid_id)%grid_type == PRISM_Irrlonlat_regvrt .or.     &
00169                 Grids(grid_id)%grid_type == PRISM_Irrlonlat_sigmavrt) then
00170 
00171 #ifdef TODO
00172          do i = 1, ndim_2d
00173          if (control (i)) then
00174             call psmile_get_cyclic_dir_2d_dble (                               &
00175                corner_pointer%corners_dble(1)%vector,                          &
00176                corner_pointer%corners_dble(2)%vector,                          &
00177                corner_pointer%corners_dble(3)%vector,                          &
00178                corner_pointer%corner_shape, corner_pointer%nbr_corners/2,      &
00179                Grids(grid_id)%grid_shape,                                      &
00180                len_cyclic(i), i, Grids(grid_id)%cyclic(i), ierror)
00181          endif
00182          end do
00183 #endif
00184 
00185       else if ( Grids(grid_id)%grid_type == PRISM_Irrlonlatvrt) then
00186 
00187 !
00188 !===> ... Control for cyclic (logical) indices
00189 !         i = 1 : Control longitudes
00190 !         i = 2 : Control latitudes
00191 !
00192          if ( control (1) ) then
00193 !
00194 ! Braucht man hier einen Loop do i = 1, ndim_3d
00195 ! oder gilt fuer longitude das immer ?
00196 !
00197             i = 1
00198 !
00199             call psmile_get_cyclic_dir_3d_dble (                               &
00200                Grids(grid_id)%mg_infos(1)%double_arrays%chmin(1)%vector,       &
00201                Grids(grid_id)%mg_infos(1)%double_arrays%chmin(2)%vector,       &
00202                Grids(grid_id)%mg_infos(1)%double_arrays%chmin(3)%vector,       &
00203                Grids(grid_id)%mg_infos(1)%double_arrays%chmax(1)%vector,       &
00204                Grids(grid_id)%mg_infos(1)%double_arrays%chmax(2)%vector,       &
00205                Grids(grid_id)%mg_infos(1)%double_arrays%chmax(3)%vector,       &
00206                Grids(grid_id)%mg_infos(1)%levdim,                              &
00207                corner_pointer%corners_dble(1)%vector,                          &
00208                corner_pointer%corners_dble(2)%vector,                          &
00209                corner_pointer%corners_dble(3)%vector,                          &
00210                corner_pointer%corner_shape, corner_pointer%nbr_corners,        &
00211                Grids(grid_id)%grid_shape,                                      &
00212                len_cyclic(1), rtol, i, Grids(grid_id)%cyclic(i), ierror)
00213 
00214             if (ierror > 0) return
00215 !           if (Grids(grid_id)%cyclic(i)) exit
00216 
00217          endif
00218 
00219          if ( control (2) ) then
00220             
00221 ! Braucht man hier einen Loop do i = 1, ndim_3d
00222 ! oder gilt fuer longitude das immer ?
00223 !
00224             i = 2
00225 !
00226             call psmile_get_cyclic_dir_3d_dble (                               &
00227                Grids(grid_id)%mg_infos(1)%double_arrays%chmin(2)%vector,       &
00228                Grids(grid_id)%mg_infos(1)%double_arrays%chmin(1)%vector,       &
00229                Grids(grid_id)%mg_infos(1)%double_arrays%chmin(3)%vector,       &
00230                Grids(grid_id)%mg_infos(1)%double_arrays%chmax(2)%vector,       &
00231                Grids(grid_id)%mg_infos(1)%double_arrays%chmax(1)%vector,       &
00232                Grids(grid_id)%mg_infos(1)%double_arrays%chmax(3)%vector,       &
00233                Grids(grid_id)%mg_infos(1)%levdim,                              &
00234                corner_pointer%corners_dble(2)%vector,                          &
00235                corner_pointer%corners_dble(1)%vector,                          &
00236                corner_pointer%corners_dble(3)%vector,                          &
00237                corner_pointer%corner_shape, corner_pointer%nbr_corners,        &
00238                Grids(grid_id)%grid_shape,                                      &
00239                len_cyclic(2), rtol, i, Grids(grid_id)%cyclic(i), ierror)
00240 
00241             if (ierror > 0) return
00242 !           if (Grids(grid_id)%cyclic(i)) exit
00243 
00244          endif
00245          
00246       else
00247 
00248          ierror = PRISM_Error_Grid
00249 
00250          ierrp (1) = grid_id
00251          ierrp (2) = Grids(grid_id)%comp_id
00252          ierrp (3) = Grids(grid_id)%grid_type
00253 
00254          call psmile_error ( ierror, 'unsupported grid generation type', &
00255                              ierrp, 3, __FILE__, __LINE__ )
00256          return
00257 
00258       endif
00259 !
00260 !===> All done
00261 !
00262 #ifdef VERBOSE
00263       print 9980, trim(ch_id), ierror
00264 
00265       call psmile_flushstd
00266 #endif /* VERBOSE */
00267 
00268 !
00269 !  Formats:
00270 !
00271 
00272 #ifdef VERBOSE
00273 
00274 9990 format (1x, a, ': psmile_mg_get_cyclic_dble: grid_id', i3)
00275 9980 format (1x, a, ': psmile_mg_get_cyclic_dble: eof ierror =', i3)
00276 
00277 #endif /* VERBOSE */
00278 
00279       end subroutine PSMILe_MG_get_cyclic_dble