prismtrs_mind_dble.F90

Go to the documentation of this file.
00001 !------------------------------------------------------------------------
00002 ! Copyright 2006-2010, CERFACS, Toulouse, France.
00003 ! All rights reserved. Use is subject to OASIS4 license terms.
00004 !-----------------------------------------------------------------------
00005 !BOP
00006 !
00007 ! !ROUTINE: PRISMTrs_Mind_dble
00008 !
00009 ! !INTERFACE
00010 subroutine prismtrs_mind_dble(id_process_global_rank,  &
00011                               id_transient_out_id,     &
00012                               id_epio_id,              &
00013                               il_trans_out_size,       &
00014                               nbr_fields,              &
00015                               id_err)
00016 
00017 !
00018 ! !USES:
00019 !
00020   USE PRISMDrv, dummy_interface => PRISMTrs_Mind_dble
00021 
00022   IMPLICIT NONE
00023 
00024 !
00025 ! !PARAMETERS:
00026 !
00027 ! rank of the psmile source process sending the info
00028   INTEGER, INTENT (In)        :: id_process_global_rank
00029 
00030 ! id of the transient_out
00031   INTEGER, INTENT (In)        :: id_transient_out_id
00032 
00033 ! Epio index
00034   INTEGER, INTENT (IN)        :: id_epio_id
00035 
00036 ! size of the transient_out
00037   INTEGER, INTENT (IN)        :: il_trans_out_size
00038 
00039 ! nbr of bundle components
00040   INTEGER, INTENT (In)        :: nbr_fields
00041 !
00042 ! ! RETURN VALUE
00043 !
00044   INTEGER, INTENT (Out)       :: id_err 
00045 
00046 ! !DESCRIPTION
00047 ! Subroutine "PRISMTrs_Mind_dble" manages all the transformations connected to
00048 ! a transient_out sent by a model.
00049 !
00050 ! !REVISED HISTORY
00051 !   Date      Programmer   Description
00052 ! ----------  ----------   -----------
00053 ! 21/01/2003  D. Declat    Creation
00054 ! 01/12/2003  D. Declat    Adapted to type real, dble
00055 ! 06/03/2008  J. Charles   Modifications added for the use of bundle fields
00056 !
00057 ! EOP
00058 !----------------------------------------------------------------------
00059 ! $Id: prismtrs_mind_dble.F90 2685 2010-10-28 14:05:10Z coquart $
00060 ! $Author: coquart $
00061 !----------------------------------------------------------------------
00062 !
00063 ! Local declarations
00064 !
00065   CHARACTER(LEN=len_cvs_string), SAVE  :: mycvs = 
00066      '$Id: prismtrs_mind_dble.F90 2685 2010-10-28 14:05:10Z coquart $'
00067 
00068   DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: dla_trans_out
00069 
00070   DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: dla_trans_in
00071   REAL, DIMENSION(:), ALLOCATABLE :: rla_trans_in
00072   INTEGER, DIMENSION(:), ALLOCATABLE :: ila_trans_in
00073 
00074   DOUBLE COMPLEX :: trans_out_global_sum(nbr_fields)
00075   LOGICAL        :: conservation
00076 
00077   INTEGER :: il_status(MPI_STATUS_SIZE)
00078   INTEGER :: il_trans_in_size
00079   INTEGER :: il_trans_in_status
00080 
00081   INTEGER :: ib
00082   INTEGER :: il_exchange_id
00083 
00084 !     ... for error handling
00085   LOGICAL             :: ll_found
00086   INTEGER, PARAMETER  :: nerrp = 2
00087   INTEGER             :: ierrp (nerrp)
00088 !
00089 ! ---------------------------------------------------------------------
00090 !
00091 #ifdef VERBOSE
00092   PRINT *, '| | | Enter PRISMTrs_Mind_dble'
00093   call psmile_flushstd
00094 #endif
00095 
00096 !
00097 ! 1. Get the exchange id
00098 !
00099   ll_found = .false.
00100   DO ib = 1, Number_of_Exchanges
00101     IF (Drv_Exchanges(ib)%trans_out_id .eq. id_transient_out_id) THEN
00102         IF (Drv_Exchanges(ib)%epio_id .eq. id_epio_id) THEN
00103             il_exchange_id = ib
00104             ll_found = .true.
00105             EXIT
00106         END IF
00107     END IF
00108   END DO
00109 
00110   IF (.NOT. ll_found) THEN
00111       ierrp(1) = Number_of_Exchanges
00112       ierrp(2) = ib
00113       call psmile_error_common ( id_err, 'PRISMTrs_Mind_dble', &
00114          ierrp, 2, __FILE__, __LINE__ )
00115   END IF
00116 
00117   conservation = Drv_Exchanges(il_exchange_id)%conservation &
00118                  .ne. PSMILe_undef
00119 
00120 !
00121 ! 2. Get the transient out informations and receive the transient_out
00122 !
00123 
00124 #ifdef VERBOSE
00125   PRINT *, '| | | | Before Reception of transient_out', id_transient_out_id,  &
00126      ' size ', il_trans_out_size
00127   call psmile_flushstd
00128 #endif
00129 
00130   ALLOCATE(dla_trans_out(il_trans_out_size), stat = id_err)
00131   IF ( id_err > 0 ) THEN
00132       ierrp (1) = id_err
00133       ierrp (2) = il_trans_out_size
00134 
00135       call psmile_error_common ( PRISM_Error_Alloc, 'dla_trans_out', &
00136          ierrp, 2, __FILE__, __LINE__ )
00137   ENDIF
00138 
00139   CALL MPI_Recv (dla_trans_out, il_trans_out_size, MPI_Double_Precision, &
00140      id_process_global_rank, 10, comm_drv_trans, &
00141      il_status, id_err)
00142 
00143 #ifdef VERBOSE
00144   PRINT *, '| | | | After Reception of transient_out ', id_transient_out_id, &
00145      ' defined on epio ', id_epio_id
00146   call psmile_flushstd
00147 #endif
00148 
00149    IF (conservation) THEN
00150 #ifdef VERBOSE
00151       PRINT *, '| | | | Before Reception of trans_out_global_sum conservation: ',&
00152                            Drv_Exchanges(il_exchange_id)%conservation
00153       CALL psmile_flushstd
00154 #endif
00155       ! receive global sum from source component
00156       CALL MPI_Recv (trans_out_global_sum, nbr_fields, MPI_DOUBLE_COMPLEX, &
00157          id_process_global_rank, CONSERVTAG, comm_drv_trans, &
00158          il_status, id_err)
00159 #ifdef VERBOSE
00160       PRINT *, '| | | | After Reception of trans_out_global_sum ', trans_out_global_sum
00161       CALL psmile_flushstd
00162 #endif
00163    ENDIF
00164 
00165 !
00166 ! 3. Call the interpolation routine
00167 !
00168   il_trans_in_size = Drv_Exchanges(il_exchange_id)%trans_in_field_size*nbr_fields
00169   ALLOCATE(dla_trans_in(il_trans_in_size), stat = id_err)
00170   IF ( id_err > 0 ) THEN
00171       ierrp (1) = id_err
00172       ierrp (2) = il_trans_in_size
00173 
00174       call psmile_error_common ( PRISM_Error_Alloc, 'dla_trans_in', &
00175          ierrp, 2, __FILE__, __LINE__ )
00176   ENDIF
00177 
00178   call prismtrs_interp(il_exchange_id,    &
00179                        id_epio_id,        &
00180                        il_trans_out_size, &
00181                        dla_trans_out,     &
00182                        il_trans_in_size,  &
00183                        dla_trans_in,      &
00184                        nbr_fields,        &
00185                        id_err)
00186 
00187 !
00188 ! 4. Manage the trans_in_field
00189 !
00190 ! 4.1. Get the trans_in_field_size
00191   il_trans_in_status = Drv_Exchanges(il_exchange_id)%trans_in_status
00192 
00193 ! 4.2. If the trans_in_field has already been requested by a target model 
00194 !      process. Send it to this process
00195   IF (Drv_Exchanges(il_exchange_id)%trans_in_status .LT. 0) THEN
00196 
00197 ! 4.2.1. Increase the status
00198       Drv_Exchanges(il_exchange_id)%trans_in_status = &
00199          Drv_Exchanges(il_exchange_id)%trans_in_status + 1
00200       il_trans_in_status = Drv_Exchanges(il_exchange_id)%trans_in_status
00201 
00202 #ifdef VERBOSE
00203           PRINT *, '| | | | | Sending of the transient_in_id ',        &
00204              Drv_Exchanges(il_exchange_id)%trans_in_id, 'to process ', &
00205              Drv_Exchanges(il_exchange_id)%trans_in_request, 'size ', &
00206              il_trans_in_size
00207           call psmile_flushstd
00208 #endif
00209 
00210       IF (Drv_Exchanges(il_exchange_id)%trans_in_field_type .EQ. &
00211          PRISM_Double_Precision) THEN
00212 
00213 ! 4.4. send the trans_in_field to the target model
00214           CALL MPI_Send(dla_trans_in(1), il_trans_in_size, &
00215              MPI_Double_Precision, &
00216              Drv_Exchanges(il_exchange_id)%trans_in_request, 0177,     &
00217              comm_drv_trans, id_err)
00218 
00219       ELSE IF (Drv_Exchanges(il_exchange_id)%trans_in_field_type .EQ. &
00220          PRISM_Real) THEN
00221           
00222 ! 4.3. Get the trans_in_field from the fields structure
00223           ALLOCATE(rla_trans_in(il_trans_in_size), stat = id_err)
00224           IF ( id_err > 0 ) THEN
00225               ierrp (1) = id_err
00226               ierrp (2) = il_trans_in_size
00227 
00228               call psmile_error_common ( PRISM_Error_Alloc, 'rla_trans_in', &
00229                  ierrp, 2, __FILE__, __LINE__ )
00230           ENDIF
00231           rla_trans_in = REAL(dla_trans_in)
00232 
00233 ! 4.4. send the trans_in_field to the target model
00234           CALL MPI_Send(rla_trans_in(1), il_trans_in_size, &
00235              MPI_Real, &
00236              Drv_Exchanges(il_exchange_id)%trans_in_request, 0177,     &
00237              comm_drv_trans, id_err)
00238 
00239 ! 4.5. Deallocation of the local array
00240           DEALLOCATE(rla_trans_in, stat = id_err)
00241           IF (id_err > 0) THEN
00242               ierrp (1) = id_err
00243 
00244               call psmile_error_common( PRISM_Error_Dealloc, 'rla_trans_in',&
00245                  ierrp, 1, __FILE__, __LINE__ )
00246           ENDIF
00247 
00248       ELSE IF (Drv_Exchanges(il_exchange_id)%trans_in_field_type .eq. &
00249          PRISM_Integer) THEN
00250 
00251 ! 4.3. Get the trans_in_field from the fields structure
00252           ALLOCATE(ila_trans_in(il_trans_in_size), stat = id_err)
00253           IF ( id_err > 0 ) THEN
00254               ierrp (1) = id_err
00255               ierrp (2) = il_trans_in_size
00256 
00257               call psmile_error_common ( PRISM_Error_Alloc, 'ila_trans_in', &
00258                  ierrp, 2, __FILE__, __LINE__ )
00259           ENDIF
00260           ila_trans_in = INT(dla_trans_in)
00261 
00262 ! 4.4. send the trans_in_field to the target model
00263           CALL MPI_Send(ila_trans_in(1), il_trans_in_size, &
00264              MPI_Integer, &
00265              Drv_Exchanges(il_exchange_id)%trans_in_request, 0177,     &
00266              comm_drv_trans, id_err)
00267 
00268 ! 4.5. Deallocation of the local array
00269           DEALLOCATE(ila_trans_in, stat = id_err)
00270           IF (id_err > 0) THEN
00271               ierrp (1) = id_err
00272       
00273               call psmile_error_common(PRISM_Error_Dealloc,'ila_trans_in',&
00274                      ierrp, 1, __FILE__, __LINE__ )
00275           ENDIF
00276 
00277       ENDIF
00278 
00279       IF (conservation) THEN
00280          ! send the global, which is needed for global conservation
00281          SELECT CASE (Drv_Exchanges(il_exchange_id)%trans_in_field_type)
00282             CASE(PRISM_Double_Precision, PRISM_Real)
00283                CALL MPI_Send(trans_out_global_sum, nbr_fields, &
00284                   MPI_Double_Complex, &
00285                   Drv_Exchanges(il_exchange_id)%trans_in_request, CONSERVTAG, &
00286                   comm_drv_trans, id_err)
00287             CASE(PRISM_Integer)
00288                CALL MPI_Send(Int(trans_out_global_sum), nbr_fields, &
00289                   MPI_Integer, &
00290                   Drv_Exchanges(il_exchange_id)%trans_in_request, CONSERVTAG, &
00291                   comm_drv_trans, id_err)
00292          END SELECT
00293       ENDIF
00294 
00295 ! The field has not yet been requested
00296   ELSE
00297 
00298 #ifdef VERBOSE
00299    PRINT *, &
00300       '| | | The transient_out ',                    &
00301              id_transient_out_id,               &
00302       ' is not requested : stored '
00303 #endif
00304 ! 5 Store the field for later use
00305 ! 5.1. Increase the status
00306       Drv_Exchanges(il_exchange_id)%trans_in_status = &
00307          Drv_Exchanges(il_exchange_id)%trans_in_status + 1
00308 ! 5.2. Store field in field array
00309       SELECT CASE (Drv_Exchanges(il_exchange_id)%trans_in_field_type)
00310          CASE (PRISM_Double_Precision)
00311             CALL prismtrs_enqueue_in_field_dble(dla_trans_in,&
00312                      il_trans_in_size, il_exchange_id, id_err)
00313          CASE (PRISM_Real)
00314             CALL prismtrs_enqueue_in_field_real(Real(dla_trans_in),
00315                      il_trans_in_size, il_exchange_id, id_err)
00316          CASE (PRISM_Integer)
00317             CALL prismtrs_enqueue_in_field_int(Int(dla_trans_in),&
00318                      il_trans_in_size, il_exchange_id, id_err)
00319       END SELECT
00320 ! 5.3. Store global sum
00321       IF (conservation) THEN
00322          SELECT CASE (Drv_Exchanges(il_exchange_id)%trans_in_field_type)
00323             CASE (PRISM_Double_Precision)
00324                CALL prismtrs_enqueue_glob_sum_dble(   &
00325                               trans_out_global_sum,&
00326                               nbr_fields, il_exchange_id, id_err)
00327             CASE (PRISM_Real)
00328                CALL prismtrs_enqueue_glob_sum_dble(   &
00329                               trans_out_global_sum,&
00330                               nbr_fields, il_exchange_id, id_err)
00331             CASE (PRISM_Integer)
00332                CALL prismtrs_enqueue_glob_sum_int(   &
00333                               Int(trans_out_global_sum),&
00334                               nbr_fields, il_exchange_id, id_err)
00335          END SELECT
00336       ENDIF
00337   END IF
00338 
00339 !
00340 ! 6. Deallocation
00341 !
00342   DEALLOCATE(dla_trans_in, stat = id_err)
00343   IF (id_err > 0) THEN
00344         ierrp (1) = id_err
00345 
00346          call psmile_error_common ( PRISM_Error_Dealloc, 'dla_trans_in', &
00347            ierrp, 1, __FILE__, __LINE__ )
00348   ENDIF
00349 
00350   DEALLOCATE(dla_trans_out, stat = id_err)
00351   IF (id_err > 0) THEN
00352       ierrp (1) = id_err
00353       call psmile_error_common ( PRISM_Error_Dealloc, 'dla_trans_out', &
00354          ierrp, 1, __FILE__, __LINE__ )
00355   ENDIF
00356   
00357 !
00358 #ifdef VERBOSE
00359   PRINT *, '| | | Quit PRISMTrs_Mind_dble'
00360   call psmile_flushstd
00361 #endif
00362 
00363 END SUBROUTINE PRISMTrs_Mind_dble