psmile_get_epio_handle.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_epio_handle
00008 !
00009 ! !INTERFACE:
00010 
00011       subroutine psmile_get_epio_handle (comp_id, grid_id, method_id,   &
00012                                          mask_id, interpolation,        &
00013                                          msg_intersections, trans_out,  &
00014                                          trans_in, tgt_epio_pe, cpl_id, &
00015                                          epio_id, trs_rank, ierror)
00016 !
00017 ! !USES:
00018 !
00019       use PRISM_constants
00020       use PSMILe, dummy_interface => PSMILe_Get_epio_handle
00021 
00022       implicit none
00023 !
00024 ! !OUTPUT PARAMETERS:
00025 !
00026       Integer, Intent (In)                          :: comp_id
00027 
00028       ! Component Id of source grid component
00029 
00030       Integer, Intent (In)                          :: grid_id
00031 
00032       ! Grid Id of source grid
00033 
00034       Integer, Intent (In)                          :: method_id
00035 
00036       ! Mehtod Id of source grid method
00037 
00038       Integer, Intent (In)                          :: mask_id
00039 
00040       ! Mask Id of source grid mask
00041 
00042       Integer, Intent (In)                          :: interpolation(ndim_3d)
00043 
00044       ! Interpolation types chosen by the user
00045 
00046       Type (enddef_msg_intersections), Intent (In)  :: msg_intersections
00047 
00048       ! Contains target grid information
00049 
00050       Integer, Intent (In)                          :: trans_out
00051 
00052       ! Global Transient Out Id as provided by the driver
00053 
00054       Integer, Intent (In)                          :: trans_in
00055 
00056       ! Global Transient In Id as provided by the driver
00057 
00058       Integer, Intent (In)                          :: tgt_epio_pe
00059 
00060       ! target process which sent it partial domain to the source process
00061 
00062       Integer, Intent (Out)                         :: cpl_id
00063 
00064       ! Handle to the list where the set of Ids is stored
00065 
00066       Integer, Intent (Out)                         :: epio_id
00067 
00068       ! Return reusable epio_id for this particular exchange,
00069       ! otherwise PSMILe_Undef (will get an id from the transformer later)
00070 
00071       Integer, Intent (Out)                         :: trs_rank
00072 
00073       ! Returned reusable transformer rank,
00074       ! otherwise PSMILe_Undef (will get a rank from the transformer later)
00075 
00076 !     Returns the handle to the grid information created.
00077 
00078       Integer, Intent (Out)                         :: ierror
00079 
00080 !     Returns the error code of PSMILe_Get_epio_handle;
00081 !             ierror = 0 : No error
00082 !             ierror > 0 : Severe error
00083 !
00084 !
00085 ! !LOCAL VARIABLES
00086 !
00087       Integer             :: i, i_list, new_dim
00088 
00089       Integer, parameter  :: nerrp = 2
00090       Integer             :: ierrp (nerrp)
00091 
00092       Type (GridConnection), Pointer :: New_cpl_list(:)
00093 !
00094 ! !DESCRIPTION:
00095 !
00096 ! Subroutine "PSMILe_Get_epio_handle" returns a epio handle.
00097 !
00098 !
00099 ! !REVISION HISTORY:
00100 !
00101 !   Date      Programmer    Description
00102 ! ----------  -----------   -----------
00103 ! 09.12.23    R. Redler     created
00104 !
00105 !EOP
00106 !----------------------------------------------------------------------
00107 !
00108 ! $Id: psmile_get_epio_handle.F90 2783 2010-11-29 13:32:36Z hanke $
00109 ! $Author: hanke $
00110 !
00111    Character(len=len_cvs_string), save :: mycvs = 
00112        '$Id: psmile_get_epio_handle.F90 2783 2010-11-29 13:32:36Z hanke $'
00113 !
00114 !----------------------------------------------------------------------
00115 #ifdef VERBOSE
00116       print *, trim(ch_id), ': PSMILe_Get_epio_handle: start'
00117       call psmile_flushstd
00118 #endif /* VERBOSE */
00119 !
00120 !   Initialization
00121 !
00122       ierror = 0
00123       epio_id  = PSMILe_undef
00124       trs_rank = PSMILe_undef
00125 !
00126 !   Initialization on first call
00127 !
00128       if ( Number_of_Cpls_allocated == 0 ) then
00129 
00130          new_dim = 8
00131 
00132          Allocate (cpl_list (new_dim), STAT = ierror)
00133          if (ierror > 0) then
00134             ierrp (1) = ierror
00135             ierrp (2) = new_dim
00136             ierror = PRISM_Error_Alloc
00137 
00138             call psmile_error ( ierror, 'cpl_list', &
00139                  ierrp, 2, __FILE__, __LINE__ )
00140             return
00141          endif
00142 
00143          cpl_list(1:new_dim)%status = PSMILe_status_free
00144 
00145          Number_of_Cpls_allocated = new_dim
00146 
00147       endif
00148 
00149       !
00150       !   Search for a free epio index
00151       !
00152       do i = 1, Number_of_Cpls_allocated
00153          if (cpl_list(i)%status == PSMILe_status_free) exit
00154       end do
00155 
00156       i_list = i-1
00157 
00158       do i = 1, i_list
00159 #ifdef VERBOSE
00160          print *, ' t comp      ', cpl_list(i)%tgt_comp_id   , msg_intersections%tgt_comp_id
00161          print *, ' t grid      ', cpl_list(i)%tgt_grid_id   , msg_intersections%tgt_grid_id
00162          print *, ' t meth      ', cpl_list(i)%tgt_method_id , msg_intersections%first_tgt_method_id
00163          print *, ' t mask      ', cpl_list(i)%tgt_mask_id   , msg_intersections%tgt_mask_id
00164          print *, ' s comp      ', cpl_list(i)%src_comp_id   , comp_id
00165          print *, ' s grid      ', cpl_list(i)%src_grid_id   , grid_id
00166          print *, ' s meth      ', cpl_list(i)%src_method_id , method_id
00167          print *, ' s mask      ', cpl_list(i)%src_mask_id   , mask_id
00168          print *, ' interp      ', cpl_list(i)%interpolation
00169          print *, ' -           ', interpolation
00170          print *, ' tgt_epio_pe ', cpl_list(i)%tgt_epio_pe, tgt_epio_pe
00171 #endif
00172          if ( cpl_list(i)%tgt_comp_id   == msg_intersections%tgt_comp_id          .and. &
00173               cpl_list(i)%tgt_grid_id   == msg_intersections%tgt_grid_id          .and. &
00174               cpl_list(i)%tgt_method_id == msg_intersections%first_tgt_method_id  .and. &
00175               cpl_list(i)%tgt_mask_id   == msg_intersections%tgt_mask_id          .and. &
00176               cpl_list(i)%src_comp_id   == comp_id                                .and. &
00177               cpl_list(i)%src_grid_id   == grid_id                                .and. &
00178               cpl_list(i)%src_method_id == method_id                              .and. &
00179               cpl_list(i)%src_mask_id   == mask_id                                .and. &
00180               cpl_list(i)%trans_out     /= trans_out                              .and. &
00181               cpl_list(i)%trans_in      /= trans_in                               .and. &
00182               cpl_list(i)%interpolation(1) == interpolation(1)                    .and. &
00183               cpl_list(i)%interpolation(2) == interpolation(2)                    .and. &
00184               cpl_list(i)%interpolation(3) == interpolation(3)                    .and. &
00185               cpl_list(i)%tgt_epio_pe      == tgt_epio_pe) then
00186 #if 1
00187             epio_id  = cpl_list(i)%epio_id
00188             trs_rank = cpl_list(i)%trs_rank
00189 #endif
00190             cpl_id   = i
00191 
00192             exit
00193          endif
00194 
00195       enddo
00196 
00197       if ( i_list == Number_of_Cpls_allocated .and. epio_id == PSMILe_undef ) then
00198 
00199          !
00200          !   Allocate new cpl_list vector, initialize and copy old vector
00201          !
00202 
00203          new_dim = Number_of_Cpls_allocated + 8
00204 
00205          Allocate (New_cpl_list (new_dim), STAT = ierror)
00206          if (ierror > 0) then
00207             ierrp (1) = ierror
00208             ierrp (2) = new_dim
00209             ierror = PRISM_Error_Alloc
00210 
00211             call psmile_error ( ierror, 'New_cpl_list', &
00212                  ierrp, 2, __FILE__, __LINE__ )
00213             return
00214          endif
00215          
00216          New_cpl_list (1:Number_of_Cpls_allocated) = &
00217              cpl_list (1:Number_of_Cpls_allocated)
00218 
00219          New_cpl_list (Number_of_Cpls_allocated+1:new_dim)%status = &
00220               PSMILe_status_free
00221          !
00222          !   De-allocate Grids vector
00223          !
00224          Deallocate (cpl_list, STAT = ierror)
00225          if (ierror > 0) then
00226             ierrp (1) = ierror
00227             ierror = PRISM_Error_Dealloc
00228 
00229             call psmile_error ( ierror, 'cpl_list', &
00230                  ierrp, 1, __FILE__, __LINE__ )
00231             return
00232          endif
00233 
00234          !
00235          !   Update Number of Grids
00236          !
00237          cpl_list => New_cpl_list
00238          !
00239          cpl_id = Number_of_Cpls_allocated + 1
00240          Number_of_Cpls_allocated = new_dim
00241 
00242       endif
00243 
00244       if ( epio_id == PSMILe_undef ) then
00245 
00246          cpl_id = i_list + 1
00247 
00248          cpl_list(cpl_id)%status        = PSMILe_status_defined
00249 
00250          cpl_list(cpl_id)%tgt_comp_id   = msg_intersections%tgt_comp_id
00251          cpl_list(cpl_id)%tgt_grid_id   = msg_intersections%tgt_grid_id
00252          cpl_list(cpl_id)%tgt_method_id = msg_intersections%first_tgt_method_id
00253          cpl_list(cpl_id)%tgt_mask_id   = msg_intersections%tgt_mask_id
00254 
00255          cpl_list(cpl_id)%src_comp_id   = comp_id
00256          cpl_list(cpl_id)%src_grid_id   = grid_id
00257          cpl_list(cpl_id)%src_method_id = method_id
00258          cpl_list(cpl_id)%src_mask_id   = mask_id
00259 
00260          cpl_list(i)%trans_out          = trans_out
00261          cpl_list(i)%trans_in           = trans_in
00262 
00263          cpl_list(i)%interpolation      = interpolation
00264 
00265          cpl_list(cpl_id)%tgt_epio_pe   = tgt_epio_pe
00266 
00267          cpl_list(cpl_id)%epio_id       = PSMILe_undef
00268          cpl_list(cpl_id)%trs_rank      = PSMILe_undef
00269 
00270          epio_id  = PSMILe_undef
00271          trs_rank = PSMILe_undef
00272 
00273       endif
00274 
00275 #ifdef VERBOSE
00276       print *, trim(ch_id), ': PSMILe_Get_epio_handle: eof handle, ierror =', &
00277                ierror
00278       print *, trim(ch_id), ':      - cpl_id   ', cpl_id
00279       print *, trim(ch_id), ':      - epio_id  ', epio_id
00280       print *, trim(ch_id), ':      - trs_rank ', trs_rank
00281       call psmile_flushstd
00282 #endif /* VERBOSE */
00283 
00284       end subroutine PSMILe_Get_epio_handle