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.
diaptr.F90 in branches/2014/dev_4728_CNRS04_coupled_interface/NEMOGCM/NEMO/OPA_SRC/DIA – NEMO

source: branches/2014/dev_4728_CNRS04_coupled_interface/NEMOGCM/NEMO/OPA_SRC/DIA/diaptr.F90 @ 4731

Last change on this file since 4731 was 4624, checked in by acc, 10 years ago

#1305. Fix slow start-up problems on some systems by introducing and using lwm logical to restrict output of merged namelists to the first (or only) processor. lwm is true only on the first processor regardless of ln_ctl. Small changes to all flavours of nemogcm.F90 are also required to write namctl and namcfg after the call to mynode which now opens output.namelist.dyn and writes nammpp.
  • 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(:,:) = tmask(:,:,1)
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.