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 2506 for branches/nemo_v3_3_beta – NEMO

Ignore:
Timestamp:
2010-12-23T11:40:44+01:00 (13 years ago)
Author:
smasson
Message:

v33b: toward coupling with OASIS4, see ticket #580

File:
1 edited

Legend:

Unmodified
Added
Removed

  • branches/nemo_v3_3_beta/NEMOGCM/NEMO/OPA_SRC/SBC/cpl_oasis4.F90

    r2329 r2506  
    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  
    119    !!---------------------------------------------------------------------- 
    120    !! NEMO/OPA 3.3 , NEMO Consortium (2010) 
    121    !! $Id$ 
    122    !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 
     70   !!---------------------------------------------------------------------- 
     71   !!   OPA 9.0 , LOCEAN-IPSL (2006)  
     72   !! $Header$  
     73   !! Software governed by the CeCILL licence (modipsl/doc/NEMO_CeCILL.txt) 
    12374   !!---------------------------------------------------------------------- 
    12475 
    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       REWIND( numnam ) 
    157       READ  ( numnam, nam_mpp ) 
    158       REWIND( numnam ) 
    159  
    160       !------------------------------------------------------------------ 
    161       ! 1st Initialize the PRISM system for the application 
    162       !------------------------------------------------------------------ 
    163  
    164       CALL prism_initialized (prism_was_initialized, ierror) 
    165       IF ( ierror /= PRISM_Success ) & 
    166          CALL prism_abort( comp_id, 'OPA9.0', 'cpl_prism_init: Failure in prism_initialized' ) 
    167  
    168       IF ( .NOT. prism_was_initialized ) THEN 
    169          CALL prism_init( app_name, ierror ) 
    170          IF ( ierror /= PRISM_Success ) & 
    171             CALL prism_abort(comp_id, 'OPA9.0', 'cpl_prism_init: Failure in prism_init') 
    172          prism_was_initialized = .true. 
    173       ELSE 
    174          call prism_abort(comp_id, 'OPA9.0', 'cpl_prism_init: Do not initialize prism twice!') 
    175       ENDIF 
    176       ! 
    177       ! Obtain the actual dates and date bounds 
    178       ! 
    179       ! date is determined by adding days since beginning of 
    180       !   the run to the corresponding initial date. Note that 
    181       !   OPA internal info about the start date of the experiment 
    182       !   is bypassed. Instead we rely sololy on the info provided 
    183       !   by the SCC.xml file.  
    184       ! 
    185       dates   = PRISM_Jobstart_date 
    186  
    187       WRITE(6,*) "PRISM JOB START DATE IS", dates 
    188  
    189       ! 
    190       ! upper bound is determined by adding half a time step 
    191       ! 
    192       tmpdate = dates 
    193       date_incr = rdttra(1)/2.0 
    194       CALL PRISM_calc_newdate ( tmpdate, date_incr, ierror ) 
    195       dates_bound(2) = tmpdate 
    196       ! 
    197       ! lower bound is determined by half distance to date from previous run 
    198       ! 
    199       tmpdate   = dates 
    200       date_incr = ( adatrj - adatrj0 ) * 43200.0 
    201       CALL PRISM_calc_newdate ( tmpdate, date_incr, ierror ) 
    202       dates_bound(1) = tmpdate 
    203  
    204       dater = dates 
    205       dater_bound(1) = dates_bound(1)  
    206       dater_bound(2) = dates_bound(2)  
    207  
    208       WRITE(6,*) "DATE send and rec BOUNDS",dater_bound 
    209       WRITE(6,*) "OTHER BITS FOR DATE",rdttra(1) 
    210       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 ) 
    21192 
    21293      !------------------------------------------------------------------ 
    21394      ! 2nd Initialize the PRISM system for the component 
    21495      !------------------------------------------------------------------ 
    215  
    216       CALL prism_init_comp ( comp_id, comp_name, ierror ) 
    217       IF ( ierror /= PRISM_Success ) & 
    218          CALL prism_abort (comp_id, 'OPA9.0', 'cpl_prism_init: Failure in prism_init_comp') 
    219  
    220       WRITE(6,*) "COMPLETED INIT_COMP",comp_name,comp_id 
    221  
    222       !------------------------------------------------------------------ 
    223       ! 3rd Get an MPI communicator for OPA local communication 
    224       !------------------------------------------------------------------ 
    225  
    226       CALL prism_get_localcomm ( comp_id, localComm, ierror ) 
    227       IF ( ierror /= PRISM_Success ) & 
    228          CALL prism_abort (comp_id, 'OPA9.0', 'cpl_prism_init: Failure in prism_get_localcomm' ) 
    229  
    230       localCommunicator = localComm 
    231  
    232        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' ) 
    233104 
    234105 
    … …  
    236107 
    237108 
    238    SUBROUTINE cpl_prism_define () 
    239  
    240       IMPLICIT NONE 
     109   SUBROUTINE cpl_prism_define (krcv, ksnd) 
    241110 
    242111      !!------------------------------------------------------------------- 
    … …  
    248117      !! ** Method  :   OASIS4 MPI communication  
    249118      !!-------------------------------------------------------------------- 
    250       !! * Arguments 
    251       !! 
    252       !! * Local declarations 
    253  
    254       INTEGER                    :: grid_id(2)     ! id returned by prism_def_grid 
    255  
    256       INTEGER                    :: upoint_id(2), & 
    257                                     vpoint_id(2), & 
    258                                     tpoint_id(2), & 
    259                                     fpoint_id(2)   ! ids returned by prism_set_points 
    260  
    261       INTEGER                    :: umask_id(2), & 
    262                                     vmask_id(2), & 
    263                                     tmask_id(2), & 
    264                                     fmask_id(2)    ! ids returned by prism_set_mask 
    265  
    266       INTEGER                    :: grid_type      ! PRISM grid type 
    267  
    268       INTEGER                    :: shape(2,3)     ! shape of arrays passed to PSMILe 
    269       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 
    270135      INTEGER                    :: data_type      ! data type of transients 
    271136 
    272       INTEGER                    :: nbr_corners 
    273137 
    274138      LOGICAL                    :: new_points 
    275139      LOGICAL                    :: new_mask 
    276       LOGICAL                    :: mask(jpi,jpj,jpk) 
    277  
    278       INTEGER                    :: ji, jj, jk     ! local loop indicees 
    279  
    280       CHARACTER(len=32)          :: cpl_send (nsend) 
    281       CHARACTER(len=32)          :: cpl_recv (nrecv) 
    282  
    283       CHARACTER(len=32)          :: grid_name      ! name of the grid 
    284       CHARACTER(len=32)          :: point_name     ! name of the grid points 
    285  
    286       REAL(kind=wp), ALLOCATABLE :: rclon(:,:,:) 
    287       REAL(kind=wp), ALLOCATABLE :: rclat(:,:,:) 
    288       REAL(kind=wp), ALLOCATABLE :: rcz  (:,:) 
    289  
     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      !! 
    290156      !!-------------------------------------------------------------------- 
    291       
     157 
    292158      IF(lwp) WRITE(numout,*) 
    293159      IF(lwp) WRITE(numout,*) 'cpl_prism_define : initialization in coupled ocean/atmosphere case' 
    294160      IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~~~~~' 
    295161      IF(lwp) WRITE(numout,*) 
    296       
    297       ! ----------------------------------------------------------------- 
    298       ! ... Some initialisation 
    299       ! ----------------------------------------------------------------- 
    300  
    301       send_id = 0 
    302       recv_id = 0 
    303  
    304 #if defined key_mpp_mpi 
    305  
    306       ! ----------------------------------------------------------------- 
    307       ! ... Some MPI stuff relevant for optional exchange via root only 
    308       ! ----------------------------------------------------------------- 
    309  
    310       commRank = .false. 
    311  
    312       localRank = mpprank ! from lib_mpp 
    313       localSize = mppsize ! from lib_mpp 
    314  
    315       IF(lwp) WRITE(numout,*) "CALLING DEFINE" 
    316  
    317       IF ( rootexchg ) THEN 
    318          IF ( localRank == localRoot ) commRank = .true. 
    319       ELSE 
    320          commRank = .true. 
    321       ENDIF 
    322  
    323 #else 
    324       ! 
    325       ! For non-parallel configurations the one and only process ("localRoot") 
    326       ! takes part in the communication 
    327       !  
    328       localRank = localRoot 
    329       commRank = .true. 
    330  
    331 #endif 
    332  
    333       ! ----------------------------------------------------------------- 
     162 
     163      ! 
    334164      ! ... Allocate memory for data exchange 
    335       ! ----------------------------------------------------------------- 
    336  
    337  
    338       IF(lwp) WRITE(numout,*) "Abbout to allocate exfld",jpi,jpj 
    339  
    340       ALLOCATE(exfld(1:jpi,1:jpj), stat = ierror) 
    341       IF (ierror > 0) THEN 
    342          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' ) 
    343169         RETURN 
    344170      ENDIF 
    345171 
    346       IF ( rootexchg .and. localRank == localRoot ) THEN 
    347          ALLOCATE(ranges(5,0:localSize-1), stat = ierror) 
    348          IF (ierror > 0) THEN 
    349             CALL prism_abort ( comp_id, 'OPA9.0', 'cpl_prism_define: Failure in allocating Integer') 
    350             RETURN 
    351          ENDIF 
    352       ENDIF 
    353  
    354       !------------------------------------------------------------------ 
    355       ! 1st Declare the local grid (ORCA tripolar) characteristics for 
    356       !     surface coupling. The halo regions must be excluded. For 
    357       !     surface coupling it is sufficient to specify only one 
    358       !     vertical z-level. 
    359       !------------------------------------------------------------------ 
    360  
    361       grid_type = PRISM_irrlonlat_regvrt 
    362  
    363       IF(lwp) WRITE(numout,*) "Set grid type" 
    364  
    365  
    366       ! ----------------------------------------------------------------- 
    367       ! ... 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 
    368175      !     For serial configuration (key_mpp_mpi not being active) 
    369176      !     nl* is set to the global values 1 and jp*glo. 
    370177      ! ----------------------------------------------------------------- 
    371178 
    372       IF ( rootexchg ) THEN 
    373          shape(1,1) = 1+jpreci 
    374          shape(2,1) = jpiglo-jpreci 
    375          shape(1,2) = 1+jpreci 
    376          shape(2,2) = jpjglo-jpreci 
    377          shape(1,3) = 1 
    378          shape(2,3) = 1 
    379       ELSE 
    380          shape(1,1) = 1+jpreci 
    381          shape(2,1) = jpi-jpreci 
    382          shape(1,2) = 1+jpreci 
    383          shape(2,2) = jpj-jpreci 
    384          shape(1,3) = 1 
    385          shape(2,3) = 1 
    386       ENDIF 
    387  
    388       IF(lwp) WRITE(numout,*) "commrank is", commRank 
    389  
    390       IF ( commRank ) THEN 
    391  
    392          IF(lwp) WRITE(numout,*) "CALLING DEF_GRID" 
    393  
    394          IF(lwp) WRITE(numout,*) "grid name",grid_name 
    395          IF(lwp) WRITE(numout,*) " shape",shape 
    396          IF(lwp) WRITE(numout,*) "grid type",grid_type 
    397  
    398          CALL prism_def_grid ( grid_id(1), grid_name, comp_id, shape, & 
    399               grid_type, ierror ) 
    400          IF ( ierror /= PRISM_Success ) THEN 
    401             PRINT *, 'OPA cpl_prism_define: Failure in prism_def_grid' 
    402             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 
    403293         ENDIF 
    404  
    405          !------------------------------------------------------------------ 
    406          ! 2nd Declare the geometic information for this grid. 
    407          !------------------------------------------------------------------ 
    408  
    409          ! ----------------------------------------------------------------- 
    410          ! ... Redefine shape which may now include the halo region as well. 
    411          ! ----------------------------------------------------------------- 
    412  
    413          shape(1,1) = 1 
    414          shape(2,1) = jpi 
    415          shape(1,2) = 1 
    416          shape(2,2) = jpj 
    417          shape(1,3) = 1 
    418          shape(2,3) = 1 
    419  
    420          IF(lwp) WRITE(numout,*) "redefined shape",shape 
    421  
    422          ! ----------------------------------------------------------------- 
    423          ! ... Define the elements, i.e. specify the corner points for each 
    424          !     volume element. In case OPA runs on level coordinates (regular 
    425          !     in the vertical) we only need to give the 4 horizontal corners 
    426          !     for a volume element plus the vertical position of the upper 
    427          !     and lower face. Nevertheless the volume element has 8 corners. 
    428          ! ----------------------------------------------------------------- 
    429  
    430          ! 
    431          ! ... Treat corners in the horizontal plane 
    432          ! 
    433          ALLOCATE(rclon(shape(1,1):shape(2,1),shape(1,2):shape(2,2),4), & 
    434               STAT=ierror) 
    435          IF ( ierror /= 0 ) & 
    436               CALL prism_abort ( comp_id, 'OPA9.0', 'cpl_prism_define: error in allocate for rclon') 
    437  
    438          ALLOCATE(rclat(shape(1,1):shape(2,1),shape(1,2):shape(2,2),4), & 
    439               STAT=ierror) 
    440          IF ( ierror /= 0 ) & 
    441               CALL prism_abort ( comp_id, 'OPA9.0', 'cpl_prism_define: error in allocate for rclon') 
    442  
    443          nbr_corners = 8 
    444          ! 
    445          ! ... Set right longitudes and upper latitudes 
    446          ! 
    447          DO jj = shape(1,2), shape(2,2) 
    448             DO ji = shape(1,1), shape(2,1) 
    449                rclon(ji,jj,1) = glamu(ji,jj) 
    450                rclon(ji,jj,2) = glamu(ji,jj) 
    451                rclat(ji,jj,2) = gphiv(ji,jj) 
    452                rclat(ji,jj,3) = gphiv(ji,jj) 
    453             ENDDO 
    454          ENDDO 
    455          ! 
    456          ! ... Set the lower latitudes 
    457          ! 
    458          DO jj = shape(1,2)+1, shape(2,2) 
    459             DO ji = shape(1,1), shape(2,1) 
    460                rclat(ji,jj-1,1) = rclat(ji,jj,2) 
    461                rclat(ji,jj-1,4) = rclat(ji,jj,3) 
    462             ENDDO 
    463          ENDDO 
    464          ! 
    465          ! ... Set the left longitudes 
    466          ! 
    467          DO jj = shape(1,2), shape(2,2) 
    468             DO ji = shape(1,1)+1, shape(2,1) 
    469                rclon(ji-1,jj,3) = rclon(ji,jj,2) 
    470                rclon(ji-1,jj,4) = rclon(ji,jj,1) 
    471             ENDDO 
    472          ENDDO 
    473          ! 
    474          ! ... Set the lowermost latitudes  
    475          ! 
    476          DO jj = shape(1,2), shape(1,2) 
    477             DO ji = shape(1,1), shape(2,1) 
    478                rclat(ji,jj,1) = 2.0*gphit(ji,jj)-rclat(ji,jj,2) 
    479                rclat(ji,jj,4) = 2.0*gphit(ji,jj)-rclat(ji,jj,4) 
    480             ENDDO 
    481          ENDDO 
    482          ! 
    483          ! ... Set the rightmost latitudes  
    484          ! 
    485          DO jj = shape(1,2), shape(2,2) 
    486             DO ji = shape(1,2), shape(1,2) 
    487                rclon(ji,jj,3) = 2.0*glamt(ji,jj)-rclon(ji,jj,2) 
    488                rclon(ji,jj,4) = 2.0*glamt(ji,jj)-rclon(ji,jj,1) 
    489  
    490                WRITE(76,*) "rclon", ji, jj, rclon(ji,jj,1), & 
    491                                             rclon(ji,jj,2), & 
    492                                             rclon(ji,jj,3), & 
    493                                             rclon(ji,jj,4) 
    494  
    495                WRITE(76,*) "rclat", ji, jj, rclat(ji,jj,1), & 
    496                                             rclat(ji,jj,2), & 
    497                                             rclat(ji,jj,3), & 
    498                                             rclat(ji,jj,4) 
    499  
    500             ENDDO 
    501          ENDDO 
    502  
    503          ! 
    504          ! ... Treat corners along the vertical axis 
    505          ! 
    506          ALLOCATE(rcz(shape(1,3):shape(2,3),2), STAT=ierror) 
    507          IF ( ierror /= 0 ) & 
    508               CALL prism_abort ( comp_id, 'OPA9.0', 'cpl_prism_define: error in allocate for rcz') 
    509  
    510          DO jk = shape(1,3), shape(2,3) 
    511             rcz(jk,1) = gdepw(jk) 
    512             rcz(jk,2) = gdepw(jk+1) 
    513          ENDDO 
    514  
    515          IF(lwp) WRITE(numout,*) "ABOUT TO CALL SET CORNERS",shape  
    516  
    517          CALL prism_set_corners ( grid_id(1), nbr_corners, shape, rclon, rclat, & 
    518               rcz, ierror) 
    519          IF ( ierror /= PRISM_Success ) & 
    520               CALL prism_abort ( comp_id, 'OPA9.0', 'cpl_prism_define: Failure in prism_set_corners') 
    521  
    522          DEALLOCATE(rclon, rclat, rcz) 
    523  
    524          ! ----------------------------------------------------------------- 
    525          ! ... Define the gridpoints   
    526          ! ----------------------------------------------------------------- 
    527  
    528          new_points = .TRUE. 
    529  
    530          IF(lwp) WRITE(numout,*) "CALLING SET_POINTS" 
    531  
    532          ! 
    533          ! ... the u-points 
    534          ! 
    535          point_name = 'u-points' 
    536          CALL prism_set_points ( upoint_id(1), point_name, grid_id(1), shape,      & 
    537               glamu, gphiu, gdept(shape(1,3):shape(2,3)), new_points, ierror ) 
    538          IF ( ierror /= PRISM_Success ) & 
    539               CALL prism_abort ( comp_id, 'OPA9.0', 'cpl_prism_define: Failure in prism_set_points upoint_id') 
    540          ! 
    541          ! ... the v-points 
    542          ! 
    543  
    544          IF(lwp) WRITE(numout,*) "CALLING SET_POINTS done u doing v" 
    545  
    546          point_name = 'v-points' 
    547          CALL prism_set_points ( vpoint_id(1), point_name, grid_id(1), shape,      & 
    548               glamv, gphiv, gdept(shape(1,3):shape(2,3)), new_points, ierror )       
    549          IF ( ierror /= PRISM_Success ) & 
    550               CALL prism_abort ( comp_id, 'OPA9.0', 'cpl_prism_define: Failure in prism_set_points vpoint_id') 
    551          ! 
    552          ! ... the t-points 
    553          ! 
    554          ! WRITE(76,*) 'CALLING T POINTS', shape 
    555          ! WRITE(77,*) 'glamt', glamt 
    556          ! WRITE(78,*) 'gphit', gphit 
    557          ! 
    558          point_name = 't-points' 
    559          CALL prism_set_points ( tpoint_id(1), point_name, grid_id(1), shape,   & 
    560               glamt, gphit, gdept(shape(1,3):shape(2,3)), new_points, ierror ) 
    561          IF ( ierror /= PRISM_Success ) & 
    562               CALL prism_abort ( comp_id, 'OPA9.0', 'cpl_prism_define: Failure in prism_set_points tpoint_id') 
    563          ! 
    564          ! ... the f-points 
    565          ! 
    566          point_name = 'f-points' 
    567          CALL prism_set_points ( fpoint_id(1), point_name, grid_id(1), shape,   & 
    568               glamf, gphif, gdept(shape(1,3):shape(2,3)), new_points, ierror ) 
    569          IF ( ierror /= PRISM_Success ) & 
    570               CALL prism_abort ( comp_id, 'OPA9.0', 'cpl_prism_define: Failure in prism_set_points fpoint_id') 
    571  
    572  
    573          IF(lwp) WRITE(numout,*) "CALLING SET_POINTS done f" 
    574  
    575          ! ----------------------------------------------------------------- 
    576          ! ... Convert OPA masks to logicals and define the masks 
    577          ! ----------------------------------------------------------------- 
    578  
    579          new_mask = .true. 
    580  
    581          mask = (umask == 1) 
    582          CALL prism_set_mask (umask_id(1), grid_id(1), shape, & 
    583                  mask(shape(1,1):shape(2,1),                  & 
    584                       shape(1,2):shape(2,2),                  & 
    585                       shape(1,3):shape(2,3)),                 & 
    586               new_mask, ierror ) 
    587          IF ( ierror /= PRISM_Success ) & 
    588               CALL prism_abort ( comp_id, 'OPA9.0', 'cpl_prism_define: Failure in prism_set_mask umask_id') 
    589  
    590          mask = (vmask == 1) 
    591          CALL prism_set_mask (vmask_id(1), grid_id(1), shape, & 
    592                  mask(shape(1,1):shape(2,1),                  & 
    593                       shape(1,2):shape(2,2),                  & 
    594                       shape(1,3):shape(2,3)),                 & 
    595               new_mask, ierror ) 
    596          IF ( ierror /= PRISM_Success ) & 
    597               CALL prism_abort ( comp_id, 'OPA9.0', 'cpl_prism_define: Failure in prism_set_mask umask_id') 
    598  
    599          mask = (tmask == 1) 
    600          CALL prism_set_mask (tmask_id(1), grid_id(1), shape, & 
    601                  mask(shape(1,1):shape(2,1),                  & 
    602                       shape(1,2):shape(2,2),                  & 
    603                       shape(1,3):shape(2,3)),                 & 
    604               new_mask, ierror ) 
    605          IF ( ierror /= PRISM_Success ) & 
    606               CALL prism_abort ( comp_id, 'OPA9.0', 'cpl_prism_define: Failure in prism_set_mask umask_id') 
    607  
    608          mask = (fmask == 1) 
    609          CALL prism_set_mask (fmask_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          IF(lwp) WRITE(numout,*) "DONE ALL THE SET MASKS" 
    618  
    619          ! ----------------------------------------------------------------- 
    620          ! ... Define the angles 
    621          !   This is needed if zonal tau is not oriented E-W and meridional 
    622          !   tau is not oriented along N-S but rather along local coordinate 
    623          !   axis. Please check!!!! 
    624          ! ----------------------------------------------------------------- 
    625  
    626 !rr      cal prism_set_angles ( ..., ierror ) ! not yet supported by OASIS4 
    627  
    628          ! ----------------------------------------------------------------- 
    629          ! ... Define the partition  
    630          ! ----------------------------------------------------------------- 
    631           
    632          IF ( rootexchg ) THEN 
    633  
    634             range(1) = nimpp-1+nldi   ! global start in i 
    635             range(2) = nlei-nldi+1    ! local size in i of valid region 
    636             range(3) = njmpp-1+nldj   ! global start in j 
    637             range(4) = nlej-nldj+1    ! local size in j of valid region 
    638             range(5) = range(2) & 
    639                      * range(4)       ! local horizontal size 
    640             ! 
    641             ! Collect ranges from all NEMO procs on the local root process 
    642             ! 
    643             CALL mpi_gather(range,  5, MPI_INTEGER, & 
    644                             ranges, 5, MPI_INTEGER, localRoot, localComm, ierror) 
    645  
    646             IF ( localRank == localRoot ) THEN 
    647  
    648                maxlen = maxval(ranges(5,:)) 
    649  
    650                ALLOCATE(buffer(1:maxlen), stat = ierror) 
    651                IF (ierror > 0) THEN 
    652                   CALL prism_abort ( comp_id, 'OPA9.0', 'cpl_prism_define: Failure in allocating buffer') 
    653                   RETURN 
    654                ENDIF 
    655  
    656             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)) 
    657311 
    658312         ENDIF 
    659  
    660          ! ----------------------------------------------------------------- 
    661          ! ... Define the scalefactors  
    662          ! ----------------------------------------------------------------- 
    663  
    664 !rr      WRITE(numout,*) "CALLING SCALEFACTOR" 
    665 !rr      call prism_set_scalefactor ( grid_id(1), shape, e1t, e2t, e3t, ierror )  ! not yet supported by OASIS4 
    666 !rr      WRITE(numout,*) "ABOUT TO DEFINE THE TRANSIENTS" 
    667  
    668          !------------------------------------------------------------------ 
    669          ! 3rd Declare the transient variables 
    670          !------------------------------------------------------------------ 
    671          ! 
    672          ! ... Define symbolic names for the transient fields send by the ocean 
    673          !     These must be identical to the names specified in the SMIOC file. 
    674          ! 
    675          cpl_send( 1)='SOSSTSST' ! sea surface temperature              -> sst_io 
    676          cpl_send( 2)='SITOCEAN' ! sea ice thickness                    -> hicif (only 1 layer available!) 
    677 #if defined key_cpl_albedo 
    678          cpl_send( 3)='STIOCEAN' ! surface temperature over sea ice     -> tn_ice 
    679          cpl_send( 4)='SAIOCEAN' ! albedo over sea ice                  -> alb_ice 
    680 #else 
    681          cpl_send( 3)='SITOCEAN' ! sea ice thickness                    -> hicif (only 1 layer available!) 
    682          cpl_send( 4)='SNTOCEAN' ! surface snow thickness over sea ice  -> hsnif 
    683 #endif 
    684 #if defined key_cpl_ocevel 
    685          cpl_send( 5)='SUNOCEAN' ! U-velocity                           -> un 
    686          cpl_send( 6)='SVNOCEAN' ! V-velocity                           -> vn 
    687 #endif 
    688          ! 
    689          ! ...  Define symbolic names for transient fields received by the ocean. 
    690          !      These must be identical to the names specified in the SMIOC file. 
    691          ! 
    692          ! ...  a) U-Grid fields 
    693          ! 
    694          cpl_recv( 1)='TXWOCEWU' ! weighted surface downward eastward stress 
    695          cpl_recv( 2)='TYWOCEWU' ! weighted surface downward northward stress 
    696          cpl_recv( 3)='TXIOCEWU' ! weighted surface downward eastward stress over ice 
    697          cpl_recv( 4)='TYIOCEWU' ! weighted surface downward northward stress over ice 
    698          ! 
    699          ! ...  a) V-Grid fields 
    700          ! 
    701          cpl_recv( 5)='TXWOCEWV' ! weighted surface downward eastward stress 
    702          cpl_recv( 6)='TYWOCEWV' ! weighted surface downward northward stress 
    703          cpl_recv( 7)='TXIOCEWV' ! weighted surface downward eastward stress over ice 
    704          cpl_recv( 8)='TYIOCEWV' ! weighted surface downward northward stress over ice 
    705          ! 
    706          ! ...  a) T-Grid fields 
    707          ! 
    708          cpl_recv( 9)='FRWOCEPE' ! P-E over water                               -> zpew 
    709          cpl_recv(10)='FRIOCEPE' ! P-E over ice                                 -> zpei 
    710          cpl_recv(11)='FRROCESN' ! surface downward snow fall                   -> zpsol 
    711          cpl_recv(12)='FRIOCEEV' ! surface upward snow flux where sea ice       -> zevice 
    712  
    713          cpl_recv(13)='QSWOCESR' ! surface net downward shortwave flux          -> qsr_oce 
    714          cpl_recv(14)='QSWOCENS' ! surface downward non-solar heat flux in air  -> qnsr_oce 
    715          cpl_recv(15)='QSIOCESR' ! solar heat flux on sea ice                   -> qsr_ice 
    716          cpl_recv(16)='QSIOCENS' ! non-solar heat flux on sea ice               -> qnsr_ice 
    717          cpl_recv(17)='QSIOCEDQ' ! non-solar heat flux derivative               -> dqns_ice 
    718  
    719 #ifdef key_cpl_discharge 
    720          cpl_recv(18)='FRWOCEIS' ! ice discharge into ocean                     -> calving 
    721          cpl_recv(19)='FRWOCERD' ! river discharge into ocean                   -> zrunriv 
    722          cpl_recv(20)='FRWOCECD' ! continental discharge into ocean             -> zruncot 
    723 #endif 
    724          IF ( wp == 4 ) data_type = PRISM_REAL 
    725          IF ( wp == 8 ) data_type = PRISM_DOUBLE_PRECISION 
    726  
    727          nodim(1) = 3 ! check 
    728          nodim(2) = 0 
    729          ! 
    730          ! ... Announce send variables, all on T points.  
    731          ! 
    732          DO ji = 1, nsend 
    733             ! if ( ji == 2 ) ; then ; nodim(2) = 2 ; else ; nodim(2) = 0 ; endif 
    734             CALL prism_def_var (send_id(ji), cpl_send(ji), grid_id(1), & 
    735                  tpoint_id(1), tmask_id(1), nodim, shape, data_type, ierror) 
    736             IF ( ierror /= PRISM_Success ) THEN 
    737                PRINT *, 'Failed to define transient ', ji, TRIM(cpl_send(ji)) 
    738                CALL prism_abort ( comp_id, 'OPA9.0', 'cpl_prism_define: Failure in prism_def_var') 
    739             ENDIF 
    740          ENDDO 
    741          ! 
    742          nodim(1) = 3 ! check 
    743          nodim(2) = 0 
    744          ! 
    745          ! ... Announce recv variables.  
    746          ! 
    747          ! ... a) on U points 
    748          ! 
    749          DO ji = 1, 4 
    750             CALL prism_def_var (recv_id(ji), cpl_recv(ji), grid_id(1), & 
    751                  upoint_id(1), umask_id(1), nodim, shape, data_type, ierror) 
    752             IF ( ierror /= PRISM_Success ) THEN 
    753                PRINT *, 'Failed to define transient ', ji, TRIM(cpl_recv(ji)) 
    754                CALL prism_abort ( comp_id, 'OPA9.0', 'cpl_prism_define: Failure in prism_def_var') 
    755             ENDIF 
    756          ENDDO 
    757          ! 
    758          ! ... b) on V points 
    759          ! 
    760          DO ji = 5, 8  
    761             CALL prism_def_var (recv_id(ji), cpl_recv(ji), grid_id(1), & 
    762                  vpoint_id(1), vmask_id(1), nodim, shape, data_type, ierror) 
    763             IF ( ierror /= PRISM_Success ) THEN 
    764                PRINT *, 'Failed to define transient ', TRIM(cpl_recv(ji)) 
    765                CALL prism_abort ( comp_id, 'OPA9.0', 'cpl_prism_define: Failure in prism_def_var') 
    766             ENDIF 
    767          ENDDO 
    768          ! 
    769          ! ... c) on T points 
    770          ! 
    771          DO ji = 9, nrecv 
    772             CALL prism_def_var (recv_id(ji), "SORUNOFF", grid_id(1), & 
    773                  tpoint_id(1), tmask_id(1), nodim, shape, data_type, ierror) 
    774             IF ( ierror /= PRISM_Success ) THEN 
    775                PRINT *, 'Failed to define transient ', TRIM(cpl_recv(ji)) 
    776                CALL prism_abort ( comp_id, 'OPA9.0', 'OPA cpl_prism_define: Failure in prism_def_var') 
    777             ENDIF 
    778          ENDDO 
    779  
    780       ENDIF ! commRank 
    781  
    782       !------------------------------------------------------------------ 
    783       ! 4th End of definition phase 
    784       !------------------------------------------------------------------ 
    785  
    786       IF(lwp) WRITE(numout,*) "ABOUT TO CALL PRISM_ENDDEF"  
    787  
    788       CALL prism_enddef(ierror) 
    789  
    790       IF(lwp) WRITE(numout,*) "DONE ENDDEF",ierror 
    791  
    792       IF ( ierror /= PRISM_Success ) & 
    793          CALL prism_abort ( comp_id, 'OPA9.0', 'cpl_prism_define: Failure in prism_enddef') 
    794          
    795       IF(lwp) WRITE(numout,*) "ALL DONE, EXITING PRISM SET UP PHASE" 
    796   
     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       
    797322   END SUBROUTINE cpl_prism_define 
    798  
    799  
    800  
    801    SUBROUTINE cpl_prism_send( var_id, date, data_array, info ) 
    802  
    803       IMPLICIT NONE 
     323    
     324    
     325   SUBROUTINE cpl_prism_snd( kid, kstep, pdata, kinfo ) 
    804326 
    805327      !!--------------------------------------------------------------------- 
    806       !!              ***  ROUTINE cpl_prism_send  *** 
     328      !!              ***  ROUTINE cpl_prism_snd  *** 
    807329      !! 
    808330      !! ** Purpose : - At each coupling time-step,this routine sends fields 
    809331      !!      like sst or ice cover to the coupler or remote application. 
    810       !! 
    811       !! ** Method  : OASIS4 
    812332      !!---------------------------------------------------------------------- 
    813333      !! * Arguments 
    814334      !! 
    815       INTEGER, INTENT( IN )  :: var_id    ! variable Id 
    816       INTEGER, INTENT( OUT ) :: info      ! variable Id 
    817       INTEGER, INTENT( IN )  :: date      ! ocean time-step in seconds 
    818       REAL(wp)               :: data_array(:,:) 
    819       !! 
    820       !! * Local declarations 
    821       !! 
    822 #if defined key_mpp_mpi 
    823       REAL(wp)               :: global_array(jpiglo,jpjglo) 
    824       ! 
    825 !mpi  INTEGER                :: status(MPI_STATUS_SIZE) 
    826 !mpi  INTEGER                :: type       ! MPI data type 
    827       INTEGER                :: request    ! MPI isend request 
    828       INTEGER                :: ji, jj, jn ! local loop indicees 
    829 #else 
    830       INTEGER                :: ji 
    831 #endif 
    832       !! 
    833       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      !! 
    834340      !! 
    835341      !!-------------------------------------------------------------------- 
    836       !! 
    837       ncount = ncount + 1 
    838  
    839 #if defined key_mpp_mpi 
    840  
    841       request = 0 
    842  
    843       IF ( rootexchg ) THEN 
    844          ! 
    845 !mpi     IF ( wp == 4 ) type = MPI_REAL 
    846 !mpi     IF ( wp == 8 ) type = MPI_DOUBLE_PRECISION 
    847          ! 
    848          ! collect data on the local root process 
    849          ! 
    850          IF ( localRank /= localRoot ) THEN 
    851  
    852             DO jj = nldj, nlej 
    853                DO ji = nldi, nlei 
    854                   exfld(ji-nldi+1,jj-nldj+1)=data_array(ji,jj) 
    855                ENDDO 
    856             ENDDO 
    857  
    858 !mpi        CALL mpi_send(exfld, range(5), type, localRoot, localRank, localComm, ierror) 
    859             CALL mppsend (localRank, exfld, range(5), localRoot, request) 
    860          ENDIF 
    861  
    862          IF ( localRank == localRoot ) THEN 
    863  
    864             DO jj = ranges(3,localRoot), ranges(3,localRoot)+ranges(4,localRoot)-1 
    865                DO ji = ranges(1,localRoot), ranges(1,localRoot)+ranges(2,localRoot)-1 
    866                   global_array(ji,jj) = data_array(ji,jj) ! workaround 
    867                ENDDO 
    868             ENDDO 
    869  
    870             DO jn = 1, localSize-1 
    871  
    872 !mpi           CALL mpi_recv(buffer, ranges(5,jn), type, localRoot, jn, localComm, status, ierror) 
    873                CALL mpprecv(jn, buffer, ranges(5,jn)) 
    874  
    875                DO jj = ranges(3,jn), ranges(3,jn)+ranges(4,jn)-1 
    876                   DO ji = ranges(1,jn), ranges(1,jn)+ranges(2,jn)-1 
    877                      global_array(ji,jj) = buffer( (jj-ranges(3,jn))*ranges(2,jn) + ji-ranges(1,jn)+1 ) 
    878                   ENDDO 
    879                ENDDO 
    880  
    881             ENDDO 
    882  
    883          ENDIF 
    884          ! 
    885          ! send data from local root to OASIS4 
    886          ! 
    887          CALL prism_put ( var_id, dates, dates_bound, global_array, info, ierror )       
    888  
    889       ELSE 
    890          ! 
    891          ! send local data from every process to OASIS4 
    892          ! 
    893          CALL prism_put ( var_id, dates, dates_bound, data_array, info, ierror )       
    894  
    895       ENDIF !rootexchg 
    896  
    897 #else 
    898  
    899       ! 
    900       ! send local data from every process to OASIS4 
    901       ! 
    902       IF ( commRank ) & 
    903       CALL prism_put ( var_id, dates, dates_bound, data_array, info, ierror )       
    904  
    905 #endif 
    906  
    907       IF ( commRank ) THEN 
    908  
    909          IF (l_ctl) THEN 
    910  
    911             IF ( info==PRISM_Cpl ) THEN 
    912                WRITE(numout,*) '****************' 
    913                DO ji = 1, nsend 
    914                   IF (var_id == send_id(ji) ) THEN 
    915                      WRITE(numout,*) 'prism_put_proto: Outgoing ', cpl_send(ji) 
    916                      EXIT 
    917                   ENDIF 
    918                ENDDO 
    919                WRITE(numout,*) 'prism_put: var_id       ', var_id 
    920                WRITE(numout,*) 'prism_put:   date       ', date 
    921                WRITE(numout,*) 'prism_put:   info       ', info 
    922                WRITE(numout,*) '     - Minimum value is ', MINVAL(data_array) 
    923                WRITE(numout,*) '     - Maximum value is ', MAXVAL(data_array) 
    924                WRITE(numout,*) '     -     Sum value is ', SUM(data_array) 
    925                WRITE(numout,*) '****************' 
    926             ENDIF 
    927  
    928          ENDIF 
    929  
    930          IF ( ncount == nrecv ) THEN 
    931             ! 
    932             !  3. Update dates and dates_bound for next step. We assume that cpl_prism_send 
    933             !  is called for all send fields at each time step. Therefore we update 
    934             !  the date argument to prism_put only every nsend call to cpl_prism_send. 
    935             ! 
    936             dates_bound(1) = dates_bound(2) 
    937  
    938             tmpdate    = dates_bound(2) 
    939             date_incr  = rdCplttra(1)/2.0 
    940  
    941             CALL PRISM_calc_newdate ( tmpdate, date_incr, ierror ) 
    942             dates = tmpdate 
    943             CALL PRISM_calc_newdate ( tmpdate, date_incr, ierror ) 
    944             dates_bound(2) = tmpdate 
    945  
    946             ncount = 0 
    947  
    948          ENDIF 
    949  
    950       ENDIF ! commRank 
    951  
    952    END SUBROUTINE cpl_prism_send 
    953  
    954  
    955  
    956    SUBROUTINE cpl_prism_recv(  var_id, date, data_array, info ) 
    957  
    958       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 ) 
    959368 
    960369      !!--------------------------------------------------------------------- 
    961       !!              ***  ROUTINE cpl_prism_recv  *** 
     370      !!              ***  ROUTINE cpl_prism_rcv  *** 
    962371      !! 
    963372      !! ** Purpose : - At each coupling time-step,this routine receives fields 
    964373      !!      like stresses and fluxes from the coupler or remote application. 
    965       !! 
    966       !! ** Method  : OASIS4 
    967374      !!---------------------------------------------------------------------- 
    968       !! * Arguments 
    969       !! 
    970       INTEGER, INTENT( IN )  :: var_id    ! variable Id 
    971       INTEGER, INTENT( OUT ) :: info      ! variable Id 
    972       INTEGER, INTENT( IN )  :: date      ! ocean time-step in seconds 
    973       REAL(wp),INTENT( OUT ) :: data_array(:,:) 
    974       !! 
    975       !! * Local declarations 
    976       !! 
    977 #if defined key_mpp_mpi 
    978       REAL(wp)               :: global_array(jpiglo,jpjglo) 
    979       ! 
    980       LOGICAL                :: action = .false. 
    981 !mpi  INTEGER                :: status(MPI_STATUS_SIZE) 
    982 !mpi  INTEGER                :: type       ! MPI data type 
    983       INTEGER                :: request    ! MPI isend request 
    984       INTEGER                :: ji, jj, jn ! local loop indicees 
    985 #else 
    986       INTEGER                :: ji 
    987 #endif 
    988  
    989       INTEGER, SAVE          :: ncount = 0 
    990       !! 
     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 
    991381      !!-------------------------------------------------------------------- 
    992       !! 
    993       ncount  = ncount + 1 
    994  
    995 #ifdef key_mpp_mpi 
    996  
    997       request = 0 
    998  
    999       IF ( rootexchg ) THEN 
    1000          ! 
    1001          ! receive data from OASIS4 on local root 
    1002          ! 
    1003          IF ( commRank ) & 
    1004          CALL prism_get (var_id, dater, dater_bound, global_array, info, ierror) 
    1005          CALL MPI_BCAST ( info, 1, MPI_INTEGER, localRoot, localComm, ierror ) 
    1006  
    1007       ELSE 
    1008          ! 
    1009          ! receive local data from OASIS4 on every process 
    1010          ! 
    1011          CALL prism_get (var_id, dater, dater_bound, exfld, info, ierror) 
    1012  
    1013       ENDIF 
    1014  
    1015       action = (info==PRISM_CplIO) 
    1016  
    1017       IF ( rootexchg .and. action ) THEN 
    1018          ! 
    1019 !mpi     IF ( wp == 4 ) type = MPI_REAL 
    1020 !mpi     IF ( wp == 8 ) type = MPI_DOUBLE_PRECISION 
    1021          ! 
    1022          ! distribute data to processes 
    1023          ! 
    1024          IF ( localRank == localRoot ) THEN 
    1025  
    1026             DO jj = ranges(3,localRoot), ranges(3,localRoot)+ranges(4,localRoot)-1 
    1027                DO ji = ranges(1,localRoot), ranges(1,localRoot)+ranges(2,localRoot)-1 
    1028                   exfld(ji,jj) = global_array(ji,jj) 
    1029                ENDDO 
    1030             ENDDO 
    1031  
    1032             DO jn = 1, localSize-1 
    1033  
    1034                DO jj = ranges(3,jn), ranges(3,jn)+ranges(4,jn)-1 
    1035                   DO ji = ranges(1,jn), ranges(1,jn)+ranges(2,jn)-1 
    1036                      buffer( (jj-ranges(3,jn))*ranges(2,jn) + ji-ranges(1,jn)+1 ) = global_array(ji,jj) 
    1037                   ENDDO 
    1038                ENDDO 
    1039  
    1040 !mpi           CALL mpi_send(buffer, ranges(5,jn), type, jn, jn, localComm, ierror) 
    1041                CALL mppsend (jn, buffer, ranges(5,jn), jn, request)   
    1042  
    1043             ENDDO 
    1044  
    1045          ENDIF 
    1046  
    1047          IF ( localRank /= localRoot ) & 
    1048 !mpi         CALL mpi_recv(exfld, range(5), type, localRoot, localRank, localComm, status, ierror) 
    1049              CALL mpprecv(localRank, exfld, range(5)) 
    1050       ENDIF 
    1051  
    1052       IF ( action ) THEN 
    1053  
    1054          data_array = 0.0 
    1055  
    1056          DO jj = nldj, nlej 
    1057             DO ji = nldi, nlei 
    1058                data_array(ji,jj)=exfld(ji-nldi+1,jj-nldj+1) 
    1059             ENDDO 
    1060          ENDDO 
    1061  
    1062          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         
    1063406            WRITE(numout,*) '****************' 
    1064             DO ji = 1, nrecv 
    1065                IF (var_id == recv_id(ji) ) THEN 
    1066                   WRITE(numout,*) 'prism_get: Incoming ', cpl_recv(ji) 
    1067                   EXIT 
    1068                ENDIF 
    1069             ENDDO 
    1070             WRITE(numout,*) 'prism_get: var_id       ', var_id 
    1071             WRITE(numout,*) 'prism_get:   date       ', date 
    1072             WRITE(numout,*) 'prism_get:   info       ', info 
    1073             WRITE(numout,*) '     - Minimum value is ', MINVAL(data_array) 
    1074             WRITE(numout,*) '     - Maximum value is ', MAXVAL(data_array) 
    1075             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) 
    1076414            WRITE(numout,*) '****************' 
    1077415         ENDIF 
    1078416 
     417      ELSE 
     418         kinfo = OASIS_idle      
    1079419      ENDIF 
    1080 #else 
    1081  
    1082       CALL prism_get (var_id, dater, dater_bound, exfld, info, ierror) 
    1083  
    1084       IF ( info==PRISM_CplIO ) THEN 
    1085                data_array=exfld 
    1086  
    1087          IF (l_ctl) THEN         
    1088             WRITE(numout,*) '****************' 
    1089             DO ji = 1, nrecv 
    1090                IF (var_id == recv_id(ji) ) THEN 
    1091                   WRITE(numout,*) 'prism_get: Incoming ', cpl_recv(ji) 
    1092                   EXIT 
    1093                ENDIF 
    1094             ENDDO 
    1095             WRITE(numout,*) 'prism_get: var_id       ', var_id 
    1096             WRITE(numout,*) 'prism_get:   date       ', date 
    1097             WRITE(numout,*) 'prism_get:   info       ', info 
    1098             WRITE(numout,*) '     - Minimum value is ', MINVAL(data_array) 
    1099             WRITE(numout,*) '     - Maximum value is ', MAXVAL(data_array) 
    1100             WRITE(numout,*) '     -     Sum value is ', SUM(data_array) 
    1101             WRITE(numout,*) '****************' 
    1102          ENDIF 
    1103  
    1104       ENDIF 
    1105  
    1106 #endif 
    1107  
    1108       IF ( ncount == nrecv ) THEN 
    1109          ! 
    1110          !  3. Update dater and dater_bound for next step. We assume that cpl_prism_recv 
    1111          !  is called for all recv fields at each time step. Therefore we update 
    1112          !  the date argument to prism_get only every nrecv call to cpl_prism_recv. 
    1113          ! 
    1114          dater_bound(1) = dater_bound(2) 
    1115  
    1116          tmpdate    = dater_bound(2) 
    1117          date_incr  = rdttra(1)/2.0 
    1118  
    1119          CALL PRISM_calc_newdate ( tmpdate, date_incr, ierror ) 
    1120          dater = tmpdate 
    1121          CALL PRISM_calc_newdate ( tmpdate, date_incr, ierror ) 
    1122          dater_bound(2) = tmpdate 
    1123  
    1124          ncount = 0 
    1125  
    1126       ENDIF 
    1127  
    1128    END SUBROUTINE cpl_prism_recv 
    1129  
     420 
     421 
     422   END SUBROUTINE cpl_prism_rcv 
    1130423 
    1131424 
    1132425   SUBROUTINE cpl_prism_finalize 
    1133  
    1134       IMPLICIT NONE 
    1135426 
    1136427      !!--------------------------------------------------------------------- 
    … …  
    1140431      !!      called explicitly before cpl_prism_init it will also close 
    1141432      !!      MPI communication. 
    1142       !! 
    1143       !! ** Method  : OASIS4 
    1144433      !!---------------------------------------------------------------------- 
    1145434 
    1146435      DEALLOCATE(exfld) 
    1147  
    1148       if ( prism_was_initialized ) then 
    1149  
    1150          call prism_terminated ( prism_was_terminated, ierror ) 
    1151           
    1152          if ( prism_was_terminated ) then 
    1153             print *, 'prism has already been terminated.' 
    1154          else 
    1155             call prism_terminate ( ierror ) 
    1156             prism_was_terminated = .true. 
    1157          endif 
    1158  
    1159       else 
    1160  
    1161          print *, 'Initialize prism before terminating it.' 
    1162  
    1163       endif 
    1164  
     436      CALL prism_terminate ( nerror )          
    1165437 
    1166438   END SUBROUTINE cpl_prism_finalize 
    1167439 
    1168 #else 
    1169  
    1170    !!---------------------------------------------------------------------- 
    1171    !!   Default case           Dummy module         forced Ocean/Atmosphere 
    1172    !!---------------------------------------------------------------------- 
    1173 CONTAINS 
    1174    SUBROUTINE cpl_prism_init             ! Dummy routine 
    1175    END SUBROUTINE cpl_prism_init 
    1176    SUBROUTINE cpl_prism_define           ! Dummy routine 
    1177    END SUBROUTINE cpl_prism_define 
    1178    SUBROUTINE cpl_prism_send             ! Dummy routine 
    1179    END SUBROUTINE cpl_prism_send 
    1180    SUBROUTINE cpl_prism_recv             ! Dummy routine 
    1181    END SUBROUTINE cpl_prism_recv 
    1182    SUBROUTINE cpl_prism_finalize         ! Dummy routine 
    1183    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 
    1184486 
    1185487#endif 
Note: See TracChangeset for help on using the changeset viewer.