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/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/SBC – NEMO

source: branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/SBC/cpl_oasis4.F90 @ 3211

Last change on this file since 3211 was 3211, checked in by spickles2, 12 years ago

Stephen Pickles, 11 Dec 2011

Commit to bring the rest of the DCSE NEMO development branch
in line with the latest development version. This includes
array index re-ordering of all OPA_SRC/.
  • Property svn:keywords set to Id
File size: 22.8 KB
Line 
1MODULE cpl_oasis4
2   !!======================================================================
3   !!                    ***  MODULE cpl_oasis  ***
4   !! Coupled O/A : coupled ocean-atmosphere case using OASIS4
5   !!=====================================================================
6   !! History :   
7   !!   9.0  !  2004-06  (R. Redler, NEC Laboratories Europe, St Augustin, Germany) Original code
8   !!    -   !  2004-11  (R. Redler, NEC Laboratories Europe; N. Keenlyside, W. Park, IFM-GEOMAR, Kiel, Germany) revision
9   !!    -   !  2004-11  (V. Gayler, MPI M&D) Grid writing
10   !!    -   !  2005-08  (R. Redler, W. Park) frld initialization, paral(2) revision
11   !!    -   !  2005-09  (R. Redler) extended to allow for communication over root only
12   !!    -   !  2006-01  (W. Park) modification of physical part
13   !!    -   !  2006-02  (R. Redler, W. Park) buffer array fix for root exchange
14   !!    -   !  2010-10  (E. Maisonnave and S. Masson) complete rewrite
15   !!----------------------------------------------------------------------
16#if defined key_oasis4
17   !!----------------------------------------------------------------------
18   !!   'key_oasis4'                    coupled Ocean/Atmosphere via OASIS4
19   !!----------------------------------------------------------------------
20   !!   cpl_prism_init     : initialization of coupled mode communication
21   !!   cpl_prism_define   : definition of grid and fields
22   !!   cpl_prism_snd      : snd out fields in coupled mode
23   !!   cpl_prism_rcv      : receive fields in coupled mode
24   !!   cpl_prism_update_time : update date sent to Oasis
25   !!   cpl_prism_finalize : finalize the coupled mode communication
26   !!----------------------------------------------------------------------
27   USE prism            ! OASIS4 prism module
28   USE par_oce          ! ocean parameters
29   USE dom_oce          ! ocean space and time domain
30   USE domwri           ! ocean space and time domain
31   USE in_out_manager   ! I/O manager
32   USE lbclnk           ! ocean lateral boundary conditions (or mpp link)
33   USE lib_mpp          ! MPP library
34
35   IMPLICIT NONE
36   PRIVATE
37
38   PUBLIC cpl_prism_init
39   PUBLIC cpl_prism_define
40   PUBLIC cpl_prism_snd
41   PUBLIC cpl_prism_rcv
42   PUBLIC cpl_prism_update_time
43   PUBLIC cpl_prism_finalize
44   
45!   LOGICAL, PUBLIC, PARAMETER :: lk_cpl = .TRUE.    ! coupled flag
46   INTEGER                    :: ncomp_id           ! id returned by prism_init_comp
47   INTEGER                    :: nerror             ! return error code
48   INTEGER, PUBLIC            :: OASIS_Rcv  = 1     ! return code if received field
49   INTEGER, PUBLIC            :: OASIS_idle = 0     ! return code if nothing done by oasis
50
51   INTEGER, PARAMETER :: nmaxfld=40    ! Maximum number of coupling fields
52   
53   TYPE, PUBLIC ::   FLD_CPL            ! Type for coupling field information
54      LOGICAL            ::   laction   ! To be coupled or not
55      CHARACTER(len = 8) ::   clname    ! Name of the coupling field   
56      CHARACTER(len = 1) ::   clgrid    ! Grid type 
57      REAL(wp)           ::   nsgn      ! Control of the sign change
58      INTEGER            ::   nid       ! Id of the field
59   END TYPE FLD_CPL
60
61   TYPE(FLD_CPL), DIMENSION(nmaxfld), PUBLIC :: srcv, ssnd   ! Coupling fields
62
63   REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: exfld  ! Temporary buffer for receiving
64
65   TYPE(PRISM_Time_struct), PUBLIC    :: date            ! date info for send operation
66   TYPE(PRISM_Time_struct), PUBLIC    :: date_bound(2)   ! date info for send operation
67
68   !! * Control permutation of array indices
69#  include "dom_oce_ftrans.h90"
70
71   !!----------------------------------------------------------------------
72   !! NEMO/OPA 3.3 , NEMO Consortium (2010)
73   !! $Id$
74   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
75   !!----------------------------------------------------------------------
76CONTAINS
77
78   SUBROUTINE cpl_prism_init( kl_comm ) 
79      !!-------------------------------------------------------------------
80      !!             ***  ROUTINE cpl_prism_init  ***
81      !!
82      !! ** Purpose :   Initialize coupled mode communication for ocean
83      !!    exchange between AGCM, OGCM and COUPLER. (OASIS4 software)
84      !!
85      !! ** Method  :   OASIS4 MPI communication
86      !!--------------------------------------------------------------------
87      INTEGER, INTENT(out) ::   kl_comm   ! local communicator of the model
88      !!--------------------------------------------------------------------
89     
90      CALL prism_init( 'nemo', nerror )
91
92      !------------------------------------------------------------------
93      ! 2nd Initialize the PRISM system for the component
94      !------------------------------------------------------------------
95      CALL prism_init_comp( ncomp_id, 'oceanx', nerror )
96      IF( nerror /= PRISM_Success )   CALL prism_abort( ncomp_id, 'cpl_prism_init', 'Failure in prism_init_comp' )
97
98      !------------------------------------------------------------------
99      ! 3rd Get an MPI communicator fr OPA local communication
100      !------------------------------------------------------------------
101      CALL prism_get_localcomm( ncomp_id, kl_comm, nerror )
102      IF( nerror /= PRISM_Success )   CALL prism_abort( ncomp_id, 'cpl_prism_init', 'Failure in prism_get_localcomm' )
103      !
104   END SUBROUTINE cpl_prism_init
105
106
107   SUBROUTINE cpl_prism_define( krcv, ksnd )
108      !!-------------------------------------------------------------------
109      !!             ***  ROUTINE cpl_prism_define  ***
110      !!
111      !! ** Purpose :   Define grid and field information for ocean
112      !!    exchange between AGCM, OGCM and COUPLER. (OASIS4 software)
113      !!
114      !! ** Method  :   OASIS4 MPI communication
115      !!--------------------------------------------------------------------
116      USE wrk_nemo, ONLY: wrk_in_use, wrk_not_released
117      USE wrk_nemo, ONLY: zclo => wrk_3d_1, zcla => wrk_3d_2
118      USE wrk_nemo, ONLY: zlon => wrk_2d_1, zlat => wrk_2d_2
119      !
120      INTEGER, INTENT(in) :: krcv, ksnd     ! Number of received and sent coupling fields
121      !
122      INTEGER, DIMENSION(4)      :: igrid     ! ids returned by prism_def_grid
123      INTEGER, DIMENSION(4)      :: iptid     ! ids returned by prism_set_points
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      INTEGER                    :: ishape(2,3)    ! shape of arrays passed to PSMILe
134      INTEGER                    :: data_type      ! data type of transients
135
136      LOGICAL                    :: new_points
137      LOGICAL                    :: new_mask
138      LOGICAL, ALLOCATABLE, SAVE :: llmask(:,:,:) ! jpi,jpj,1
139
140      INTEGER                    :: ji, jj, jg, jc   ! local loop indicees
141      INTEGER                    :: ii, ij           ! index
142      INTEGER, DIMENSION(1)      :: ind              ! index
143
144      CHARACTER(len=32)          :: clpt_name     ! name of the grid points
145      CHARACTER(len=7)           :: cltxt 
146      CHARACTER(len=1), DIMENSION(4) :: clgrd = (/ 'T','U','V','F' /)     ! name of the grid points
147
148      TYPE(PRISM_Time_struct)    :: tmpdate
149      INTEGER                    :: idate_incr      ! date increment
150      !!--------------------------------------------------------------------
151
152      IF( wrk_in_use(3, 1,2) .OR. wrk_in_use(2, 1,2) )THEN
153         CALL ctl_stop('cpl_prism_define: ERROR: requested workspace arrays are unavailable.')   ;   RETURN
154      ENDIF
155
156      IF(lwp) WRITE(numout,*)
157      IF(lwp) WRITE(numout,*) 'cpl_prism_define : initialization in coupled ocean/atmosphere case'
158      IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~~~~~'
159      IF(lwp) WRITE(numout,*)
160
161      !
162      ! ... Allocate memory for data exchange
163      !
164      ALLOCATE( exfld(nlei-nldi+1, nlej-nldj+1, 1), stat = nerror )
165      IF ( nerror > 0 ) THEN
166         CALL prism_abort( ncomp_id, 'cpl_prism_define', 'Failure in allocating exfld' )
167         RETURN
168      ENDIF
169
170      IF(.not. ALLOCATED(mask))THEN
171         ALLOCATE(llmask(jpi,jpj,1), Stat=ji)
172         IF(ji /= 0)THEN
173            CALL prism_abort( ncomp_id, 'cpl_prism_define', 'Failure in allocating llmask' )
174            RETURN
175         END IF
176      END IF
177
178      ! -----------------------------------------------------------------
179      ! ... Define the shape of the valid region without the halo and overlaps between cpus
180      !     For serial configuration (key_mpp_mpi not being active)
181      !     nl* is set to the global values 1 and jp*glo.
182      ! -----------------------------------------------------------------
183
184      ishape(:,1) = (/ 1, nlei-nldi+1 /)
185      ishape(:,2) = (/ 1, nlej-nldj+1 /)
186      ishape(:,3) = (/ 1,           1 /)
187         
188      DO ji = 1, 4
189         CALL prism_def_grid( igrid(ji), 'orca'//clgrd(ji), ncomp_id, ishape, PRISM_irrlonlat_regvrt, nerror )
190         IF( nerror /= PRISM_Success )   CALL prism_abort (ncomp_id, 'cpl_prism_define',   &
191            &                                                        'Failure in prism_def_grid of '//clgrd(jg)//'-point' )
192      END DO
193     
194      ! -----------------------------------------------------------------
195      ! ... Define the partition
196      ! -----------------------------------------------------------------
197     
198      iextent(1,:) = (/    nlei-nldi+1,    nlej-nldj+1, 1 /)
199      ioffset(1,:) = (/ nldi-1+nimpp-1, nldj-1+njmpp-1, 0 /)
200     
201      DO ji = 1, 4
202         CALL prism_def_partition( igrid(ji), 1, ioffset, iextent, nerror )
203         IF( nerror /= PRISM_Success )   CALL prism_abort (ncomp_id, 'cpl_prism_define',   &
204            &                                                        'Failure in prism_def_partition of '//clgrd(jg)//'-point' )
205      END DO
206
207      ! -----------------------------------------------------------------
208      ! ... Define the elements, i.e. specify the corner points for each
209      !     volume element. In case OPA runs on level coordinates (regular
210      !     in the vertical) we only need to give the 4 horizontal corners
211      !     for a volume element plus the vertical position of the upper
212      !     and lower face. Nevertheless the volume element has 8 corners.
213      ! -----------------------------------------------------------------
214     
215      iioff(:) = (/0,1,0,1/)
216      ijoff(:) = (/0,0,1,1/) 
217      iishift(:) = (/0,1,1,0/)
218      ijshift(:) = (/0,0,1,1/)
219
220      DO jg = 1, 4    ! ... the t,u,v,f-points
221
222         cltxt = clgrd(jg)//'-point'
223         
224         ! -----------------------------------------------------------------
225         ! ... Convert OPA masks to logicals and define the masks
226         ! -----------------------------------------------------------------
227         SELECT CASE( jg ) 
228         CASE(1)   ;   llmask(:,:,1) = ( tmask(:,:,1)  ) == 1.
229         CASE(2)   ;   llmask(:,:,1) = ( umask(:,:,1)  ) == 1.
230         CASE(3)   ;   llmask(:,:,1) = ( vmask(:,:,1)  ) == 1.
231         CASE(4)   ;   llmask(:,:,1) = ( fmask(:,:,1)  ) == 1.
232!         CASE(1)   ;   llmask(:,:,1) = ( tmask(:,:,1) * dom_uniq('T') ) == 1.
233!         CASE(2)   ;   llmask(:,:,1) = ( umask(:,:,1) * dom_uniq('U') ) == 1.
234!         CASE(3)   ;   llmask(:,:,1) = ( vmask(:,:,1) * dom_uniq('V') ) == 1.
235!         CASE(4)   ;   llmask(:,:,1) = ( fmask(:,:,1) * dom_uniq('F') ) == 1.
236         END SELECT
237         CALL prism_set_mask( imskid(jg), igrid(jg), ishape, llmask(nldi:nlei, nldj:nlej, 1), .TRUE., nerror )
238         IF( nerror /= PRISM_Success )   CALL prism_abort( ncomp_id, 'cpl_prism_define', 'Failure in prism_set_mask for '//cltxt )
239
240         ! -----------------------------------------------------------------
241         ! ... Define the corners
242         ! -----------------------------------------------------------------
243         SELECT CASE( jg ) 
244         CASE(1)   ;   zlon(:,:) = glamf(:,:)   ;   zlat(:,:) = gphif(:,:)
245         CASE(2)   ;   zlon(:,:) = glamv(:,:)   ;   zlat(:,:) = gphiv(:,:)
246         CASE(3)   ;   zlon(:,:) = glamu(:,:)   ;   zlat(:,:) = gphiu(:,:) 
247         CASE(4)   ;   zlon(:,:) = glamt(:,:)   ;   zlat(:,:) = gphit(:,:)
248         END SELECT
249
250         DO jc = 1, 4   ! corner number (anti-clockwise, starting from the bottom left corner)
251            DO jj = 2, jpjm1
252               DO ji = 2, jpim1   ! NO vector opt.
253                  ii = ji-1 + iioff(jg) + iishift(jc)
254                  ij = jj-1 + ijoff(jg) + ijshift(jc)
255                  zclo(ji,jj,jc) = zlon(ii,ij)
256                  zcla(ji,jj,jc) = zlat(ii,ij)
257               END DO
258            END DO
259            CALL lbc_lnk( zclo(:,:,jc), clgrd(jg), 1. )   ;   CALL lbc_lnk( zcla(:,:,jc), clgrd(jg), 1. )
260         END DO
261
262         CALL prism_set_corners( igrid(jg), 8, ishape, zclo(nldi:nlei, nldj:nlej,:),   &
263            &                                          zcla(nldi:nlei, nldj:nlej,:), RESHAPE( (/-1.,1./), (/1,2/) ), nerror )
264         IF( nerror /= PRISM_Success )   CALL prism_abort( ncomp_id, 'cpl_prism_define', 'Failure in prism_set_corners of '//cltxt )   
265
266         ! -----------------------------------------------------------------
267         ! ... Define the center points
268         ! -----------------------------------------------------------------
269         SELECT CASE( jg ) 
270         CASE(1)   ;   zlon(:,:) = glamt(:,:)   ;   zlat(:,:) = gphit(:,:)
271         CASE(2)   ;   zlon(:,:) = glamu(:,:)   ;   zlat(:,:) = gphiu(:,:)
272         CASE(3)   ;   zlon(:,:) = glamv(:,:)   ;   zlat(:,:) = gphiv(:,:)
273         CASE(4)   ;   zlon(:,:) = glamf(:,:)   ;   zlat(:,:) = gphif(:,:)
274         END SELECT
275
276         CALL prism_set_points ( iptid(jg), cltxt, igrid(jg), ishape, zlon(nldi:nlei, nldj:nlej),   &
277         &                                                            zlat(nldi:nlei, nldj:nlej), (/0./), .TRUE., nerror )
278         IF( nerror /= PRISM_Success )   CALL prism_abort ( ncomp_id, 'cpl_prism_define', 'Failure in prism_set_points '//cltxt )
279
280      END DO
281
282      ! ... Announce send variables.
283      !
284      DO ji = 1, ksnd
285         IF ( ssnd(ji)%laction ) THEN
286           
287            itmp(:) = 0
288            WHERE( clgrd == ssnd(ji)%clgrid  ) itmp = 1
289            ind(:) = maxloc( itmp )
290            WRITE(6,*) ' grid for field ', ind(1), ssnd(ji)%clname
291             ind(1) = 1
292
293            CALL prism_def_var( ssnd(ji)%nid, ssnd(ji)%clname, igrid(ind(1)), iptid(ind(1)),  imskid(ind(1)), (/ 3, 0/),   &
294               &                ishape, PRISM_Double_Precision, nerror )
295            IF ( nerror /= PRISM_Success )   CALL prism_abort( ssnd(ji)%nid, 'cpl_prism_define',   &
296               &                                               'Failure in prism_def_var for '//TRIM(ssnd(ji)%clname))
297
298         ENDIF
299      END DO
300      !
301      ! ... Announce received variables.
302      !
303      DO ji = 1, krcv
304         IF ( srcv(ji)%laction ) THEN
305
306            itmp(:) = 0
307            WHERE( clgrd == srcv(ji)%clgrid  ) itmp = 1
308            ind(:) = maxloc( itmp )
309            WRITE(6,*) ' grid for field ', ind(1), srcv(ji)%clname
310             ind(1) = 1
311 
312            CALL prism_def_var( srcv(ji)%nid, srcv(ji)%clname, igrid(ind(1)), iptid(ind(1)), imskid(ind(1)), (/ 3, 0/),   &
313               &                ishape, PRISM_Double_Precision, nerror )
314            IF ( nerror /= PRISM_Success )   CALL prism_abort( srcv(ji)%nid, 'cpl_prism_define',   &
315               &                                               'Failure in prism_def_var for '//TRIM(srcv(ji)%clname))
316
317         ENDIF
318      END DO
319     
320      !------------------------------------------------------------------
321      ! End of definition phase
322      !------------------------------------------------------------------
323     
324      CALL prism_enddef( nerror )
325      IF ( nerror /= PRISM_Success )   CALL prism_abort ( ncomp_id, 'cpl_prism_define', 'Failure in prism_enddef')
326     
327      IF( wrk_not_released(3, 1,2) .OR.   &
328          wrk_not_released(2, 1,2)   )   CALL ctl_stop('cpl_prism_define: failed to release workspace arrays')
329      !
330   END SUBROUTINE cpl_prism_define
331   
332   
333   SUBROUTINE cpl_prism_snd( kid, kstep, pdata, kinfo )
334      !!---------------------------------------------------------------------
335      !!              ***  ROUTINE cpl_prism_snd  ***
336      !!
337      !! ** Purpose : - At each coupling time-step,this routine sends fields
338      !!      like sst or ice cover to the coupler or remote application.
339      !!----------------------------------------------------------------------
340      INTEGER                 , INTENT(in   ) ::   kid     ! variable intex in the array
341      INTEGER                 , INTENT(  out) ::   kinfo   ! OASIS4 info argument
342      INTEGER                 , INTENT(in   ) ::   kstep   ! ocean time-step in seconds
343      REAL(wp), DIMENSION(:,:), INTENT(in   ) ::   pdata
344      !!--------------------------------------------------------------------
345      !
346      ! snd data to OASIS4
347      !
348      exfld(:,:,1) = pdata(nldi:nlei, nldj:nlej)
349      CALL prism_put( ssnd(kid)%nid, date, date_bound, exfld, kinfo, nerror )
350      IF ( nerror /= PRISM_Success )   CALL prism_abort( ssnd(kid)%nid, 'cpl_prism_snd',   &
351         &                                               'Failure in prism_put for '//TRIM(ssnd(kid)%clname) )
352
353      IF( ln_ctl ) THEN       
354         IF ( kinfo >= PRISM_Cpl     .OR. kinfo == PRISM_Rst .OR.   &
355            & kinfo == PRISM_RstTimeop ) THEN
356            WRITE(numout,*) '****************'
357            WRITE(numout,*) 'prism_put: Outgoing ', ssnd(kid)%clname
358            WRITE(numout,*) 'prism_put: ivarid ', ssnd(kid)%nid
359            WRITE(numout,*) 'prism_put:  kstep ', kstep
360            WRITE(numout,*) 'prism_put:   info ', kinfo
361            WRITE(numout,*) '     - Minimum value is ', MINVAL(pdata)
362            WRITE(numout,*) '     - Maximum value is ', MAXVAL(pdata)
363            WRITE(numout,*) '     -     Sum value is ', SUM(pdata)
364            WRITE(numout,*) '****************'
365         ENDIF
366      ENDIF
367      !
368   END SUBROUTINE cpl_prism_snd
369
370
371   SUBROUTINE cpl_prism_rcv( kid, kstep, pdata, kinfo )
372      !!---------------------------------------------------------------------
373      !!              ***  ROUTINE cpl_prism_rcv  ***
374      !!
375      !! ** Purpose : - At each coupling time-step,this routine receives fields
376      !!      like stresses and fluxes from the coupler or remote application.
377      !!----------------------------------------------------------------------
378      INTEGER                 , INTENT(in   ) ::   kid     ! variable intex in the array
379      INTEGER                 , INTENT(in   ) ::   kstep   ! ocean time-step in seconds
380      REAL(wp), DIMENSION(:,:), INTENT(inout) ::   pdata   ! IN to keep the value if nothing is done
381      INTEGER                 , INTENT(  out) ::   kinfo   ! OASIS4 info argument
382      !
383      LOGICAL                :: llaction
384      !!--------------------------------------------------------------------
385      !
386      ! receive local data from OASIS4 on every process
387      !
388      CALL prism_get( srcv(kid)%nid, date, date_bound, exfld, kinfo, nerror )         
389      IF ( nerror /= PRISM_Success )   CALL prism_abort( srcv(kid)%nid, 'cpl_prism_rcv',   &
390         &                                               'Failure in prism_get for '//TRIM(srcv(kid)%clname) )
391
392      WRITE(numout,*) 'prism_get: Incoming ', srcv(kid)%clname
393      call flush(numout)
394      llaction = .false.
395      IF( kinfo == PRISM_Cpl )  llaction = .TRUE.
396
397      IF ( ln_ctl )   WRITE(numout,*) "llaction, kinfo, kstep, ivarid: " , llaction, kinfo, kstep, srcv(kid)%nid
398
399      IF ( llaction ) THEN
400
401         kinfo = OASIS_Rcv
402         pdata(nldi:nlei, nldj:nlej) = exfld(:,:,1)
403         
404         !--- Fill the overlap areas and extra hallows (mpp)
405         !--- check periodicity conditions (all cases)
406         CALL lbc_lnk( pdata, srcv(kid)%clgrid, srcv(kid)%nsgn )   
407         
408         IF ( ln_ctl ) THEN       
409            WRITE(numout,*) '****************'
410            WRITE(numout,*) 'prism_get: Incoming ', srcv(kid)%clname
411            WRITE(numout,*) 'prism_get: ivarid '  , srcv(kid)%nid
412            WRITE(numout,*) 'prism_get:   kstep', kstep
413            WRITE(numout,*) 'prism_get:   info ', kinfo
414            WRITE(numout,*) '     - Minimum value is ', MINVAL(pdata)
415            WRITE(numout,*) '     - Maximum value is ', MAXVAL(pdata)
416            WRITE(numout,*) '     -     Sum value is ', SUM(pdata)
417            WRITE(numout,*) '****************'
418         ENDIF
419
420      ELSE
421         kinfo = OASIS_idle     
422      ENDIF
423      !
424   END SUBROUTINE cpl_prism_rcv
425
426
427   SUBROUTINE cpl_prism_finalize
428      !!---------------------------------------------------------------------
429      !!              ***  ROUTINE cpl_prism_finalize  ***
430      !!
431      !! ** Purpose : - Finalizes the coupling. If MPI_init has not been
432      !!      called explicitly before cpl_prism_init it will also close
433      !!      MPI communication.
434      !!----------------------------------------------------------------------
435      !
436      DEALLOCATE(exfld)
437      CALL prism_terminate ( nerror )         
438      !
439   END SUBROUTINE cpl_prism_finalize
440
441
442   SUBROUTINE cpl_prism_update_time(kt)
443      !!---------------------------------------------------------------------
444      !!              ***  ROUTINE cpl_prism_update_time  ***
445      !!
446      !! ** Purpose : - Increment date with model timestep
447      !!                called explicitly at the end of each timestep
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      ! Define the actual date
456         !
457         ! date is determined by adding days since beginning of the run to the corresponding initial date.
458         ! Note that OPA internal info about the start date of the experiment is bypassed.
459         ! Instead we rely sololy on the info provided by the SCC.xml file.
460         !
461         date = PRISM_Jobstart_date
462         !
463         !
464         ! lower/upper bound is determined by adding half a time step
465         !
466         idate_incr = 0.5 * NINT ( rdttra(1) )
467         tmpdate = date   ;   CALL PRISM_calc_newdate ( tmpdate, -idate_incr, nerror )   ;   date_bound(1) = tmpdate
468         tmpdate = date   ;   CALL PRISM_calc_newdate ( tmpdate,  idate_incr, nerror )   ;   date_bound(2) = tmpdate
469         !
470      ELSE      ! Date update
471         !
472         idate_incr  = rdttra(1)
473         CALL PRISM_calc_newdate( date, idate_incr, nerror )
474         date_bound(1) = date_bound(2)
475         tmpdate = date_bound(2)
476         CALL PRISM_calc_newdate( tmpdate, idate_incr, nerror )
477         date_bound(2) = tmpdate
478         !
479      END IF
480      !
481   END SUBROUTINE cpl_prism_update_time
482
483#endif
484
485   !!=====================================================================
486END MODULE cpl_oasis4
Note: See TracBrowser for help on using the repository browser.