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/UKMO/2014_Surge_Modelling/NEMOGCM/NEMO/OPA_SRC/SBC – NEMO

source: branches/UKMO/2014_Surge_Modelling/NEMOGCM/NEMO/OPA_SRC/SBC/cpl_oasis4.F90 @ 5728

Last change on this file since 5728 was 3294, checked in by rblod, 12 years ago

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