source: branches/2014/dev_r4650_UKMO2_ice_shelves/NEMOGCM/NEMO/OPA_SRC/DIA/diaptr.F90 @ 4726

Last change on this file since 4726 was 4726, checked in by mathiot, 6 years ago

ISF branch: change name of 2 variables (icedep ⇒ risfdep and lmask ⇒ ssmask), cosmetic changes and add ldfslp key

  • Property svn:keywords set to Id
File size: 43.7 KB
Line 
1MODULE diaptr
2   !!======================================================================
3   !!                       ***  MODULE  diaptr  ***
4   !! Ocean physics:  Computes meridonal transports and zonal means
5   !!=====================================================================
6   !! History :  1.0  ! 2003-09  (C. Talandier, G. Madec)  Original code
7   !!            2.0  ! 2006-01  (A. Biastoch)  Allow sub-basins computation
8   !!            3.2  ! 2010-03  (O. Marti, S. Flavoni) Add fields
9   !!            3.3  ! 2010-10  (G. Madec)  dynamical allocation
10   !!----------------------------------------------------------------------
11
12   !!----------------------------------------------------------------------
13   !!   dia_ptr      : Poleward Transport Diagnostics module
14   !!   dia_ptr_init : Initialization, namelist read
15   !!   dia_ptr_wri  : Output of poleward fluxes
16   !!   ptr_vjk      : "zonal" sum computation of a "meridional" flux array
17   !!   ptr_tjk      : "zonal" mean computation of a tracer field
18   !!   ptr_vj       : "zonal" and vertical sum computation of a "meridional" flux array
19   !!                   (Generic interface to ptr_vj_3d, ptr_vj_2d)
20   !!----------------------------------------------------------------------
21   USE oce              ! ocean dynamics and active tracers
22   USE dom_oce          ! ocean space and time domain
23   USE phycst           ! physical constants
24   USE ldftra_oce       ! ocean active tracers: lateral physics
25   USE dianam           !
26   USE iom              ! IOM library
27   USE ioipsl           ! IO-IPSL library
28   USE in_out_manager   ! I/O manager
29   USE lib_mpp          ! MPP library
30   USE lbclnk           ! lateral boundary condition - processor exchanges
31   USE timing           ! preformance summary
32   USE wrk_nemo         ! working arrays
33
34   IMPLICIT NONE
35   PRIVATE
36
37   INTERFACE ptr_vj
38      MODULE PROCEDURE ptr_vj_3d, ptr_vj_2d
39   END INTERFACE
40
41   PUBLIC   dia_ptr_init   ! call in opa module
42   PUBLIC   dia_ptr        ! call in step module
43   PUBLIC   ptr_vj         ! call by tra_ldf & tra_adv routines
44   PUBLIC   ptr_vjk        ! call by tra_ldf & tra_adv routines
45
46   !                                  !!** namelist  namptr  **
47   LOGICAL , PUBLIC ::   ln_diaptr     !: Poleward transport flag (T) or not (F)
48   LOGICAL , PUBLIC ::   ln_subbas     !: Atlantic/Pacific/Indian basins calculation
49   LOGICAL , PUBLIC ::   ln_diaznl     !: Add zonal means and meridional stream functions
50   LOGICAL , PUBLIC ::   ln_ptrcomp    !: Add decomposition : overturning (and gyre, soon ...)
51   INTEGER , PUBLIC ::   nn_fptr       !: frequency of ptr computation  [time step]
52   INTEGER , PUBLIC ::   nn_fwri       !: frequency of ptr outputs      [time step]
53
54   REAL(wp), ALLOCATABLE, SAVE, PUBLIC, DIMENSION(:) ::   htr_adv, htr_ldf, htr_ove   !: Heat TRansports (adv, diff, overturn.)
55   REAL(wp), ALLOCATABLE, SAVE, PUBLIC, DIMENSION(:) ::   str_adv, str_ldf, str_ove   !: Salt TRansports (adv, diff, overturn.)
56   
57   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   btmsk                  ! T-point basin interior masks
58   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   btm30                  ! mask out Southern Ocean (=0 south of 30°S)
59   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   htr  , str             ! adv heat and salt transports (approx)
60   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   tn_jk, sn_jk , v_msf   ! i-mean T and S, j-Stream-Function
61   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   sjk  , r1_sjk          ! i-mean i-k-surface and its inverse       
62   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   htr_eiv, str_eiv       ! bolus adv heat ans salt transports ('key_diaeiv')
63   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   v_msf_eiv              ! bolus j-streamfuction              ('key_diaeiv')
64
65
66   INTEGER ::   niter       !
67   INTEGER ::   nidom_ptr   !
68   INTEGER ::   numptr      ! logical unit for Poleward TRansports
69   INTEGER ::   nptr        ! = 1 (ln_subbas=F) or = 5 (glo, atl, pac, ind, ipc) (ln_subbas=T)
70
71   REAL(wp) ::   rc_sv    = 1.e-6_wp   ! conversion from m3/s to Sverdrup
72   REAL(wp) ::   rc_pwatt = 1.e-15_wp  ! conversion from W    to PW (further x rau0 x Cp)
73   REAL(wp) ::   rc_ggram = 1.e-6_wp   ! conversion from g    to Pg
74
75   REAL(wp), TARGET, DIMENSION(:),   ALLOCATABLE, SAVE :: p_fval1d
76   REAL(wp), TARGET, DIMENSION(:,:), ALLOCATABLE, SAVE :: p_fval2d
77
78   !! Integer, 1D workspace arrays. Not common enough to be implemented in
79   !! wrk_nemo module.
80   INTEGER, ALLOCATABLE, SAVE, DIMENSION(:) :: ndex  , ndex_atl     , ndex_pac     , ndex_ind     , ndex_ipc
81   INTEGER, ALLOCATABLE, SAVE, DIMENSION(:) ::         ndex_atl_30  , ndex_pac_30  , ndex_ind_30  , ndex_ipc_30
82   INTEGER, ALLOCATABLE, SAVE, DIMENSION(:) :: ndex_h, ndex_h_atl_30, ndex_h_pac_30, ndex_h_ind_30, ndex_h_ipc_30
83
84   !! * Substitutions
85#  include "domzgr_substitute.h90"
86#  include "vectopt_loop_substitute.h90"
87   !!----------------------------------------------------------------------
88   !! NEMO/OPA 3.3 , NEMO Consortium (2010)
89   !! $Id$
90   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
91   !!----------------------------------------------------------------------
92CONTAINS
93
94   FUNCTION dia_ptr_alloc()
95      !!----------------------------------------------------------------------
96      !!                    ***  ROUTINE dia_ptr_alloc  ***
97      !!----------------------------------------------------------------------
98      INTEGER               ::   dia_ptr_alloc   ! return value
99      INTEGER, DIMENSION(6) ::   ierr
100      !!----------------------------------------------------------------------
101      ierr(:) = 0
102      !
103      ALLOCATE( btmsk(jpi,jpj,nptr) ,           &
104         &      htr_adv(jpj) , str_adv(jpj) ,   &
105         &      htr_ldf(jpj) , str_ldf(jpj) ,   &
106         &      htr_ove(jpj) , str_ove(jpj),    &
107         &      htr(jpj,nptr) , str(jpj,nptr) , &
108         &      tn_jk(jpj,jpk,nptr) , sn_jk (jpj,jpk,nptr) , v_msf(jpj,jpk,nptr) , &
109         &      sjk  (jpj,jpk,nptr) , r1_sjk(jpj,jpk,nptr) , STAT=ierr(1)  )
110         !
111#if defined key_diaeiv
112      ALLOCATE( htr_eiv(jpj,nptr) , str_eiv(jpj,nptr) , &
113         &      v_msf_eiv(jpj,jpk,nptr) , STAT=ierr(2) )
114#endif
115      ALLOCATE( p_fval1d(jpj), p_fval2d(jpj,jpk), Stat=ierr(3))
116      !
117      ALLOCATE(ndex(jpj*jpk),        ndex_atl(jpj*jpk), ndex_pac(jpj*jpk), &
118         &     ndex_ind(jpj*jpk),    ndex_ipc(jpj*jpk),                    &
119         &     ndex_atl_30(jpj*jpk), ndex_pac_30(jpj*jpk), Stat=ierr(4))
120
121      ALLOCATE(ndex_ind_30(jpj*jpk), ndex_ipc_30(jpj*jpk),                   &
122         &     ndex_h(jpj),          ndex_h_atl_30(jpj), ndex_h_pac_30(jpj), &
123         &     ndex_h_ind_30(jpj),   ndex_h_ipc_30(jpj), Stat=ierr(5) )
124         !
125     ALLOCATE( btm30(jpi,jpj) , STAT=ierr(6)  )
126         !
127      dia_ptr_alloc = MAXVAL( ierr )
128      IF(lk_mpp)   CALL mpp_sum( dia_ptr_alloc )
129      !
130   END FUNCTION dia_ptr_alloc
131
132
133   FUNCTION ptr_vj_3d( pva )   RESULT ( p_fval )
134      !!----------------------------------------------------------------------
135      !!                    ***  ROUTINE ptr_vj_3d  ***
136      !!
137      !! ** Purpose :   i-k sum computation of a j-flux array
138      !!
139      !! ** Method  : - i-k sum of pva using the interior 2D vmask (vmask_i).
140      !!              pva is supposed to be a masked flux (i.e. * vmask*e1v*e3v)
141      !!
142      !! ** Action  : - p_fval: i-k-mean poleward flux of pva
143      !!----------------------------------------------------------------------
144      REAL(wp) , INTENT(in), DIMENSION(jpi,jpj,jpk) ::   pva   ! mask flux array at V-point
145      !!
146      INTEGER                  ::   ji, jj, jk   ! dummy loop arguments
147      INTEGER                  ::   ijpj         ! ???
148      REAL(wp), POINTER, DIMENSION(:) :: p_fval  ! function value
149      !!--------------------------------------------------------------------
150      !
151      p_fval => p_fval1d
152
153      ijpj = jpj
154      p_fval(:) = 0._wp
155      DO jk = 1, jpkm1
156         DO jj = 2, jpjm1
157            DO ji = fs_2, fs_jpim1   ! Vector opt.
158               p_fval(jj) = p_fval(jj) + pva(ji,jj,jk) * tmask_i(ji,jj) 
159            END DO
160         END DO
161      END DO
162#if defined key_mpp_mpi
163      IF(lk_mpp)   CALL mpp_sum( p_fval, ijpj, ncomm_znl)
164#endif
165      !
166   END FUNCTION ptr_vj_3d
167
168
169   FUNCTION ptr_vj_2d( pva )   RESULT ( p_fval )
170      !!----------------------------------------------------------------------
171      !!                    ***  ROUTINE ptr_vj_2d  ***
172      !!
173      !! ** Purpose :   "zonal" and vertical sum computation of a i-flux array
174      !!
175      !! ** Method  : - i-k sum of pva using the interior 2D vmask (vmask_i).
176      !!      pva is supposed to be a masked flux (i.e. * vmask*e1v*e3v)
177      !!
178      !! ** Action  : - p_fval: i-k-mean poleward flux of pva
179      !!----------------------------------------------------------------------
180      IMPLICIT none
181      REAL(wp) , INTENT(in), DIMENSION(jpi,jpj) ::   pva   ! mask flux array at V-point
182      !!
183      INTEGER                  ::   ji,jj       ! dummy loop arguments
184      INTEGER                  ::   ijpj        ! ???
185      REAL(wp), POINTER, DIMENSION(:) :: p_fval ! function value
186      !!--------------------------------------------------------------------
187      !
188      p_fval => p_fval1d
189
190      ijpj = jpj
191      p_fval(:) = 0._wp
192      DO jj = 2, jpjm1
193         DO ji = nldi, nlei   ! No vector optimisation here. Better use a mask ?
194            p_fval(jj) = p_fval(jj) + pva(ji,jj) * tmask_i(ji,jj)
195         END DO
196      END DO
197#if defined key_mpp_mpi
198      CALL mpp_sum( p_fval, ijpj, ncomm_znl )
199#endif
200      !
201   END FUNCTION ptr_vj_2d
202
203
204   FUNCTION ptr_vjk( pva, pmsk )   RESULT ( p_fval )
205      !!----------------------------------------------------------------------
206      !!                    ***  ROUTINE ptr_vjk  ***
207      !!
208      !! ** Purpose :   i-sum computation of a j-velocity array
209      !!
210      !! ** Method  : - i-sum of pva using the interior 2D vmask (vmask_i).
211      !!              pva is supposed to be a masked flux (i.e. * vmask)
212      !!
213      !! ** Action  : - p_fval: i-mean poleward flux of pva
214      !!----------------------------------------------------------------------
215      !!
216      IMPLICIT none
217      REAL(wp) , INTENT(in), DIMENSION(jpi,jpj,jpk)           ::   pva    ! mask flux array at V-point
218      REAL(wp) , INTENT(in), DIMENSION(jpi,jpj)    , OPTIONAL ::   pmsk   ! Optional 2D basin mask
219      !!
220      INTEGER                           :: ji, jj, jk ! dummy loop arguments
221      REAL(wp), POINTER, DIMENSION(:,:) :: p_fval     ! return function value
222#if defined key_mpp_mpi
223      INTEGER, DIMENSION(1) ::   ish
224      INTEGER, DIMENSION(2) ::   ish2
225      INTEGER               ::   ijpjjpk
226#endif
227#if defined key_mpp_mpi
228      REAL(wp), POINTER, DIMENSION(:) ::   zwork    ! mask flux array at V-point
229#endif
230      !!--------------------------------------------------------------------
231      !
232#if defined key_mpp_mpi
233      ijpjjpk = jpj*jpk
234      CALL wrk_alloc( jpj*jpk, zwork )
235#endif
236
237      p_fval => p_fval2d
238
239      p_fval(:,:) = 0._wp
240      !
241      IF( PRESENT( pmsk ) ) THEN
242         DO jk = 1, jpkm1
243            DO jj = 2, jpjm1
244!!gm here, use of tmask_i  ==> no need of loop over nldi, nlei....
245               DO ji =  nldi, nlei   ! No vector optimisation here. Better use a mask ?
246                  p_fval(jj,jk) = p_fval(jj,jk) + pva(ji,jj,jk) * e1v(ji,jj) * fse3v(ji,jj,jk) * pmsk(ji,jj)
247               END DO
248            END DO
249         END DO
250      ELSE
251         DO jk = 1, jpkm1
252            DO jj = 2, jpjm1
253               DO ji =  nldi, nlei   ! No vector optimisation here. Better use a mask ?
254                  p_fval(jj,jk) = p_fval(jj,jk) + pva(ji,jj,jk) * e1v(ji,jj) * fse3v(ji,jj,jk) * tmask_i(ji,jj)
255               END DO
256            END DO
257         END DO
258      END IF
259      !
260#if defined key_mpp_mpi
261      ijpjjpk = jpj*jpk
262      ish(1) = ijpjjpk  ;   ish2(1) = jpj   ;   ish2(2) = jpk
263      zwork(1:ijpjjpk) = RESHAPE( p_fval, ish )
264      CALL mpp_sum( zwork, ijpjjpk, ncomm_znl )
265      p_fval(:,:) = RESHAPE( zwork, ish2 )
266#endif
267      !
268#if defined key_mpp_mpi
269      CALL wrk_dealloc( jpj*jpk, zwork )
270#endif
271      !
272   END FUNCTION ptr_vjk
273
274
275   FUNCTION ptr_tjk( pta, pmsk )   RESULT ( p_fval )
276      !!----------------------------------------------------------------------
277      !!                    ***  ROUTINE ptr_tjk  ***
278      !!
279      !! ** Purpose :   i-sum computation of e1t*e3t * a tracer field
280      !!
281      !! ** Method  : - i-sum of mj(pta) using tmask
282      !!
283      !! ** Action  : - p_fval: i-sum of e1t*e3t*pta
284      !!----------------------------------------------------------------------
285      !!
286      REAL(wp) , INTENT(in), DIMENSION(jpi,jpj,jpk) ::   pta    ! tracer flux array at T-point
287      REAL(wp) , INTENT(in), DIMENSION(jpi,jpj)     ::   pmsk   ! Optional 2D basin mask
288      !!
289      INTEGER                           :: ji, jj, jk   ! dummy loop arguments
290      REAL(wp), POINTER, DIMENSION(:,:) :: p_fval       ! return function value
291#if defined key_mpp_mpi
292      INTEGER, DIMENSION(1) ::   ish
293      INTEGER, DIMENSION(2) ::   ish2
294      INTEGER               ::   ijpjjpk
295#endif
296#if defined key_mpp_mpi
297      REAL(wp), POINTER, DIMENSION(:) ::   zwork    ! mask flux array at V-point
298#endif
299      !!--------------------------------------------------------------------
300      !
301#if defined key_mpp_mpi
302      ijpjjpk = jpj*jpk
303      CALL wrk_alloc( jpj*jpk, zwork )
304#endif
305
306      p_fval => p_fval2d
307
308      p_fval(:,:) = 0._wp
309      DO jk = 1, jpkm1
310         DO jj = 2, jpjm1
311            DO ji =  nldi, nlei   ! No vector optimisation here. Better use a mask ?
312               p_fval(jj,jk) = p_fval(jj,jk) + pta(ji,jj,jk) * e1t(ji,jj) * fse3t(ji,jj,jk) * pmsk(ji,jj)
313            END DO
314         END DO
315      END DO
316#if defined key_mpp_mpi
317      ijpjjpk = jpj*jpk
318      ish(1) = jpj*jpk   ;   ish2(1) = jpj   ;   ish2(2) = jpk
319      zwork(1:ijpjjpk)= RESHAPE( p_fval, ish )
320      CALL mpp_sum( zwork, ijpjjpk, ncomm_znl )
321      p_fval(:,:)= RESHAPE( zwork, ish2 )
322#endif
323      !
324#if defined key_mpp_mpi
325      CALL wrk_dealloc( jpj*jpk, zwork )
326#endif
327      !   
328   END FUNCTION ptr_tjk
329
330
331   SUBROUTINE dia_ptr( kt )
332      !!----------------------------------------------------------------------
333      !!                  ***  ROUTINE dia_ptr  ***
334      !!----------------------------------------------------------------------
335      USE oce,     vt  =>   ua   ! use ua as workspace
336      USE oce,     vs  =>   va   ! use va as workspace
337      IMPLICIT none
338      !!
339      INTEGER, INTENT(in) ::   kt   ! ocean time step index
340      !
341      INTEGER  ::   ji, jj, jk, jn   ! dummy loop indices
342      REAL(wp) ::   zv               ! local scalar
343      !!----------------------------------------------------------------------
344      !
345      IF( nn_timing == 1 )   CALL timing_start('dia_ptr')
346      !
347      IF( kt == nit000 .OR. MOD( kt, nn_fptr ) == 0 )   THEN
348         !
349         IF( MOD( kt, nn_fptr ) == 0 ) THEN 
350            !
351            IF( ln_diaznl ) THEN               ! i-mean temperature and salinity
352               DO jn = 1, nptr
353                  tn_jk(:,:,jn) = ptr_tjk( tsn(:,:,:,jp_tem), btmsk(:,:,jn) ) * r1_sjk(:,:,jn)
354                  sn_jk(:,:,jn) = ptr_tjk( tsn(:,:,:,jp_sal), btmsk(:,:,jn) ) * r1_sjk(:,:,jn)
355               END DO
356            ENDIF
357            !
358            !                          ! horizontal integral and vertical dz
359            !                                ! eulerian velocity
360            v_msf(:,:,1) = ptr_vjk( vn(:,:,:) ) 
361            DO jn = 2, nptr
362               v_msf(:,:,jn) = ptr_vjk( vn(:,:,:), btmsk(:,:,jn)*btm30(:,:) ) 
363            END DO
364#if defined key_diaeiv
365            DO jn = 1, nptr                  ! bolus velocity
366               v_msf_eiv(:,:,jn) = ptr_vjk( v_eiv(:,:,:), btmsk(:,:,jn) )   ! here no btm30 for MSFeiv
367            END DO
368            !                                ! add bolus stream-function to the eulerian one
369            v_msf(:,:,:) = v_msf(:,:,:) + v_msf_eiv(:,:,:)
370#endif
371            !
372            !                          ! Transports
373            !                                ! local heat & salt transports at T-points  ( tsn*mj[vn+v_eiv] )
374            vt(:,:,jpk) = 0._wp   ;   vs(:,:,jpk) = 0._wp
375            DO jk= 1, jpkm1
376               DO jj = 2, jpj
377                  DO ji = 1, jpi
378#if defined key_diaeiv 
379                     zv = ( vn(ji,jj,jk) + vn(ji,jj-1,jk) + v_eiv(ji,jj,jk) + v_eiv(ji,jj-1,jk) ) * 0.5_wp
380#else
381                     zv = ( vn(ji,jj,jk) + vn(ji,jj-1,jk) ) * 0.5_wp
382#endif
383                     vt(ji,jj,jk) = zv * tsn(ji,jj,jk,jp_tem)
384                     vs(ji,jj,jk) = zv * tsn(ji,jj,jk,jp_sal)
385                  END DO
386               END DO
387            END DO
388!!gm useless as overlap areas are not used in ptr_vjk
389            CALL lbc_lnk( vs, 'V', -1. )   ;   CALL lbc_lnk( vt, 'V', -1. )
390!!gm
391            !                                ! heat & salt advective transports (approximation)
392            htr(:,1) = SUM( ptr_vjk( vt(:,:,:) ) , 2 ) * rc_pwatt   ! SUM over jk + conversion
393            str(:,1) = SUM( ptr_vjk( vs(:,:,:) ) , 2 ) * rc_ggram
394            DO jn = 2, nptr 
395               htr(:,jn) = SUM( ptr_vjk( vt(:,:,:), btmsk(:,:,jn)*btm30(:,:) ) , 2 ) * rc_pwatt   ! mask Southern Ocean
396               str(:,jn) = SUM( ptr_vjk( vs(:,:,:), btmsk(:,:,jn)*btm30(:,:) ) , 2 ) * rc_ggram   ! mask Southern Ocean
397            END DO
398
399            IF( ln_ptrcomp ) THEN            ! overturning transport
400               htr_ove(:) = SUM( v_msf(:,:,1) * tn_jk(:,:,1), 2 ) * rc_pwatt   ! SUM over jk + conversion
401               str_ove(:) = SUM( v_msf(:,:,1) * sn_jk(:,:,1), 2 ) * rc_ggram
402            END IF
403            !                                ! Advective and diffusive transport
404            htr_adv(:) = htr_adv(:) * rc_pwatt        ! these are computed in tra_adv... and tra_ldf... routines
405            htr_ldf(:) = htr_ldf(:) * rc_pwatt        ! here just the conversion in PW and Gg
406            str_adv(:) = str_adv(:) * rc_ggram
407            str_ldf(:) = str_ldf(:) * rc_ggram
408
409#if defined key_diaeiv
410            DO jn = 1, nptr                  ! Bolus component
411               htr_eiv(:,jn) = SUM( v_msf_eiv(:,:,jn) * tn_jk(:,:,jn), 2 ) * rc_pwatt   ! SUM over jk
412               str_eiv(:,jn) = SUM( v_msf_eiv(:,:,jn) * sn_jk(:,:,jn), 2 ) * rc_ggram   ! SUM over jk
413            END DO
414#endif
415            !                                ! "Meridional" Stream-Function
416            DO jn = 1, nptr
417               DO jk = 2, jpk 
418                  v_msf    (:,jk,jn) = v_msf    (:,jk-1,jn) + v_msf    (:,jk,jn)       ! Eulerian j-Stream-Function
419#if defined key_diaeiv
420                  v_msf_eiv(:,jk,jn) = v_msf_eiv(:,jk-1,jn) + v_msf_eiv(:,jk,jn)       ! Bolus    j-Stream-Function
421
422#endif
423               END DO
424            END DO
425            v_msf    (:,:,:) = v_msf    (:,:,:) * rc_sv       ! converte in Sverdrups
426#if defined key_diaeiv
427            v_msf_eiv(:,:,:) = v_msf_eiv(:,:,:) * rc_sv
428#endif
429         ENDIF
430         !
431         CALL dia_ptr_wri( kt )                        ! outputs
432         !
433      ENDIF
434      !
435#if defined key_mpp_mpi
436      IF( kt == nitend .AND. l_znl_root )   CALL histclo( numptr )      ! Close the file
437#else
438      IF( kt == nitend )                    CALL histclo( numptr )      ! Close the file
439#endif
440      !
441      IF( nn_timing == 1 )   CALL timing_stop('dia_ptr')
442      !
443   END SUBROUTINE dia_ptr
444
445
446   SUBROUTINE dia_ptr_init
447      !!----------------------------------------------------------------------
448      !!                  ***  ROUTINE dia_ptr_init  ***
449      !!                   
450      !! ** Purpose :   Initialization, namelist read
451      !!----------------------------------------------------------------------
452      INTEGER ::   jn           ! dummy loop indices
453      INTEGER ::   inum, ierr   ! local integers
454      INTEGER ::   ios          ! Local integer output status for namelist read
455#if defined key_mpp_mpi
456      INTEGER, DIMENSION(1) :: iglo, iloc, iabsf, iabsl, ihals, ihale, idid
457#endif
458      !!
459      NAMELIST/namptr/ ln_diaptr, ln_diaznl, ln_subbas, ln_ptrcomp, nn_fptr, nn_fwri
460      !!----------------------------------------------------------------------
461
462      REWIND( numnam_ref )              ! Namelist namptr in reference namelist : Poleward transport
463      READ  ( numnam_ref, namptr, IOSTAT = ios, ERR = 901)
464901   IF( ios /= 0 ) CALL ctl_nam ( ios , 'namptr in reference namelist', lwp )
465
466      REWIND( numnam_cfg )              ! Namelist namptr in configuration namelist : Poleward transport
467      READ  ( numnam_cfg, namptr, IOSTAT = ios, ERR = 902 )
468902   IF( ios /= 0 ) CALL ctl_nam ( ios , 'namptr in configuration namelist', lwp )
469      IF(lwm) WRITE ( numond, namptr )
470
471      IF(lwp) THEN                     ! Control print
472         WRITE(numout,*)
473         WRITE(numout,*) 'dia_ptr_init : poleward transport and msf initialization'
474         WRITE(numout,*) '~~~~~~~~~~~~'
475         WRITE(numout,*) '   Namelist namptr : set ptr parameters'
476         WRITE(numout,*) '      Poleward heat & salt transport (T) or not (F)      ln_diaptr  = ', ln_diaptr
477         WRITE(numout,*) '      Overturning heat & salt transport                  ln_ptrcomp = ', ln_ptrcomp
478         WRITE(numout,*) '      T & S zonal mean and meridional stream function    ln_diaznl  = ', ln_diaznl 
479         WRITE(numout,*) '      Global (F) or glo/Atl/Pac/Ind/Indo-Pac basins      ln_subbas  = ', ln_subbas
480         WRITE(numout,*) '      Frequency of computation                           nn_fptr    = ', nn_fptr
481         WRITE(numout,*) '      Frequency of outputs                               nn_fwri    = ', nn_fwri
482      ENDIF
483     
484      IF( ln_diaptr) THEN 
485     
486         IF( nn_timing == 1 )   CALL timing_start('dia_ptr_init')
487     
488         IF( ln_subbas ) THEN   ;   nptr = 5       ! Global, Atlantic, Pacific, Indian, Indo-Pacific
489         ELSE                   ;   nptr = 1       ! Global only
490         ENDIF
491
492         !                                      ! allocate dia_ptr arrays
493         IF( dia_ptr_alloc() /= 0 )   CALL ctl_stop( 'STOP', 'dia_ptr_init : unable to allocate arrays' )
494
495         rc_pwatt = rc_pwatt * rau0 * rcp          ! conversion from K.s-1 to PetaWatt
496
497         IF( lk_mpp )   CALL mpp_ini_znl( numout )     ! Define MPI communicator for zonal sum
498
499         IF( ln_subbas ) THEN                ! load sub-basin mask
500            CALL iom_open( 'subbasins', inum )
501            CALL iom_get( inum, jpdom_data, 'atlmsk', btmsk(:,:,2) )   ! Atlantic basin
502            CALL iom_get( inum, jpdom_data, 'pacmsk', btmsk(:,:,3) )   ! Pacific  basin
503            CALL iom_get( inum, jpdom_data, 'indmsk', btmsk(:,:,4) )   ! Indian   basin
504            CALL iom_close( inum )
505            btmsk(:,:,5) = MAX ( btmsk(:,:,3), btmsk(:,:,4) )          ! Indo-Pacific basin
506            WHERE( gphit(:,:) < -30._wp)   ;   btm30(:,:) = 0._wp      ! mask out Southern Ocean
507            ELSE WHERE                     ;   btm30(:,:) = ssmask(:,:)
508            END WHERE
509         ENDIF
510         btmsk(:,:,1) = tmask_i(:,:)                                   ! global ocean
511     
512         DO jn = 1, nptr
513            btmsk(:,:,jn) = btmsk(:,:,jn) * tmask_i(:,:)               ! interior domain only
514         END DO
515     
516         IF( lk_vvl )   CALL ctl_stop( 'diaptr: error in vvl case as constant i-mean surface is used' )
517
518         !                                   ! i-sum of e1v*e3v surface and its inverse
519         DO jn = 1, nptr
520            sjk(:,:,jn) = ptr_tjk( tmask(:,:,:), btmsk(:,:,jn) )
521            r1_sjk(:,:,jn) = 0._wp
522            WHERE( sjk(:,:,jn) /= 0._wp )   r1_sjk(:,:,jn) = 1._wp / sjk(:,:,jn)
523         END DO
524
525      ! Initialise arrays to zero because diatpr is called before they are first calculated
526      ! Note that this means diagnostics will not be exactly correct when model run is restarted.
527      htr_adv(:) = 0._wp ; str_adv(:) =  0._wp ;  htr_ldf(:) = 0._wp ; str_ldf(:) =  0._wp
528
529#if defined key_mpp_mpi 
530         iglo (1) = jpjglo                   ! MPP case using MPI  ('key_mpp_mpi')
531         iloc (1) = nlcj
532         iabsf(1) = njmppt(narea)
533         iabsl(:) = iabsf(:) + iloc(:) - 1
534         ihals(1) = nldj - 1
535         ihale(1) = nlcj - nlej
536         idid (1) = 2
537         CALL flio_dom_set( jpnj, nproc/jpni, idid, iglo, iloc, iabsf, iabsl, ihals, ihale, 'BOX', nidom_ptr )
538#else
539         nidom_ptr = FLIO_DOM_NONE
540#endif
541      IF( nn_timing == 1 )   CALL timing_stop('dia_ptr_init')
542      !
543      ENDIF 
544      !
545   END SUBROUTINE dia_ptr_init
546
547
548   SUBROUTINE dia_ptr_wri( kt )
549      !!---------------------------------------------------------------------
550      !!                ***  ROUTINE dia_ptr_wri  ***
551      !!
552      !! ** Purpose :   output of poleward fluxes
553      !!
554      !! ** Method  :   NetCDF file
555      !!----------------------------------------------------------------------
556      !!
557      INTEGER, INTENT(in) ::   kt   ! ocean time-step index
558      !!
559      INTEGER, SAVE ::   nhoridz, ndepidzt, ndepidzw
560      INTEGER, SAVE ::   ndim  , ndim_atl     , ndim_pac     , ndim_ind     , ndim_ipc
561      INTEGER, SAVE ::           ndim_atl_30  , ndim_pac_30  , ndim_ind_30  , ndim_ipc_30
562      INTEGER, SAVE ::   ndim_h, ndim_h_atl_30, ndim_h_pac_30, ndim_h_ind_30, ndim_h_ipc_30
563      !!
564      CHARACTER (len=40) ::   clhstnam, clop, clop_once, cl_comment   ! temporary names
565      INTEGER            ::   iline, it, itmod, ji, jj, jk            !
566#if defined key_iomput
567      INTEGER            ::   inum                                    ! temporary logical unit
568#endif
569      REAL(wp)           ::   zsto, zout, zdt, zjulian                ! temporary scalars
570      !!
571      REAL(wp), POINTER, DIMENSION(:)   ::   zphi, zfoo    ! 1D workspace
572      REAL(wp), POINTER, DIMENSION(:,:) ::   z_1           ! 2D workspace
573      !!--------------------------------------------------------------------
574      !
575      CALL wrk_alloc( jpj      , zphi , zfoo )
576      CALL wrk_alloc( jpj , jpk, z_1 )
577
578      ! define time axis
579      it    = kt / nn_fptr
580      itmod = kt - nit000 + 1
581     
582      ! Initialization
583      ! --------------
584      IF( kt == nit000 ) THEN
585         niter = ( nit000 - 1 ) / nn_fptr
586         zdt = rdt
587         IF( nacc == 1 )   zdt = rdtmin
588         !
589         IF(lwp) THEN
590            WRITE(numout,*)
591            WRITE(numout,*) 'dia_ptr_wri : poleward transport and msf writing: initialization , niter = ', niter
592            WRITE(numout,*) '~~~~~~~~~~~~'
593         ENDIF
594
595         ! Reference latitude (used in plots)
596         ! ------------------
597         !                                           ! =======================
598         IF( cp_cfg == "orca" ) THEN                 !   ORCA configurations
599            !                                        ! =======================
600            IF( jp_cfg == 05  )   iline = 192   ! i-line that passes near the North Pole
601            IF( jp_cfg == 025 )   iline = 384   ! i-line that passes near the North Pole
602            IF( jp_cfg == 1   )   iline =  96   ! i-line that passes near the North Pole
603            IF( jp_cfg == 2   )   iline =  48   ! i-line that passes near the North Pole
604            IF( jp_cfg == 4   )   iline =  24   ! i-line that passes near the North Pole
605            zphi(1:jpj) = 0._wp
606            DO ji = mi0(iline), mi1(iline) 
607               zphi(1:jpj) = gphiv(ji,:)         ! if iline is in the local domain
608               ! Correct highest latitude for some configurations - will work if domain is parallelized in J ?
609               IF( jp_cfg == 05 ) THEN
610                  DO jj = mj0(jpjdta), mj1(jpjdta) 
611                     zphi( jj ) = zphi(mj0(jpjdta-1)) + ( zphi(mj0(jpjdta-1))-zphi(mj0(jpjdta-2)) ) * 0.5_wp
612                     zphi( jj ) = MIN( zphi(jj), 90._wp )
613                  END DO
614               END IF
615               IF( jp_cfg == 1 .OR. jp_cfg == 2 .OR. jp_cfg == 4 ) THEN
616                  DO jj = mj0(jpjdta-1), mj1(jpjdta-1) 
617                     zphi( jj ) = 88.5_wp
618                  END DO
619                  DO jj = mj0(jpjdta  ), mj1(jpjdta  ) 
620                     zphi( jj ) = 89.5_wp
621                  END DO
622               END IF
623            END DO
624            ! provide the correct zphi to all local domains
625#if defined key_mpp_mpi
626            CALL mpp_sum( zphi, jpj, ncomm_znl )       
627#endif
628            !                                        ! =======================
629         ELSE                                        !   OTHER configurations
630            !                                        ! =======================
631            zphi(1:jpj) = gphiv(1,:)             ! assume lat/lon coordinate, select the first i-line
632            !
633         ENDIF
634         !
635         ! Work only on westmost processor (will not work if mppini2 is used)
636#if defined key_mpp_mpi
637         IF( l_znl_root ) THEN 
638#endif
639            !
640            ! OPEN netcdf file
641            ! ----------------
642            ! Define frequency of output and means
643            zsto = nn_fptr * zdt
644            IF( ln_mskland )   THEN    ! put 1.e+20 on land (very expensive!!)
645               clop      = "ave(only(x))"
646               clop_once = "once(only(x))"
647            ELSE                       ! no use of the mask value (require less cpu time)
648               clop      = "ave(x)"       
649               clop_once = "once"
650            ENDIF
651
652            zout = nn_fwri * zdt
653            zfoo(1:jpj) = 0._wp
654
655            CALL ymds2ju( nyear, nmonth, nday, rdt, zjulian )  ! Compute julian date from starting date of the run
656            zjulian = zjulian - adatrj                         ! set calendar origin to the beginning of the experiment
657
658#if defined key_iomput
659            ! Requested by IPSL people, use by their postpro...
660            IF(lwp) THEN
661               CALL dia_nam( clhstnam, nn_fwri,' ' )
662               CALL ctl_opn( inum, 'date.file', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, lwp, narea )
663               WRITE(inum,*) clhstnam
664               CLOSE(inum)
665            ENDIF
666#endif
667
668            CALL dia_nam( clhstnam, nn_fwri, 'diaptr' )
669            IF(lwp)WRITE( numout,*)" Name of diaptr NETCDF file : ", clhstnam
670
671            ! Horizontal grid : zphi()
672            CALL histbeg(clhstnam, 1, zfoo, jpj, zphi,   &
673               1, 1, 1, jpj, niter, zjulian, zdt*nn_fptr, nhoridz, numptr, domain_id=nidom_ptr)
674            ! Vertical grids : gdept_1d, gdepw_1d
675            CALL histvert( numptr, "deptht", "Vertical T levels",   &
676               &                   "m", jpk, gdept_1d, ndepidzt, "down" )
677            CALL histvert( numptr, "depthw", "Vertical W levels",   &
678               &                   "m", jpk, gdepw_1d, ndepidzw, "down" )
679            !
680            CALL wheneq ( jpj*jpk, MIN(sjk(:,:,1), 1._wp), 1, 1., ndex  , ndim  )      ! Lat-Depth
681            CALL wheneq ( jpj    , MIN(sjk(:,1,1), 1._wp), 1, 1., ndex_h, ndim_h )     ! Lat
682
683            IF( ln_subbas ) THEN
684               z_1(:,1) = 1._wp
685               WHERE ( gphit(jpi/2,:) < -30._wp )   z_1(:,1) = 0._wp
686               DO jk = 2, jpk
687                  z_1(:,jk) = z_1(:,1)
688               END DO
689               !                       ! Atlantic (jn=2)
690               CALL wheneq ( jpj*jpk, MIN(sjk(:,:,2)         , 1._wp), 1, 1., ndex_atl     , ndim_atl      ) ! Lat-Depth
691               CALL wheneq ( jpj*jpk, MIN(sjk(:,:,2)*z_1(:,:), 1._wp), 1, 1., ndex_atl_30  , ndim_atl_30   ) ! Lat-Depth
692               CALL wheneq ( jpj    , MIN(sjk(:,1,2)*z_1(:,1), 1._wp), 1, 1., ndex_h_atl_30, ndim_h_atl_30 ) ! Lat
693               !                       ! Pacific (jn=3)
694               CALL wheneq ( jpj*jpk, MIN(sjk(:,:,3)         , 1._wp), 1, 1., ndex_pac     , ndim_pac      ) ! Lat-Depth
695               CALL wheneq ( jpj*jpk, MIN(sjk(:,:,3)*z_1(:,:), 1._wp), 1, 1., ndex_pac_30  , ndim_pac_30   ) ! Lat-Depth
696               CALL wheneq ( jpj    , MIN(sjk(:,1,3)*z_1(:,1), 1._wp), 1, 1., ndex_h_pac_30, ndim_h_pac_30 ) ! Lat
697               !                       ! Indian (jn=4)
698               CALL wheneq ( jpj*jpk, MIN(sjk(:,:,4)         , 1._wp), 1, 1., ndex_ind     , ndim_ind      ) ! Lat-Depth
699               CALL wheneq ( jpj*jpk, MIN(sjk(:,:,4)*z_1(:,:), 1._wp), 1, 1., ndex_ind_30  , ndim_ind_30   ) ! Lat-Depth
700               CALL wheneq ( jpj    , MIN(sjk(:,1,4)*z_1(:,1), 1._wp), 1, 1., ndex_h_ind_30, ndim_h_ind_30 ) ! Lat
701               !                       ! Indo-Pacific (jn=5)
702               CALL wheneq ( jpj*jpk, MIN(sjk(:,:,5)         , 1._wp), 1, 1., ndex_ipc     , ndim_ipc      ) ! Lat-Depth
703               CALL wheneq ( jpj*jpk, MIN(sjk(:,:,5)*z_1(:,:), 1._wp), 1, 1., ndex_ipc_30  , ndim_ipc_30   ) ! Lat-Depth
704               CALL wheneq ( jpj    , MIN(sjk(:,1,5)*z_1(:,1), 1._wp), 1, 1., ndex_h_ipc_30, ndim_h_ipc_30 ) ! Lat
705            ENDIF
706            !
707#if defined key_diaeiv
708            cl_comment = ' (Bolus part included)'
709#else
710            cl_comment = '                      '
711#endif
712            IF( ln_diaznl ) THEN             !  Zonal mean T and S
713               CALL histdef( numptr, "zotemglo", "Zonal Mean Temperature","C" ,   &
714                  1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop, zsto, zout )
715               CALL histdef( numptr, "zosalglo", "Zonal Mean Salinity","PSU"  ,   &
716                  1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop, zsto, zout )
717
718               CALL histdef( numptr, "zosrfglo", "Zonal Mean Surface","m^2"   ,   &
719                  1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop_once, zsto, zout )
720               !
721               IF (ln_subbas) THEN
722                  CALL histdef( numptr, "zotematl", "Zonal Mean Temperature: Atlantic","C" ,   &
723                     1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop, zsto, zout )
724                  CALL histdef( numptr, "zosalatl", "Zonal Mean Salinity: Atlantic","PSU"  ,   &
725                     1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop, zsto, zout )
726                  CALL histdef( numptr, "zosrfatl", "Zonal Mean Surface: Atlantic","m^2"   ,   &
727                     1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop_once, zsto, zout )
728
729                  CALL histdef( numptr, "zotempac", "Zonal Mean Temperature: Pacific","C"  ,   &
730                     1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop, zsto, zout )
731                  CALL histdef( numptr, "zosalpac", "Zonal Mean Salinity: Pacific","PSU"   ,   &
732                     1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop, zsto, zout )
733                  CALL histdef( numptr, "zosrfpac", "Zonal Mean Surface: Pacific","m^2"    ,   &
734                     1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop_once, zsto, zout )
735
736                  CALL histdef( numptr, "zotemind", "Zonal Mean Temperature: Indian","C"   ,   &
737                     1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop, zsto, zout )
738                  CALL histdef( numptr, "zosalind", "Zonal Mean Salinity: Indian","PSU"    ,   &
739                     1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop, zsto, zout )
740                  CALL histdef( numptr, "zosrfind", "Zonal Mean Surface: Indian","m^2"     ,   &
741                     1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop_once, zsto, zout )
742
743                  CALL histdef( numptr, "zotemipc", "Zonal Mean Temperature: Pacific+Indian","C" ,   &
744                     1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop, zsto, zout )
745                  CALL histdef( numptr, "zosalipc", "Zonal Mean Salinity: Pacific+Indian","PSU"  ,   &
746                     1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop, zsto, zout )
747                  CALL histdef( numptr, "zosrfipc", "Zonal Mean Surface: Pacific+Indian","m^2"   ,   &
748                     1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop_once, zsto, zout )
749               ENDIF
750            ENDIF
751            !
752            !  Meridional Stream-Function (Eulerian and Bolus)
753            CALL histdef( numptr, "zomsfglo", "Meridional Stream-Function: Global"//TRIM(cl_comment),"Sv" ,   &
754               1, jpj, nhoridz, jpk, 1, jpk, ndepidzw, 32, clop, zsto, zout )
755            IF( ln_subbas .AND. ln_diaznl ) THEN
756               CALL histdef( numptr, "zomsfatl", "Meridional Stream-Function: Atlantic"//TRIM(cl_comment),"Sv" ,   &
757                  1, jpj, nhoridz, jpk, 1, jpk, ndepidzw, 32, clop, zsto, zout )
758               CALL histdef( numptr, "zomsfpac", "Meridional Stream-Function: Pacific"//TRIM(cl_comment),"Sv"  ,   &
759                  1, jpj, nhoridz, jpk, 1, jpk, ndepidzw, 32, clop, zsto, zout )
760               CALL histdef( numptr, "zomsfind", "Meridional Stream-Function: Indian"//TRIM(cl_comment),"Sv"   ,   &
761                  1, jpj, nhoridz, jpk, 1, jpk, ndepidzw, 32, clop, zsto, zout )
762               CALL histdef( numptr, "zomsfipc", "Meridional Stream-Function: Indo-Pacific"//TRIM(cl_comment),"Sv" ,&
763                  1, jpj, nhoridz, jpk, 1, jpk, ndepidzw, 32, clop, zsto, zout )
764            ENDIF
765            !
766            !  Heat transport
767            CALL histdef( numptr, "sophtadv", "Advective Heat Transport"      ,   &
768               "PW", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout )
769            CALL histdef( numptr, "sophtldf", "Diffusive Heat Transport"      ,   &
770               "PW",1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout )
771            IF ( ln_ptrcomp ) THEN
772               CALL histdef( numptr, "sophtove", "Overturning Heat Transport"    ,   &
773                  "PW",1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout )
774            END IF
775            IF( ln_subbas ) THEN
776               CALL histdef( numptr, "sohtatl", "Heat Transport Atlantic"//TRIM(cl_comment),  &
777                  "PW", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout )
778               CALL histdef( numptr, "sohtpac", "Heat Transport Pacific"//TRIM(cl_comment) ,  &
779                  "PW", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout )
780               CALL histdef( numptr, "sohtind", "Heat Transport Indian"//TRIM(cl_comment)  ,  &
781                  "PW", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout )
782               CALL histdef( numptr, "sohtipc", "Heat Transport Pacific+Indian"//TRIM(cl_comment), &
783                  "PW", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout )
784            ENDIF
785            !
786            !  Salt transport
787            CALL histdef( numptr, "sopstadv", "Advective Salt Transport"      ,   &
788               "Giga g/s", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout )
789            CALL histdef( numptr, "sopstldf", "Diffusive Salt Transport"      ,   &
790               "Giga g/s", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout )
791            IF ( ln_ptrcomp ) THEN
792               CALL histdef( numptr, "sopstove", "Overturning Salt Transport"    ,   &
793                  "Giga g/s", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout )
794            END IF
795#if defined key_diaeiv
796            ! Eddy induced velocity
797            CALL histdef( numptr, "zomsfeiv", "Bolus Meridional Stream-Function: global",   &
798               "Sv"      , 1, jpj, nhoridz, jpk, 1, jpk, ndepidzw, 32, clop, zsto, zout )
799            CALL histdef( numptr, "sophteiv", "Bolus Advective Heat Transport",   &
800               "PW"      , 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout )
801            CALL histdef( numptr, "sopsteiv", "Bolus Advective Salt Transport",   &
802               "Giga g/s", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout )
803#endif
804            IF( ln_subbas ) THEN
805               CALL histdef( numptr, "sostatl", "Salt Transport Atlantic"//TRIM(cl_comment)      ,  &
806                  "Giga g/s", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout )
807               CALL histdef( numptr, "sostpac", "Salt Transport Pacific"//TRIM(cl_comment)      ,   &
808                  "Giga g/s", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout )
809               CALL histdef( numptr, "sostind", "Salt Transport Indian"//TRIM(cl_comment)      ,    &
810                  "Giga g/s", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout )
811               CALL histdef( numptr, "sostipc", "Salt Transport Pacific+Indian"//TRIM(cl_comment),  &
812                  "Giga g/s", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout )
813            ENDIF
814            !
815            CALL histend( numptr )
816            !
817         END IF
818#if defined key_mpp_mpi
819      END IF
820#endif
821
822#if defined key_mpp_mpi
823      IF( MOD( itmod, nn_fptr ) == 0 .AND. l_znl_root ) THEN
824#else
825      IF( MOD( itmod, nn_fptr ) == 0  ) THEN
826#endif
827         niter = niter + 1
828
829         IF( ln_diaznl ) THEN
830            CALL histwrite( numptr, "zosrfglo", niter, sjk  (:,:,1) , ndim, ndex )
831            CALL histwrite( numptr, "zotemglo", niter, tn_jk(:,:,1)  , ndim, ndex )
832            CALL histwrite( numptr, "zosalglo", niter, sn_jk(:,:,1)  , ndim, ndex )
833
834            IF (ln_subbas) THEN
835               CALL histwrite( numptr, "zosrfatl", niter, sjk(:,:,2), ndim_atl, ndex_atl )
836               CALL histwrite( numptr, "zosrfpac", niter, sjk(:,:,3), ndim_pac, ndex_pac )
837               CALL histwrite( numptr, "zosrfind", niter, sjk(:,:,4), ndim_ind, ndex_ind )
838               CALL histwrite( numptr, "zosrfipc", niter, sjk(:,:,5), ndim_ipc, ndex_ipc )
839
840               CALL histwrite( numptr, "zotematl", niter, tn_jk(:,:,2)  , ndim_atl, ndex_atl )
841               CALL histwrite( numptr, "zosalatl", niter, sn_jk(:,:,2)  , ndim_atl, ndex_atl )
842               CALL histwrite( numptr, "zotempac", niter, tn_jk(:,:,3)  , ndim_pac, ndex_pac )
843               CALL histwrite( numptr, "zosalpac", niter, sn_jk(:,:,3)  , ndim_pac, ndex_pac )
844               CALL histwrite( numptr, "zotemind", niter, tn_jk(:,:,4)  , ndim_ind, ndex_ind )
845               CALL histwrite( numptr, "zosalind", niter, sn_jk(:,:,4)  , ndim_ind, ndex_ind )
846               CALL histwrite( numptr, "zotemipc", niter, tn_jk(:,:,5)  , ndim_ipc, ndex_ipc )
847               CALL histwrite( numptr, "zosalipc", niter, sn_jk(:,:,5)  , ndim_ipc, ndex_ipc )
848            END IF
849         ENDIF
850
851         ! overturning outputs:
852         CALL histwrite( numptr, "zomsfglo", niter, v_msf(:,:,1), ndim, ndex )
853         IF( ln_subbas .AND. ln_diaznl ) THEN
854            CALL histwrite( numptr, "zomsfatl", niter, v_msf(:,:,2) , ndim_atl_30, ndex_atl_30 )
855            CALL histwrite( numptr, "zomsfpac", niter, v_msf(:,:,3) , ndim_pac_30, ndex_pac_30 )
856            CALL histwrite( numptr, "zomsfind", niter, v_msf(:,:,4) , ndim_ind_30, ndex_ind_30 )
857            CALL histwrite( numptr, "zomsfipc", niter, v_msf(:,:,5) , ndim_ipc_30, ndex_ipc_30 )
858         ENDIF
859#if defined key_diaeiv
860         CALL histwrite( numptr, "zomsfeiv", niter, v_msf_eiv(:,:,1), ndim  , ndex   )
861#endif
862
863         ! heat transport outputs:
864         IF( ln_subbas ) THEN
865            CALL histwrite( numptr, "sohtatl", niter, htr(:,2)  , ndim_h_atl_30, ndex_h_atl_30 )
866            CALL histwrite( numptr, "sohtpac", niter, htr(:,3)  , ndim_h_pac_30, ndex_h_pac_30 )
867            CALL histwrite( numptr, "sohtind", niter, htr(:,4)  , ndim_h_ind_30, ndex_h_ind_30 )
868            CALL histwrite( numptr, "sohtipc", niter, htr(:,5)  , ndim_h_ipc_30, ndex_h_ipc_30 )
869            CALL histwrite( numptr, "sostatl", niter, str(:,2)  , ndim_h_atl_30, ndex_h_atl_30 )
870            CALL histwrite( numptr, "sostpac", niter, str(:,3)  , ndim_h_pac_30, ndex_h_pac_30 )
871            CALL histwrite( numptr, "sostind", niter, str(:,4)  , ndim_h_ind_30, ndex_h_ind_30 )
872            CALL histwrite( numptr, "sostipc", niter, str(:,5)  , ndim_h_ipc_30, ndex_h_ipc_30 )
873         ENDIF
874
875         CALL histwrite( numptr, "sophtadv", niter, htr_adv     , ndim_h, ndex_h )
876         CALL histwrite( numptr, "sophtldf", niter, htr_ldf     , ndim_h, ndex_h )
877         CALL histwrite( numptr, "sopstadv", niter, str_adv     , ndim_h, ndex_h )
878         CALL histwrite( numptr, "sopstldf", niter, str_ldf     , ndim_h, ndex_h )
879         IF( ln_ptrcomp ) THEN
880            CALL histwrite( numptr, "sopstove", niter, str_ove(:) , ndim_h, ndex_h )
881            CALL histwrite( numptr, "sophtove", niter, htr_ove(:) , ndim_h, ndex_h )
882         ENDIF
883#if defined key_diaeiv
884         CALL histwrite( numptr, "sophteiv", niter, htr_eiv(:,1)  , ndim_h, ndex_h )
885         CALL histwrite( numptr, "sopsteiv", niter, str_eiv(:,1)  , ndim_h, ndex_h )
886#endif
887         !
888      ENDIF
889      !
890      CALL wrk_dealloc( jpj      , zphi , zfoo )
891      CALL wrk_dealloc( jpj , jpk, z_1 )
892      !
893  END SUBROUTINE dia_ptr_wri
894
895   !!======================================================================
896END MODULE diaptr
Note: See TracBrowser for help on using the repository browser.