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

source: trunk/NEMOGCM/NEMO/OPA_SRC/SBC/cpl_oasis4.F90 @ 2715

Last change on this file since 2715 was 2715, checked in by rblod, 13 years ago

First attempt to put dynamic allocation on the trunk
  • Property svn:keywords set to Id
File size: 22.7 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   !!----------------------------------------------------------------------
69   !! NEMO/OPA 3.3 , NEMO Consortium (2010)
70   !! $Id$
71   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
72   !!----------------------------------------------------------------------
73CONTAINS
74
75   SUBROUTINE cpl_prism_init( kl_comm ) 
76      !!-------------------------------------------------------------------
77      !!             ***  ROUTINE cpl_prism_init  ***
78      !!
79      !! ** Purpose :   Initialize coupled mode communication for ocean
80      !!    exchange between AGCM, OGCM and COUPLER. (OASIS4 software)
81      !!
82      !! ** Method  :   OASIS4 MPI communication
83      !!--------------------------------------------------------------------
84      INTEGER, INTENT(out) ::   kl_comm   ! local communicator of the model
85      !!--------------------------------------------------------------------
86     
87      CALL prism_init( 'nemo', nerror )
88
89      !------------------------------------------------------------------
90      ! 2nd Initialize the PRISM system for the component
91      !------------------------------------------------------------------
92      CALL prism_init_comp( ncomp_id, 'oceanx', nerror )
93      IF( nerror /= PRISM_Success )   CALL prism_abort( ncomp_id, 'cpl_prism_init', 'Failure in prism_init_comp' )
94
95      !------------------------------------------------------------------
96      ! 3rd Get an MPI communicator fr OPA local communication
97      !------------------------------------------------------------------
98      CALL prism_get_localcomm( ncomp_id, kl_comm, nerror )
99      IF( nerror /= PRISM_Success )   CALL prism_abort( ncomp_id, 'cpl_prism_init', 'Failure in prism_get_localcomm' )
100      !
101   END SUBROUTINE cpl_prism_init
102
103
104   SUBROUTINE cpl_prism_define( krcv, ksnd )
105      !!-------------------------------------------------------------------
106      !!             ***  ROUTINE cpl_prism_define  ***
107      !!
108      !! ** Purpose :   Define grid and field information for ocean
109      !!    exchange between AGCM, OGCM and COUPLER. (OASIS4 software)
110      !!
111      !! ** Method  :   OASIS4 MPI communication
112      !!--------------------------------------------------------------------
113      USE wrk_nemo, ONLY: wrk_in_use, wrk_not_released
114      USE wrk_nemo, ONLY: zclo => wrk_3d_1, zcla => wrk_3d_2
115      USE wrk_nemo, ONLY: zlon => wrk_2d_1, zlat => wrk_2d_2
116      !
117      INTEGER, INTENT(in) :: krcv, ksnd     ! Number of received and sent coupling fields
118      !
119      INTEGER, DIMENSION(4)      :: igrid     ! ids returned by prism_def_grid
120      INTEGER, DIMENSION(4)      :: iptid     ! ids returned by prism_set_points
121      INTEGER, DIMENSION(4)      :: imskid    ! ids returned by prism_set_mask
122      INTEGER, DIMENSION(4)      :: iishift   !
123      INTEGER, DIMENSION(4)      :: ijshift   !
124      INTEGER, DIMENSION(4)      :: iioff     !
125      INTEGER, DIMENSION(4)      :: ijoff     !
126      INTEGER, DIMENSION(4)      :: itmp      !
127      INTEGER, DIMENSION(1,3)    :: iextent   !
128      INTEGER, DIMENSION(1,3)    :: ioffset   !
129
130      INTEGER                    :: ishape(2,3)    ! shape of arrays passed to PSMILe
131      INTEGER                    :: data_type      ! data type of transients
132
133      LOGICAL                    :: new_points
134      LOGICAL                    :: new_mask
135      LOGICAL, ALLOCATABLE, SAVE :: llmask(:,:,:) ! jpi,jpj,1
136
137      INTEGER                    :: ji, jj, jg, jc   ! local loop indicees
138      INTEGER                    :: ii, ij           ! index
139      INTEGER, DIMENSION(1)      :: ind              ! index
140
141      CHARACTER(len=32)          :: clpt_name     ! name of the grid points
142      CHARACTER(len=7)           :: cltxt 
143      CHARACTER(len=1), DIMENSION(4) :: clgrd = (/ 'T','U','V','F' /)     ! name of the grid points
144
145      TYPE(PRISM_Time_struct)    :: tmpdate
146      INTEGER                    :: idate_incr      ! date increment
147      !!--------------------------------------------------------------------
148
149      IF( wrk_in_use(3, 1,2) .OR. wrk_in_use(2, 1,2) )THEN
150         CALL ctl_stop('cpl_prism_define: ERROR: requested workspace arrays are unavailable.')   ;   RETURN
151      ENDIF
152
153      IF(lwp) WRITE(numout,*)
154      IF(lwp) WRITE(numout,*) 'cpl_prism_define : initialization in coupled ocean/atmosphere case'
155      IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~~~~~'
156      IF(lwp) WRITE(numout,*)
157
158      !
159      ! ... Allocate memory for data exchange
160      !
161      ALLOCATE( exfld(nlei-nldi+1, nlej-nldj+1, 1), stat = nerror )
162      IF ( nerror > 0 ) THEN
163         CALL prism_abort( ncomp_id, 'cpl_prism_define', 'Failure in allocating exfld' )
164         RETURN
165      ENDIF
166
167      IF(.not. ALLOCATED(mask))THEN
168         ALLOCATE(llmask(jpi,jpj,1), Stat=ji)
169         IF(ji /= 0)THEN
170            CALL prism_abort( ncomp_id, 'cpl_prism_define', 'Failure in allocating llmask' )
171            RETURN
172         END IF
173      END IF
174
175      ! -----------------------------------------------------------------
176      ! ... Define the shape of the valid region without the halo and overlaps between cpus
177      !     For serial configuration (key_mpp_mpi not being active)
178      !     nl* is set to the global values 1 and jp*glo.
179      ! -----------------------------------------------------------------
180
181      ishape(:,1) = (/ 1, nlei-nldi+1 /)
182      ishape(:,2) = (/ 1, nlej-nldj+1 /)
183      ishape(:,3) = (/ 1,           1 /)
184         
185      DO ji = 1, 4
186         CALL prism_def_grid( igrid(ji), 'orca'//clgrd(ji), ncomp_id, ishape, PRISM_irrlonlat_regvrt, nerror )
187         IF( nerror /= PRISM_Success )   CALL prism_abort (ncomp_id, 'cpl_prism_define',   &
188            &                                                        'Failure in prism_def_grid of '//clgrd(jg)//'-point' )
189      END DO
190     
191      ! -----------------------------------------------------------------
192      ! ... Define the partition
193      ! -----------------------------------------------------------------
194     
195      iextent(1,:) = (/    nlei-nldi+1,    nlej-nldj+1, 1 /)
196      ioffset(1,:) = (/ nldi-1+nimpp-1, nldj-1+njmpp-1, 0 /)
197     
198      DO ji = 1, 4
199         CALL prism_def_partition( igrid(ji), 1, ioffset, iextent, nerror )
200         IF( nerror /= PRISM_Success )   CALL prism_abort (ncomp_id, 'cpl_prism_define',   &
201            &                                                        'Failure in prism_def_partition of '//clgrd(jg)//'-point' )
202      END DO
203
204      ! -----------------------------------------------------------------
205      ! ... Define the elements, i.e. specify the corner points for each
206      !     volume element. In case OPA runs on level coordinates (regular
207      !     in the vertical) we only need to give the 4 horizontal corners
208      !     for a volume element plus the vertical position of the upper
209      !     and lower face. Nevertheless the volume element has 8 corners.
210      ! -----------------------------------------------------------------
211     
212      iioff(:) = (/0,1,0,1/)
213      ijoff(:) = (/0,0,1,1/) 
214      iishift(:) = (/0,1,1,0/)
215      ijshift(:) = (/0,0,1,1/)
216
217      DO jg = 1, 4    ! ... the t,u,v,f-points
218
219         cltxt = clgrd(jg)//'-point'
220         
221         ! -----------------------------------------------------------------
222         ! ... Convert OPA masks to logicals and define the masks
223         ! -----------------------------------------------------------------
224         SELECT CASE( jg ) 
225         CASE(1)   ;   llmask(:,:,1) = ( tmask(:,:,1)  ) == 1.
226         CASE(2)   ;   llmask(:,:,1) = ( umask(:,:,1)  ) == 1.
227         CASE(3)   ;   llmask(:,:,1) = ( vmask(:,:,1)  ) == 1.
228         CASE(4)   ;   llmask(:,:,1) = ( fmask(:,:,1)  ) == 1.
229!         CASE(1)   ;   llmask(:,:,1) = ( tmask(:,:,1) * dom_uniq('T') ) == 1.
230!         CASE(2)   ;   llmask(:,:,1) = ( umask(:,:,1) * dom_uniq('U') ) == 1.
231!         CASE(3)   ;   llmask(:,:,1) = ( vmask(:,:,1) * dom_uniq('V') ) == 1.
232!         CASE(4)   ;   llmask(:,:,1) = ( fmask(:,:,1) * dom_uniq('F') ) == 1.
233         END SELECT
234         CALL prism_set_mask( imskid(jg), igrid(jg), ishape, llmask(nldi:nlei, nldj:nlej, 1), .TRUE., nerror )
235         IF( nerror /= PRISM_Success )   CALL prism_abort( ncomp_id, 'cpl_prism_define', 'Failure in prism_set_mask for '//cltxt )
236
237         ! -----------------------------------------------------------------
238         ! ... Define the corners
239         ! -----------------------------------------------------------------
240         SELECT CASE( jg ) 
241         CASE(1)   ;   zlon(:,:) = glamf(:,:)   ;   zlat(:,:) = gphif(:,:)
242         CASE(2)   ;   zlon(:,:) = glamv(:,:)   ;   zlat(:,:) = gphiv(:,:)
243         CASE(3)   ;   zlon(:,:) = glamu(:,:)   ;   zlat(:,:) = gphiu(:,:) 
244         CASE(4)   ;   zlon(:,:) = glamt(:,:)   ;   zlat(:,:) = gphit(:,:)
245         END SELECT
246
247         DO jc = 1, 4   ! corner number (anti-clockwise, starting from the bottom left corner)
248            DO jj = 2, jpjm1
249               DO ji = 2, jpim1   ! NO vector opt.
250                  ii = ji-1 + iioff(jg) + iishift(jc)
251                  ij = jj-1 + ijoff(jg) + ijshift(jc)
252                  zclo(ji,jj,jc) = zlon(ii,ij)
253                  zcla(ji,jj,jc) = zlat(ii,ij)
254               END DO
255            END DO
256            CALL lbc_lnk( zclo(:,:,jc), clgrd(jg), 1. )   ;   CALL lbc_lnk( zcla(:,:,jc), clgrd(jg), 1. )
257         END DO
258
259         CALL prism_set_corners( igrid(jg), 8, ishape, zclo(nldi:nlei, nldj:nlej,:),   &
260            &                                          zcla(nldi:nlei, nldj:nlej,:), RESHAPE( (/-1.,1./), (/1,2/) ), nerror )
261         IF( nerror /= PRISM_Success )   CALL prism_abort( ncomp_id, 'cpl_prism_define', 'Failure in prism_set_corners of '//cltxt )   
262
263         ! -----------------------------------------------------------------
264         ! ... Define the center points
265         ! -----------------------------------------------------------------
266         SELECT CASE( jg ) 
267         CASE(1)   ;   zlon(:,:) = glamt(:,:)   ;   zlat(:,:) = gphit(:,:)
268         CASE(2)   ;   zlon(:,:) = glamu(:,:)   ;   zlat(:,:) = gphiu(:,:)
269         CASE(3)   ;   zlon(:,:) = glamv(:,:)   ;   zlat(:,:) = gphiv(:,:)
270         CASE(4)   ;   zlon(:,:) = glamf(:,:)   ;   zlat(:,:) = gphif(:,:)
271         END SELECT
272
273         CALL prism_set_points ( iptid(jg), cltxt, igrid(jg), ishape, zlon(nldi:nlei, nldj:nlej),   &
274         &                                                            zlat(nldi:nlei, nldj:nlej), (/0./), .TRUE., nerror )
275         IF( nerror /= PRISM_Success )   CALL prism_abort ( ncomp_id, 'cpl_prism_define', 'Failure in prism_set_points '//cltxt )
276
277      END DO
278
279      ! ... Announce send variables.
280      !
281      DO ji = 1, ksnd
282         IF ( ssnd(ji)%laction ) THEN
283           
284            itmp(:) = 0
285            WHERE( clgrd == ssnd(ji)%clgrid  ) itmp = 1
286            ind(:) = maxloc( itmp )
287            WRITE(6,*) ' grid for field ', ind(1), ssnd(ji)%clname
288             ind(1) = 1
289
290            CALL prism_def_var( ssnd(ji)%nid, ssnd(ji)%clname, igrid(ind(1)), iptid(ind(1)),  imskid(ind(1)), (/ 3, 0/),   &
291               &                ishape, PRISM_Double_Precision, nerror )
292            IF ( nerror /= PRISM_Success )   CALL prism_abort( ssnd(ji)%nid, 'cpl_prism_define',   &
293               &                                               'Failure in prism_def_var for '//TRIM(ssnd(ji)%clname))
294
295         ENDIF
296      END DO
297      !
298      ! ... Announce received variables.
299      !
300      DO ji = 1, krcv
301         IF ( srcv(ji)%laction ) THEN
302
303            itmp(:) = 0
304            WHERE( clgrd == srcv(ji)%clgrid  ) itmp = 1
305            ind(:) = maxloc( itmp )
306            WRITE(6,*) ' grid for field ', ind(1), srcv(ji)%clname
307             ind(1) = 1
308 
309            CALL prism_def_var( srcv(ji)%nid, srcv(ji)%clname, igrid(ind(1)), iptid(ind(1)), imskid(ind(1)), (/ 3, 0/),   &
310               &                ishape, PRISM_Double_Precision, nerror )
311            IF ( nerror /= PRISM_Success )   CALL prism_abort( srcv(ji)%nid, 'cpl_prism_define',   &
312               &                                               'Failure in prism_def_var for '//TRIM(srcv(ji)%clname))
313
314         ENDIF
315      END DO
316     
317      !------------------------------------------------------------------
318      ! End of definition phase
319      !------------------------------------------------------------------
320     
321      CALL prism_enddef( nerror )
322      IF ( nerror /= PRISM_Success )   CALL prism_abort ( ncomp_id, 'cpl_prism_define', 'Failure in prism_enddef')
323     
324      IF( wrk_not_released(3, 1,2) .OR.   &
325          wrk_not_released(2, 1,2)   )   CALL ctl_stop('cpl_prism_define: failed to release workspace arrays')
326      !
327   END SUBROUTINE cpl_prism_define
328   
329   
330   SUBROUTINE cpl_prism_snd( kid, kstep, pdata, kinfo )
331      !!---------------------------------------------------------------------
332      !!              ***  ROUTINE cpl_prism_snd  ***
333      !!
334      !! ** Purpose : - At each coupling time-step,this routine sends fields
335      !!      like sst or ice cover to the coupler or remote application.
336      !!----------------------------------------------------------------------
337      INTEGER                 , INTENT(in   ) ::   kid     ! variable intex in the array
338      INTEGER                 , INTENT(  out) ::   kinfo   ! OASIS4 info argument
339      INTEGER                 , INTENT(in   ) ::   kstep   ! ocean time-step in seconds
340      REAL(wp), DIMENSION(:,:), INTENT(in   ) ::   pdata
341      !!--------------------------------------------------------------------
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      !
365   END SUBROUTINE cpl_prism_snd
366
367
368   SUBROUTINE cpl_prism_rcv( kid, kstep, pdata, kinfo )
369      !!---------------------------------------------------------------------
370      !!              ***  ROUTINE cpl_prism_rcv  ***
371      !!
372      !! ** Purpose : - At each coupling time-step,this routine receives fields
373      !!      like stresses and fluxes from the coupler or remote application.
374      !!----------------------------------------------------------------------
375      INTEGER                 , INTENT(in   ) ::   kid     ! variable intex in the array
376      INTEGER                 , INTENT(in   ) ::   kstep   ! ocean time-step in seconds
377      REAL(wp), DIMENSION(:,:), INTENT(inout) ::   pdata   ! IN to keep the value if nothing is done
378      INTEGER                 , INTENT(  out) ::   kinfo   ! OASIS4 info argument
379      !
380      LOGICAL                :: llaction
381      !!--------------------------------------------------------------------
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       
406            WRITE(numout,*) '****************'
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)
414            WRITE(numout,*) '****************'
415         ENDIF
416
417      ELSE
418         kinfo = OASIS_idle     
419      ENDIF
420      !
421   END SUBROUTINE cpl_prism_rcv
422
423
424   SUBROUTINE cpl_prism_finalize
425      !!---------------------------------------------------------------------
426      !!              ***  ROUTINE cpl_prism_finalize  ***
427      !!
428      !! ** Purpose : - Finalizes the coupling. If MPI_init has not been
429      !!      called explicitly before cpl_prism_init it will also close
430      !!      MPI communication.
431      !!----------------------------------------------------------------------
432      !
433      DEALLOCATE(exfld)
434      CALL prism_terminate ( nerror )         
435      !
436   END SUBROUTINE cpl_prism_finalize
437
438
439   SUBROUTINE cpl_prism_update_time(kt)
440      !!---------------------------------------------------------------------
441      !!              ***  ROUTINE cpl_prism_update_time  ***
442      !!
443      !! ** Purpose : - Increment date with model timestep
444      !!                called explicitly at the end of each timestep
445      !!----------------------------------------------------------------------
446      INTEGER, INTENT(in) ::   kt   ! ocean model time step index
447
448      TYPE(PRISM_Time_struct) ::   tmpdate
449      INTEGER                 ::   idate_incr   ! date increment
450      !!----------------------------------------------------------------------
451
452      IF( kt == nit000 ) THEN      ! Define the actual date
453         !
454         ! date is determined by adding days since beginning of the run to the corresponding initial date.
455         ! Note that OPA internal info about the start date of the experiment is bypassed.
456         ! Instead we rely sololy on the info provided by the SCC.xml file.
457         !
458         date = PRISM_Jobstart_date
459         !
460         !
461         ! lower/upper bound is determined by adding half a time step
462         !
463         idate_incr = 0.5 * NINT ( rdttra(1) )
464         tmpdate = date   ;   CALL PRISM_calc_newdate ( tmpdate, -idate_incr, nerror )   ;   date_bound(1) = tmpdate
465         tmpdate = date   ;   CALL PRISM_calc_newdate ( tmpdate,  idate_incr, nerror )   ;   date_bound(2) = tmpdate
466         !
467      ELSE      ! Date update
468         !
469         idate_incr  = rdttra(1)
470         CALL PRISM_calc_newdate( date, idate_incr, nerror )
471         date_bound(1) = date_bound(2)
472         tmpdate = date_bound(2)
473         CALL PRISM_calc_newdate( tmpdate, idate_incr, nerror )
474         date_bound(2) = tmpdate
475         !
476      END IF
477      !
478   END SUBROUTINE cpl_prism_update_time
479
480#endif
481
482   !!=====================================================================
483END MODULE cpl_oasis4
Note: See TracBrowser for help on using the repository browser.