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/2013/dev_LOCEAN_CMCC_INGV_2013/NEMOGCM/NEMO/OPA_SRC/DIA – NEMO

source: branches/2013/dev_LOCEAN_CMCC_INGV_2013/NEMOGCM/NEMO/OPA_SRC/DIA/diaptr.F90 @ 4234

Last change on this file since 4234 was 4148, checked in by cetlod, 11 years ago

merge in trunk changes between r3853 and r3940 and commit the changes, see ticket #1169
  • 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      ish(1) = ijpjjpk  ;   ish2(1) = jpj   ;   ish2(2) = jpk
262      zwork(1:ijpjjpk) = RESHAPE( p_fval, ish )
263      CALL mpp_sum( zwork, ijpjjpk, ncomm_znl )
264      p_fval(:,:) = RESHAPE( zwork, ish2 )
265#endif
266      !
267#if defined key_mpp_mpi
268      CALL wrk_dealloc( jpj*jpk, zwork )
269#endif
270      !
271   END FUNCTION ptr_vjk
272
273
274   FUNCTION ptr_tjk( pta, pmsk )   RESULT ( p_fval )
275      !!----------------------------------------------------------------------
276      !!                    ***  ROUTINE ptr_tjk  ***
277      !!
278      !! ** Purpose :   i-sum computation of e1t*e3t * a tracer field
279      !!
280      !! ** Method  : - i-sum of mj(pta) using tmask
281      !!
282      !! ** Action  : - p_fval: i-sum of e1t*e3t*pta
283      !!----------------------------------------------------------------------
284      !!
285      REAL(wp) , INTENT(in), DIMENSION(jpi,jpj,jpk) ::   pta    ! tracer flux array at T-point
286      REAL(wp) , INTENT(in), DIMENSION(jpi,jpj)     ::   pmsk   ! Optional 2D basin mask
287      !!
288      INTEGER                           :: ji, jj, jk   ! dummy loop arguments
289      REAL(wp), POINTER, DIMENSION(:,:) :: p_fval       ! return function value
290#if defined key_mpp_mpi
291      INTEGER, DIMENSION(1) ::   ish
292      INTEGER, DIMENSION(2) ::   ish2
293      INTEGER               ::   ijpjjpk
294#endif
295#if defined key_mpp_mpi
296      REAL(wp), POINTER, DIMENSION(:) ::   zwork    ! mask flux array at V-point
297#endif
298      !!--------------------------------------------------------------------
299      !
300#if defined key_mpp_mpi
301      ijpjjpk = jpj*jpk
302      CALL wrk_alloc( jpj*jpk, zwork )
303#endif
304
305      p_fval => p_fval2d
306
307      p_fval(:,:) = 0._wp
308      DO jk = 1, jpkm1
309         DO jj = 2, jpjm1
310            DO ji =  nldi, nlei   ! No vector optimisation here. Better use a mask ?
311               p_fval(jj,jk) = p_fval(jj,jk) + pta(ji,jj,jk) * e1t(ji,jj) * fse3t(ji,jj,jk) * pmsk(ji,jj)
312            END DO
313         END DO
314      END DO
315#if defined key_mpp_mpi
316      ish(1) = jpj*jpk   ;   ish2(1) = jpj   ;   ish2(2) = jpk
317      zwork(1:ijpjjpk)= RESHAPE( p_fval, ish )
318      CALL mpp_sum( zwork, ijpjjpk, ncomm_znl )
319      p_fval(:,:)= RESHAPE( zwork, ish2 )
320#endif
321      !
322#if defined key_mpp_mpi
323      CALL wrk_dealloc( jpj*jpk, zwork )
324#endif
325      !   
326   END FUNCTION ptr_tjk
327
328
329   SUBROUTINE dia_ptr( kt )
330      !!----------------------------------------------------------------------
331      !!                  ***  ROUTINE dia_ptr  ***
332      !!----------------------------------------------------------------------
333      USE oce,     vt  =>   ua   ! use ua as workspace
334      USE oce,     vs  =>   va   ! use va as workspace
335      IMPLICIT none
336      !!
337      INTEGER, INTENT(in) ::   kt   ! ocean time step index
338      !
339      INTEGER  ::   ji, jj, jk, jn   ! dummy loop indices
340      REAL(wp) ::   zv               ! local scalar
341      !!----------------------------------------------------------------------
342      !
343      IF( nn_timing == 1 )   CALL timing_start('dia_ptr')
344      !
345      IF( kt == nit000 .OR. MOD( kt, nn_fptr ) == 0 )   THEN
346         !
347         IF( MOD( kt, nn_fptr ) == 0 ) THEN 
348            !
349            IF( ln_diaznl ) THEN               ! i-mean temperature and salinity
350               DO jn = 1, nptr
351                  tn_jk(:,:,jn) = ptr_tjk( tsn(:,:,:,jp_tem), btmsk(:,:,jn) ) * r1_sjk(:,:,jn)
352                  sn_jk(:,:,jn) = ptr_tjk( tsn(:,:,:,jp_sal), btmsk(:,:,jn) ) * r1_sjk(:,:,jn)
353               END DO
354            ENDIF
355            !
356            !                          ! horizontal integral and vertical dz
357            !                                ! eulerian velocity
358            v_msf(:,:,1) = ptr_vjk( vn(:,:,:) ) 
359            DO jn = 2, nptr
360               v_msf(:,:,jn) = ptr_vjk( vn(:,:,:), btmsk(:,:,jn)*btm30(:,:) ) 
361            END DO
362#if defined key_diaeiv
363            DO jn = 1, nptr                  ! bolus velocity
364               v_msf_eiv(:,:,jn) = ptr_vjk( v_eiv(:,:,:), btmsk(:,:,jn) )   ! here no btm30 for MSFeiv
365            END DO
366            !                                ! add bolus stream-function to the eulerian one
367            v_msf(:,:,:) = v_msf(:,:,:) + v_msf_eiv(:,:,:)
368#endif
369            !
370            !                          ! Transports
371            !                                ! local heat & salt transports at T-points  ( tsn*mj[vn+v_eiv] )
372            vt(:,:,jpk) = 0._wp   ;   vs(:,:,jpk) = 0._wp
373            DO jk= 1, jpkm1
374               DO jj = 2, jpj
375                  DO ji = 1, jpi
376#if defined key_diaeiv 
377                     zv = ( vn(ji,jj,jk) + vn(ji,jj-1,jk) + v_eiv(ji,jj,jk) + v_eiv(ji,jj-1,jk) ) * 0.5_wp
378#else
379                     zv = ( vn(ji,jj,jk) + vn(ji,jj-1,jk) ) * 0.5_wp
380#endif
381                     vt(ji,jj,jk) = zv * tsn(ji,jj,jk,jp_tem)
382                     vs(ji,jj,jk) = zv * tsn(ji,jj,jk,jp_sal)
383                  END DO
384               END DO
385            END DO
386!!gm useless as overlap areas are not used in ptr_vjk
387            CALL lbc_lnk( vs, 'V', -1. )   ;   CALL lbc_lnk( vt, 'V', -1. )
388!!gm
389            !                                ! heat & salt advective transports (approximation)
390            htr(:,1) = SUM( ptr_vjk( vt(:,:,:) ) , 2 ) * rc_pwatt   ! SUM over jk + conversion
391            str(:,1) = SUM( ptr_vjk( vs(:,:,:) ) , 2 ) * rc_ggram
392            DO jn = 2, nptr 
393               htr(:,jn) = SUM( ptr_vjk( vt(:,:,:), btmsk(:,:,jn)*btm30(:,:) ) , 2 ) * rc_pwatt   ! mask Southern Ocean
394               str(:,jn) = SUM( ptr_vjk( vs(:,:,:), btmsk(:,:,jn)*btm30(:,:) ) , 2 ) * rc_ggram   ! mask Southern Ocean
395            END DO
396
397            IF( ln_ptrcomp ) THEN            ! overturning transport
398               htr_ove(:) = SUM( v_msf(:,:,1) * tn_jk(:,:,1), 2 ) * rc_pwatt   ! SUM over jk + conversion
399               str_ove(:) = SUM( v_msf(:,:,1) * sn_jk(:,:,1), 2 ) * rc_ggram
400            END IF
401            !                                ! Advective and diffusive transport
402            htr_adv(:) = htr_adv(:) * rc_pwatt        ! these are computed in tra_adv... and tra_ldf... routines
403            htr_ldf(:) = htr_ldf(:) * rc_pwatt        ! here just the conversion in PW and Gg
404            str_adv(:) = str_adv(:) * rc_ggram
405            str_ldf(:) = str_ldf(:) * rc_ggram
406
407#if defined key_diaeiv
408            DO jn = 1, nptr                  ! Bolus component
409               htr_eiv(:,jn) = SUM( v_msf_eiv(:,:,jn) * tn_jk(:,:,jn), 2 ) * rc_pwatt   ! SUM over jk
410               str_eiv(:,jn) = SUM( v_msf_eiv(:,:,jn) * sn_jk(:,:,jn), 2 ) * rc_ggram   ! SUM over jk
411            END DO
412#endif
413            !                                ! "Meridional" Stream-Function
414            DO jn = 1, nptr
415               DO jk = 2, jpk 
416                  v_msf    (:,jk,jn) = v_msf    (:,jk-1,jn) + v_msf    (:,jk,jn)       ! Eulerian j-Stream-Function
417#if defined key_diaeiv
418                  v_msf_eiv(:,jk,jn) = v_msf_eiv(:,jk-1,jn) + v_msf_eiv(:,jk,jn)       ! Bolus    j-Stream-Function
419
420#endif
421               END DO
422            END DO
423            v_msf    (:,:,:) = v_msf    (:,:,:) * rc_sv       ! converte in Sverdrups
424#if defined key_diaeiv
425            v_msf_eiv(:,:,:) = v_msf_eiv(:,:,:) * rc_sv
426#endif
427         ENDIF
428         !
429         CALL dia_ptr_wri( kt )                        ! outputs
430         !
431      ENDIF
432      !
433#if defined key_mpp_mpi
434      IF( kt == nitend .AND. l_znl_root )   CALL histclo( numptr )      ! Close the file
435#else
436      IF( kt == nitend )                    CALL histclo( numptr )      ! Close the file
437#endif
438      !
439      IF( nn_timing == 1 )   CALL timing_stop('dia_ptr')
440      !
441   END SUBROUTINE dia_ptr
442
443
444   SUBROUTINE dia_ptr_init
445      !!----------------------------------------------------------------------
446      !!                  ***  ROUTINE dia_ptr_init  ***
447      !!                   
448      !! ** Purpose :   Initialization, namelist read
449      !!----------------------------------------------------------------------
450      INTEGER ::   jn           ! dummy loop indices
451      INTEGER ::   inum, ierr   ! local integers
452      INTEGER ::   ios          ! Local integer output status for namelist read
453#if defined key_mpp_mpi
454      INTEGER, DIMENSION(1) :: iglo, iloc, iabsf, iabsl, ihals, ihale, idid
455#endif
456      !!
457      NAMELIST/namptr/ ln_diaptr, ln_diaznl, ln_subbas, ln_ptrcomp, nn_fptr, nn_fwri
458      !!----------------------------------------------------------------------
459
460      REWIND( numnam_ref )              ! Namelist namptr in reference namelist : Poleward transport
461      READ  ( numnam_ref, namptr, IOSTAT = ios, ERR = 901)
462901   IF( ios /= 0 ) CALL ctl_nam ( ios , 'namptr in reference namelist', lwp )
463
464      REWIND( numnam_cfg )              ! Namelist namptr in configuration namelist : Poleward transport
465      READ  ( numnam_cfg, namptr, IOSTAT = ios, ERR = 902 )
466902   IF( ios /= 0 ) CALL ctl_nam ( ios , 'namptr in configuration namelist', lwp )
467      WRITE ( numond, namptr )
468
469      IF(lwp) THEN                     ! Control print
470         WRITE(numout,*)
471         WRITE(numout,*) 'dia_ptr_init : poleward transport and msf initialization'
472         WRITE(numout,*) '~~~~~~~~~~~~'
473         WRITE(numout,*) '   Namelist namptr : set ptr parameters'
474         WRITE(numout,*) '      Poleward heat & salt transport (T) or not (F)      ln_diaptr  = ', ln_diaptr
475         WRITE(numout,*) '      Overturning heat & salt transport                  ln_ptrcomp = ', ln_ptrcomp
476         WRITE(numout,*) '      T & S zonal mean and meridional stream function    ln_diaznl  = ', ln_diaznl 
477         WRITE(numout,*) '      Global (F) or glo/Atl/Pac/Ind/Indo-Pac basins      ln_subbas  = ', ln_subbas
478         WRITE(numout,*) '      Frequency of computation                           nn_fptr    = ', nn_fptr
479         WRITE(numout,*) '      Frequency of outputs                               nn_fwri    = ', nn_fwri
480      ENDIF
481     
482      IF( ln_diaptr) THEN 
483     
484         IF( nn_timing == 1 )   CALL timing_start('dia_ptr_init')
485     
486         IF( ln_subbas ) THEN   ;   nptr = 5       ! Global, Atlantic, Pacific, Indian, Indo-Pacific
487         ELSE                   ;   nptr = 1       ! Global only
488         ENDIF
489
490         !                                      ! allocate dia_ptr arrays
491         IF( dia_ptr_alloc() /= 0 )   CALL ctl_stop( 'STOP', 'dia_ptr_init : unable to allocate arrays' )
492
493         rc_pwatt = rc_pwatt * rau0 * rcp          ! conversion from K.s-1 to PetaWatt
494
495         IF( lk_mpp )   CALL mpp_ini_znl( numout )     ! Define MPI communicator for zonal sum
496
497         IF( ln_subbas ) THEN                ! load sub-basin mask
498            CALL iom_open( 'subbasins', inum )
499            CALL iom_get( inum, jpdom_data, 'atlmsk', btmsk(:,:,2) )   ! Atlantic basin
500            CALL iom_get( inum, jpdom_data, 'pacmsk', btmsk(:,:,3) )   ! Pacific  basin
501            CALL iom_get( inum, jpdom_data, 'indmsk', btmsk(:,:,4) )   ! Indian   basin
502            CALL iom_close( inum )
503            btmsk(:,:,5) = MAX ( btmsk(:,:,3), btmsk(:,:,4) )          ! Indo-Pacific basin
504            WHERE( gphit(:,:) < -30._wp)   ;   btm30(:,:) = 0._wp      ! mask out Southern Ocean
505            ELSE WHERE                     ;   btm30(:,:) = tmask(:,:,1)
506            END WHERE
507         ENDIF
508         btmsk(:,:,1) = tmask_i(:,:)                                   ! global ocean
509     
510         DO jn = 1, nptr
511            btmsk(:,:,jn) = btmsk(:,:,jn) * tmask_i(:,:)               ! interior domain only
512         END DO
513     
514         IF( lk_vvl )   CALL ctl_stop( 'diaptr: error in vvl case as constant i-mean surface is used' )
515
516         !                                   ! i-sum of e1v*e3v surface and its inverse
517         DO jn = 1, nptr
518            sjk(:,:,jn) = ptr_tjk( tmask(:,:,:), btmsk(:,:,jn) )
519            r1_sjk(:,:,jn) = 0._wp
520            WHERE( sjk(:,:,jn) /= 0._wp )   r1_sjk(:,:,jn) = 1._wp / sjk(:,:,jn)
521         END DO
522
523      ! Initialise arrays to zero because diatpr is called before they are first calculated
524      ! Note that this means diagnostics will not be exactly correct when model run is restarted.
525      htr_adv(:) = 0._wp ; str_adv(:) =  0._wp ;  htr_ldf(:) = 0._wp ; str_ldf(:) =  0._wp
526
527#if defined key_mpp_mpi 
528         iglo (1) = jpjglo                   ! MPP case using MPI  ('key_mpp_mpi')
529         iloc (1) = nlcj
530         iabsf(1) = njmppt(narea)
531         iabsl(:) = iabsf(:) + iloc(:) - 1
532         ihals(1) = nldj - 1
533         ihale(1) = nlcj - nlej
534         idid (1) = 2
535         CALL flio_dom_set( jpnj, nproc/jpni, idid, iglo, iloc, iabsf, iabsl, ihals, ihale, 'BOX', nidom_ptr )
536#else
537         nidom_ptr = FLIO_DOM_NONE
538#endif
539      IF( nn_timing == 1 )   CALL timing_stop('dia_ptr_init')
540      !
541      ENDIF 
542      !
543   END SUBROUTINE dia_ptr_init
544
545
546   SUBROUTINE dia_ptr_wri( kt )
547      !!---------------------------------------------------------------------
548      !!                ***  ROUTINE dia_ptr_wri  ***
549      !!
550      !! ** Purpose :   output of poleward fluxes
551      !!
552      !! ** Method  :   NetCDF file
553      !!----------------------------------------------------------------------
554      !!
555      INTEGER, INTENT(in) ::   kt   ! ocean time-step index
556      !!
557      INTEGER, SAVE ::   nhoridz, ndepidzt, ndepidzw
558      INTEGER, SAVE ::   ndim  , ndim_atl     , ndim_pac     , ndim_ind     , ndim_ipc
559      INTEGER, SAVE ::           ndim_atl_30  , ndim_pac_30  , ndim_ind_30  , ndim_ipc_30
560      INTEGER, SAVE ::   ndim_h, ndim_h_atl_30, ndim_h_pac_30, ndim_h_ind_30, ndim_h_ipc_30
561      !!
562      CHARACTER (len=40) ::   clhstnam, clop, clop_once, cl_comment   ! temporary names
563      INTEGER            ::   iline, it, itmod, ji, jj, jk            !
564#if defined key_iomput
565      INTEGER            ::   inum                                    ! temporary logical unit
566#endif
567      REAL(wp)           ::   zsto, zout, zdt, zjulian                ! temporary scalars
568      !!
569      REAL(wp), POINTER, DIMENSION(:)   ::   zphi, zfoo    ! 1D workspace
570      REAL(wp), POINTER, DIMENSION(:,:) ::   z_1           ! 2D workspace
571      !!--------------------------------------------------------------------
572      !
573      CALL wrk_alloc( jpj      , zphi , zfoo )
574      CALL wrk_alloc( jpj , jpk, z_1 )
575
576      ! define time axis
577      it    = kt / nn_fptr
578      itmod = kt - nit000 + 1
579     
580      ! Initialization
581      ! --------------
582      IF( kt == nit000 ) THEN
583         niter = ( nit000 - 1 ) / nn_fptr
584         zdt = rdt
585         IF( nacc == 1 )   zdt = rdtmin
586         !
587         IF(lwp) THEN
588            WRITE(numout,*)
589            WRITE(numout,*) 'dia_ptr_wri : poleward transport and msf writing: initialization , niter = ', niter
590            WRITE(numout,*) '~~~~~~~~~~~~'
591         ENDIF
592
593         ! Reference latitude (used in plots)
594         ! ------------------
595         !                                           ! =======================
596         IF( cp_cfg == "orca" ) THEN                 !   ORCA configurations
597            !                                        ! =======================
598            IF( jp_cfg == 05  )   iline = 192   ! i-line that passes near the North Pole
599            IF( jp_cfg == 025 )   iline = 384   ! i-line that passes near the North Pole
600            IF( jp_cfg == 1   )   iline =  96   ! i-line that passes near the North Pole
601            IF( jp_cfg == 2   )   iline =  48   ! i-line that passes near the North Pole
602            IF( jp_cfg == 4   )   iline =  24   ! i-line that passes near the North Pole
603            zphi(1:jpj) = 0._wp
604            DO ji = mi0(iline), mi1(iline) 
605               zphi(1:jpj) = gphiv(ji,:)         ! if iline is in the local domain
606               ! Correct highest latitude for some configurations - will work if domain is parallelized in J ?
607               IF( jp_cfg == 05 ) THEN
608                  DO jj = mj0(jpjdta), mj1(jpjdta) 
609                     zphi( jj ) = zphi(mj0(jpjdta-1)) + ( zphi(mj0(jpjdta-1))-zphi(mj0(jpjdta-2)) ) * 0.5_wp
610                     zphi( jj ) = MIN( zphi(jj), 90._wp )
611                  END DO
612               END IF
613               IF( jp_cfg == 1 .OR. jp_cfg == 2 .OR. jp_cfg == 4 ) THEN
614                  DO jj = mj0(jpjdta-1), mj1(jpjdta-1) 
615                     zphi( jj ) = 88.5_wp
616                  END DO
617                  DO jj = mj0(jpjdta  ), mj1(jpjdta  ) 
618                     zphi( jj ) = 89.5_wp
619                  END DO
620               END IF
621            END DO
622            ! provide the correct zphi to all local domains
623#if defined key_mpp_mpi
624            CALL mpp_sum( zphi, jpj, ncomm_znl )       
625#endif
626            !                                        ! =======================
627         ELSE                                        !   OTHER configurations
628            !                                        ! =======================
629            zphi(1:jpj) = gphiv(1,:)             ! assume lat/lon coordinate, select the first i-line
630            !
631         ENDIF
632         !
633         ! Work only on westmost processor (will not work if mppini2 is used)
634#if defined key_mpp_mpi
635         IF( l_znl_root ) THEN 
636#endif
637            !
638            ! OPEN netcdf file
639            ! ----------------
640            ! Define frequency of output and means
641            zsto = nn_fptr * zdt
642            IF( ln_mskland )   THEN    ! put 1.e+20 on land (very expensive!!)
643               clop      = "ave(only(x))"
644               clop_once = "once(only(x))"
645            ELSE                       ! no use of the mask value (require less cpu time)
646               clop      = "ave(x)"       
647               clop_once = "once"
648            ENDIF
649
650            zout = nn_fwri * zdt
651            zfoo(1:jpj) = 0._wp
652
653            CALL ymds2ju( nyear, nmonth, nday, rdt, zjulian )  ! Compute julian date from starting date of the run
654            zjulian = zjulian - adatrj                         ! set calendar origin to the beginning of the experiment
655
656#if defined key_iomput
657            ! Requested by IPSL people, use by their postpro...
658            IF(lwp) THEN
659               CALL dia_nam( clhstnam, nn_fwri,' ' )
660               CALL ctl_opn( inum, 'date.file', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, lwp, narea )
661               WRITE(inum,*) clhstnam
662               CLOSE(inum)
663            ENDIF
664#endif
665
666            CALL dia_nam( clhstnam, nn_fwri, 'diaptr' )
667            IF(lwp)WRITE( numout,*)" Name of diaptr NETCDF file : ", clhstnam
668
669            ! Horizontal grid : zphi()
670            CALL histbeg(clhstnam, 1, zfoo, jpj, zphi,   &
671               1, 1, 1, jpj, niter, zjulian, zdt*nn_fptr, nhoridz, numptr, domain_id=nidom_ptr)
672            ! Vertical grids : gdept_0, gdepw_0
673            CALL histvert( numptr, "deptht", "Vertical T levels",   &
674               &                   "m", jpk, gdept_0, ndepidzt, "down" )
675            CALL histvert( numptr, "depthw", "Vertical W levels",   &
676               &                   "m", jpk, gdepw_0, ndepidzw, "down" )
677            !
678            CALL wheneq ( jpj*jpk, MIN(sjk(:,:,1), 1._wp), 1, 1., ndex  , ndim  )      ! Lat-Depth
679            CALL wheneq ( jpj    , MIN(sjk(:,1,1), 1._wp), 1, 1., ndex_h, ndim_h )     ! Lat
680
681            IF( ln_subbas ) THEN
682               z_1(:,1) = 1._wp
683               WHERE ( gphit(jpi/2,:) < -30._wp )   z_1(:,1) = 0._wp
684               DO jk = 2, jpk
685                  z_1(:,jk) = z_1(:,1)
686               END DO
687               !                       ! Atlantic (jn=2)
688               CALL wheneq ( jpj*jpk, MIN(sjk(:,:,2)         , 1._wp), 1, 1., ndex_atl     , ndim_atl      ) ! Lat-Depth
689               CALL wheneq ( jpj*jpk, MIN(sjk(:,:,2)*z_1(:,:), 1._wp), 1, 1., ndex_atl_30  , ndim_atl_30   ) ! Lat-Depth
690               CALL wheneq ( jpj    , MIN(sjk(:,1,2)*z_1(:,1), 1._wp), 1, 1., ndex_h_atl_30, ndim_h_atl_30 ) ! Lat
691               !                       ! Pacific (jn=3)
692               CALL wheneq ( jpj*jpk, MIN(sjk(:,:,3)         , 1._wp), 1, 1., ndex_pac     , ndim_pac      ) ! Lat-Depth
693               CALL wheneq ( jpj*jpk, MIN(sjk(:,:,3)*z_1(:,:), 1._wp), 1, 1., ndex_pac_30  , ndim_pac_30   ) ! Lat-Depth
694               CALL wheneq ( jpj    , MIN(sjk(:,1,3)*z_1(:,1), 1._wp), 1, 1., ndex_h_pac_30, ndim_h_pac_30 ) ! Lat
695               !                       ! Indian (jn=4)
696               CALL wheneq ( jpj*jpk, MIN(sjk(:,:,4)         , 1._wp), 1, 1., ndex_ind     , ndim_ind      ) ! Lat-Depth
697               CALL wheneq ( jpj*jpk, MIN(sjk(:,:,4)*z_1(:,:), 1._wp), 1, 1., ndex_ind_30  , ndim_ind_30   ) ! Lat-Depth
698               CALL wheneq ( jpj    , MIN(sjk(:,1,4)*z_1(:,1), 1._wp), 1, 1., ndex_h_ind_30, ndim_h_ind_30 ) ! Lat
699               !                       ! Indo-Pacific (jn=5)
700               CALL wheneq ( jpj*jpk, MIN(sjk(:,:,5)         , 1._wp), 1, 1., ndex_ipc     , ndim_ipc      ) ! Lat-Depth
701               CALL wheneq ( jpj*jpk, MIN(sjk(:,:,5)*z_1(:,:), 1._wp), 1, 1., ndex_ipc_30  , ndim_ipc_30   ) ! Lat-Depth
702               CALL wheneq ( jpj    , MIN(sjk(:,1,5)*z_1(:,1), 1._wp), 1, 1., ndex_h_ipc_30, ndim_h_ipc_30 ) ! Lat
703            ENDIF
704            !
705#if defined key_diaeiv
706            cl_comment = ' (Bolus part included)'
707#else
708            cl_comment = '                      '
709#endif
710            IF( ln_diaznl ) THEN             !  Zonal mean T and S
711               CALL histdef( numptr, "zotemglo", "Zonal Mean Temperature","C" ,   &
712                  1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop, zsto, zout )
713               CALL histdef( numptr, "zosalglo", "Zonal Mean Salinity","PSU"  ,   &
714                  1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop, zsto, zout )
715
716               CALL histdef( numptr, "zosrfglo", "Zonal Mean Surface","m^2"   ,   &
717                  1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop_once, zsto, zout )
718               !
719               IF (ln_subbas) THEN
720                  CALL histdef( numptr, "zotematl", "Zonal Mean Temperature: Atlantic","C" ,   &
721                     1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop, zsto, zout )
722                  CALL histdef( numptr, "zosalatl", "Zonal Mean Salinity: Atlantic","PSU"  ,   &
723                     1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop, zsto, zout )
724                  CALL histdef( numptr, "zosrfatl", "Zonal Mean Surface: Atlantic","m^2"   ,   &
725                     1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop_once, zsto, zout )
726
727                  CALL histdef( numptr, "zotempac", "Zonal Mean Temperature: Pacific","C"  ,   &
728                     1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop, zsto, zout )
729                  CALL histdef( numptr, "zosalpac", "Zonal Mean Salinity: Pacific","PSU"   ,   &
730                     1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop, zsto, zout )
731                  CALL histdef( numptr, "zosrfpac", "Zonal Mean Surface: Pacific","m^2"    ,   &
732                     1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop_once, zsto, zout )
733
734                  CALL histdef( numptr, "zotemind", "Zonal Mean Temperature: Indian","C"   ,   &
735                     1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop, zsto, zout )
736                  CALL histdef( numptr, "zosalind", "Zonal Mean Salinity: Indian","PSU"    ,   &
737                     1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop, zsto, zout )
738                  CALL histdef( numptr, "zosrfind", "Zonal Mean Surface: Indian","m^2"     ,   &
739                     1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop_once, zsto, zout )
740
741                  CALL histdef( numptr, "zotemipc", "Zonal Mean Temperature: Pacific+Indian","C" ,   &
742                     1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop, zsto, zout )
743                  CALL histdef( numptr, "zosalipc", "Zonal Mean Salinity: Pacific+Indian","PSU"  ,   &
744                     1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop, zsto, zout )
745                  CALL histdef( numptr, "zosrfipc", "Zonal Mean Surface: Pacific+Indian","m^2"   ,   &
746                     1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop_once, zsto, zout )
747               ENDIF
748            ENDIF
749            !
750            !  Meridional Stream-Function (Eulerian and Bolus)
751            CALL histdef( numptr, "zomsfglo", "Meridional Stream-Function: Global"//TRIM(cl_comment),"Sv" ,   &
752               1, jpj, nhoridz, jpk, 1, jpk, ndepidzw, 32, clop, zsto, zout )
753            IF( ln_subbas .AND. ln_diaznl ) THEN
754               CALL histdef( numptr, "zomsfatl", "Meridional Stream-Function: Atlantic"//TRIM(cl_comment),"Sv" ,   &
755                  1, jpj, nhoridz, jpk, 1, jpk, ndepidzw, 32, clop, zsto, zout )
756               CALL histdef( numptr, "zomsfpac", "Meridional Stream-Function: Pacific"//TRIM(cl_comment),"Sv"  ,   &
757                  1, jpj, nhoridz, jpk, 1, jpk, ndepidzw, 32, clop, zsto, zout )
758               CALL histdef( numptr, "zomsfind", "Meridional Stream-Function: Indian"//TRIM(cl_comment),"Sv"   ,   &
759                  1, jpj, nhoridz, jpk, 1, jpk, ndepidzw, 32, clop, zsto, zout )
760               CALL histdef( numptr, "zomsfipc", "Meridional Stream-Function: Indo-Pacific"//TRIM(cl_comment),"Sv" ,&
761                  1, jpj, nhoridz, jpk, 1, jpk, ndepidzw, 32, clop, zsto, zout )
762            ENDIF
763            !
764            !  Heat transport
765            CALL histdef( numptr, "sophtadv", "Advective Heat Transport"      ,   &
766               "PW", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout )
767            CALL histdef( numptr, "sophtldf", "Diffusive Heat Transport"      ,   &
768               "PW",1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout )
769            IF ( ln_ptrcomp ) THEN
770               CALL histdef( numptr, "sophtove", "Overturning Heat Transport"    ,   &
771                  "PW",1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout )
772            END IF
773            IF( ln_subbas ) THEN
774               CALL histdef( numptr, "sohtatl", "Heat Transport Atlantic"//TRIM(cl_comment),  &
775                  "PW", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout )
776               CALL histdef( numptr, "sohtpac", "Heat Transport Pacific"//TRIM(cl_comment) ,  &
777                  "PW", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout )
778               CALL histdef( numptr, "sohtind", "Heat Transport Indian"//TRIM(cl_comment)  ,  &
779                  "PW", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout )
780               CALL histdef( numptr, "sohtipc", "Heat Transport Pacific+Indian"//TRIM(cl_comment), &
781                  "PW", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout )
782            ENDIF
783            !
784            !  Salt transport
785            CALL histdef( numptr, "sopstadv", "Advective Salt Transport"      ,   &
786               "Giga g/s", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout )
787            CALL histdef( numptr, "sopstldf", "Diffusive Salt Transport"      ,   &
788               "Giga g/s", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout )
789            IF ( ln_ptrcomp ) THEN
790               CALL histdef( numptr, "sopstove", "Overturning Salt Transport"    ,   &
791                  "Giga g/s", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout )
792            END IF
793#if defined key_diaeiv
794            ! Eddy induced velocity
795            CALL histdef( numptr, "zomsfeiv", "Bolus Meridional Stream-Function: global",   &
796               "Sv"      , 1, jpj, nhoridz, jpk, 1, jpk, ndepidzw, 32, clop, zsto, zout )
797            CALL histdef( numptr, "sophteiv", "Bolus Advective Heat Transport",   &
798               "PW"      , 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout )
799            CALL histdef( numptr, "sopsteiv", "Bolus Advective Salt Transport",   &
800               "Giga g/s", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout )
801#endif
802            IF( ln_subbas ) THEN
803               CALL histdef( numptr, "sostatl", "Salt Transport Atlantic"//TRIM(cl_comment)      ,  &
804                  "Giga g/s", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout )
805               CALL histdef( numptr, "sostpac", "Salt Transport Pacific"//TRIM(cl_comment)      ,   &
806                  "Giga g/s", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout )
807               CALL histdef( numptr, "sostind", "Salt Transport Indian"//TRIM(cl_comment)      ,    &
808                  "Giga g/s", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout )
809               CALL histdef( numptr, "sostipc", "Salt Transport Pacific+Indian"//TRIM(cl_comment),  &
810                  "Giga g/s", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout )
811            ENDIF
812            !
813            CALL histend( numptr )
814            !
815         END IF
816#if defined key_mpp_mpi
817      END IF
818#endif
819
820#if defined key_mpp_mpi
821      IF( MOD( itmod, nn_fptr ) == 0 .AND. l_znl_root ) THEN
822#else
823      IF( MOD( itmod, nn_fptr ) == 0  ) THEN
824#endif
825         niter = niter + 1
826
827         IF( ln_diaznl ) THEN
828            CALL histwrite( numptr, "zosrfglo", niter, sjk  (:,:,1) , ndim, ndex )
829            CALL histwrite( numptr, "zotemglo", niter, tn_jk(:,:,1)  , ndim, ndex )
830            CALL histwrite( numptr, "zosalglo", niter, sn_jk(:,:,1)  , ndim, ndex )
831
832            IF (ln_subbas) THEN
833               CALL histwrite( numptr, "zosrfatl", niter, sjk(:,:,2), ndim_atl, ndex_atl )
834               CALL histwrite( numptr, "zosrfpac", niter, sjk(:,:,3), ndim_pac, ndex_pac )
835               CALL histwrite( numptr, "zosrfind", niter, sjk(:,:,4), ndim_ind, ndex_ind )
836               CALL histwrite( numptr, "zosrfipc", niter, sjk(:,:,5), ndim_ipc, ndex_ipc )
837
838               CALL histwrite( numptr, "zotematl", niter, tn_jk(:,:,2)  , ndim_atl, ndex_atl )
839               CALL histwrite( numptr, "zosalatl", niter, sn_jk(:,:,2)  , ndim_atl, ndex_atl )
840               CALL histwrite( numptr, "zotempac", niter, tn_jk(:,:,3)  , ndim_pac, ndex_pac )
841               CALL histwrite( numptr, "zosalpac", niter, sn_jk(:,:,3)  , ndim_pac, ndex_pac )
842               CALL histwrite( numptr, "zotemind", niter, tn_jk(:,:,4)  , ndim_ind, ndex_ind )
843               CALL histwrite( numptr, "zosalind", niter, sn_jk(:,:,4)  , ndim_ind, ndex_ind )
844               CALL histwrite( numptr, "zotemipc", niter, tn_jk(:,:,5)  , ndim_ipc, ndex_ipc )
845               CALL histwrite( numptr, "zosalipc", niter, sn_jk(:,:,5)  , ndim_ipc, ndex_ipc )
846            END IF
847         ENDIF
848
849         ! overturning outputs:
850         CALL histwrite( numptr, "zomsfglo", niter, v_msf(:,:,1), ndim, ndex )
851         IF( ln_subbas .AND. ln_diaznl ) THEN
852            CALL histwrite( numptr, "zomsfatl", niter, v_msf(:,:,2) , ndim_atl_30, ndex_atl_30 )
853            CALL histwrite( numptr, "zomsfpac", niter, v_msf(:,:,3) , ndim_pac_30, ndex_pac_30 )
854            CALL histwrite( numptr, "zomsfind", niter, v_msf(:,:,4) , ndim_ind_30, ndex_ind_30 )
855            CALL histwrite( numptr, "zomsfipc", niter, v_msf(:,:,5) , ndim_ipc_30, ndex_ipc_30 )
856         ENDIF
857#if defined key_diaeiv
858         CALL histwrite( numptr, "zomsfeiv", niter, v_msf_eiv(:,:,1), ndim  , ndex   )
859#endif
860
861         ! heat transport outputs:
862         IF( ln_subbas ) THEN
863            CALL histwrite( numptr, "sohtatl", niter, htr(:,2)  , ndim_h_atl_30, ndex_h_atl_30 )
864            CALL histwrite( numptr, "sohtpac", niter, htr(:,3)  , ndim_h_pac_30, ndex_h_pac_30 )
865            CALL histwrite( numptr, "sohtind", niter, htr(:,4)  , ndim_h_ind_30, ndex_h_ind_30 )
866            CALL histwrite( numptr, "sohtipc", niter, htr(:,5)  , ndim_h_ipc_30, ndex_h_ipc_30 )
867            CALL histwrite( numptr, "sostatl", niter, str(:,2)  , ndim_h_atl_30, ndex_h_atl_30 )
868            CALL histwrite( numptr, "sostpac", niter, str(:,3)  , ndim_h_pac_30, ndex_h_pac_30 )
869            CALL histwrite( numptr, "sostind", niter, str(:,4)  , ndim_h_ind_30, ndex_h_ind_30 )
870            CALL histwrite( numptr, "sostipc", niter, str(:,5)  , ndim_h_ipc_30, ndex_h_ipc_30 )
871         ENDIF
872
873         CALL histwrite( numptr, "sophtadv", niter, htr_adv     , ndim_h, ndex_h )
874         CALL histwrite( numptr, "sophtldf", niter, htr_ldf     , ndim_h, ndex_h )
875         CALL histwrite( numptr, "sopstadv", niter, str_adv     , ndim_h, ndex_h )
876         CALL histwrite( numptr, "sopstldf", niter, str_ldf     , ndim_h, ndex_h )
877         IF( ln_ptrcomp ) THEN
878            CALL histwrite( numptr, "sopstove", niter, str_ove(:) , ndim_h, ndex_h )
879            CALL histwrite( numptr, "sophtove", niter, htr_ove(:) , ndim_h, ndex_h )
880         ENDIF
881#if defined key_diaeiv
882         CALL histwrite( numptr, "sophteiv", niter, htr_eiv(:,1)  , ndim_h, ndex_h )
883         CALL histwrite( numptr, "sopsteiv", niter, str_eiv(:,1)  , ndim_h, ndex_h )
884#endif
885         !
886      ENDIF
887      !
888      CALL wrk_dealloc( jpj      , zphi , zfoo )
889      CALL wrk_dealloc( jpj , jpk, z_1 )
890      !
891  END SUBROUTINE dia_ptr_wri
892
893   !!======================================================================
894END MODULE diaptr
Note: See TracBrowser for help on using the repository browser.