New URL for NEMO forge!   http://forge.nemo-ocean.eu

Since March 2022 along with NEMO 4.2 release, the code development moved to a self-hosted GitLab.
This present forge is now archived and remained online for history.
Changeset 2528 for trunk/NEMOGCM/NEMO/OPA_SRC/SBC/cpl_oasis4.F90 – NEMO

Ignore:
Timestamp:
2010-12-27T18:33:53+01:00 (13 years ago)
Author:
rblod
Message:

Update NEMOGCM from branch nemo_v3_3_beta

File:
1 edited

Legend:

Unmodified
Added
Removed

  • trunk/NEMOGCM/NEMO/OPA_SRC/SBC/cpl_oasis4.F90

    • Property svn:eol-style deleted
    r1715 r2528  
    11MODULE cpl_oasis4 
    22   !!====================================================================== 
    3    !!                    ***  MODULE cpl_oasis4  *** 
     3   !!                    ***  MODULE cpl_oasis  *** 
    44   !! Coupled O/A : coupled ocean-atmosphere case using OASIS4 
    5    !!               special case: OPA/LIM coupled to ECHAM5 
    65   !!===================================================================== 
    76   !! History :    
    … …  
    1110   !!   " "  !  05-08  (R. Redler, W. Park) frld initialization, paral(2) revision 
    1211   !!   " "  !  05-09  (R. Redler) extended to allow for communication over root only 
    13    !!   " "  !  05-09  (R. Redler) extended to allow for communication over root only 
    14    !!   " "  !  05-12  (R. Hill, Met. Office) Tweaks and hacks to get NEMO/O4 working 
    15    !!   " "  !  06-02  (R. Redler, W. Park) Bug fixes and updates according to the OASIS3 interface 
    16    !!   " "  !  06-02  (R. Redler) app/grid/grid_name from namelist 
     12   !!   " "  !  06-01  (W. Park) modification of physical part 
     13   !!   " "  !  06-02  (R. Redler, W. Park) buffer array fix for root exchange 
     14   !!   " "  !  2010   (E. Maisonnave and S. Masson) complete rewrite 
    1715   !!---------------------------------------------------------------------- 
    1816#if defined key_oasis4 
    1917   !!---------------------------------------------------------------------- 
    2018   !!   'key_oasis4'                    coupled Ocean/Atmosphere via OASIS4 
     19   !!---------------------------------------------------------------------- 
    2120   !!---------------------------------------------------------------------- 
    2221   !!   cpl_prism_init     : initialization of coupled mode communication 
    2322   !!   cpl_prism_define   : definition of grid and fields 
    24    !!   cpl_prism_send     : send out fields in coupled mode 
    25    !!   cpl_prism_recv     : receive fields in coupled mode 
     23   !!   cpl_prism_snd     : snd out fields in coupled mode 
     24   !!   cpl_prism_rcv     : receive fields in coupled mode 
     25   !!   cpl_prism_update_time   : update date sent to Oasis 
    2626   !!   cpl_prism_finalize : finalize the coupled mode communication 
    2727   !!---------------------------------------------------------------------- 
    28    !! * Modules used 
    29 !##################### WARNING coupled mode ############################### 
    30 !##################### WARNING coupled mode ############################### 
    31 !   Following line must be enabled if coupling with OASIS 
    32 !   USE prism                        ! prism module 
    33 !##################### WARNING coupled mode ############################### 
    34 !##################### WARNING coupled mode ############################### 
    35 #if defined key_mpp_mpi 
    36    USE lib_mpp, only : mppsize, mpprank   ! message passing 
    37    USE lib_mpp, only : mppsend            ! message passing 
    38    USE lib_mpp, only : mpprecv            ! message passing 
    39 #endif 
     28   USE prism              ! OASIS4 prism module 
     29   USE par_oce                      ! ocean parameters 
    4030   USE dom_oce                      ! ocean space and time domain 
     31   USE domwri                       ! ocean space and time domain 
    4132   USE in_out_manager               ! I/O manager 
    42    USE par_oce                      ! 
    43    USE phycst, only : rt0           ! freezing point of sea water 
    44    USE oasis4_date                  ! OASIS4 date declarations in 
    45                                     ! PRISM compatible format 
     33   USE lbclnk          ! ocean lateral boundary conditions (or mpp link) 
     34 
    4635   IMPLICIT NONE 
     36   PRIVATE 
    4737! 
    48 ! Exchange parameters for coupling ORCA-LIM with ECHAM5 
    49 ! 
    50 #if defined key_cpl_ocevel 
    51    INTEGER, PARAMETER         :: nsend =  6 
    52 #else 
    53    INTEGER, PARAMETER         :: nsend =  4 
    54 #endif 
    55  
    56 #if defined key_cpl_discharge 
    57    INTEGER, PARAMETER         :: nrecv = 20 
    58 #else 
    59    INTEGER, PARAMETER         :: nrecv = 17 
    60 #endif 
    61  
    62    INTEGER, DIMENSION(nsend)  :: send_id 
    63    INTEGER, DIMENSION(nrecv)  :: recv_id 
    64  
    65    CHARACTER(len=32)          :: cpl_send (nsend) 
    66    CHARACTER(len=32)          :: cpl_recv (nrecv) 
    67  
    68    CHARACTER(len=16)          :: app_name       ! application name for OASIS use 
    69    CHARACTER(len=16)          :: comp_name      ! name of this PRISM component 
    70    CHARACTER(len=16)          :: grid_name      ! name of the grid 
    71    CHARACTER(len=1)           :: c_mpi_send 
    72  
    73 ! The following now come in via new module oasis4_date 
    74 !   TYPE(PRISM_Time_struct), PUBLIC    :: dates          ! date info for send operation 
    75 !   TYPE(PRISM_Time_struct), PUBLIC    :: dates_bound(2) ! date info for send operation 
    76 !   TYPE(PRISM_Time_struct), PUBLIC    :: dater          ! date info for receive operation 
    77 !   TYPE(PRISM_Time_struct), PUBLIC    :: dater_bound(2) ! date info for receive operation 
    78 !   TYPE(PRISM_Time_struct), PUBLIC    :: tmpdate 
    79  
    80    PRIVATE 
    81  
    82    INTEGER, PARAMETER         :: localRoot  = 0 
    83  
    84    INTEGER                    :: localRank      ! local MPI rank 
    85    INTEGER                    :: localSize      ! local MPI size 
    86    INTEGER                    :: localComm      ! local MPI size 
    87    LOGICAL                    :: commRank       ! true for ranks doing OASIS communication 
    88    INTEGER                    :: comp_id        ! id returned by prism_init_comp 
    89  
    90    INTEGER                    :: range(5) 
    91  
    92    LOGICAL, SAVE              :: prism_was_initialized 
    93    LOGICAL, SAVE              :: prism_was_terminated 
    94    INTEGER, SAVE              :: write_grid 
    95  
    96    INTEGER                    :: ierror         ! return error code 
    97  
    98 #ifdef key_cpl_rootexchg 
    99    LOGICAL                               :: rootexchg =.true.     ! logical switch  
    100 #else 
    101    LOGICAL                               :: rootexchg =.false.    ! logical switch 
    102 #endif 
    103  
    104    REAL(wp), DIMENSION(:,:), ALLOCATABLE :: exfld  ! Temporary buffer for exchange 
    105    REAL(wp), DIMENSION(:),   ALLOCATABLE :: buffer ! Temporary buffer for exchange 
    106    INTEGER, DIMENSION(:,:),  ALLOCATABLE :: ranges ! Temporary buffer for exchange 
    107  
    108    DOUBLE PRECISION           :: date_incr 
     38!   LOGICAL, PUBLIC, PARAMETER :: lk_cpl = .TRUE.    ! coupled flag 
     39   INTEGER                    :: ncomp_id           ! id returned by prism_init_comp 
     40   INTEGER                    :: nerror             ! return error code 
     41   INTEGER, PUBLIC            :: OASIS_Rcv  = 1     ! return code if received field 
     42   INTEGER, PUBLIC            :: OASIS_idle = 0     ! return code if nothing done by oasis 
     43 
     44   INTEGER, PARAMETER :: nmaxfld=40    ! Maximum number of coupling fields 
     45    
     46   TYPE, PUBLIC ::   FLD_CPL            ! Type for coupling field information 
     47      LOGICAL            ::   laction   ! To be coupled or not 
     48      CHARACTER(len = 8) ::   clname    ! Name of the coupling field    
     49      CHARACTER(len = 1) ::   clgrid    ! Grid type   
     50      REAL(wp)           ::   nsgn      ! Control of the sign change 
     51      INTEGER            ::   nid       ! Id of the field 
     52   END TYPE FLD_CPL 
     53 
     54   TYPE(FLD_CPL), DIMENSION(nmaxfld), PUBLIC :: srcv, ssnd   ! Coupling fields 
     55 
     56   REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: exfld  ! Temporary buffer for receiving 
     57 
     58   TYPE(PRISM_Time_struct), PUBLIC    :: date            ! date info for send operation 
     59   TYPE(PRISM_Time_struct), PUBLIC    :: date_bound(2)   ! date info for send operation 
     60 
    10961 
    11062   !! Routine accessibility 
    11163   PUBLIC cpl_prism_init 
    11264   PUBLIC cpl_prism_define 
    113    PUBLIC cpl_prism_send 
    114    PUBLIC cpl_prism_recv 
     65   PUBLIC cpl_prism_snd 
     66   PUBLIC cpl_prism_rcv 
     67   PUBLIC cpl_prism_update_time 
    11568   PUBLIC cpl_prism_finalize 
    11669 
    117    PUBLIC send_id, recv_id 
    118  
    11970   !!---------------------------------------------------------------------- 
    12071   !!   OPA 9.0 , LOCEAN-IPSL (2006)  
    121    !! $Id$ 
     72   !! $Header$  
    12273   !! Software governed by the CeCILL licence (modipsl/doc/NEMO_CeCILL.txt) 
    12374   !!---------------------------------------------------------------------- 
    … …  
    12576CONTAINS 
    12677 
    127    SUBROUTINE cpl_prism_init( localCommunicator ) 
    128  
    129       IMPLICIT NONE 
     78   SUBROUTINE cpl_prism_init (kl_comm)  
    13079 
    13180      !!------------------------------------------------------------------- 
    … …  
    13786      !! ** Method  :   OASIS4 MPI communication  
    13887      !!-------------------------------------------------------------------- 
    139       !! * Arguments 
    140       !! 
    141       INTEGER, INTENT(OUT)       :: localCommunicator 
    142       !! 
    143       !! * Local declarations 
    144       !! 
    145  
    146       NAMELIST/nam_mpp/ app_name, comp_name, c_mpi_send, grid_name 
    147  
    148       !! 
    149       !!-------------------------------------------------------------------- 
    150       !! 
    151       IF(lwp) WRITE(numout,*) 
    152       IF(lwp) WRITE(numout,*) 'cpl_prism_init : initialization in coupled ocean/atmosphere case' 
    153       IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~~~~' 
    154       IF(lwp) WRITE(numout,*) 
    155       
    156 #if defined key_flx_bulk_monthly || defined key_flx_bulk_daily || defined key_flx_forced_daily 
    157  
    158 #if !defined key_oasis4 
    159 ! The following is not necessarily a valid peice of checking 
    160  
    161       IF(lwp) WRITE(numout,cform_err) 
    162       IF(lwp) WRITE(numout,*) ' key_coupled and key_flx_bulk_* key_flx_forced_daily are incompatible' 
    163       nstop = nstop + 1 
    164  
    165 #endif 
    166  
    167 #endif 
    168  
    169       REWIND( numnam ) 
    170       READ  ( numnam, nam_mpp ) 
    171       REWIND( numnam ) 
    172  
    173       !------------------------------------------------------------------ 
    174       ! 1st Initialize the PRISM system for the application 
    175       !------------------------------------------------------------------ 
    176  
    177       CALL prism_initialized (prism_was_initialized, ierror) 
    178       IF ( ierror /= PRISM_Success ) & 
    179          CALL prism_abort( comp_id, 'OPA9.0', 'cpl_prism_init: Failure in prism_initialized' ) 
    180  
    181       IF ( .NOT. prism_was_initialized ) THEN 
    182          CALL prism_init( app_name, ierror ) 
    183          IF ( ierror /= PRISM_Success ) & 
    184             CALL prism_abort(comp_id, 'OPA9.0', 'cpl_prism_init: Failure in prism_init') 
    185          prism_was_initialized = .true. 
    186       ELSE 
    187          call prism_abort(comp_id, 'OPA9.0', 'cpl_prism_init: Do not initialize prism twice!') 
    188       ENDIF 
    189       ! 
    190       ! Obtain the actual dates and date bounds 
    191       ! 
    192       ! date is determined by adding days since beginning of 
    193       !   the run to the corresponding initial date. Note that 
    194       !   OPA internal info about the start date of the experiment 
    195       !   is bypassed. Instead we rely sololy on the info provided 
    196       !   by the SCC.xml file.  
    197       ! 
    198       dates   = PRISM_Jobstart_date 
    199  
    200       WRITE(6,*) "PRISM JOB START DATE IS", dates 
    201  
    202       ! 
    203       ! upper bound is determined by adding half a time step 
    204       ! 
    205       tmpdate = dates 
    206       date_incr = rdttra(1)/2.0 
    207       CALL PRISM_calc_newdate ( tmpdate, date_incr, ierror ) 
    208       dates_bound(2) = tmpdate 
    209       ! 
    210       ! lower bound is determined by half distance to date from previous run 
    211       ! 
    212       tmpdate   = dates 
    213       date_incr = ( adatrj - adatrj0 ) * 43200.0 
    214       CALL PRISM_calc_newdate ( tmpdate, date_incr, ierror ) 
    215       dates_bound(1) = tmpdate 
    216  
    217       dater = dates 
    218       dater_bound(1) = dates_bound(1)  
    219       dater_bound(2) = dates_bound(2)  
    220  
    221       WRITE(6,*) "DATE send and rec BOUNDS",dater_bound 
    222       WRITE(6,*) "OTHER BITS FOR DATE",rdttra(1) 
    223       WRITE(6,*) "adatrj/0",adatrj,adatrj0,date_incr 
     88      INTEGER, INTENT(   OUT )   :: kl_comm       ! local communicator of the model 
     89      ! 
     90       
     91      CALL prism_init( 'nemo', nerror ) 
    22492 
    22593      !------------------------------------------------------------------ 
    22694      ! 2nd Initialize the PRISM system for the component 
    22795      !------------------------------------------------------------------ 
    228  
    229       CALL prism_init_comp ( comp_id, comp_name, ierror ) 
    230       IF ( ierror /= PRISM_Success ) & 
    231          CALL prism_abort (comp_id, 'OPA9.0', 'cpl_prism_init: Failure in prism_init_comp') 
    232  
    233       WRITE(6,*) "COMPLETED INIT_COMP",comp_name,comp_id 
    234  
    235       !------------------------------------------------------------------ 
    236       ! 3rd Get an MPI communicator for OPA local communication 
    237       !------------------------------------------------------------------ 
    238  
    239       CALL prism_get_localcomm ( comp_id, localComm, ierror ) 
    240       IF ( ierror /= PRISM_Success ) & 
    241          CALL prism_abort (comp_id, 'OPA9.0', 'cpl_prism_init: Failure in prism_get_localcomm' ) 
    242  
    243       localCommunicator = localComm 
    244  
    245        WRITE(6,*) "COMPLETED GET_LOCALCOMM",comp_name,comp_id 
     96      CALL prism_init_comp( ncomp_id, 'oceanx', nerror ) 
     97      IF( nerror /= PRISM_Success )   CALL prism_abort( ncomp_id, 'cpl_prism_init', 'Failure in prism_init_comp' ) 
     98 
     99      !------------------------------------------------------------------ 
     100      ! 3rd Get an MPI communicator fr OPA local communication 
     101      !------------------------------------------------------------------ 
     102      CALL prism_get_localcomm( ncomp_id, kl_comm, nerror ) 
     103      IF( nerror /= PRISM_Success )   CALL prism_abort( ncomp_id, 'cpl_prism_init', 'Failure in prism_get_localcomm' ) 
    246104 
    247105 
    … …  
    249107 
    250108 
    251    SUBROUTINE cpl_prism_define () 
    252  
    253       IMPLICIT NONE 
     109   SUBROUTINE cpl_prism_define (krcv, ksnd) 
    254110 
    255111      !!------------------------------------------------------------------- 
    … …  
    261117      !! ** Method  :   OASIS4 MPI communication  
    262118      !!-------------------------------------------------------------------- 
    263       !! * Arguments 
    264       !! 
    265       !! * Local declarations 
    266  
    267       INTEGER                    :: grid_id(2)     ! id returned by prism_def_grid 
    268  
    269       INTEGER                    :: upoint_id(2), & 
    270                                     vpoint_id(2), & 
    271                                     tpoint_id(2), & 
    272                                     fpoint_id(2)   ! ids returned by prism_set_points 
    273  
    274       INTEGER                    :: umask_id(2), & 
    275                                     vmask_id(2), & 
    276                                     tmask_id(2), & 
    277                                     fmask_id(2)    ! ids returned by prism_set_mask 
    278  
    279       INTEGER                    :: grid_type      ! PRISM grid type 
    280  
    281       INTEGER                    :: shape(2,3)     ! shape of arrays passed to PSMILe 
    282       INTEGER                    :: nodim(2) 
     119      INTEGER, INTENT( IN    )   :: krcv, ksnd     ! Number of received and sent coupling fields 
     120      ! 
     121      INTEGER, DIMENSION(4)      :: igrid     ! ids returned by prism_def_grid 
     122      INTEGER, DIMENSION(4)      :: iptid     ! ids returned by prism_set_points 
     123 
     124      INTEGER, DIMENSION(4)      :: imskid  ! ids returned by prism_set_mask 
     125      INTEGER, DIMENSION(4)      :: iishift     !  
     126      INTEGER, DIMENSION(4)      :: ijshift    !  
     127      INTEGER, DIMENSION(4)      :: iioff     !  
     128      INTEGER, DIMENSION(4)      :: ijoff    !  
     129      INTEGER, DIMENSION(4)      :: itmp    !  
     130      INTEGER, DIMENSION(1,3)    :: iextent    !  
     131      INTEGER, DIMENSION(1,3)    :: ioffset    !  
     132 
     133 
     134      INTEGER                    :: ishape(2,3)     ! shape of arrays passed to PSMILe 
    283135      INTEGER                    :: data_type      ! data type of transients 
    284136 
    285       INTEGER                    :: nbr_corners 
    286137 
    287138      LOGICAL                    :: new_points 
    288139      LOGICAL                    :: new_mask 
    289       LOGICAL                    :: mask(jpi,jpj,jpk) 
    290  
    291       INTEGER                    :: ji, jj, jk     ! local loop indicees 
    292  
    293       CHARACTER(len=32)          :: cpl_send (nsend) 
    294       CHARACTER(len=32)          :: cpl_recv (nrecv) 
    295  
    296       CHARACTER(len=32)          :: grid_name      ! name of the grid 
    297       CHARACTER(len=32)          :: point_name     ! name of the grid points 
    298  
    299       REAL(kind=wp), ALLOCATABLE :: rclon(:,:,:) 
    300       REAL(kind=wp), ALLOCATABLE :: rclat(:,:,:) 
    301       REAL(kind=wp), ALLOCATABLE :: rcz  (:,:) 
    302  
     140      LOGICAL                    :: llmask(jpi,jpj,1) 
     141 
     142      INTEGER                    :: ji, jj, jg, jc     ! local loop indicees 
     143      INTEGER                    :: ii,ij     ! index 
     144      INTEGER, DIMENSION(1)      :: ind     ! index 
     145 
     146      CHARACTER(len=32)          :: clpt_name     ! name of the grid points 
     147      CHARACTER(len=7)           :: cltxt  
     148      CHARACTER(len=1), DIMENSION(4) :: clgrd = (/ 'T','U','V','F' /)     ! name of the grid points 
     149 
     150      REAL(kind=wp), DIMENSION(jpi,jpj,4)  :: zclo, zcla 
     151      REAL(kind=wp), DIMENSION(jpi,jpj  )  :: zlon, zlat 
     152 
     153      TYPE(PRISM_Time_struct)    :: tmpdate 
     154      INTEGER                    :: idate_incr      ! date increment 
     155      !! 
    303156      !!-------------------------------------------------------------------- 
    304       
     157 
    305158      IF(lwp) WRITE(numout,*) 
    306159      IF(lwp) WRITE(numout,*) 'cpl_prism_define : initialization in coupled ocean/atmosphere case' 
    307160      IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~~~~~' 
    308161      IF(lwp) WRITE(numout,*) 
    309       
    310 #if defined key_flx_bulk_monthly || defined key_flx_bulk_daily || defined key_flx_forced_daily 
    311  
    312 #if !defined key_oasis4 
    313 ! The problem with the following is that it ASSUMES we're only ever coupling to an atmosphere 
    314 ! which is not necessarily the case. Prevent this test temporarily for NEMOGAM development. 
    315  
    316       IF(lwp) WRITE(numout,cform_err) 
    317       IF(lwp) WRITE(numout,*) ' key_coupled and key_flx_bulk_... are incompatible' 
    318       nstop = nstop + 1 
    319  
    320 #endif 
    321  
    322 #endif 
    323  
    324       ! ----------------------------------------------------------------- 
    325       ! ... Some initialisation 
    326       ! ----------------------------------------------------------------- 
    327  
    328       send_id = 0 
    329       recv_id = 0 
    330  
    331 #if defined key_mpp_mpi 
    332  
    333       ! ----------------------------------------------------------------- 
    334       ! ... Some MPI stuff relevant for optional exchange via root only 
    335       ! ----------------------------------------------------------------- 
    336  
    337       commRank = .false. 
    338  
    339       localRank = mpprank ! from lib_mpp 
    340       localSize = mppsize ! from lib_mpp 
    341  
    342       IF(lwp) WRITE(numout,*) "CALLING DEFINE" 
    343  
    344       IF ( rootexchg ) THEN 
    345          IF ( localRank == localRoot ) commRank = .true. 
    346       ELSE 
    347          commRank = .true. 
    348       ENDIF 
    349  
    350 #else 
    351       ! 
    352       ! For non-parallel configurations the one and only process ("localRoot") 
    353       ! takes part in the communication 
    354       !  
    355       localRank = localRoot 
    356       commRank = .true. 
    357  
    358 #endif 
    359  
    360       ! ----------------------------------------------------------------- 
     162 
     163      ! 
    361164      ! ... Allocate memory for data exchange 
    362       ! ----------------------------------------------------------------- 
    363  
    364  
    365       IF(lwp) WRITE(numout,*) "Abbout to allocate exfld",jpi,jpj 
    366  
    367       ALLOCATE(exfld(1:jpi,1:jpj), stat = ierror) 
    368       IF (ierror > 0) THEN 
    369          CALL prism_abort ( comp_id, 'OPA9.0', 'cpl_prism_define: Failure in allocating Reals') 
     165      ! 
     166      ALLOCATE( exfld(nlei-nldi+1, nlej-nldj+1, 1), stat = nerror ) 
     167      IF ( nerror > 0 ) THEN 
     168         CALL prism_abort( ncomp_id, 'cpl_prism_define', 'Failure in allocating exfld' ) 
    370169         RETURN 
    371170      ENDIF 
    372171 
    373       IF ( rootexchg .and. localRank == localRoot ) THEN 
    374          ALLOCATE(ranges(5,0:localSize-1), stat = ierror) 
    375          IF (ierror > 0) THEN 
    376             CALL prism_abort ( comp_id, 'OPA9.0', 'cpl_prism_define: Failure in allocating Integer') 
    377             RETURN 
    378          ENDIF 
    379       ENDIF 
    380  
    381       !------------------------------------------------------------------ 
    382       ! 1st Declare the local grid (ORCA tripolar) characteristics for 
    383       !     surface coupling. The halo regions must be excluded. For 
    384       !     surface coupling it is sufficient to specify only one 
    385       !     vertical z-level. 
    386       !------------------------------------------------------------------ 
    387  
    388       grid_type = PRISM_irrlonlat_regvrt 
    389  
    390       IF(lwp) WRITE(numout,*) "Set grid type" 
    391  
    392  
    393       ! ----------------------------------------------------------------- 
    394       ! ... Define the shape of the valid region without the halo. 
     172 
     173      ! ----------------------------------------------------------------- 
     174      ! ... Define the shape of the valid region without the halo and overlaps between cpus 
    395175      !     For serial configuration (key_mpp_mpi not being active) 
    396176      !     nl* is set to the global values 1 and jp*glo. 
    397177      ! ----------------------------------------------------------------- 
    398178 
    399       IF ( rootexchg ) THEN 
    400          shape(1,1) = 1+jpreci 
    401          shape(2,1) = jpiglo-jpreci 
    402          shape(1,2) = 1+jpreci 
    403          shape(2,2) = jpjglo-jpreci 
    404          shape(1,3) = 1 
    405          shape(2,3) = 1 
    406       ELSE 
    407          shape(1,1) = 1+jpreci 
    408          shape(2,1) = jpi-jpreci 
    409          shape(1,2) = 1+jpreci 
    410          shape(2,2) = jpj-jpreci 
    411          shape(1,3) = 1 
    412          shape(2,3) = 1 
    413       ENDIF 
    414  
    415       IF(lwp) WRITE(numout,*) "commrank is", commRank 
    416  
    417       IF ( commRank ) THEN 
    418  
    419          IF(lwp) WRITE(numout,*) "CALLING DEF_GRID" 
    420  
    421          IF(lwp) WRITE(numout,*) "grid name",grid_name 
    422          IF(lwp) WRITE(numout,*) " shape",shape 
    423          IF(lwp) WRITE(numout,*) "grid type",grid_type 
    424  
    425          CALL prism_def_grid ( grid_id(1), grid_name, comp_id, shape, & 
    426               grid_type, ierror ) 
    427          IF ( ierror /= PRISM_Success ) THEN 
    428             PRINT *, 'OPA cpl_prism_define: Failure in prism_def_grid' 
    429             CALL prism_abort (comp_id, 'OPA9.0', 'cpl_prism_define: Failure in prism_def_grid') 
     179      ishape(:,1) = (/ 1, nlei-nldi+1 /) 
     180      ishape(:,2) = (/ 1, nlej-nldj+1 /) 
     181      ishape(:,3) = (/ 1,           1 /) 
     182           
     183      DO ji = 1, 4 
     184         CALL prism_def_grid( igrid(ji), 'orca'//clgrd(ji), ncomp_id, ishape, PRISM_irrlonlat_regvrt, nerror ) 
     185         IF( nerror /= PRISM_Success )   CALL prism_abort (ncomp_id, 'cpl_prism_define',   & 
     186            &                                                        'Failure in prism_def_grid of '//clgrd(jg)//'-point' ) 
     187      END DO 
     188       
     189      ! ----------------------------------------------------------------- 
     190      ! ... Define the partition  
     191      ! ----------------------------------------------------------------- 
     192       
     193      iextent(1,:) = (/    nlei-nldi+1,    nlej-nldj+1, 1 /) 
     194      ioffset(1,:) = (/ nldi-1+nimpp-1, nldj-1+njmpp-1, 0 /) 
     195       
     196      DO ji = 1, 4 
     197         CALL prism_def_partition( igrid(ji), 1, ioffset, iextent, nerror ) 
     198         IF( nerror /= PRISM_Success )   CALL prism_abort (ncomp_id, 'cpl_prism_define',   & 
     199            &                                                        'Failure in prism_def_partition of '//clgrd(jg)//'-point' ) 
     200      END DO 
     201 
     202      ! ----------------------------------------------------------------- 
     203      ! ... Define the elements, i.e. specify the corner points for each 
     204      !     volume element. In case OPA runs on level coordinates (regular 
     205      !     in the vertical) we only need to give the 4 horizontal corners 
     206      !     for a volume element plus the vertical position of the upper 
     207      !     and lower face. Nevertheless the volume element has 8 corners. 
     208      ! ----------------------------------------------------------------- 
     209       
     210      iioff(:) = (/0,1,0,1/) 
     211      ijoff(:) = (/0,0,1,1/)  
     212      iishift(:) = (/0,1,1,0/) 
     213      ijshift(:) = (/0,0,1,1/) 
     214 
     215      DO jg = 1, 4    ! ... the t,u,v,f-points 
     216 
     217         cltxt = clgrd(jg)//'-point' 
     218          
     219         ! ----------------------------------------------------------------- 
     220         ! ... Convert OPA masks to logicals and define the masks 
     221         ! ----------------------------------------------------------------- 
     222         SELECT CASE( jg )  
     223         CASE(1)   ;   llmask(:,:,1) = ( tmask(:,:,1)  ) == 1. 
     224         CASE(2)   ;   llmask(:,:,1) = ( umask(:,:,1)  ) == 1. 
     225         CASE(3)   ;   llmask(:,:,1) = ( vmask(:,:,1)  ) == 1. 
     226         CASE(4)   ;   llmask(:,:,1) = ( fmask(:,:,1)  ) == 1. 
     227!         CASE(1)   ;   llmask(:,:,1) = ( tmask(:,:,1) * dom_uniq('T') ) == 1. 
     228!         CASE(2)   ;   llmask(:,:,1) = ( umask(:,:,1) * dom_uniq('U') ) == 1. 
     229!         CASE(3)   ;   llmask(:,:,1) = ( vmask(:,:,1) * dom_uniq('V') ) == 1. 
     230!         CASE(4)   ;   llmask(:,:,1) = ( fmask(:,:,1) * dom_uniq('F') ) == 1. 
     231         END SELECT 
     232         CALL prism_set_mask( imskid(jg), igrid(jg), ishape, llmask(nldi:nlei, nldj:nlej, 1), .TRUE., nerror ) 
     233         IF( nerror /= PRISM_Success )   CALL prism_abort( ncomp_id, 'cpl_prism_define', 'Failure in prism_set_mask for '//cltxt ) 
     234 
     235         ! ----------------------------------------------------------------- 
     236         ! ... Define the corners 
     237         ! ----------------------------------------------------------------- 
     238         SELECT CASE( jg )  
     239         CASE(1)   ;   zlon(:,:) = glamf(:,:)   ;   zlat(:,:) = gphif(:,:) 
     240         CASE(2)   ;   zlon(:,:) = glamv(:,:)   ;   zlat(:,:) = gphiv(:,:) 
     241         CASE(3)   ;   zlon(:,:) = glamu(:,:)   ;   zlat(:,:) = gphiu(:,:)  
     242         CASE(4)   ;   zlon(:,:) = glamt(:,:)   ;   zlat(:,:) = gphit(:,:) 
     243         END SELECT 
     244 
     245         DO jc = 1, 4   ! corner number (anti-clockwise, starting from the bottom left corner) 
     246            DO jj = 2, jpjm1 
     247               DO ji = 2, jpim1   ! NO vector opt. 
     248                  ii = ji-1 + iioff(jg) + iishift(jc) 
     249                  ij = jj-1 + ijoff(jg) + ijshift(jc) 
     250                  zclo(ji,jj,jc) = zlon(ii,ij) 
     251                  zcla(ji,jj,jc) = zlat(ii,ij) 
     252               END DO 
     253            END DO 
     254            CALL lbc_lnk( zclo(:,:,jc), clgrd(jg), 1. )   ;   CALL lbc_lnk( zcla(:,:,jc), clgrd(jg), 1. ) 
     255         END DO 
     256 
     257         CALL prism_set_corners( igrid(jg), 8, ishape, zclo(nldi:nlei, nldj:nlej,:),   & 
     258            &                                          zcla(nldi:nlei, nldj:nlej,:), RESHAPE( (/-1.,1./), (/1,2/) ), nerror ) 
     259         IF( nerror /= PRISM_Success )   CALL prism_abort( ncomp_id, 'cpl_prism_define', 'Failure in prism_set_corners of '//cltxt )     
     260 
     261         ! ----------------------------------------------------------------- 
     262         ! ... Define the center points 
     263         ! ----------------------------------------------------------------- 
     264         SELECT CASE( jg )  
     265         CASE(1)   ;   zlon(:,:) = glamt(:,:)   ;   zlat(:,:) = gphit(:,:) 
     266         CASE(2)   ;   zlon(:,:) = glamu(:,:)   ;   zlat(:,:) = gphiu(:,:) 
     267         CASE(3)   ;   zlon(:,:) = glamv(:,:)   ;   zlat(:,:) = gphiv(:,:) 
     268         CASE(4)   ;   zlon(:,:) = glamf(:,:)   ;   zlat(:,:) = gphif(:,:) 
     269         END SELECT 
     270 
     271         CALL prism_set_points ( iptid(jg), cltxt, igrid(jg), ishape, zlon(nldi:nlei, nldj:nlej),   & 
     272         &                                                            zlat(nldi:nlei, nldj:nlej), (/0./), .TRUE., nerror ) 
     273         IF( nerror /= PRISM_Success )   CALL prism_abort ( ncomp_id, 'cpl_prism_define', 'Failure in prism_set_points '//cltxt ) 
     274 
     275      END DO 
     276 
     277      ! ... Announce send variables.  
     278      ! 
     279      DO ji = 1, ksnd 
     280         IF ( ssnd(ji)%laction ) THEN  
     281             
     282            itmp(:) = 0 
     283            WHERE( clgrd == ssnd(ji)%clgrid  ) itmp = 1 
     284            ind(:) = maxloc( itmp ) 
     285            WRITE(6,*) ' grid for field ', ind(1), ssnd(ji)%clname 
     286             ind(1) = 1 
     287 
     288            CALL prism_def_var( ssnd(ji)%nid, ssnd(ji)%clname, igrid(ind(1)), iptid(ind(1)),  imskid(ind(1)), (/ 3, 0/),   & 
     289               &                ishape, PRISM_Double_Precision, nerror ) 
     290            IF ( nerror /= PRISM_Success )   CALL prism_abort( ssnd(ji)%nid, 'cpl_prism_define',   & 
     291               &                                               'Failure in prism_def_var for '//TRIM(ssnd(ji)%clname)) 
     292 
    430293         ENDIF 
    431  
    432          !------------------------------------------------------------------ 
    433          ! 2nd Declare the geometic information for this grid. 
    434          !------------------------------------------------------------------ 
    435  
    436          ! ----------------------------------------------------------------- 
    437          ! ... Redefine shape which may now include the halo region as well. 
    438          ! ----------------------------------------------------------------- 
    439  
    440          shape(1,1) = 1 
    441          shape(2,1) = jpi 
    442          shape(1,2) = 1 
    443          shape(2,2) = jpj 
    444          shape(1,3) = 1 
    445          shape(2,3) = 1 
    446  
    447          IF(lwp) WRITE(numout,*) "redefined shape",shape 
    448  
    449          ! ----------------------------------------------------------------- 
    450          ! ... Define the elements, i.e. specify the corner points for each 
    451          !     volume element. In case OPA runs on level coordinates (regular 
    452          !     in the vertical) we only need to give the 4 horizontal corners 
    453          !     for a volume element plus the vertical position of the upper 
    454          !     and lower face. Nevertheless the volume element has 8 corners. 
    455          ! ----------------------------------------------------------------- 
    456  
    457          ! 
    458          ! ... Treat corners in the horizontal plane 
    459          ! 
    460          ALLOCATE(rclon(shape(1,1):shape(2,1),shape(1,2):shape(2,2),4), & 
    461               STAT=ierror) 
    462          IF ( ierror /= 0 ) & 
    463               CALL prism_abort ( comp_id, 'OPA9.0', 'cpl_prism_define: error in allocate for rclon') 
    464  
    465          ALLOCATE(rclat(shape(1,1):shape(2,1),shape(1,2):shape(2,2),4), & 
    466               STAT=ierror) 
    467          IF ( ierror /= 0 ) & 
    468               CALL prism_abort ( comp_id, 'OPA9.0', 'cpl_prism_define: error in allocate for rclon') 
    469  
    470          nbr_corners = 8 
    471          ! 
    472          ! ... Set right longitudes and upper latitudes 
    473          ! 
    474          DO jj = shape(1,2), shape(2,2) 
    475             DO ji = shape(1,1), shape(2,1) 
    476                rclon(ji,jj,1) = glamu(ji,jj) 
    477                rclon(ji,jj,2) = glamu(ji,jj) 
    478                rclat(ji,jj,2) = gphiv(ji,jj) 
    479                rclat(ji,jj,3) = gphiv(ji,jj) 
    480             ENDDO 
    481          ENDDO 
    482          ! 
    483          ! ... Set the lower latitudes 
    484          ! 
    485          DO jj = shape(1,2)+1, shape(2,2) 
    486             DO ji = shape(1,1), shape(2,1) 
    487                rclat(ji,jj-1,1) = rclat(ji,jj,2) 
    488                rclat(ji,jj-1,4) = rclat(ji,jj,3) 
    489             ENDDO 
    490          ENDDO 
    491          ! 
    492          ! ... Set the left longitudes 
    493          ! 
    494          DO jj = shape(1,2), shape(2,2) 
    495             DO ji = shape(1,1)+1, shape(2,1) 
    496                rclon(ji-1,jj,3) = rclon(ji,jj,2) 
    497                rclon(ji-1,jj,4) = rclon(ji,jj,1) 
    498             ENDDO 
    499          ENDDO 
    500          ! 
    501          ! ... Set the lowermost latitudes  
    502          ! 
    503          DO jj = shape(1,2), shape(1,2) 
    504             DO ji = shape(1,1), shape(2,1) 
    505                rclat(ji,jj,1) = 2.0*gphit(ji,jj)-rclat(ji,jj,2) 
    506                rclat(ji,jj,4) = 2.0*gphit(ji,jj)-rclat(ji,jj,4) 
    507             ENDDO 
    508          ENDDO 
    509          ! 
    510          ! ... Set the rightmost latitudes  
    511          ! 
    512          DO jj = shape(1,2), shape(2,2) 
    513             DO ji = shape(1,2), shape(1,2) 
    514                rclon(ji,jj,3) = 2.0*glamt(ji,jj)-rclon(ji,jj,2) 
    515                rclon(ji,jj,4) = 2.0*glamt(ji,jj)-rclon(ji,jj,1) 
    516  
    517                WRITE(76,*) "rclon", ji, jj, rclon(ji,jj,1), & 
    518                                             rclon(ji,jj,2), & 
    519                                             rclon(ji,jj,3), & 
    520                                             rclon(ji,jj,4) 
    521  
    522                WRITE(76,*) "rclat", ji, jj, rclat(ji,jj,1), & 
    523                                             rclat(ji,jj,2), & 
    524                                             rclat(ji,jj,3), & 
    525                                             rclat(ji,jj,4) 
    526  
    527             ENDDO 
    528          ENDDO 
    529  
    530          ! 
    531          ! ... Treat corners along the vertical axis 
    532          ! 
    533          ALLOCATE(rcz(shape(1,3):shape(2,3),2), STAT=ierror) 
    534          IF ( ierror /= 0 ) & 
    535               CALL prism_abort ( comp_id, 'OPA9.0', 'cpl_prism_define: error in allocate for rcz') 
    536  
    537          DO jk = shape(1,3), shape(2,3) 
    538             rcz(jk,1) = gdepw(jk) 
    539             rcz(jk,2) = gdepw(jk+1) 
    540          ENDDO 
    541  
    542          IF(lwp) WRITE(numout,*) "ABOUT TO CALL SET CORNERS",shape  
    543  
    544          CALL prism_set_corners ( grid_id(1), nbr_corners, shape, rclon, rclat, & 
    545               rcz, ierror) 
    546          IF ( ierror /= PRISM_Success ) & 
    547               CALL prism_abort ( comp_id, 'OPA9.0', 'cpl_prism_define: Failure in prism_set_corners') 
    548  
    549          DEALLOCATE(rclon, rclat, rcz) 
    550  
    551          ! ----------------------------------------------------------------- 
    552          ! ... Define the gridpoints   
    553          ! ----------------------------------------------------------------- 
    554  
    555          new_points = .TRUE. 
    556  
    557          IF(lwp) WRITE(numout,*) "CALLING SET_POINTS" 
    558  
    559          ! 
    560          ! ... the u-points 
    561          ! 
    562          point_name = 'u-points' 
    563          CALL prism_set_points ( upoint_id(1), point_name, grid_id(1), shape,      & 
    564               glamu, gphiu, gdept(shape(1,3):shape(2,3)), new_points, ierror ) 
    565          IF ( ierror /= PRISM_Success ) & 
    566               CALL prism_abort ( comp_id, 'OPA9.0', 'cpl_prism_define: Failure in prism_set_points upoint_id') 
    567          ! 
    568          ! ... the v-points 
    569          ! 
    570  
    571          IF(lwp) WRITE(numout,*) "CALLING SET_POINTS done u doing v" 
    572  
    573          point_name = 'v-points' 
    574          CALL prism_set_points ( vpoint_id(1), point_name, grid_id(1), shape,      & 
    575               glamv, gphiv, gdept(shape(1,3):shape(2,3)), new_points, ierror )       
    576          IF ( ierror /= PRISM_Success ) & 
    577               CALL prism_abort ( comp_id, 'OPA9.0', 'cpl_prism_define: Failure in prism_set_points vpoint_id') 
    578          ! 
    579          ! ... the t-points 
    580          ! 
    581          ! WRITE(76,*) 'CALLING T POINTS', shape 
    582          ! WRITE(77,*) 'glamt', glamt 
    583          ! WRITE(78,*) 'gphit', gphit 
    584          ! 
    585          point_name = 't-points' 
    586          CALL prism_set_points ( tpoint_id(1), point_name, grid_id(1), shape,   & 
    587               glamt, gphit, gdept(shape(1,3):shape(2,3)), new_points, ierror ) 
    588          IF ( ierror /= PRISM_Success ) & 
    589               CALL prism_abort ( comp_id, 'OPA9.0', 'cpl_prism_define: Failure in prism_set_points tpoint_id') 
    590          ! 
    591          ! ... the f-points 
    592          ! 
    593          point_name = 'f-points' 
    594          CALL prism_set_points ( fpoint_id(1), point_name, grid_id(1), shape,   & 
    595               glamf, gphif, gdept(shape(1,3):shape(2,3)), new_points, ierror ) 
    596          IF ( ierror /= PRISM_Success ) & 
    597               CALL prism_abort ( comp_id, 'OPA9.0', 'cpl_prism_define: Failure in prism_set_points fpoint_id') 
    598  
    599  
    600          IF(lwp) WRITE(numout,*) "CALLING SET_POINTS done f" 
    601  
    602          ! ----------------------------------------------------------------- 
    603          ! ... Convert OPA masks to logicals and define the masks 
    604          ! ----------------------------------------------------------------- 
    605  
    606          new_mask = .true. 
    607  
    608          mask = (umask == 1) 
    609          CALL prism_set_mask (umask_id(1), grid_id(1), shape, & 
    610                  mask(shape(1,1):shape(2,1),                  & 
    611                       shape(1,2):shape(2,2),                  & 
    612                       shape(1,3):shape(2,3)),                 & 
    613               new_mask, ierror ) 
    614          IF ( ierror /= PRISM_Success ) & 
    615               CALL prism_abort ( comp_id, 'OPA9.0', 'cpl_prism_define: Failure in prism_set_mask umask_id') 
    616  
    617          mask = (vmask == 1) 
    618          CALL prism_set_mask (vmask_id(1), grid_id(1), shape, & 
    619                  mask(shape(1,1):shape(2,1),                  & 
    620                       shape(1,2):shape(2,2),                  & 
    621                       shape(1,3):shape(2,3)),                 & 
    622               new_mask, ierror ) 
    623          IF ( ierror /= PRISM_Success ) & 
    624               CALL prism_abort ( comp_id, 'OPA9.0', 'cpl_prism_define: Failure in prism_set_mask umask_id') 
    625  
    626          mask = (tmask == 1) 
    627          CALL prism_set_mask (tmask_id(1), grid_id(1), shape, & 
    628                  mask(shape(1,1):shape(2,1),                  & 
    629                       shape(1,2):shape(2,2),                  & 
    630                       shape(1,3):shape(2,3)),                 & 
    631               new_mask, ierror ) 
    632          IF ( ierror /= PRISM_Success ) & 
    633               CALL prism_abort ( comp_id, 'OPA9.0', 'cpl_prism_define: Failure in prism_set_mask umask_id') 
    634  
    635          mask = (fmask == 1) 
    636          CALL prism_set_mask (fmask_id(1), grid_id(1), shape, & 
    637                  mask(shape(1,1):shape(2,1),                  & 
    638                       shape(1,2):shape(2,2),                  & 
    639                       shape(1,3):shape(2,3)),                 & 
    640               new_mask, ierror ) 
    641          IF ( ierror /= PRISM_Success ) & 
    642               CALL prism_abort ( comp_id, 'OPA9.0', 'cpl_prism_define: Failure in prism_set_mask umask_id') 
    643  
    644          IF(lwp) WRITE(numout,*) "DONE ALL THE SET MASKS" 
    645  
    646          ! ----------------------------------------------------------------- 
    647          ! ... Define the angles 
    648          !   This is needed if zonal tau is not oriented E-W and meridional 
    649          !   tau is not oriented along N-S but rather along local coordinate 
    650          !   axis. Please check!!!! 
    651          ! ----------------------------------------------------------------- 
    652  
    653 !rr      cal prism_set_angles ( ..., ierror ) ! not yet supported by OASIS4 
    654  
    655          ! ----------------------------------------------------------------- 
    656          ! ... Define the partition  
    657          ! ----------------------------------------------------------------- 
    658           
    659          IF ( rootexchg ) THEN 
    660  
    661             range(1) = nimpp-1+nldi   ! global start in i 
    662             range(2) = nlei-nldi+1    ! local size in i of valid region 
    663             range(3) = njmpp-1+nldj   ! global start in j 
    664             range(4) = nlej-nldj+1    ! local size in j of valid region 
    665             range(5) = range(2) & 
    666                      * range(4)       ! local horizontal size 
    667             ! 
    668             ! Collect ranges from all NEMO procs on the local root process 
    669             ! 
    670             CALL mpi_gather(range,  5, MPI_INTEGER, & 
    671                             ranges, 5, MPI_INTEGER, localRoot, localComm, ierror) 
    672  
    673             IF ( localRank == localRoot ) THEN 
    674  
    675                maxlen = maxval(ranges(5,:)) 
    676  
    677                ALLOCATE(buffer(1:maxlen), stat = ierror) 
    678                IF (ierror > 0) THEN 
    679                   CALL prism_abort ( comp_id, 'OPA9.0', 'cpl_prism_define: Failure in allocating buffer') 
    680                   RETURN 
    681                ENDIF 
    682  
    683             ENDIF 
     294      END DO 
     295      ! 
     296      ! ... Announce received variables.  
     297      ! 
     298      DO ji = 1, krcv 
     299         IF ( srcv(ji)%laction ) THEN  
     300 
     301            itmp(:) = 0 
     302            WHERE( clgrd == srcv(ji)%clgrid  ) itmp = 1 
     303            ind(:) = maxloc( itmp ) 
     304            WRITE(6,*) ' grid for field ', ind(1), srcv(ji)%clname 
     305             ind(1) = 1 
     306  
     307            CALL prism_def_var( srcv(ji)%nid, srcv(ji)%clname, igrid(ind(1)), iptid(ind(1)), imskid(ind(1)), (/ 3, 0/),   & 
     308               &                ishape, PRISM_Double_Precision, nerror ) 
     309            IF ( nerror /= PRISM_Success )   CALL prism_abort( srcv(ji)%nid, 'cpl_prism_define',   & 
     310               &                                               'Failure in prism_def_var for '//TRIM(srcv(ji)%clname)) 
    684311 
    685312         ENDIF 
    686  
    687          ! ----------------------------------------------------------------- 
    688          ! ... Define the scalefactors  
    689          ! ----------------------------------------------------------------- 
    690  
    691 !rr      WRITE(numout,*) "CALLING SCALEFACTOR" 
    692 !rr      call prism_set_scalefactor ( grid_id(1), shape, e1t, e2t, e3t, ierror )  ! not yet supported by OASIS4 
    693 !rr      WRITE(numout,*) "ABOUT TO DEFINE THE TRANSIENTS" 
    694  
    695          !------------------------------------------------------------------ 
    696          ! 3rd Declare the transient variables 
    697          !------------------------------------------------------------------ 
    698          ! 
    699          ! ... Define symbolic names for the transient fields send by the ocean 
    700          !     These must be identical to the names specified in the SMIOC file. 
    701          ! 
    702          cpl_send( 1)='SOSSTSST' ! sea surface temperature              -> sst_io 
    703          cpl_send( 2)='SITOCEAN' ! sea ice thickness                    -> hicif (only 1 layer available!) 
    704 #if defined key_cpl_albedo 
    705          cpl_send( 3)='STIOCEAN' ! surface temperature over sea ice     -> tn_ice 
    706          cpl_send( 4)='SAIOCEAN' ! albedo over sea ice                  -> alb_ice 
    707 #else 
    708          cpl_send( 3)='SITOCEAN' ! sea ice thickness                    -> hicif (only 1 layer available!) 
    709          cpl_send( 4)='SNTOCEAN' ! surface snow thickness over sea ice  -> hsnif 
    710 #endif 
    711 #if defined key_cpl_ocevel 
    712          cpl_send( 5)='SUNOCEAN' ! U-velocity                           -> un 
    713          cpl_send( 6)='SVNOCEAN' ! V-velocity                           -> vn 
    714 #endif 
    715          ! 
    716          ! ...  Define symbolic names for transient fields received by the ocean. 
    717          !      These must be identical to the names specified in the SMIOC file. 
    718          ! 
    719          ! ...  a) U-Grid fields 
    720          ! 
    721          cpl_recv( 1)='TXWOCEWU' ! weighted surface downward eastward stress 
    722          cpl_recv( 2)='TYWOCEWU' ! weighted surface downward northward stress 
    723          cpl_recv( 3)='TXIOCEWU' ! weighted surface downward eastward stress over ice 
    724          cpl_recv( 4)='TYIOCEWU' ! weighted surface downward northward stress over ice 
    725          ! 
    726          ! ...  a) V-Grid fields 
    727          ! 
    728          cpl_recv( 5)='TXWOCEWV' ! weighted surface downward eastward stress 
    729          cpl_recv( 6)='TYWOCEWV' ! weighted surface downward northward stress 
    730          cpl_recv( 7)='TXIOCEWV' ! weighted surface downward eastward stress over ice 
    731          cpl_recv( 8)='TYIOCEWV' ! weighted surface downward northward stress over ice 
    732          ! 
    733          ! ...  a) T-Grid fields 
    734          ! 
    735          cpl_recv( 9)='FRWOCEPE' ! P-E over water                               -> zpew 
    736          cpl_recv(10)='FRIOCEPE' ! P-E over ice                                 -> zpei 
    737          cpl_recv(11)='FRROCESN' ! surface downward snow fall                   -> zpsol 
    738          cpl_recv(12)='FRIOCEEV' ! surface upward snow flux where sea ice       -> zevice 
    739  
    740          cpl_recv(13)='QSWOCESR' ! surface net downward shortwave flux          -> qsr_oce 
    741          cpl_recv(14)='QSWOCENS' ! surface downward non-solar heat flux in air  -> qnsr_oce 
    742          cpl_recv(15)='QSIOCESR' ! solar heat flux on sea ice                   -> qsr_ice 
    743          cpl_recv(16)='QSIOCENS' ! non-solar heat flux on sea ice               -> qnsr_ice 
    744          cpl_recv(17)='QSIOCEDQ' ! non-solar heat flux derivative               -> dqns_ice 
    745  
    746 #ifdef key_cpl_discharge 
    747          cpl_recv(18)='FRWOCEIS' ! ice discharge into ocean                     -> calving 
    748          cpl_recv(19)='FRWOCERD' ! river discharge into ocean                   -> zrunriv 
    749          cpl_recv(20)='FRWOCECD' ! continental discharge into ocean             -> zruncot 
    750 #endif 
    751          IF ( wp == 4 ) data_type = PRISM_REAL 
    752          IF ( wp == 8 ) data_type = PRISM_DOUBLE_PRECISION 
    753  
    754          nodim(1) = 3 ! check 
    755          nodim(2) = 0 
    756          ! 
    757          ! ... Announce send variables, all on T points.  
    758          ! 
    759          DO ji = 1, nsend 
    760             ! if ( ji == 2 ) ; then ; nodim(2) = 2 ; else ; nodim(2) = 0 ; endif 
    761             CALL prism_def_var (send_id(ji), cpl_send(ji), grid_id(1), & 
    762                  tpoint_id(1), tmask_id(1), nodim, shape, data_type, ierror) 
    763             IF ( ierror /= PRISM_Success ) THEN 
    764                PRINT *, 'Failed to define transient ', ji, TRIM(cpl_send(ji)) 
    765                CALL prism_abort ( comp_id, 'OPA9.0', 'cpl_prism_define: Failure in prism_def_var') 
    766             ENDIF 
    767          ENDDO 
    768          ! 
    769          nodim(1) = 3 ! check 
    770          nodim(2) = 0 
    771          ! 
    772          ! ... Announce recv variables.  
    773          ! 
    774          ! ... a) on U points 
    775          ! 
    776          DO ji = 1, 4 
    777             CALL prism_def_var (recv_id(ji), cpl_recv(ji), grid_id(1), & 
    778                  upoint_id(1), umask_id(1), nodim, shape, data_type, ierror) 
    779             IF ( ierror /= PRISM_Success ) THEN 
    780                PRINT *, 'Failed to define transient ', ji, TRIM(cpl_recv(ji)) 
    781                CALL prism_abort ( comp_id, 'OPA9.0', 'cpl_prism_define: Failure in prism_def_var') 
    782             ENDIF 
    783          ENDDO 
    784          ! 
    785          ! ... b) on V points 
    786          ! 
    787          DO ji = 5, 8  
    788             CALL prism_def_var (recv_id(ji), cpl_recv(ji), grid_id(1), & 
    789                  vpoint_id(1), vmask_id(1), nodim, shape, data_type, ierror) 
    790             IF ( ierror /= PRISM_Success ) THEN 
    791                PRINT *, 'Failed to define transient ', TRIM(cpl_recv(ji)) 
    792                CALL prism_abort ( comp_id, 'OPA9.0', 'cpl_prism_define: Failure in prism_def_var') 
    793             ENDIF 
    794          ENDDO 
    795          ! 
    796          ! ... c) on T points 
    797          ! 
    798          DO ji = 9, nrecv 
    799             CALL prism_def_var (recv_id(ji), "SORUNOFF", grid_id(1), & 
    800                  tpoint_id(1), tmask_id(1), nodim, shape, data_type, ierror) 
    801             IF ( ierror /= PRISM_Success ) THEN 
    802                PRINT *, 'Failed to define transient ', TRIM(cpl_recv(ji)) 
    803                CALL prism_abort ( comp_id, 'OPA9.0', 'OPA cpl_prism_define: Failure in prism_def_var') 
    804             ENDIF 
    805          ENDDO 
    806  
    807       ENDIF ! commRank 
    808  
    809       !------------------------------------------------------------------ 
    810       ! 4th End of definition phase 
    811       !------------------------------------------------------------------ 
    812  
    813       IF(lwp) WRITE(numout,*) "ABOUT TO CALL PRISM_ENDDEF"  
    814  
    815       CALL prism_enddef(ierror) 
    816  
    817       IF(lwp) WRITE(numout,*) "DONE ENDDEF",ierror 
    818  
    819       IF ( ierror /= PRISM_Success ) & 
    820          CALL prism_abort ( comp_id, 'OPA9.0', 'cpl_prism_define: Failure in prism_enddef') 
    821          
    822       IF(lwp) WRITE(numout,*) "ALL DONE, EXITING PRISM SET UP PHASE" 
    823   
     313      END DO 
     314       
     315      !------------------------------------------------------------------ 
     316      ! End of definition phase 
     317      !------------------------------------------------------------------ 
     318       
     319      CALL prism_enddef( nerror ) 
     320      IF ( nerror /= PRISM_Success )   CALL prism_abort ( ncomp_id, 'cpl_prism_define', 'Failure in prism_enddef') 
     321       
    824322   END SUBROUTINE cpl_prism_define 
    825  
    826  
    827  
    828    SUBROUTINE cpl_prism_send( var_id, date, data_array, info ) 
    829  
    830       IMPLICIT NONE 
     323    
     324    
     325   SUBROUTINE cpl_prism_snd( kid, kstep, pdata, kinfo ) 
    831326 
    832327      !!--------------------------------------------------------------------- 
    833       !!              ***  ROUTINE cpl_prism_send  *** 
     328      !!              ***  ROUTINE cpl_prism_snd  *** 
    834329      !! 
    835330      !! ** Purpose : - At each coupling time-step,this routine sends fields 
    836331      !!      like sst or ice cover to the coupler or remote application. 
    837       !! 
    838       !! ** Method  : OASIS4 
    839332      !!---------------------------------------------------------------------- 
    840333      !! * Arguments 
    841334      !! 
    842       INTEGER, INTENT( IN )  :: var_id    ! variable Id 
    843       INTEGER, INTENT( OUT ) :: info      ! variable Id 
    844       INTEGER, INTENT( IN )  :: date      ! ocean time-step in seconds 
    845       REAL(wp)               :: data_array(:,:) 
    846       !! 
    847       !! * Local declarations 
    848       !! 
    849 #if defined key_mpp_mpi 
    850       REAL(wp)               :: global_array(jpiglo,jpjglo) 
    851       ! 
    852 !mpi  INTEGER                :: status(MPI_STATUS_SIZE) 
    853 !mpi  INTEGER                :: type       ! MPI data type 
    854       INTEGER                :: request    ! MPI isend request 
    855       INTEGER                :: ji, jj, jn ! local loop indicees 
    856 #else 
    857       INTEGER                :: ji 
    858 #endif 
    859       !! 
    860       INTEGER, SAVE          :: ncount = 0 
     335      INTEGER,                      INTENT( IN    )   :: kid       ! variable intex in the array 
     336      INTEGER,                      INTENT(   OUT )   :: kinfo     ! OASIS4 info argument 
     337      INTEGER,                      INTENT( IN    )   :: kstep     ! ocean time-step in seconds 
     338      REAL(wp), DIMENSION(jpi,jpj), INTENT( IN    )   :: pdata 
     339      !! 
    861340      !! 
    862341      !!-------------------------------------------------------------------- 
    863       !! 
    864       ncount = ncount + 1 
    865  
    866 #if defined key_mpp_mpi 
    867  
    868       request = 0 
    869  
    870       IF ( rootexchg ) THEN 
    871          ! 
    872 !mpi     IF ( wp == 4 ) type = MPI_REAL 
    873 !mpi     IF ( wp == 8 ) type = MPI_DOUBLE_PRECISION 
    874          ! 
    875          ! collect data on the local root process 
    876          ! 
    877          IF ( localRank /= localRoot ) THEN 
    878  
    879             DO jj = nldj, nlej 
    880                DO ji = nldi, nlei 
    881                   exfld(ji-nldi+1,jj-nldj+1)=data_array(ji,jj) 
    882                ENDDO 
    883             ENDDO 
    884  
    885 !mpi        CALL mpi_send(exfld, range(5), type, localRoot, localRank, localComm, ierror) 
    886             CALL mppsend (localRank, exfld, range(5), localRoot, request) 
    887          ENDIF 
    888  
    889          IF ( localRank == localRoot ) THEN 
    890  
    891             DO jj = ranges(3,localRoot), ranges(3,localRoot)+ranges(4,localRoot)-1 
    892                DO ji = ranges(1,localRoot), ranges(1,localRoot)+ranges(2,localRoot)-1 
    893                   global_array(ji,jj) = data_array(ji,jj) ! workaround 
    894                ENDDO 
    895             ENDDO 
    896  
    897             DO jn = 1, localSize-1 
    898  
    899 !mpi           CALL mpi_recv(buffer, ranges(5,jn), type, localRoot, jn, localComm, status, ierror) 
    900                CALL mpprecv(jn, buffer, ranges(5,jn)) 
    901  
    902                DO jj = ranges(3,jn), ranges(3,jn)+ranges(4,jn)-1 
    903                   DO ji = ranges(1,jn), ranges(1,jn)+ranges(2,jn)-1 
    904                      global_array(ji,jj) = buffer( (jj-ranges(3,jn))*ranges(2,jn) + ji-ranges(1,jn)+1 ) 
    905                   ENDDO 
    906                ENDDO 
    907  
    908             ENDDO 
    909  
    910          ENDIF 
    911          ! 
    912          ! send data from local root to OASIS4 
    913          ! 
    914          CALL prism_put ( var_id, dates, dates_bound, global_array, info, ierror )       
    915  
    916       ELSE 
    917          ! 
    918          ! send local data from every process to OASIS4 
    919          ! 
    920          CALL prism_put ( var_id, dates, dates_bound, data_array, info, ierror )       
    921  
    922       ENDIF !rootexchg 
    923  
    924 #else 
    925  
    926       ! 
    927       ! send local data from every process to OASIS4 
    928       ! 
    929       IF ( commRank ) & 
    930       CALL prism_put ( var_id, dates, dates_bound, data_array, info, ierror )       
    931  
    932 #endif 
    933  
    934       IF ( commRank ) THEN 
    935  
    936          IF (l_ctl) THEN 
    937  
    938             IF ( info==PRISM_Cpl ) THEN 
    939                WRITE(numout,*) '****************' 
    940                DO ji = 1, nsend 
    941                   IF (var_id == send_id(ji) ) THEN 
    942                      WRITE(numout,*) 'prism_put_proto: Outgoing ', cpl_send(ji) 
    943                      EXIT 
    944                   ENDIF 
    945                ENDDO 
    946                WRITE(numout,*) 'prism_put: var_id       ', var_id 
    947                WRITE(numout,*) 'prism_put:   date       ', date 
    948                WRITE(numout,*) 'prism_put:   info       ', info 
    949                WRITE(numout,*) '     - Minimum value is ', MINVAL(data_array) 
    950                WRITE(numout,*) '     - Maximum value is ', MAXVAL(data_array) 
    951                WRITE(numout,*) '     -     Sum value is ', SUM(data_array) 
    952                WRITE(numout,*) '****************' 
    953             ENDIF 
    954  
    955          ENDIF 
    956  
    957          IF ( ncount == nrecv ) THEN 
    958             ! 
    959             !  3. Update dates and dates_bound for next step. We assume that cpl_prism_send 
    960             !  is called for all send fields at each time step. Therefore we update 
    961             !  the date argument to prism_put only every nsend call to cpl_prism_send. 
    962             ! 
    963             dates_bound(1) = dates_bound(2) 
    964  
    965             tmpdate    = dates_bound(2) 
    966             date_incr  = rdCplttra(1)/2.0 
    967  
    968             CALL PRISM_calc_newdate ( tmpdate, date_incr, ierror ) 
    969             dates = tmpdate 
    970             CALL PRISM_calc_newdate ( tmpdate, date_incr, ierror ) 
    971             dates_bound(2) = tmpdate 
    972  
    973             ncount = 0 
    974  
    975          ENDIF 
    976  
    977       ENDIF ! commRank 
    978  
    979    END SUBROUTINE cpl_prism_send 
    980  
    981  
    982  
    983    SUBROUTINE cpl_prism_recv(  var_id, date, data_array, info ) 
    984  
    985       IMPLICIT NONE 
     342      ! 
     343      ! snd data to OASIS4 
     344      ! 
     345      exfld(:,:,1) = pdata(nldi:nlei, nldj:nlej) 
     346      CALL prism_put( ssnd(kid)%nid, date, date_bound, exfld, kinfo, nerror ) 
     347      IF ( nerror /= PRISM_Success )   CALL prism_abort( ssnd(kid)%nid, 'cpl_prism_snd',   & 
     348         &                                               'Failure in prism_put for '//TRIM(ssnd(kid)%clname) ) 
     349 
     350      IF ( ln_ctl ) THEN         
     351         IF ( kinfo >= PRISM_Cpl     .OR. kinfo == PRISM_Rst .OR.   & 
     352            & kinfo == PRISM_RstTimeop ) THEN 
     353            WRITE(numout,*) '****************' 
     354            WRITE(numout,*) 'prism_put: Outgoing ', ssnd(kid)%clname 
     355            WRITE(numout,*) 'prism_put: ivarid ', ssnd(kid)%nid 
     356            WRITE(numout,*) 'prism_put:  kstep ', kstep 
     357            WRITE(numout,*) 'prism_put:   info ', kinfo 
     358            WRITE(numout,*) '     - Minimum value is ', MINVAL(pdata) 
     359            WRITE(numout,*) '     - Maximum value is ', MAXVAL(pdata) 
     360            WRITE(numout,*) '     -     Sum value is ', SUM(pdata) 
     361            WRITE(numout,*) '****************' 
     362        ENDIF 
     363     ENDIF 
     364    END SUBROUTINE cpl_prism_snd 
     365 
     366 
     367   SUBROUTINE cpl_prism_rcv( kid, kstep, pdata, kinfo ) 
    986368 
    987369      !!--------------------------------------------------------------------- 
    988       !!              ***  ROUTINE cpl_prism_recv  *** 
     370      !!              ***  ROUTINE cpl_prism_rcv  *** 
    989371      !! 
    990372      !! ** Purpose : - At each coupling time-step,this routine receives fields 
    991373      !!      like stresses and fluxes from the coupler or remote application. 
    992       !! 
    993       !! ** Method  : OASIS4 
    994374      !!---------------------------------------------------------------------- 
    995       !! * Arguments 
    996       !! 
    997       INTEGER, INTENT( IN )  :: var_id    ! variable Id 
    998       INTEGER, INTENT( OUT ) :: info      ! variable Id 
    999       INTEGER, INTENT( IN )  :: date      ! ocean time-step in seconds 
    1000       REAL(wp),INTENT( OUT ) :: data_array(:,:) 
    1001       !! 
    1002       !! * Local declarations 
    1003       !! 
    1004 #if defined key_mpp_mpi 
    1005       REAL(wp)               :: global_array(jpiglo,jpjglo) 
    1006       ! 
    1007       LOGICAL                :: action = .false. 
    1008 !mpi  INTEGER                :: status(MPI_STATUS_SIZE) 
    1009 !mpi  INTEGER                :: type       ! MPI data type 
    1010       INTEGER                :: request    ! MPI isend request 
    1011       INTEGER                :: ji, jj, jn ! local loop indicees 
    1012 #else 
    1013       INTEGER                :: ji 
    1014 #endif 
    1015  
    1016       INTEGER, SAVE          :: ncount = 0 
    1017       !! 
     375      INTEGER,                      INTENT( IN    )   :: kid       ! variable intex in the array 
     376      INTEGER,                      INTENT( IN    )   :: kstep     ! ocean time-step in seconds 
     377      REAL(wp), DIMENSION(jpi,jpj), INTENT( INOUT )   :: pdata     ! IN to keep the value if nothing is done 
     378      INTEGER,                      INTENT(   OUT )   :: kinfo     ! OASIS4 info argument 
     379      !! 
     380      LOGICAL                :: llaction 
    1018381      !!-------------------------------------------------------------------- 
    1019       !! 
    1020       ncount  = ncount + 1 
    1021  
    1022 #ifdef key_mpp_mpi 
    1023  
    1024       request = 0 
    1025  
    1026       IF ( rootexchg ) THEN 
    1027          ! 
    1028          ! receive data from OASIS4 on local root 
    1029          ! 
    1030          IF ( commRank ) & 
    1031          CALL prism_get (var_id, dater, dater_bound, global_array, info, ierror) 
    1032          CALL MPI_BCAST ( info, 1, MPI_INTEGER, localRoot, localComm, ierror ) 
    1033  
    1034       ELSE 
    1035          ! 
    1036          ! receive local data from OASIS4 on every process 
    1037          ! 
    1038          CALL prism_get (var_id, dater, dater_bound, exfld, info, ierror) 
    1039  
    1040       ENDIF 
    1041  
    1042       action = (info==PRISM_CplIO) 
    1043  
    1044       IF ( rootexchg .and. action ) THEN 
    1045          ! 
    1046 !mpi     IF ( wp == 4 ) type = MPI_REAL 
    1047 !mpi     IF ( wp == 8 ) type = MPI_DOUBLE_PRECISION 
    1048          ! 
    1049          ! distribute data to processes 
    1050          ! 
    1051          IF ( localRank == localRoot ) THEN 
    1052  
    1053             DO jj = ranges(3,localRoot), ranges(3,localRoot)+ranges(4,localRoot)-1 
    1054                DO ji = ranges(1,localRoot), ranges(1,localRoot)+ranges(2,localRoot)-1 
    1055                   exfld(ji,jj) = global_array(ji,jj) 
    1056                ENDDO 
    1057             ENDDO 
    1058  
    1059             DO jn = 1, localSize-1 
    1060  
    1061                DO jj = ranges(3,jn), ranges(3,jn)+ranges(4,jn)-1 
    1062                   DO ji = ranges(1,jn), ranges(1,jn)+ranges(2,jn)-1 
    1063                      buffer( (jj-ranges(3,jn))*ranges(2,jn) + ji-ranges(1,jn)+1 ) = global_array(ji,jj) 
    1064                   ENDDO 
    1065                ENDDO 
    1066  
    1067 !mpi           CALL mpi_send(buffer, ranges(5,jn), type, jn, jn, localComm, ierror) 
    1068                CALL mppsend (jn, buffer, ranges(5,jn), jn, request)   
    1069  
    1070             ENDDO 
    1071  
    1072          ENDIF 
    1073  
    1074          IF ( localRank /= localRoot ) & 
    1075 !mpi         CALL mpi_recv(exfld, range(5), type, localRoot, localRank, localComm, status, ierror) 
    1076              CALL mpprecv(localRank, exfld, range(5)) 
    1077       ENDIF 
    1078  
    1079       IF ( action ) THEN 
    1080  
    1081          data_array = 0.0 
    1082  
    1083          DO jj = nldj, nlej 
    1084             DO ji = nldi, nlei 
    1085                data_array(ji,jj)=exfld(ji-nldi+1,jj-nldj+1) 
    1086             ENDDO 
    1087          ENDDO 
    1088  
    1089          IF (l_ctl) THEN         
     382      ! 
     383      ! receive local data from OASIS4 on every process 
     384      ! 
     385      CALL prism_get( srcv(kid)%nid, date, date_bound, exfld, kinfo, nerror )          
     386      IF ( nerror /= PRISM_Success )   CALL prism_abort( srcv(kid)%nid, 'cpl_prism_rcv',   & 
     387         &                                               'Failure in prism_get for '//TRIM(srcv(kid)%clname) ) 
     388 
     389      WRITE(numout,*) 'prism_get: Incoming ', srcv(kid)%clname 
     390      call flush(numout) 
     391      llaction = .false. 
     392      IF( kinfo == PRISM_Cpl )  llaction = .TRUE. 
     393 
     394      IF ( ln_ctl )   WRITE(numout,*) "llaction, kinfo, kstep, ivarid: " , llaction, kinfo, kstep, srcv(kid)%nid 
     395 
     396      IF ( llaction ) THEN 
     397 
     398         kinfo = OASIS_Rcv 
     399         pdata(nldi:nlei, nldj:nlej) = exfld(:,:,1) 
     400          
     401         !--- Fill the overlap areas and extra hallows (mpp) 
     402         !--- check periodicity conditions (all cases) 
     403         CALL lbc_lnk( pdata, srcv(kid)%clgrid, srcv(kid)%nsgn )    
     404          
     405         IF ( ln_ctl ) THEN         
    1090406            WRITE(numout,*) '****************' 
    1091             DO ji = 1, nrecv 
    1092                IF (var_id == recv_id(ji) ) THEN 
    1093                   WRITE(numout,*) 'prism_get: Incoming ', cpl_recv(ji) 
    1094                   EXIT 
    1095                ENDIF 
    1096             ENDDO 
    1097             WRITE(numout,*) 'prism_get: var_id       ', var_id 
    1098             WRITE(numout,*) 'prism_get:   date       ', date 
    1099             WRITE(numout,*) 'prism_get:   info       ', info 
    1100             WRITE(numout,*) '     - Minimum value is ', MINVAL(data_array) 
    1101             WRITE(numout,*) '     - Maximum value is ', MAXVAL(data_array) 
    1102             WRITE(numout,*) '     -     Sum value is ', SUM(data_array) 
     407            WRITE(numout,*) 'prism_get: Incoming ', srcv(kid)%clname 
     408            WRITE(numout,*) 'prism_get: ivarid '  , srcv(kid)%nid 
     409            WRITE(numout,*) 'prism_get:   kstep', kstep 
     410            WRITE(numout,*) 'prism_get:   info ', kinfo 
     411            WRITE(numout,*) '     - Minimum value is ', MINVAL(pdata) 
     412            WRITE(numout,*) '     - Maximum value is ', MAXVAL(pdata) 
     413            WRITE(numout,*) '     -     Sum value is ', SUM(pdata) 
    1103414            WRITE(numout,*) '****************' 
    1104415         ENDIF 
    1105416 
     417      ELSE 
     418         kinfo = OASIS_idle      
    1106419      ENDIF 
    1107 #else 
    1108  
    1109       CALL prism_get (var_id, dater, dater_bound, exfld, info, ierror) 
    1110  
    1111       IF ( info==PRISM_CplIO ) THEN 
    1112                data_array=exfld 
    1113  
    1114          IF (l_ctl) THEN         
    1115             WRITE(numout,*) '****************' 
    1116             DO ji = 1, nrecv 
    1117                IF (var_id == recv_id(ji) ) THEN 
    1118                   WRITE(numout,*) 'prism_get: Incoming ', cpl_recv(ji) 
    1119                   EXIT 
    1120                ENDIF 
    1121             ENDDO 
    1122             WRITE(numout,*) 'prism_get: var_id       ', var_id 
    1123             WRITE(numout,*) 'prism_get:   date       ', date 
    1124             WRITE(numout,*) 'prism_get:   info       ', info 
    1125             WRITE(numout,*) '     - Minimum value is ', MINVAL(data_array) 
    1126             WRITE(numout,*) '     - Maximum value is ', MAXVAL(data_array) 
    1127             WRITE(numout,*) '     -     Sum value is ', SUM(data_array) 
    1128             WRITE(numout,*) '****************' 
    1129          ENDIF 
    1130  
    1131       ENDIF 
    1132  
    1133 #endif 
    1134  
    1135       IF ( ncount == nrecv ) THEN 
    1136          ! 
    1137          !  3. Update dater and dater_bound for next step. We assume that cpl_prism_recv 
    1138          !  is called for all recv fields at each time step. Therefore we update 
    1139          !  the date argument to prism_get only every nrecv call to cpl_prism_recv. 
    1140          ! 
    1141          dater_bound(1) = dater_bound(2) 
    1142  
    1143          tmpdate    = dater_bound(2) 
    1144          date_incr  = rdttra(1)/2.0 
    1145  
    1146          CALL PRISM_calc_newdate ( tmpdate, date_incr, ierror ) 
    1147          dater = tmpdate 
    1148          CALL PRISM_calc_newdate ( tmpdate, date_incr, ierror ) 
    1149          dater_bound(2) = tmpdate 
    1150  
    1151          ncount = 0 
    1152  
    1153       ENDIF 
    1154  
    1155    END SUBROUTINE cpl_prism_recv 
    1156  
     420 
     421 
     422   END SUBROUTINE cpl_prism_rcv 
    1157423 
    1158424 
    1159425   SUBROUTINE cpl_prism_finalize 
    1160  
    1161       IMPLICIT NONE 
    1162426 
    1163427      !!--------------------------------------------------------------------- 
    … …  
    1167431      !!      called explicitly before cpl_prism_init it will also close 
    1168432      !!      MPI communication. 
    1169       !! 
    1170       !! ** Method  : OASIS4 
    1171433      !!---------------------------------------------------------------------- 
    1172434 
    1173435      DEALLOCATE(exfld) 
    1174  
    1175       if ( prism_was_initialized ) then 
    1176  
    1177          call prism_terminated ( prism_was_terminated, ierror ) 
    1178           
    1179          if ( prism_was_terminated ) then 
    1180             print *, 'prism has already been terminated.' 
    1181          else 
    1182             call prism_terminate ( ierror ) 
    1183             prism_was_terminated = .true. 
    1184          endif 
    1185  
    1186       else 
    1187  
    1188          print *, 'Initialize prism before terminating it.' 
    1189  
    1190       endif 
    1191  
     436      CALL prism_terminate ( nerror )          
    1192437 
    1193438   END SUBROUTINE cpl_prism_finalize 
    1194439 
    1195 #else 
    1196  
    1197    !!---------------------------------------------------------------------- 
    1198    !!   Default case           Dummy module         forced Ocean/Atmosphere 
    1199    !!---------------------------------------------------------------------- 
    1200 CONTAINS 
    1201    SUBROUTINE cpl_prism_init             ! Dummy routine 
    1202    END SUBROUTINE cpl_prism_init 
    1203    SUBROUTINE cpl_prism_define           ! Dummy routine 
    1204    END SUBROUTINE cpl_prism_define 
    1205    SUBROUTINE cpl_prism_send             ! Dummy routine 
    1206    END SUBROUTINE cpl_prism_send 
    1207    SUBROUTINE cpl_prism_recv             ! Dummy routine 
    1208    END SUBROUTINE cpl_prism_recv 
    1209    SUBROUTINE cpl_prism_finalize         ! Dummy routine 
    1210    END SUBROUTINE cpl_prism_finalize 
     440   SUBROUTINE cpl_prism_update_time(kt) 
     441 
     442      !!--------------------------------------------------------------------- 
     443      !!              ***  ROUTINE cpl_prism_update_time  *** 
     444      !! 
     445      !! ** Purpose : - Increment date with model timestep 
     446      !!      called explicitly at the end of each timestep 
     447      !!---------------------------------------------------------------------- 
     448 
     449      INTEGER, INTENT(in) ::   kt       ! ocean model time step index 
     450 
     451      TYPE(PRISM_Time_struct)    :: tmpdate 
     452      INTEGER                    :: idate_incr     ! date increment 
     453 
     454 
     455      IF( kt == nit000 ) THEN 
     456      ! 
     457      ! Define the actual date  
     458      ! 
     459      ! date is determined by adding days since beginning of the run to the corresponding initial date. 
     460      ! Note that OPA internal info about the start date of the experiment is bypassed. 
     461      ! Instead we rely sololy on the info provided by the SCC.xml file. 
     462      ! 
     463         date = PRISM_Jobstart_date 
     464         ! 
     465         ! 
     466         ! lower/upper bound is determined by adding half a time step 
     467         ! 
     468         idate_incr = 0.5 * NINT ( rdttra(1) ) 
     469         tmpdate = date   ;   CALL PRISM_calc_newdate ( tmpdate, -idate_incr, nerror )   ;   date_bound(1) = tmpdate 
     470         tmpdate = date   ;   CALL PRISM_calc_newdate ( tmpdate,  idate_incr, nerror )   ;   date_bound(2) = tmpdate 
     471 
     472      ELSE 
     473      ! 
     474      ! Date update 
     475      ! 
     476         idate_incr  = rdttra(1) 
     477         CALL PRISM_calc_newdate( date, idate_incr, nerror ) 
     478         date_bound(1) = date_bound(2) 
     479         tmpdate = date_bound(2) 
     480         CALL PRISM_calc_newdate( tmpdate, idate_incr, nerror ) 
     481         date_bound(2) = tmpdate 
     482 
     483      END IF 
     484 
     485   END SUBROUTINE cpl_prism_update_time 
    1211486 
    1212487#endif 
Note: See TracChangeset for help on using the changeset viewer.