source: branches/UKMO/dev_r5518_GO6_under_ice_relax_dr_hook/NEMOGCM/NEMO/OPA_SRC/DIA/diaprod.F90 @ 11738

Last change on this file since 11738 was 11738, checked in by marc, 12 months ago

The Dr Hook changes from my perl code.

File size: 10.4 KB
Line 
1MODULE diaprod
2! Requires key_iom_put
3# if defined key_iomput
4   !!======================================================================
5   !!                     ***  MODULE  diaprod  ***
6   !! Ocean diagnostics :  write ocean product diagnostics
7   !!=====================================================================
8   !! History :  3.4  ! 2012  (D. Storkey)  Original code
9   !!----------------------------------------------------------------------
10
11   !!----------------------------------------------------------------------
12   !!   dia_prod      : calculate and write out product diagnostics
13   !!----------------------------------------------------------------------
14   USE oce             ! ocean dynamics and tracers
15   USE dom_oce         ! ocean space and time domain
16   USE domvvl          ! for thickness weighted diagnostics if key_vvl
17   USE eosbn2          ! equation of state  (eos call)
18   USE phycst          ! physical constants
19   USE lbclnk          ! ocean lateral boundary conditions (or mpp link)
20   USE in_out_manager  ! I/O manager
21   USE diadimg         ! dimg direct access file format output
22   USE iom
23   USE ioipsl
24   USE lib_mpp         ! MPP library
25   USE timing          ! preformance summary
26   USE wrk_nemo        ! working array
27   USE diaptr
28
29   USE yomhook, ONLY: lhook, dr_hook
30   USE parkind1, ONLY: jprb, jpim
31
32   IMPLICIT NONE
33   PRIVATE
34
35   PUBLIC   dia_prod                 ! routines called by step.F90
36
37   !! * Substitutions
38#  include "zdfddm_substitute.h90"
39#  include "domzgr_substitute.h90"
40#  include "vectopt_loop_substitute.h90"
41   !!----------------------------------------------------------------------
42   !! NEMO/OPA 3.4 , NEMO Consortium (2012)
43   !! $Id$
44   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
45   !!----------------------------------------------------------------------
46CONTAINS
47
48   SUBROUTINE dia_prod( kt )
49      !!---------------------------------------------------------------------
50      !!                  ***  ROUTINE dia_prod  ***
51      !!                   
52      !! ** Purpose :   Write out product diagnostics (uT, vS etc.)
53      !!
54      !! ** Method  :  use iom_put
55      !!               Product diagnostics are not thickness-weighted in this routine.
56      !!               They should be thickness-weighted using XIOS if key_vvl is set.
57      !!----------------------------------------------------------------------
58      !!
59      INTEGER, INTENT( in ) ::   kt      ! ocean time-step index
60      !!
61      INTEGER                      ::   ji, jj, jk              ! dummy loop indices
62      REAL(wp)                     ::   zztmp, zztmpx, zztmpy   !
63      !!
64      REAL(wp), POINTER, DIMENSION(:,:)   :: z2d      ! 2D workspace
65      REAL(wp), POINTER, DIMENSION(:,:,:) :: z3d      ! 3D workspace
66      REAL(wp), POINTER, DIMENSION(:,:,:) :: zrhop    ! potential density
67      INTEGER(KIND=jpim), PARAMETER :: zhook_in = 0
68      INTEGER(KIND=jpim), PARAMETER :: zhook_out = 1
69      REAL(KIND=jprb)               :: zhook_handle
70
71      CHARACTER(LEN=*), PARAMETER :: RoutineName='DIA_PROD'
72
73      IF (lhook) CALL dr_hook(RoutineName,zhook_in,zhook_handle)
74
75      !!----------------------------------------------------------------------
76      !
77      IF( nn_timing == 1 )   CALL timing_start('dia_prod')
78      !
79      CALL wrk_alloc( jpi , jpj      , z2d )
80      CALL wrk_alloc( jpi , jpj, jpk , z3d )
81      CALL wrk_alloc( jpi , jpj, jpk , zrhop )
82      !
83
84      IF( iom_use("urhop") .OR. iom_use("vrhop") .OR. iom_use("wrhop") &
85#if ! defined key_diaar5
86     &  .OR. iom_use("rhop") &
87#endif
88     & ) THEN
89         CALL eos( tsn, z3d, zrhop )                 ! now in situ and potential density
90         zrhop(:,:,:) = zrhop(:,:,:)-1000.e0         ! reference potential density to 1000 to avoid precision issues in rhop2 calculation
91         zrhop(:,:,jpk) = 0._wp
92#if ! defined key_diaar5
93         CALL iom_put( 'rhop', zrhop )
94#else
95         ! If key_diaar5 set then there is already an iom_put call to output rhop.
96         ! Really should be a standard diagnostics option?
97#endif
98      ENDIF
99
100      IF( iom_use("ut") ) THEN
101         z3d(:,:,:) = 0.e0 
102         DO jk = 1, jpkm1
103            DO jj = 2, jpjm1
104               DO ji = fs_2, fs_jpim1   ! vector opt.
105                  z3d(ji,jj,jk) = un(ji,jj,jk) * 0.5 * ( tsn(ji,jj,jk,jp_tem) + tsn(ji+1,jj,jk,jp_tem) )
106               END DO
107            END DO
108         END DO
109         CALL iom_put( "ut", z3d )                  ! product of temperature and zonal velocity at U points
110      ENDIF
111
112      IF( iom_use("vt") .OR. iom_use("sopht_vt") ) THEN
113         z3d(:,:,:) = 0.e0 
114         DO jk = 1, jpkm1
115            DO jj = 2, jpjm1
116               DO ji = fs_2, fs_jpim1   ! vector opt.
117                  z3d(ji,jj,jk) = vn(ji,jj,jk) * 0.5 * ( tsn(ji,jj,jk,jp_tem) + tsn(ji,jj+1,jk,jp_tem) )
118               END DO
119            END DO
120         END DO
121         CALL iom_put( "vt", z3d )                  ! product of temperature and meridional velocity at V points
122         DO jk = 1, jpkm1
123            DO jj = 2, jpjm1
124               DO ji = fs_2, fs_jpim1   ! vector opt.
125                  z3d(ji,jj,jk) = z3d(ji,jj,jk) * fse3v(ji,jj,jk) * e1v(ji,jj)
126               END DO
127            END DO
128         END DO
129         IF(ln_diaptr) CALL dia_ptr_ohst_components( jp_tem, 'vts', z3d)
130      ENDIF
131
132      IF( iom_use("wt") ) THEN
133         z3d(:,:,:) = 0.e0 
134         DO jj = 2, jpjm1
135            DO ji = fs_2, fs_jpim1   ! vector opt.
136               z3d(ji,jj,1) = wn(ji,jj,1) * tsn(ji,jj,1,jp_tem)
137            END DO
138         END DO
139         DO jk = 2, jpkm1
140            DO jj = 2, jpjm1
141               DO ji = fs_2, fs_jpim1   ! vector opt.
142                  z3d(ji,jj,jk) = wn(ji,jj,jk) * 0.5 * ( tsn(ji,jj,jk-1,jp_tem) + tsn(ji,jj,jk,jp_tem) )
143               END DO
144            END DO
145         END DO
146         CALL iom_put( "wt", z3d )                  ! product of temperature and vertical velocity at W points
147      ENDIF
148
149      IF( iom_use("us") ) THEN
150         z3d(:,:,:) = 0.e0 
151         DO jk = 1, jpkm1
152            DO jj = 2, jpjm1
153               DO ji = fs_2, fs_jpim1   ! vector opt.
154                  z3d(ji,jj,jk) = un(ji,jj,jk) * 0.5 * ( tsn(ji,jj,jk,jp_sal) + tsn(ji+1,jj,jk,jp_sal) )
155               END DO
156            END DO
157         END DO
158         CALL iom_put( "us", z3d )                  ! product of salinity and zonal velocity at U points
159      ENDIF
160
161      IF( iom_use("vs") .OR. iom_use("sopst_vs") ) THEN
162         z3d(:,:,:) = 0.e0 
163         DO jk = 1, jpkm1
164            DO jj = 2, jpjm1
165               DO ji = fs_2, fs_jpim1   ! vector opt.
166                  z3d(ji,jj,jk) = vn(ji,jj,jk) * 0.5 * ( tsn(ji,jj,jk,jp_sal) + tsn(ji,jj+1,jk,jp_sal) )
167               END DO
168            END DO
169         END DO
170         CALL iom_put( "vs", z3d )                  ! product of salinity and meridional velocity at V points
171         DO jk = 1, jpkm1
172            DO jj = 2, jpjm1
173               DO ji = fs_2, fs_jpim1   ! vector opt.
174                  z3d(ji,jj,jk) = z3d(ji,jj,jk) * fse3v(ji,jj,jk) * e1v(ji,jj)
175               END DO
176            END DO
177         END DO
178         IF(ln_diaptr) CALL dia_ptr_ohst_components( jp_sal, 'vts', z3d)
179      ENDIF
180
181      IF( iom_use("ws") ) THEN
182         z3d(:,:,:) = 0.e0 
183         DO jj = 2, jpjm1
184            DO ji = fs_2, fs_jpim1   ! vector opt.
185               z3d(ji,jj,1) = wn(ji,jj,1) * tsn(ji,jj,1,jp_sal)
186            END DO
187         END DO
188         DO jk = 2, jpkm1
189            DO jj = 2, jpjm1
190               DO ji = fs_2, fs_jpim1   ! vector opt.
191                  z3d(ji,jj,jk) = wn(ji,jj,jk) * 0.5 * ( tsn(ji,jj,jk-1,jp_sal) + tsn(ji,jj,jk,jp_sal) )
192               END DO
193            END DO
194         END DO
195         CALL iom_put( "ws", z3d )                  ! product of salinity and vertical velocity at W points
196      ENDIF
197
198      IF( iom_use("urhop") ) THEN
199         z3d(:,:,:) = 0.e0 
200         DO jk = 1, jpkm1
201            DO jj = 2, jpjm1
202               DO ji = fs_2, fs_jpim1   ! vector opt.
203                  z3d(ji,jj,jk) = un(ji,jj,jk) * 0.5 * ( zrhop(ji,jj,jk) + zrhop(ji+1,jj,jk) )
204               END DO
205            END DO
206         END DO
207         CALL iom_put( "urhop", z3d )                  ! product of density and zonal velocity at U points
208      ENDIF
209
210      IF( iom_use("vrhop") ) THEN
211         z3d(:,:,:) = 0.e0 
212         DO jk = 1, jpkm1
213            DO jj = 2, jpjm1
214               DO ji = fs_2, fs_jpim1   ! vector opt.
215                  z3d(ji,jj,jk) = vn(ji,jj,jk) * 0.5 * ( zrhop(ji,jj,jk) + zrhop(ji,jj+1,jk) )
216               END DO
217            END DO
218         END DO
219         CALL iom_put( "vrhop", z3d )                  ! product of density and meridional velocity at V points
220      ENDIF
221
222      IF( iom_use("wrhop") ) THEN
223         z3d(:,:,:) = 0.e0 
224         DO jj = 2, jpjm1
225            DO ji = fs_2, fs_jpim1   ! vector opt.
226               z3d(ji,jj,1) = wn(ji,jj,1) * zrhop(ji,jj,1)
227            END DO
228         END DO
229         DO jk = 2, jpkm1
230            DO jj = 2, jpjm1
231               DO ji = fs_2, fs_jpim1   ! vector opt.
232                  z3d(ji,jj,jk) = wn(ji,jj,jk) * 0.5 * ( zrhop(ji,jj,jk-1) + zrhop(ji,jj,jk) )
233               END DO
234            END DO
235         END DO
236         CALL iom_put( "wrhop", z3d )                  ! product of density and vertical velocity at W points
237      ENDIF
238
239      !
240      CALL wrk_dealloc( jpi , jpj      , z2d )
241      CALL wrk_dealloc( jpi , jpj, jpk , z3d )
242      CALL wrk_dealloc( jpi , jpj, jpk , zrhop )
243      !
244      IF( nn_timing == 1 )   CALL timing_stop('dia_prod')
245      !
246      IF (lhook) CALL dr_hook(RoutineName,zhook_out,zhook_handle)
247   END SUBROUTINE dia_prod
248#else
249   !!----------------------------------------------------------------------
250   !!   Default option :                                         NO diaprod
251   !!----------------------------------------------------------------------
252   LOGICAL, PUBLIC, PARAMETER :: lk_diaprod = .FALSE.   ! coupled flag
253CONTAINS
254   SUBROUTINE dia_prod( kt )   ! Empty routine
255      INTEGER ::   kt
256      INTEGER(KIND=jpim), PARAMETER :: zhook_in = 0
257      INTEGER(KIND=jpim), PARAMETER :: zhook_out = 1
258      REAL(KIND=jprb)               :: zhook_handle
259
260      CHARACTER(LEN=*), PARAMETER :: RoutineName='DIA_PROD'
261
262      IF (lhook) CALL dr_hook(RoutineName,zhook_in,zhook_handle)
263
264      WRITE(*,*) 'dia_prod: You should not have seen this print! error?', kt
265      IF (lhook) CALL dr_hook(RoutineName,zhook_out,zhook_handle)
266   END SUBROUTINE dia_prod
267#endif
268   !!======================================================================
269END MODULE diaprod
Note: See TracBrowser for help on using the repository browser.