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.
cpl_oasis4.F90 in branches/DEV_r2106_LOCEAN2010/NEMO/OPA_SRC/SBC – NEMO

source: branches/DEV_r2106_LOCEAN2010/NEMO/OPA_SRC/SBC/cpl_oasis4.F90 @ 2113

Last change on this file since 2113 was 1715, checked in by smasson, 15 years ago

move daymod public variables in dom_oce, see ticket:590

  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 45.2 KB
Line 
1MODULE cpl_oasis4
2   !!======================================================================
3   !!                    ***  MODULE cpl_oasis4  ***
4   !! Coupled O/A : coupled ocean-atmosphere case using OASIS4
5   !!               special case: OPA/LIM coupled to ECHAM5
6   !!=====================================================================
7   !! History :   
8   !!   9.0  !  04-06  (R. Redler, NEC Laboratories Europe, St Augustin, Germany) Original code
9   !!   " "  !  04-11  (R. Redler, NEC Laboratories Europe; N. Keenlyside, W. Park, IFM-GEOMAR, Kiel, Germany) revision
10   !!   " "  !  04-11  (V. Gayler, MPI M&D) Grid writing
11   !!   " "  !  05-08  (R. Redler, W. Park) frld initialization, paral(2) revision
12   !!   " "  !  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
17   !!----------------------------------------------------------------------
18#if defined key_oasis4
19   !!----------------------------------------------------------------------
20   !!   'key_oasis4'                    coupled Ocean/Atmosphere via OASIS4
21   !!----------------------------------------------------------------------
22   !!   cpl_prism_init     : initialization of coupled mode communication
23   !!   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
26   !!   cpl_prism_finalize : finalize the coupled mode communication
27   !!----------------------------------------------------------------------
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
40   USE dom_oce                      ! ocean space and time domain
41   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
46   IMPLICIT NONE
47!
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
109
110   !! Routine accessibility
111   PUBLIC cpl_prism_init
112   PUBLIC cpl_prism_define
113   PUBLIC cpl_prism_send
114   PUBLIC cpl_prism_recv
115   PUBLIC cpl_prism_finalize
116
117   PUBLIC send_id, recv_id
118
119   !!----------------------------------------------------------------------
120   !!   OPA 9.0 , LOCEAN-IPSL (2006)
121   !! $Id$
122   !! Software governed by the CeCILL licence (modipsl/doc/NEMO_CeCILL.txt)
123   !!----------------------------------------------------------------------
124
125CONTAINS
126
127   SUBROUTINE cpl_prism_init( localCommunicator )
128
129      IMPLICIT NONE
130
131      !!-------------------------------------------------------------------
132      !!             ***  ROUTINE cpl_prism_init  ***
133      !!
134      !! ** Purpose :   Initialize coupled mode communication for ocean
135      !!    exchange between AGCM, OGCM and COUPLER. (OASIS4 software)
136      !!
137      !! ** Method  :   OASIS4 MPI communication
138      !!--------------------------------------------------------------------
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
224
225      !------------------------------------------------------------------
226      ! 2nd Initialize the PRISM system for the component
227      !------------------------------------------------------------------
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
246
247
248   END SUBROUTINE cpl_prism_init
249
250
251   SUBROUTINE cpl_prism_define ()
252
253      IMPLICIT NONE
254
255      !!-------------------------------------------------------------------
256      !!             ***  ROUTINE cpl_prism_define  ***
257      !!
258      !! ** Purpose :   Define grid and field information for ocean
259      !!    exchange between AGCM, OGCM and COUPLER. (OASIS4 software)
260      !!
261      !! ** Method  :   OASIS4 MPI communication
262      !!--------------------------------------------------------------------
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)
283      INTEGER                    :: data_type      ! data type of transients
284
285      INTEGER                    :: nbr_corners
286
287      LOGICAL                    :: new_points
288      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
303      !!--------------------------------------------------------------------
304     
305      IF(lwp) WRITE(numout,*)
306      IF(lwp) WRITE(numout,*) 'cpl_prism_define : initialization in coupled ocean/atmosphere case'
307      IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~~~~~'
308      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      ! -----------------------------------------------------------------
361      ! ... 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')
370         RETURN
371      ENDIF
372
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.
395      !     For serial configuration (key_mpp_mpi not being active)
396      !     nl* is set to the global values 1 and jp*glo.
397      ! -----------------------------------------------------------------
398
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')
430         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
684
685         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 
824   END SUBROUTINE cpl_prism_define
825
826
827
828   SUBROUTINE cpl_prism_send( var_id, date, data_array, info )
829
830      IMPLICIT NONE
831
832      !!---------------------------------------------------------------------
833      !!              ***  ROUTINE cpl_prism_send  ***
834      !!
835      !! ** Purpose : - At each coupling time-step,this routine sends fields
836      !!      like sst or ice cover to the coupler or remote application.
837      !!
838      !! ** Method  : OASIS4
839      !!----------------------------------------------------------------------
840      !! * Arguments
841      !!
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
861      !!
862      !!--------------------------------------------------------------------
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
986
987      !!---------------------------------------------------------------------
988      !!              ***  ROUTINE cpl_prism_recv  ***
989      !!
990      !! ** Purpose : - At each coupling time-step,this routine receives fields
991      !!      like stresses and fluxes from the coupler or remote application.
992      !!
993      !! ** Method  : OASIS4
994      !!----------------------------------------------------------------------
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      !!
1018      !!--------------------------------------------------------------------
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       
1090            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)
1103            WRITE(numout,*) '****************'
1104         ENDIF
1105
1106      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
1157
1158
1159   SUBROUTINE cpl_prism_finalize
1160
1161      IMPLICIT NONE
1162
1163      !!---------------------------------------------------------------------
1164      !!              ***  ROUTINE cpl_prism_finalize  ***
1165      !!
1166      !! ** Purpose : - Finalizes the coupling. If MPI_init has not been
1167      !!      called explicitly before cpl_prism_init it will also close
1168      !!      MPI communication.
1169      !!
1170      !! ** Method  : OASIS4
1171      !!----------------------------------------------------------------------
1172
1173      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
1192
1193   END SUBROUTINE cpl_prism_finalize
1194
1195#else
1196
1197   !!----------------------------------------------------------------------
1198   !!   Default case           Dummy module         forced Ocean/Atmosphere
1199   !!----------------------------------------------------------------------
1200CONTAINS
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
1211
1212#endif
1213
1214END MODULE cpl_oasis4
Note: See TracBrowser for help on using the repository browser.