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

source: branches/dev_r2586_dynamic_mem/NEMOGCM/NEMO/OPA_SRC/SBC/cpl_oasis4.F90 @ 2633

Last change on this file since 2633 was 2633, checked in by trackstand2, 13 years ago

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