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/UKMO/dev_r5518_GO6_package_text_diagnostics/NEMOGCM/NEMO/OPA_SRC/DIA – NEMO

source: branches/UKMO/dev_r5518_GO6_package_text_diagnostics/NEMOGCM/NEMO/OPA_SRC/DIA/diaptr.F90 @ 10759

Last change on this file since 10759 was 10759, checked in by andmirek, 5 years ago

GMED 450 write output.namelist.dyn only for nprint > 2

File size: 33.8 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   !!            3.6  ! 2014-12  (C. Ethe) use of IOM
11   !!            3.6  ! 2016-06  (T. Graham) Addition of diagnostics for CMIP6
12   !!----------------------------------------------------------------------
13
14   !!----------------------------------------------------------------------
15   !!   dia_ptr      : Poleward Transport Diagnostics module
16   !!   dia_ptr_init : Initialization, namelist read
17   !!   ptr_sjk      : "zonal" mean computation of a field - tracer or flux array
18   !!   ptr_sj       : "zonal" and vertical sum computation of a "meridional" flux array
19   !!                   (Generic interface to ptr_sj_3d, ptr_sj_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 
25   !
26   USE iom              ! IOM library
27   USE in_out_manager   ! I/O manager
28   USE lib_mpp          ! MPP library
29   USE timing           ! preformance summary
30
31   IMPLICIT NONE
32   PRIVATE
33
34   INTERFACE ptr_sj
35      MODULE PROCEDURE ptr_sj_3d, ptr_sj_2d
36   END INTERFACE
37
38   PUBLIC   ptr_sj         ! call by tra_ldf & tra_adv routines
39   PUBLIC   ptr_sjk        !
40   PUBLIC   dia_ptr_init   ! call in step module
41   PUBLIC   dia_ptr        ! call in step module
42   PUBLIC   dia_ptr_ohst_components        ! called from tra_ldf/tra_adv routines
43
44   !                                  !!** namelist  namptr  **
45   REAL(wp), ALLOCATABLE, SAVE, PUBLIC, DIMENSION(:,:) ::   htr_adv, htr_ldf, htr_eiv, htr_vt   !: Heat TRansports (adv, diff, Bolus.)
46   REAL(wp), ALLOCATABLE, SAVE, PUBLIC, DIMENSION(:,:) ::   str_adv, str_ldf, str_eiv, str_vs   !: Salt TRansports (adv, diff, Bolus.)
47   REAL(wp), ALLOCATABLE, SAVE, PUBLIC, DIMENSION(:,:) ::   htr_ove, str_ove   !: heat Salt TRansports ( overturn.)
48   REAL(wp), ALLOCATABLE, SAVE, PUBLIC, DIMENSION(:,:) ::   htr_btr, str_btr   !: heat Salt TRansports ( barotropic )
49
50   LOGICAL, PUBLIC ::   ln_diaptr   !  Poleward transport flag (T) or not (F)
51   LOGICAL, PUBLIC ::   ln_subbas   !  Atlantic/Pacific/Indian basins calculation
52   INTEGER, PUBLIC ::   nptr        ! = 1 (l_subbas=F) or = 5 (glo, atl, pac, ind, ipc) (l_subbas=T)
53
54   REAL(wp) ::   rc_sv    = 1.e-6_wp   ! conversion from m3/s to Sverdrup
55   REAL(wp) ::   rc_pwatt = 1.e-15_wp  ! conversion from W    to PW (further x rau0 x Cp)
56   REAL(wp) ::   rc_ggram = 1.e-6_wp   ! conversion from g    to Pg
57
58   CHARACTER(len=3), ALLOCATABLE, SAVE, DIMENSION(:)     :: clsubb
59   REAL(wp),         ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: btmsk   ! T-point basin interior masks
60   REAL(wp),         ALLOCATABLE, SAVE, DIMENSION(:,:)   :: btm30   ! mask out Southern Ocean (=0 south of 30°S)
61
62   REAL(wp), TARGET, ALLOCATABLE, SAVE, DIMENSION(:)     :: p_fval1d
63   REAL(wp), TARGET, ALLOCATABLE, SAVE, DIMENSION(:,:)   :: p_fval2d
64
65
66   !! * Substitutions
67#  include "domzgr_substitute.h90"
68#  include "vectopt_loop_substitute.h90"
69   !!----------------------------------------------------------------------
70   !! NEMO/OPA 3.3 , NEMO Consortium (2010)
71   !! $Id$
72   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
73   !!----------------------------------------------------------------------
74CONTAINS
75
76   SUBROUTINE dia_ptr( pvtr )
77      !!----------------------------------------------------------------------
78      !!                  ***  ROUTINE dia_ptr  ***
79      !!----------------------------------------------------------------------
80      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in), OPTIONAL ::   pvtr   ! j-effective transport
81      !
82      INTEGER  ::   ji, jj, jk, jn   ! dummy loop indices
83      REAL(wp) ::   zsfc,zvfc               ! local scalar
84      REAL(wp), DIMENSION(jpi,jpj)     ::  z2d   ! 2D workspace
85      REAL(wp), DIMENSION(jpi,jpj,jpk) ::  z3d   ! 3D workspace
86      REAL(wp), DIMENSION(jpi,jpj,jpk) ::  zvn   ! 3D workspace
87      REAL(wp), DIMENSION(jpi,jpj,jpk) ::  zmask   ! 3D workspace
88      REAL(wp), DIMENSION(jpi,jpj,jpk,jpts) ::  zts   ! 3D workspace
89      REAL(wp), DIMENSION(jpj)     ::  vsum   ! 1D workspace
90      REAL(wp), DIMENSION(jpj,jpts)     ::  tssum   ! 1D workspace
91 
92      !
93      !overturning calculation
94      REAL(wp), DIMENSION(jpj,jpk,nptr) ::   sjk  , r1_sjk ! i-mean i-k-surface and its inverse
95      REAL(wp), DIMENSION(jpj,jpk,nptr) ::   v_msf, sn_jk  , tn_jk ! i-mean T and S, j-Stream-Function
96
97
98      CHARACTER( len = 12 )  :: cl1
99      !!----------------------------------------------------------------------
100      !
101      IF( nn_timing == 1 )   CALL timing_start('dia_ptr')
102
103      !
104      z2d(:,:) = 0._wp
105      z3d(:,:,:) = 0._wp
106      IF( PRESENT( pvtr ) ) THEN
107         IF( iom_use("zomsfglo") ) THEN    ! effective MSF
108            z3d(1,:,:) = ptr_sjk( pvtr(:,:,:) )  ! zonal cumulative effective transport
109            DO jk = jpkm1,1,-1                   !Integrate from bottom up to get
110              z3d(1,:,jk) = z3d(1,:,jk+1) - z3d(1,:,jk)   ! effective j-Stream-Function (MSF)
111            END DO
112            DO ji = 1, jpi
113               z3d(ji,:,:) = z3d(1,:,:)
114            ENDDO
115            cl1 = TRIM('zomsf'//clsubb(1) )
116            CALL iom_put( cl1, z3d * rc_sv )
117            DO jn = 2, nptr                                    ! by sub-basins
118               z3d(1,:,:) =  ptr_sjk( pvtr(:,:,:), btmsk(:,:,jn) ) 
119               DO jk = jpkm1,1,-1
120                  z3d(1,:,jk) = z3d(1,:,jk+1) - z3d(1,:,jk)    ! effective j-Stream-Function (MSF)
121               END DO
122               DO ji = 1, jpi
123                  z3d(ji,:,:) = z3d(1,:,:)
124               ENDDO
125               cl1 = TRIM('zomsf'//clsubb(jn) )
126               CALL iom_put( cl1, z3d * rc_sv )
127            END DO
128         ENDIF
129         IF( iom_use("sopstove") .OR. iom_use("sophtove") .OR. iom_use("sopstbtr") .OR. iom_use("sophtbtr") ) THEN
130            ! define fields multiplied by scalar
131            zmask(:,:,:) = 0._wp
132            zts(:,:,:,:) = 0._wp
133            DO jk = 1, jpkm1
134               DO jj = 1, jpjm1
135                  DO ji = 1, jpi
136                     zvfc = e1v(ji,jj) * fse3v(ji,jj,jk)
137                     zmask(ji,jj,jk)      = vmask(ji,jj,jk)      * zvfc
138                     zts(ji,jj,jk,jp_tem) = (tsn(ji,jj,jk,jp_tem)+tsn(ji,jj+1,jk,jp_tem)) * 0.5 * zvfc  !Tracers averaged onto V grid
139                     zts(ji,jj,jk,jp_sal) = (tsn(ji,jj,jk,jp_sal)+tsn(ji,jj+1,jk,jp_sal)) * 0.5 * zvfc
140                  ENDDO
141               ENDDO
142             ENDDO
143         ENDIF
144         IF( iom_use("sopstove") .OR. iom_use("sophtove") ) THEN
145             sjk(:,:,1) = ptr_sjk( zmask(:,:,:), btmsk(:,:,1) )
146             r1_sjk(:,:,1) = 0._wp
147             WHERE( sjk(:,:,1) /= 0._wp )   r1_sjk(:,:,1) = 1._wp / sjk(:,:,1)
148
149             ! i-mean T and S, j-Stream-Function, global
150             tn_jk(:,:,1) = ptr_sjk( zts(:,:,:,jp_tem) ) * r1_sjk(:,:,1)
151             sn_jk(:,:,1) = ptr_sjk( zts(:,:,:,jp_sal) ) * r1_sjk(:,:,1)
152             v_msf(:,:,1) = ptr_sjk( pvtr(:,:,:) )
153
154             htr_ove(:,1) = SUM( v_msf(:,:,1)*tn_jk(:,:,1) ,2 )
155             str_ove(:,1) = SUM( v_msf(:,:,1)*sn_jk(:,:,1) ,2 )
156
157             z2d(1,:) = htr_ove(:,1) * rc_pwatt        !  (conversion in PW)
158             DO ji = 1, jpi
159               z2d(ji,:) = z2d(1,:)
160             ENDDO
161             cl1 = 'sophtove'
162             CALL iom_put( TRIM(cl1), z2d )
163             z2d(1,:) = str_ove(:,1) * rc_ggram        !  (conversion in Gg)
164             DO ji = 1, jpi
165               z2d(ji,:) = z2d(1,:)
166             ENDDO
167             cl1 = 'sopstove'
168             CALL iom_put( TRIM(cl1), z2d )
169             IF( ln_subbas ) THEN
170                DO jn = 2, nptr
171                    sjk(:,:,jn) = ptr_sjk( zmask(:,:,:), btmsk(:,:,jn) )
172                    r1_sjk(:,:,jn) = 0._wp
173                    WHERE( sjk(:,:,jn) /= 0._wp )   r1_sjk(:,:,jn) = 1._wp / sjk(:,:,jn)
174
175                    ! i-mean T and S, j-Stream-Function, basin
176                    tn_jk(:,:,jn) = ptr_sjk( zts(:,:,:,jp_tem), btmsk(:,:,jn) ) * r1_sjk(:,:,jn)
177                    sn_jk(:,:,jn) = ptr_sjk( zts(:,:,:,jp_sal), btmsk(:,:,jn) ) * r1_sjk(:,:,jn)
178                    v_msf(:,:,jn) = ptr_sjk( pvtr(:,:,:), btmsk(:,:,jn) ) 
179                    htr_ove(:,jn) = SUM( v_msf(:,:,jn)*tn_jk(:,:,jn) ,2 )
180                    str_ove(:,jn) = SUM( v_msf(:,:,jn)*sn_jk(:,:,jn) ,2 )
181
182                    z2d(1,:) = htr_ove(:,jn) * rc_pwatt !  (conversion in PW)
183                    DO ji = 1, jpi
184                        z2d(ji,:) = z2d(1,:)
185                    ENDDO
186                    cl1 = TRIM('sophtove_'//clsubb(jn))
187                    CALL iom_put( cl1, z2d )
188                    z2d(1,:) = str_ove(:,jn) * rc_ggram        ! (conversion in Gg)
189                    DO ji = 1, jpi
190                        z2d(ji,:) = z2d(1,:)
191                    ENDDO
192                    cl1 = TRIM('sopstove_'//clsubb(jn))
193                    CALL iom_put( cl1, z2d )
194                END DO
195             ENDIF
196         ENDIF
197         IF( iom_use("sopstbtr") .OR. iom_use("sophtbtr") ) THEN
198         ! Calculate barotropic heat and salt transport here
199             sjk(:,1,1) = ptr_sj( zmask(:,:,:), btmsk(:,:,1) )
200             r1_sjk(:,1,1) = 0._wp
201             WHERE( sjk(:,1,1) /= 0._wp )   r1_sjk(:,1,1) = 1._wp / sjk(:,1,1)
202           
203            vsum = ptr_sj( pvtr(:,:,:), btmsk(:,:,1))
204            tssum(:,jp_tem) = ptr_sj( zts(:,:,:,jp_tem), btmsk(:,:,1) )
205            tssum(:,jp_sal) = ptr_sj( zts(:,:,:,jp_sal), btmsk(:,:,1) )
206            htr_btr(:,1) = vsum * tssum(:,jp_tem) * r1_sjk(:,1,1)
207            str_btr(:,1) = vsum * tssum(:,jp_sal) * r1_sjk(:,1,1)
208            z2d(1,:) = htr_btr(:,1) * rc_pwatt        !  (conversion in PW)
209            DO ji = 2, jpi
210               z2d(ji,:) = z2d(1,:)
211            ENDDO
212            cl1 = 'sophtbtr'
213            CALL iom_put( TRIM(cl1), z2d )
214            z2d(1,:) = str_btr(:,1) * rc_ggram        !  (conversion in Gg)
215            DO ji = 2, jpi
216              z2d(ji,:) = z2d(1,:)
217            ENDDO
218            cl1 = 'sopstbtr'
219            CALL iom_put( TRIM(cl1), z2d )
220            IF( ln_subbas ) THEN
221                DO jn = 2, nptr
222                    sjk(:,1,jn) = ptr_sj( zmask(:,:,:), btmsk(:,:,jn) )
223                    r1_sjk(:,1,jn) = 0._wp
224                    WHERE( sjk(:,1,jn) /= 0._wp )   r1_sjk(:,1,jn) = 1._wp / sjk(:,1,jn)
225                    vsum = ptr_sj( pvtr(:,:,:), btmsk(:,:,jn))
226                    tssum(:,jp_tem) = ptr_sj( zts(:,:,:,jp_tem), btmsk(:,:,jn) )
227                    tssum(:,jp_sal) = ptr_sj( zts(:,:,:,jp_sal), btmsk(:,:,jn) )
228                    htr_btr(:,jn) = vsum * tssum(:,jp_tem) * r1_sjk(:,1,jn)
229                    str_btr(:,jn) = vsum * tssum(:,jp_sal) * r1_sjk(:,1,jn)
230                    z2d(1,:) = htr_btr(:,jn) * rc_pwatt !  (conversion in PW)
231                    DO ji = 1, jpi
232                        z2d(ji,:) = z2d(1,:)
233                    ENDDO
234                    cl1 = TRIM('sophtbtr_'//clsubb(jn))
235                    CALL iom_put( cl1, z2d )
236                    z2d(1,:) = str_btr(:,jn) * rc_ggram        ! (conversion in Gg)
237                    DO ji = 1, jpi
238                        z2d(ji,:) = z2d(1,:)
239                    ENDDO
240                    cl1 = TRIM('sopstbtr_'//clsubb(jn))
241                    CALL iom_put( cl1, z2d )
242               ENDDO
243            ENDIF !ln_subbas
244         ENDIF !iom_use("sopstbtr....)
245         !
246      ELSE
247         !
248         IF( iom_use("zotemglo") ) THEN    ! i-mean i-k-surface
249            zmask(:,:,:) = 0._wp
250            zts(:,:,:,:) = 0._wp
251            DO jk = 1, jpkm1
252               DO jj = 1, jpj
253                  DO ji = 1, jpi
254                     zsfc = e1t(ji,jj) * fse3t(ji,jj,jk)
255                     zmask(ji,jj,jk)      = tmask(ji,jj,jk)      * zsfc
256                     zts(ji,jj,jk,jp_tem) = tsn(ji,jj,jk,jp_tem) * zsfc
257                     zts(ji,jj,jk,jp_sal) = tsn(ji,jj,jk,jp_sal) * zsfc
258                  ENDDO
259               ENDDO
260            ENDDO
261            DO jn = 1, nptr
262               zmask(1,:,:) = ptr_sjk( zmask(:,:,:), btmsk(:,:,jn) )
263               cl1 = TRIM('zosrf'//clsubb(jn) )
264               CALL iom_put( cl1, zmask )
265               !
266               z3d(1,:,:) = ptr_sjk( zts(:,:,:,jp_tem), btmsk(:,:,jn) ) &
267                  &            / MAX( zmask(1,:,:), 10.e-15 )
268               DO ji = 1, jpi
269                  z3d(ji,:,:) = z3d(1,:,:)
270               ENDDO
271               cl1 = TRIM('zotem'//clsubb(jn) )
272               CALL iom_put( cl1, z3d )
273               !
274               z3d(1,:,:) = ptr_sjk( zts(:,:,:,jp_sal), btmsk(:,:,jn) ) &
275                  &            / MAX( zmask(1,:,:), 10.e-15 )
276               DO ji = 1, jpi
277                  z3d(ji,:,:) = z3d(1,:,:)
278               ENDDO
279               cl1 = TRIM('zosal'//clsubb(jn) )
280               CALL iom_put( cl1, z3d )
281            END DO
282         ENDIF
283         !
284         !                                ! Advective and diffusive heat and salt transport
285         IF( iom_use("sophtadv") .OR. iom_use("sopstadv") ) THEN   
286            z2d(1,:) = htr_adv(:,1) * rc_pwatt        !  (conversion in PW)
287            DO ji = 1, jpi
288               z2d(ji,:) = z2d(1,:)
289            ENDDO
290            cl1 = 'sophtadv'                 
291            CALL iom_put( TRIM(cl1), z2d )
292            z2d(1,:) = str_adv(:,1) * rc_ggram        ! (conversion in Gg)
293            DO ji = 1, jpi
294               z2d(ji,:) = z2d(1,:)
295            ENDDO
296            cl1 = 'sopstadv'
297            CALL iom_put( TRIM(cl1), z2d )
298            IF( ln_subbas ) THEN
299              DO jn=2,nptr
300               z2d(1,:) = htr_adv(:,jn) * rc_pwatt        !  (conversion in PW)
301               DO ji = 1, jpi
302                 z2d(ji,:) = z2d(1,:)
303               ENDDO
304               cl1 = TRIM('sophtadv_'//clsubb(jn))                 
305               CALL iom_put( cl1, z2d )
306               z2d(1,:) = str_adv(:,jn) * rc_ggram        ! (conversion in Gg)
307               DO ji = 1, jpi
308                  z2d(ji,:) = z2d(1,:)
309               ENDDO
310               cl1 = TRIM('sopstadv_'//clsubb(jn))                 
311               CALL iom_put( cl1, z2d )             
312              ENDDO
313            ENDIF
314         ENDIF
315         !
316         IF( iom_use("sophtldf") .OR. iom_use("sopstldf") ) THEN   
317            z2d(1,:) = htr_ldf(:,1) * rc_pwatt        !  (conversion in PW)
318            DO ji = 1, jpi
319               z2d(ji,:) = z2d(1,:)
320            ENDDO
321            cl1 = 'sophtldf'
322            CALL iom_put( TRIM(cl1), z2d )
323            z2d(1,:) = str_ldf(:,1) * rc_ggram        !  (conversion in Gg)
324            DO ji = 1, jpi
325               z2d(ji,:) = z2d(1,:)
326            ENDDO
327            cl1 = 'sopstldf'
328            CALL iom_put( TRIM(cl1), z2d )
329            IF( ln_subbas ) THEN
330              DO jn=2,nptr
331               z2d(1,:) = htr_ldf(:,jn) * rc_pwatt        !  (conversion in PW)
332               DO ji = 1, jpi
333                 z2d(ji,:) = z2d(1,:)
334               ENDDO
335               cl1 = TRIM('sophtldf_'//clsubb(jn))                 
336               CALL iom_put( cl1, z2d )
337               z2d(1,:) = str_ldf(:,jn) * rc_ggram        ! (conversion in Gg)
338               DO ji = 1, jpi
339                  z2d(ji,:) = z2d(1,:)
340               ENDDO
341               cl1 = TRIM('sopstldf_'//clsubb(jn))                 
342               CALL iom_put( cl1, z2d )             
343              ENDDO
344            ENDIF
345         ENDIF
346
347         IF( iom_use("sopht_vt") .OR. iom_use("sopst_vs") ) THEN   
348            z2d(1,:) = htr_vt(:,1) * rc_pwatt        !  (conversion in PW)
349            DO ji = 1, jpi
350               z2d(ji,:) = z2d(1,:)
351            ENDDO
352            cl1 = 'sopht_vt'
353            CALL iom_put( TRIM(cl1), z2d )
354            z2d(1,:) = str_vs(:,1) * rc_ggram        !  (conversion in Gg)
355            DO ji = 1, jpi
356               z2d(ji,:) = z2d(1,:)
357            ENDDO
358            cl1 = 'sopst_vs'
359            CALL iom_put( TRIM(cl1), z2d )
360            IF( ln_subbas ) THEN
361              DO jn=2,nptr
362               z2d(1,:) = htr_vt(:,jn) * rc_pwatt        !  (conversion in PW)
363               DO ji = 1, jpi
364                 z2d(ji,:) = z2d(1,:)
365               ENDDO
366               cl1 = TRIM('sopht_vt_'//clsubb(jn))                 
367               CALL iom_put( cl1, z2d )
368               z2d(1,:) = str_vs(:,jn) * rc_ggram        ! (conversion in Gg)
369               DO ji = 1, jpi
370                  z2d(ji,:) = z2d(1,:)
371               ENDDO
372               cl1 = TRIM('sopst_vs_'//clsubb(jn))                 
373               CALL iom_put( cl1, z2d )             
374              ENDDO
375            ENDIF
376         ENDIF
377
378#ifdef key_diaeiv
379         IF(lk_traldf_eiv) THEN
380            IF( iom_use("sophteiv") .OR. iom_use("sopsteiv") ) THEN
381               z2d(1,:) = htr_eiv(:,1) * rc_pwatt        !  (conversion in PW)
382               DO ji = 1, jpi
383                  z2d(ji,:) = z2d(1,:)
384               ENDDO
385               cl1 = 'sophteiv'
386               CALL iom_put( TRIM(cl1), z2d )
387               z2d(1,:) = str_eiv(:,1) * rc_ggram        !  (conversion in Gg)
388               DO ji = 1, jpi
389                  z2d(ji,:) = z2d(1,:)
390               ENDDO
391               cl1 = 'sopsteiv'
392               CALL iom_put( TRIM(cl1), z2d )
393               IF( ln_subbas ) THEN
394                  DO jn=2,nptr
395                     z2d(1,:) = htr_eiv(:,jn) * rc_pwatt        !  (conversion in PW)
396                     DO ji = 1, jpi
397                        z2d(ji,:) = z2d(1,:)
398                     ENDDO
399                     cl1 = TRIM('sophteiv_'//clsubb(jn))                 
400                     CALL iom_put( cl1, z2d )
401                     z2d(1,:) = str_eiv(:,jn) * rc_ggram        ! (conversion in Gg)
402                     DO ji = 1, jpi
403                        z2d(ji,:) = z2d(1,:)
404                     ENDDO
405                     cl1 = TRIM('sopsteiv_'//clsubb(jn)) 
406                     CALL iom_put( cl1, z2d )             
407                  ENDDO
408               ENDIF
409            ENDIF
410            IF( iom_use("zomsfeivglo") ) THEN
411               DO jk=1,jpk
412                  DO jj=1,jpj
413                     DO ji=1,jpi
414                        zvn(ji,jj,jk) = v_eiv(ji,jj,jk) * fse3v(ji,jj,jk) * e1v(ji,jj)
415                     ENDDO
416                  ENDDO
417               ENDDO
418               z3d(1,:,:) = ptr_sjk( zvn(:,:,:) )  ! zonal cumulative effective transport
419               DO jk = jpkm1,1,-1
420                 z3d(1,:,jk) = z3d(1,:,jk+1) - z3d(1,:,jk)   ! effective j-Stream-Function (MSF)
421               END DO
422               DO ji = 1, jpi
423                  z3d(ji,:,:) = z3d(1,:,:)
424               ENDDO
425               cl1 = TRIM('zomsfeiv'//clsubb(1) )
426               CALL iom_put( cl1, z3d * rc_sv )
427               IF( ln_subbas ) THEN
428                  DO jn = 2, nptr                                    ! by sub-basins
429                     z3d(1,:,:) =  ptr_sjk( zvn(:,:,:), btmsk(:,:,jn) ) 
430                     DO jk = jpkm1,1,-1
431                        z3d(1,:,jk) = z3d(1,:,jk+1) - z3d(1,:,jk)    ! effective j-Stream-Function (MSF)
432                     END DO
433                     DO ji = 1, jpi
434                        z3d(ji,:,:) = z3d(1,:,:)
435                     ENDDO
436                     cl1 = TRIM('zomsfeiv'//clsubb(jn) )
437                     CALL iom_put( cl1, z3d * rc_sv )
438                  END DO
439               ENDIF
440            ENDIF
441         ENDIF
442#endif
443         !
444      ENDIF
445      !
446      IF( nn_timing == 1 )   CALL timing_stop('dia_ptr')
447      !
448   END SUBROUTINE dia_ptr
449
450
451   SUBROUTINE dia_ptr_init
452      !!----------------------------------------------------------------------
453      !!                  ***  ROUTINE dia_ptr_init  ***
454      !!                   
455      !! ** Purpose :   Initialization, namelist read
456      !!----------------------------------------------------------------------
457      INTEGER ::  jn           ! local integers
458      INTEGER ::  inum, ierr   ! local integers
459      INTEGER ::  ios          ! Local integer output status for namelist read
460      !!
461      NAMELIST/namptr/ ln_diaptr, ln_subbas
462      !!----------------------------------------------------------------------
463
464      REWIND( numnam_ref )              ! Namelist namptr in reference namelist : Poleward transport
465      READ  ( numnam_ref, namptr, IOSTAT = ios, ERR = 901)
466901   IF( ios /= 0 ) CALL ctl_nam ( ios , 'namptr in reference namelist', lwp )
467
468      REWIND( numnam_cfg )              ! Namelist namptr in configuration namelist : Poleward transport
469      READ  ( numnam_cfg, namptr, IOSTAT = ios, ERR = 902 )
470902   IF( ios /= 0 ) CALL ctl_nam ( ios , 'namptr in configuration namelist', lwp )
471      IF(lwm .AND. nprint > 2) WRITE ( numond, namptr )
472
473      IF(lwp) THEN                     ! Control print
474         WRITE(numout,*)
475         WRITE(numout,*) 'dia_ptr_init : poleward transport and msf initialization'
476         WRITE(numout,*) '~~~~~~~~~~~~'
477         WRITE(numout,*) '   Namelist namptr : set ptr parameters'
478         WRITE(numout,*) '      Poleward heat & salt transport (T) or not (F)      ln_diaptr  = ', ln_diaptr
479         WRITE(numout,*) '      Global (F) or glo/Atl/Pac/Ind/Indo-Pac basins      ln_subbas  = ', ln_subbas
480      ENDIF
481
482      IF( ln_diaptr ) THEN 
483         !
484         IF( ln_subbas ) THEN
485            nptr = 5            ! Global, Atlantic, Pacific, Indian, Indo-Pacific
486            ALLOCATE( clsubb(nptr) )
487            clsubb(1) = 'glo' ;  clsubb(2) = 'atl'  ;  clsubb(3) = 'pac'  ;  clsubb(4) = 'ind'  ;  clsubb(5) = 'ipc'
488         ELSE               
489            nptr = 1       ! Global only
490            ALLOCATE( clsubb(nptr) )
491            clsubb(1) = 'glo' 
492         ENDIF
493
494         !                                      ! allocate dia_ptr arrays
495         IF( dia_ptr_alloc() /= 0 )   CALL ctl_stop( 'STOP', 'dia_ptr_init : unable to allocate arrays' )
496
497         rc_pwatt = rc_pwatt * rau0_rcp          ! conversion from K.s-1 to PetaWatt
498
499         IF( lk_mpp )   CALL mpp_ini_znl( numout )     ! Define MPI communicator for zonal sum
500
501         IF( ln_subbas ) THEN                ! load sub-basin mask
502            CALL iom_open( 'subbasins', inum,  ldstop = .TRUE.  )
503            CALL iom_get( inum, jpdom_data, 'atlmsk', btmsk(:,:,2) )   ! Atlantic basin
504            CALL iom_get( inum, jpdom_data, 'pacmsk', btmsk(:,:,3) )   ! Pacific  basin
505            CALL iom_get( inum, jpdom_data, 'indmsk', btmsk(:,:,4) )   ! Indian   basin
506            CALL iom_close( inum )
507            btmsk(:,:,5) = MAX ( btmsk(:,:,3), btmsk(:,:,4) )          ! Indo-Pacific basin
508            WHERE( gphit(:,:) < -30._wp)   ;   btm30(:,:) = 0._wp      ! mask out Southern Ocean
509            ELSE WHERE                     ;   btm30(:,:) = ssmask(:,:)
510            END WHERE
511         ENDIF
512   
513         btmsk(:,:,1) = tmask_i(:,:)                                   ! global ocean
514     
515         DO jn = 1, nptr
516            btmsk(:,:,jn) = btmsk(:,:,jn) * tmask_i(:,:)               ! interior domain only
517         END DO
518
519         ! Initialise arrays to zero because diatpr is called before they are first calculated
520         ! Note that this means diagnostics will not be exactly correct when model run is restarted.
521         htr_adv(:,:) = 0._wp  ;  str_adv(:,:) =  0._wp 
522         htr_ldf(:,:) = 0._wp  ;  str_ldf(:,:) =  0._wp 
523         htr_eiv(:,:) = 0._wp  ;  str_eiv(:,:) =  0._wp 
524         htr_vt(:,:) = 0._wp  ;   str_vs(:,:) =  0._wp
525         htr_ove(:,:) = 0._wp  ;   str_ove(:,:) =  0._wp
526         htr_btr(:,:) = 0._wp  ;   str_btr(:,:) =  0._wp
527         !
528      ENDIF 
529      !
530   END SUBROUTINE dia_ptr_init
531
532   SUBROUTINE dia_ptr_ohst_components( ktra, cptr, pva ) 
533      !!----------------------------------------------------------------------
534      !!                    ***  ROUTINE dia_ptr_ohst_components  ***
535      !!----------------------------------------------------------------------
536      !! Wrapper for heat and salt transport calculations to calculate them for each basin
537      !! Called from all advection and/or diffusion routines
538      !!----------------------------------------------------------------------
539      INTEGER                         , INTENT(in )  :: ktra  ! tracer index
540      CHARACTER(len=3)                , INTENT(in)   :: cptr  ! transport type  'adv'/'ldf'/'eiv'
541      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in)   :: pva   ! 3D input array of advection/diffusion
542      INTEGER                                        :: jn    !
543
544      IF( cptr == 'adv' ) THEN
545         IF( ktra == jp_tem )  htr_adv(:,1) = ptr_sj( pva(:,:,:) )
546         IF( ktra == jp_sal )  str_adv(:,1) = ptr_sj( pva(:,:,:) )
547      ENDIF
548      IF( cptr == 'ldf' ) THEN
549         IF( ktra == jp_tem )  htr_ldf(:,1) = ptr_sj( pva(:,:,:) )
550         IF( ktra == jp_sal )  str_ldf(:,1) = ptr_sj( pva(:,:,:) )
551      ENDIF
552      IF( cptr == 'eiv' ) THEN
553         IF( ktra == jp_tem )  htr_eiv(:,1) = ptr_sj( pva(:,:,:) )
554         IF( ktra == jp_sal )  str_eiv(:,1) = ptr_sj( pva(:,:,:) )
555      ENDIF
556      IF( cptr == 'vts' ) THEN
557         IF( ktra == jp_tem )  htr_vt(:,1) = ptr_sj( pva(:,:,:) )
558         IF( ktra == jp_sal )  str_vs(:,1) = ptr_sj( pva(:,:,:) )
559      ENDIF
560      !
561      IF( ln_subbas ) THEN
562         !
563         IF( cptr == 'adv' ) THEN
564             IF( ktra == jp_tem ) THEN
565                DO jn = 2, nptr
566                   htr_adv(:,jn) = ptr_sj( pva(:,:,:), btmsk(:,:,jn) )
567                END DO
568             ENDIF
569             IF( ktra == jp_sal ) THEN
570                DO jn = 2, nptr
571                   str_adv(:,jn) = ptr_sj( pva(:,:,:), btmsk(:,:,jn) )
572                END DO
573             ENDIF
574         ENDIF
575         IF( cptr == 'ldf' ) THEN
576             IF( ktra == jp_tem ) THEN
577                DO jn = 2, nptr
578                    htr_ldf(:,jn) = ptr_sj( pva(:,:,:), btmsk(:,:,jn) )
579                 END DO
580             ENDIF
581             IF( ktra == jp_sal ) THEN
582                DO jn = 2, nptr
583                   str_ldf(:,jn) = ptr_sj( pva(:,:,:), btmsk(:,:,jn) )
584                END DO
585             ENDIF
586         ENDIF
587         IF( cptr == 'eiv' ) THEN
588             IF( ktra == jp_tem ) THEN
589                DO jn = 2, nptr
590                    htr_eiv(:,jn) = ptr_sj( pva(:,:,:), btmsk(:,:,jn) )
591                 END DO
592             ENDIF
593             IF( ktra == jp_sal ) THEN
594                DO jn = 2, nptr
595                   str_eiv(:,jn) = ptr_sj( pva(:,:,:), btmsk(:,:,jn) )
596                END DO
597             ENDIF
598         ENDIF
599         IF( cptr == 'vts' ) THEN
600             IF( ktra == jp_tem ) THEN
601                DO jn = 2, nptr
602                    htr_vt(:,jn) = ptr_sj( pva(:,:,:), btmsk(:,:,jn) )
603                 END DO
604             ENDIF
605             IF( ktra == jp_sal ) THEN
606                DO jn = 2, nptr
607                   str_vs(:,jn) = ptr_sj( pva(:,:,:), btmsk(:,:,jn) )
608                END DO
609             ENDIF
610         ENDIF
611         !
612      ENDIF
613   END SUBROUTINE dia_ptr_ohst_components
614
615
616   FUNCTION dia_ptr_alloc()
617      !!----------------------------------------------------------------------
618      !!                    ***  ROUTINE dia_ptr_alloc  ***
619      !!----------------------------------------------------------------------
620      INTEGER               ::   dia_ptr_alloc   ! return value
621      INTEGER, DIMENSION(3) ::   ierr
622      !!----------------------------------------------------------------------
623      ierr(:) = 0
624      !
625      ALLOCATE( btmsk(jpi,jpj,nptr) ,              &
626         &      htr_adv(jpj,nptr) , str_adv(jpj,nptr) ,   &
627         &      htr_eiv(jpj,nptr) , str_eiv(jpj,nptr) ,   &
628         &      htr_vt(jpj,nptr)  , str_vs(jpj,nptr)  ,   &
629         &      htr_ove(jpj,nptr) , str_ove(jpj,nptr) ,   &
630         &      htr_btr(jpj,nptr) , str_btr(jpj,nptr) ,   &
631         &      htr_ldf(jpj,nptr) , str_ldf(jpj,nptr) , STAT=ierr(1)  )
632         !
633      ALLOCATE( p_fval1d(jpj), p_fval2d(jpj,jpk), Stat=ierr(2))
634      !
635      ALLOCATE( btm30(jpi,jpj), STAT=ierr(3)  )
636
637         !
638      dia_ptr_alloc = MAXVAL( ierr )
639      IF(lk_mpp)   CALL mpp_sum( dia_ptr_alloc )
640      !
641   END FUNCTION dia_ptr_alloc
642
643
644   FUNCTION ptr_sj_3d( pva, pmsk )   RESULT ( p_fval )
645      !!----------------------------------------------------------------------
646      !!                    ***  ROUTINE ptr_sj_3d  ***
647      !!
648      !! ** Purpose :   i-k sum computation of a j-flux array
649      !!
650      !! ** Method  : - i-k sum of pva using the interior 2D vmask (vmask_i).
651      !!              pva is supposed to be a masked flux (i.e. * vmask*e1v*e3v)
652      !!
653      !! ** Action  : - p_fval: i-k-mean poleward flux of pva
654      !!----------------------------------------------------------------------
655      REAL(wp), INTENT(in), DIMENSION(jpi,jpj,jpk)       ::   pva   ! mask flux array at V-point
656      REAL(wp), INTENT(in), DIMENSION(jpi,jpj), OPTIONAL ::   pmsk   ! Optional 2D basin mask
657      !
658      INTEGER                  ::   ji, jj, jk   ! dummy loop arguments
659      INTEGER                  ::   ijpj         ! ???
660      REAL(wp), POINTER, DIMENSION(:) :: p_fval  ! function value
661      !!--------------------------------------------------------------------
662      !
663      p_fval => p_fval1d
664
665      ijpj = jpj
666      p_fval(:) = 0._wp
667      IF( PRESENT( pmsk ) ) THEN
668         DO jk = 1, jpkm1
669            DO jj = 2, jpjm1
670               DO ji = fs_2, fs_jpim1   ! Vector opt.
671                  p_fval(jj) = p_fval(jj) + pva(ji,jj,jk) * tmask_i(ji,jj) * pmsk(ji,jj)
672               END DO
673            END DO
674         END DO
675      ELSE
676         DO jk = 1, jpkm1
677            DO jj = 2, jpjm1
678               DO ji = fs_2, fs_jpim1   ! Vector opt.
679                  p_fval(jj) = p_fval(jj) + pva(ji,jj,jk) * tmask_i(ji,jj) 
680               END DO
681            END DO
682         END DO
683      ENDIF
684#if defined key_mpp_mpi
685      IF(lk_mpp)   CALL mpp_sum( p_fval, ijpj, ncomm_znl)
686#endif
687      !
688   END FUNCTION ptr_sj_3d
689
690
691   FUNCTION ptr_sj_2d( pva, pmsk )   RESULT ( p_fval )
692      !!----------------------------------------------------------------------
693      !!                    ***  ROUTINE ptr_sj_2d  ***
694      !!
695      !! ** Purpose :   "zonal" and vertical sum computation of a i-flux array
696      !!
697      !! ** Method  : - i-k sum of pva using the interior 2D vmask (vmask_i).
698      !!      pva is supposed to be a masked flux (i.e. * vmask*e1v*e3v)
699      !!
700      !! ** Action  : - p_fval: i-k-mean poleward flux of pva
701      !!----------------------------------------------------------------------
702      REAL(wp) , INTENT(in), DIMENSION(jpi,jpj)           ::   pva   ! mask flux array at V-point
703      REAL(wp) , INTENT(in), DIMENSION(jpi,jpj), OPTIONAL ::   pmsk   ! Optional 2D basin mask
704      !
705      INTEGER                  ::   ji,jj       ! dummy loop arguments
706      INTEGER                  ::   ijpj        ! ???
707      REAL(wp), POINTER, DIMENSION(:) :: p_fval ! function value
708      !!--------------------------------------------------------------------
709      !
710      p_fval => p_fval1d
711
712      ijpj = jpj
713      p_fval(:) = 0._wp
714      IF( PRESENT( pmsk ) ) THEN
715         DO jj = 2, jpjm1
716            DO ji = nldi, nlei   ! No vector optimisation here. Better use a mask ?
717               p_fval(jj) = p_fval(jj) + pva(ji,jj) * tmask_i(ji,jj) * pmsk(ji,jj)
718            END DO
719         END DO
720      ELSE
721         DO jj = 2, jpjm1
722            DO ji = nldi, nlei   ! No vector optimisation here. Better use a mask ?
723               p_fval(jj) = p_fval(jj) + pva(ji,jj) * tmask_i(ji,jj)
724            END DO
725         END DO
726      ENDIF
727#if defined key_mpp_mpi
728      CALL mpp_sum( p_fval, ijpj, ncomm_znl )
729#endif
730      !
731   END FUNCTION ptr_sj_2d
732
733
734   FUNCTION ptr_sjk( pta, pmsk )   RESULT ( p_fval )
735      !!----------------------------------------------------------------------
736      !!                    ***  ROUTINE ptr_sjk  ***
737      !!
738      !! ** Purpose :   i-sum computation of an array
739      !!
740      !! ** Method  : - i-sum of pva using the interior 2D vmask (vmask_i).
741      !!
742      !! ** Action  : - p_fval: i-mean poleward flux of pva
743      !!----------------------------------------------------------------------
744      !!
745      IMPLICIT none
746      REAL(wp) , INTENT(in), DIMENSION(jpi,jpj,jpk)           ::   pta    ! mask flux array at V-point
747      REAL(wp) , INTENT(in), DIMENSION(jpi,jpj)    , OPTIONAL ::   pmsk   ! Optional 2D basin mask
748      !!
749      INTEGER                           :: ji, jj, jk ! dummy loop arguments
750      REAL(wp), POINTER, DIMENSION(:,:) :: p_fval     ! return function value
751#if defined key_mpp_mpi
752      INTEGER, DIMENSION(1) ::   ish
753      INTEGER, DIMENSION(2) ::   ish2
754      INTEGER               ::   ijpjjpk
755      REAL(wp), DIMENSION(jpj*jpk) ::   zwork    ! mask flux array at V-point
756#endif
757      !!--------------------------------------------------------------------
758     !
759      p_fval => p_fval2d
760
761      p_fval(:,:) = 0._wp
762      !
763      IF( PRESENT( pmsk ) ) THEN
764         DO jk = 1, jpkm1
765            DO jj = 2, jpjm1
766!!gm here, use of tmask_i  ==> no need of loop over nldi, nlei....
767               DO ji =  nldi, nlei   ! No vector optimisation here. Better use a mask ?
768                  p_fval(jj,jk) = p_fval(jj,jk) + pta(ji,jj,jk) * pmsk(ji,jj)
769               END DO
770            END DO
771         END DO
772      ELSE
773         DO jk = 1, jpkm1
774            DO jj = 2, jpjm1
775               DO ji =  nldi, nlei   ! No vector optimisation here. Better use a mask ?
776                  p_fval(jj,jk) = p_fval(jj,jk) + pta(ji,jj,jk) * tmask_i(ji,jj)
777               END DO
778            END DO
779         END DO
780      END IF
781      !
782#if defined key_mpp_mpi
783      ijpjjpk = jpj*jpk
784      ish(1) = ijpjjpk  ;   ish2(1) = jpj   ;   ish2(2) = jpk
785      zwork(1:ijpjjpk) = RESHAPE( p_fval, ish )
786      CALL mpp_sum( zwork, ijpjjpk, ncomm_znl )
787      p_fval(:,:) = RESHAPE( zwork, ish2 )
788#endif
789      !
790
791   END FUNCTION ptr_sjk
792
793
794   !!======================================================================
795END MODULE diaptr
Note: See TracBrowser for help on using the repository browser.