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.
istate_tam.F90 in branches/2012/dev_v3_4_STABLE_2012/NEMOGCM/NEMO/OPATAM_SRC/DOM – NEMO

source: branches/2012/dev_v3_4_STABLE_2012/NEMOGCM/NEMO/OPATAM_SRC/DOM/istate_tam.F90 @ 4572

Last change on this file since 4572 was 4572, checked in by pabouttier, 10 years ago

Add missing div_cur_adj/tan in istate_tam module ; remove call to day_init in istate_tan, see Ticket #1269
  • Property svn:executable set to *
File size: 26.8 KB
Line 
1MODULE istate_tam
2#ifdef key_tam
3   !!======================================================================
4   !!                     ***  MODULE  istate_tam  ***
5   !! Ocean state   :  initial state setting
6   !!                  Tangent and Adjoint Module
7   !!=====================================================================
8   !! History of the direct module:
9   !!             4.0  !  89-12  (P. Andrich)  Original code
10   !!             5.0  !  91-11  (G. Madec)  rewritting
11   !!             6.0  !  96-01  (G. Madec)  terrain following coordinates
12   !!             8.0  !  01-09  (M. Levy, M. Ben Jelloul)  istate_eel
13   !!             8.0  !  01-09  (M. Levy, M. Ben Jelloul)  istate_uvg
14   !!             9.0  !  03-08  (G. Madec)  F90: Free form, modules
15   !!             9.0  !  03-09  (G. Madec, C. Talandier)  add EEL R5
16   !!             9.0  !  04-05  (A. Koch-Larrouy)  istate_gyre
17   !!             9.0  !  06-07  (S. Masson)  distributed restart using iom
18   !! History of the T&A module:
19   !!             9.0  !  09-04  (F. Vigilant) TAM of the 06-07 version
20   !!             9.0  !  10-05  (A. Vidard) TAM - NEMO 3.2
21   !!        NEMO 3.4  ! 12-07   (P.-A. Bouttier) Phasing with 3.4
22   !!----------------------------------------------------------------------
23
24   !!----------------------------------------------------------------------
25   !!   istate_init_tan : initial state setting for the tangent model
26   !!----------------------------------------------------------------------
27   USE par_oce        , ONLY: & ! Ocean space and time domain variables
28      & jpi, jpj, jpk, jpiglo
29   USE oce_tam ! ocean dynamics and active tracers
30   USE oce
31   USE dom_oce
32   USE daymod
33   USE c1d
34   USE restart
35   USE in_out_manager
36   USE zpshde_tam
37   USE eosbn2_tam
38   USE divcur_tam
39   USE tstool_tam
40   USE gridrandom
41   USE dotprodfld
42   USE paresp
43
44   IMPLICIT NONE
45   PRIVATE
46
47   PUBLIC   istate_init_tan       ! routine called by step.F90
48   PUBLIC   istate_init_adj       ! routine called by step.F90
49   PUBLIC   istate_init_adj_tst   ! routine called by tst.F90
50
51   !! * Substitutions
52#  include "domzgr_substitute.h90"
53#  include "vectopt_loop_substitute.h90"
54   !!----------------------------------------------------------------------
55   !!   OPA 9.0 , LOCEAN-IPSL (2006)
56   !! $Id$
57   !! Software governed by the CeCILL licence (modipsl/doc/NEMO_CeCILL.txt)
58   !!----------------------------------------------------------------------
59
60CONTAINS
61
62   SUBROUTINE istate_init_tan( keuler )
63      !!----------------------------------------------------------------------
64      !!                   ***  ROUTINE istate_init Tangent ***
65      !!
66      !! ** Purpose :   Initialization of the dynamics and tracer fields.
67      !!----------------------------------------------------------------------
68      INTEGER, INTENT (IN), OPTIONAL :: keuler
69
70      IF(lwp) WRITE(numout,*)
71      IF(lwp) WRITE(numout,*) 'istate_ini_tan : Initialization of the dynamics and tracers'
72      IF(lwp) WRITE(numout,*) '~~~~~~~~~~'
73      !
74      rhd_tl  (:,:,:) = 0.0_wp
75      rhop_tl (:,:,:) = 0.0_wp
76      rn2_tl  (:,:,:) = 0.0_wp
77      !                                    ! Start from rest
78      !                                    ! ---------------
79      IF ( PRESENT( keuler ) ) THEN
80         neuler = keuler
81      ELSE
82         neuler = 0                              ! Set time-step indicator at nit000 (euler forward)
83      END IF
84      numror = 0                              ! define numror = 0 -> no restart file to read
85      !CALL day_init()                         ! model calendar (using both namelist and restart infos)
86      !                                       ! Initialization of ocean to zero
87      !     before fields       !       now fields
88      IF ( neuler == 0 ) THEN
89         ub_tl   (:,:,:) = un_tl   (:,:,:)
90         vb_tl   (:,:,:) = vn_tl   (:,:,:)
91         tsb_tl   (:,:,:,:) = tsn_tl   (:,:,:,:)
92         sshb_tl (  :,:) = sshn_tl (  :,:)
93         CALL div_cur_tan( nit000 - 1 )
94      END IF
95      !
96      CALL eos_tan( tsb, tsb_tl, rhd_tl, rhop_tl )        ! before potential and in situ densities
97      !
98      IF( ln_zps .AND. .NOT. lk_c1d )   &
99            &             CALL zps_hde_tan( nit000, jpts, tsb, tsb_tl, rhd_tl,  &  ! Partial steps: before Horizontal DErivative
100            &                                  gtsu_tl, gru_tl,             &  ! of t, s, rd at the bottom ocean level
101            &                                  gtsv_tl, grv_tl )
102   END SUBROUTINE istate_init_tan
103
104   SUBROUTINE istate_init_adj
105      !!----------------------------------------------------------------------
106      !!                   ***  ROUTINE istate_init  Adjoint Module ***
107      !!
108      !! ** Purpose :   Initialization of the dynamics and tracer fields.
109      !!----------------------------------------------------------------------
110      !! * Local declarations
111
112      IF(lwp) WRITE(numout,*)
113      IF(lwp) WRITE(numout,*) 'istate_ini_adj : Initialization of the dynamics and tracers'
114      IF(lwp) WRITE(numout,*) '~~~~~~~~~~'
115
116      neuler=0
117      IF( ln_zps .AND. .NOT. lk_c1d )   &
118            &             CALL zps_hde_adj( nit000, jpts, tsb, tsb_ad, rhd_ad, &  ! Partial steps: before Horizontal DErivative
119            &                                  gtsu_ad, gru_ad,               &  ! of t, s, rd at the bottom ocean level
120            &                                  gtsv_ad, grv_ad )
121
122
123      CALL eos_adj( tsb, tsb_ad, rhd_ad, rhop_ad )        ! before potential and in situ densities
124
125      !     before fields       !       now fields
126      CALL div_cur_adj( nit000 - 1 )
127      un_ad   (:,:,:) = un_ad(:,:,:) + ub_ad (:,:,:)
128      ub_ad   (:,:,:) = 0.0_wp
129      vn_ad   (:,:,:) = vn_ad(:,:,:) + vb_ad (:,:,:)
130      vb_ad   (:,:,:) = 0.0_wp
131      tsn_ad   (:,:,:,:) = tsn_ad(:,:,:,:) + tsb_ad (:,:,:,:)
132      tsb_ad   (:,:,:,:) = 0.0_wp
133      sshn_ad   (:,:  ) = sshn_ad(:,:  ) + sshb_ad (:,:  )
134      sshb_ad   (:,:  ) = 0.0_wp
135      !
136      rhd_ad  (:,:,:) = 0.0_wp
137      rhop_ad (:,:,:) = 0.0_wp
138      rn2_ad  (:,:,:) = 0.0_wp
139      !
140   END SUBROUTINE istate_init_adj
141
142   SUBROUTINE istate_init_adj_tst( kumadt )
143      !!-----------------------------------------------------------------------
144      !!
145      !!                  ***  ROUTINE istate_init_adj_tst ***
146      !!
147      !! ** Purpose : Test the adjoint routine.
148      !!
149      !! ** Method  : Verify the scalar product
150      !!
151      !!                 ( L dx )^T W dy  =  dx^T L^T W dy
152      !!
153      !!              where  L   = tangent routine
154      !!                     L^T = adjoint routine
155      !!                     W   = diagonal matrix of scale factors
156      !!                     dx  = input perturbation (random field)
157      !!                     dy  = L dx
158      !!
159      !!
160      !! History :
161      !!        ! 2009-05 (F. Vigilant)
162      !!        ! 2010-05 (A. Vidard) Update for NEMO 3.2
163      !!-----------------------------------------------------------------------
164      !! * Modules used
165
166      !! * Arguments
167      INTEGER, INTENT(IN) :: &
168         & kumadt             ! Output unit
169
170      INTEGER ::         &
171         & ji,           &        ! dummy loop indices
172         & jj,           &
173         & jk
174
175      !! * Local declarations
176      REAL(KIND=wp), DIMENSION(:,:,:), ALLOCATABLE :: &
177         & ztn_tlin,     & ! Tangent input: temperature
178         & zsn_tlin,     & ! Tangent input: salinity
179         & zun_tlin,     & ! Tangent input: velocity
180         & zvn_tlin,     & ! Tangent input: velocity
181         & zrotn_tlin,   & ! Tangent input: rotational
182         & zdivn_tlin,   & ! Tangent input: divergence
183         & ztn_adout,    & ! Adjoint output: temperature
184         & zsn_adout,    & ! Adjoint output: salinity
185         & zun_adout,    & ! Adjoint output: velocity
186         & zvn_adout,    & ! Adjoint output: velocity
187         & zrotn_adout,  & ! adjoint output: rotational
188         & zdivn_adout,  & ! adjoint output: divergence
189         & ztb_tlout,    & ! Tangent output: temperature
190         & zsb_tlout,    & ! Tangent output: salinity
191         & zub_tlout,    & ! Tangent output: velocity
192         & zvb_tlout,    & ! Tangent output: velocity
193         & zrhd_tlout,   & ! Tangent output:
194         & zrhop_tlout,  & ! Tangent output:
195         & zrotb_tlout,  & ! Tangent output:
196         & zdivb_tlout,  & ! Tangent output:
197         & zrn2_tlout,   & ! Tangent output:
198         & zrhd_adin,    & ! Adjoint input:
199         & zrhop_adin,   & ! Adjoint input:
200         & ztb_adin,     & ! Adjoint input: temperature
201         & zsb_adin,     & ! Adjoint input: salinity
202         & zub_adin,     & ! Adjoint input: velocity
203         & zvb_adin,     & ! Adjoint input: velocity
204         & zrotb_adin,   & ! Adjoint input:
205         & zdivb_adin,   & ! Adjoint input:
206         & zrn2_adin,    & ! Adjoint input:
207         & z3r             ! 3D random field
208
209      REAL(KIND=wp), DIMENSION(:,:), ALLOCATABLE :: &
210         & zsshn_tlin,   & ! Tangent input : horizontal gradient
211         & zsshb_tlout,  & ! Tangent output: horizontal gradient
212         & zgtu_tlout,   & ! Tangent output: horizontal gradient
213         & zgtv_tlout,   & ! Tangent output: horizontal gradient
214         & zgsu_tlout,   & ! Tangent output: horizontal gradient
215         & zgsv_tlout,   & ! Tangent output: horizontal gradient
216         & zgru_tlout,   & ! Tangent output: horizontal gradient
217         & zgrv_tlout,   & ! Tangent output: horizontal gradient
218         & zgtu_adin,    & ! Adjoint input : horizontal gradient
219         & zgtv_adin,    & ! Adjoint input : horizontal gradient
220         & zgsu_adin,    & ! Adjoint input : horizontal gradient
221         & zgsv_adin,    & ! Adjoint input : horizontal gradient
222         & zgru_adin,    & ! Adjoint input : horizontal gradient
223         & zgrv_adin,    & ! Adjoint input : horizontal gradient
224         & zsshb_adin,   & ! Adjoint input : horizontal gradient
225         & zsshn_adout,  & ! Adjoint output : horizontal gradient
226         & z2r             ! 2D random field
227
228      REAL(KIND=wp) ::   &
229                           ! random field standard deviation for:
230         & zsp1,         & ! scalar product involving the tangent routine
231         & zsp1_1,       & !   scalar product components
232         & zsp1_2,       &
233         & zsp1_3,       & !   scalar product components
234         & zsp1_4,       &
235         & zsp1_5,       & !   scalar product components
236         & zsp1_6,       &
237         & zsp1_7,       & !   scalar product components
238         & zsp1_8,       &
239         & zsp1_9,       &
240         & zsp1_10,      &
241         & zsp1_11,      &
242         & zsp1_12,      &
243         & zsp1_13,      &
244         & zsp1_14,      &
245         & zsp1_15,      &
246         & zsp1_16,      &
247         & zsp2,         & ! scalar product involving the adjoint routine
248         & zsp2_1,       & !   scalar product components
249         & zsp2_2,       &
250         & zsp2_3,       &
251         & zsp2_4,       &
252         & zsp2_5,       &
253         & zsp2_6,       &
254         & zsp2_7
255
256      CHARACTER (LEN=14) :: &
257         & cl_name
258
259      ! Allocate memory
260      ALLOCATE( &
261         & ztn_tlin(jpi,jpj,jpk),     &
262         & zsn_tlin(jpi,jpj,jpk),     &
263         & zun_tlin(jpi,jpj,jpk),     &
264         & zvn_tlin(jpi,jpj,jpk),     &
265         & zsshn_tlin(jpi,jpj),       &
266         & zrotn_tlin(jpi,jpj,jpk),   &
267         & zdivn_tlin(jpi,jpj,jpk),   &
268         & ztn_adout(jpi,jpj,jpk),    &
269         & zsn_adout(jpi,jpj,jpk),    &
270         & zun_adout(jpi,jpj,jpk),    &
271         & zvn_adout(jpi,jpj,jpk),    &
272         & zrotn_adout(jpi,jpj,jpk),  &
273         & zdivn_adout(jpi,jpj,jpk),  &
274         & zsshn_adout(jpi, jpj),     &
275         & z3r(jpi,jpj,jpk),          &
276         & z2r(jpi,jpj),              &
277         & zub_tlout(jpi,jpj,jpk),    &
278         & zvb_tlout(jpi,jpj,jpk),    &
279         & zsb_tlout(jpi,jpj,jpk),    &
280         & ztb_tlout(jpi,jpj,jpk),    &
281         & zrotb_tlout(jpi,jpj,jpk),  &
282         & zdivb_tlout(jpi,jpj,jpk),  &
283         & zrn2_tlout(jpi,jpj,jpk),   &
284         & zsshb_tlout(jpi,jpj),      &
285         & zgtu_tlout(jpi,jpj),       &
286         & zgtv_tlout(jpi,jpj),       &
287         & zgsu_tlout(jpi,jpj),       &
288         & zgsv_tlout(jpi,jpj),       &
289         & zgru_tlout(jpi,jpj),       &
290         & zgrv_tlout(jpi,jpj),       &
291         & zrhd_tlout(jpi,jpj,jpk),   &
292         & zrhop_tlout(jpi,jpj,jpk),  &
293         & zub_adin(jpi,jpj,jpk),     &
294         & zvb_adin(jpi,jpj,jpk),     &
295         & zsb_adin(jpi,jpj,jpk),     &
296         & ztb_adin(jpi,jpj,jpk),     &
297         & zrotb_adin(jpi,jpj,jpk),   &
298         & zdivb_adin(jpi,jpj,jpk),   &
299         & zrn2_adin(jpi,jpj,jpk),    &
300         & zsshb_adin(jpi,jpj),       &
301         & zgtu_adin(jpi,jpj),        &
302         & zgtv_adin(jpi,jpj),        &
303         & zgsu_adin(jpi,jpj),        &
304         & zgsv_adin(jpi,jpj),        &
305         & zgru_adin(jpi,jpj),        &
306         & zgrv_adin(jpi,jpj),        &
307         & zrhd_adin(jpi,jpj,jpk),    &
308         & zrhop_adin(jpi,jpj,jpk)    &
309         & )
310
311
312      !=============================================================
313      ! 1) dx = ( T ) and dy = ( T )
314      !=============================================================
315
316      !--------------------------------------------------------------------
317      ! Reset the tangent and adjoint variables
318      !--------------------------------------------------------------------
319      ztn_tlin    = 0.0_wp
320      zsn_tlin    = 0.0_wp
321      zun_tlin    = 0.0_wp
322      zvn_tlin    = 0.0_wp
323      zsshn_tlin  = 0.0_wp
324      zrotn_tlin  = 0.0_wp
325      zdivn_tlin  = 0.0_wp
326      ztn_adout   = 0.0_wp
327      zsn_adout   = 0.0_wp
328      zun_adout   = 0.0_wp
329      zvn_adout   = 0.0_wp
330      zrotn_adout = 0.0_wp
331      zdivn_adout = 0.0_wp
332      zsshn_adout = 0.0_wp
333      zub_tlout   = 0.0_wp
334      zvb_tlout   = 0.0_wp
335      zsb_tlout   = 0.0_wp
336      ztb_tlout   = 0.0_wp
337      zrotb_tlout = 0.0_wp
338      zdivb_tlout = 0.0_wp
339      zrn2_tlout  = 0.0_wp
340      zsshb_tlout = 0.0_wp
341      zgtu_tlout  = 0.0_wp
342      zgtv_tlout  = 0.0_wp
343      zgsu_tlout  = 0.0_wp
344      zgsv_tlout  = 0.0_wp
345      zgru_tlout  = 0.0_wp
346      zgrv_tlout  = 0.0_wp
347      zrhd_tlout  = 0.0_wp
348      zrhop_tlout = 0.0_wp
349      zub_adin    = 0.0_wp
350      zvb_adin    = 0.0_wp
351      zsb_adin    = 0.0_wp
352      ztb_adin    = 0.0_wp
353      zrotb_adin  = 0.0_wp
354      zdivb_adin  = 0.0_wp
355      zrn2_adin   = 0.0_wp
356      zsshb_adin  = 0.0_wp
357      zgtu_adin   = 0.0_wp
358      zgtv_adin   = 0.0_wp
359      zgsu_adin   = 0.0_wp
360      zgsv_adin   = 0.0_wp
361      zgru_adin   = 0.0_wp
362      zgrv_adin   = 0.0_wp
363      zrhd_adin   = 0.0_wp
364      zrhop_adin  = 0.0_wp
365
366      tsn_tl      (:,:,:,:) = 0.0_wp
367      un_tl      (:,:,:) = 0.0_wp
368      vn_tl      (:,:,:) = 0.0_wp
369      rotn_tl    (:,:,:) = 0.0_wp
370      hdivn_tl   (:,:,:) = 0.0_wp
371      sshn_tl    (:,:  ) = 0.0_wp
372      tsb_tl      (:,:,:,:) = 0.0_wp
373      ub_tl      (:,:,:) = 0.0_wp
374      vb_tl      (:,:,:) = 0.0_wp
375      sshb_tl    (:,:  ) = 0.0_wp
376      rhd_tl     (:,:,:) = 0.0_wp
377      rhop_tl    (:,:,:) = 0.0_wp
378      gtsu_tl    (:,:,:) = 0.0_wp
379      gru_tl     (:,:  ) = 0.0_wp
380      gtsv_tl     (:,:,:  ) = 0.0_wp
381      grv_tl     (:,:  ) = 0.0_wp
382      tsb_ad      (:,:,:,:) = 0.0_wp
383      ub_ad      (:,:,:) = 0.0_wp
384      vb_ad      (:,:,:) = 0.0_wp
385      sshb_ad    (:,:  ) = 0.0_wp
386      tsn_ad      (:,:,:,:) = 0.0_wp
387      un_ad      (:,:,:) = 0.0_wp
388      vn_ad      (:,:,:) = 0.0_wp
389      sshn_ad    (:,:  ) = 0.0_wp
390      gtsu_ad     (:,:,:  ) = 0.0_wp
391      gtsv_ad     (:,:,:  ) = 0.0_wp
392
393      ! Warning, following variables used by istate
394      hdivn_tl           = 0.0_wp
395      hdivb_tl           = 0.0_wp
396      rotn_tl            = 0.0_wp
397      rotb_tl            = 0.0_wp
398      hdivn_ad           = 0.0_wp
399      hdivb_ad           = 0.0_wp
400      rotn_ad            = 0.0_wp
401      rotb_ad            = 0.0_wp
402
403      CALL grid_random(  z3r, 'T', 0.0_wp, stdt )
404      DO jk = 1, jpk
405         DO jj = nldj, nlej
406            DO ji = nldi, nlei
407               ztn_tlin(ji,jj,jk) = z3r(ji,jj,jk)
408            END DO
409         END DO
410      END DO
411      CALL grid_random(  z3r, 'T', 0.0_wp, stds )
412      DO jk = 1, jpk
413         DO jj = nldj, nlej
414            DO ji = nldi, nlei
415               zsn_tlin(ji,jj,jk) = z3r(ji,jj,jk)
416            END DO
417         END DO
418      END DO
419      CALL grid_random(  z3r, 'T', 0.0_wp, stdr )
420      DO jk = 1, jpk
421         DO jj = nldj, nlej
422            DO ji = nldi, nlei
423               zrotn_tlin(ji,jj,jk) = z3r(ji,jj,jk)
424            END DO
425         END DO
426      END DO
427      CALL grid_random(  z3r, 'T', 0.0_wp, stdr )
428      DO jk = 1, jpk
429         DO jj = nldj, nlej
430            DO ji = nldi, nlei
431               zdivn_tlin(ji,jj,jk) = z3r(ji,jj,jk)
432            END DO
433         END DO
434      END DO
435      CALL grid_random(  z2r, 'T', 0.0_wp, stdssh )
436      DO jj = nldj, nlej
437         DO ji = nldi, nlei
438            zsshn_tlin(ji,jj) = z2r(ji,jj)
439         END DO
440      END DO
441      CALL grid_random(  z3r, 'U', 0.0_wp, stdu )
442      DO jk = 1, jpk
443         DO jj = nldj, nlej
444            DO ji = nldi, nlei
445               zun_tlin(ji,jj,jk) = z3r(ji,jj,jk)
446            END DO
447         END DO
448      END DO
449      CALL grid_random(  z3r, 'V', 0.0_wp, stdv )
450      DO jk = 1, jpk
451         DO jj = nldj, nlej
452            DO ji = nldi, nlei
453               zvn_tlin(ji,jj,jk) = z3r(ji,jj,jk)
454            END DO
455         END DO
456      END DO
457
458      tsn_tl  (:,:,:,jp_tem) = ztn_tlin  (:,:,:)
459      tsn_tl  (:,:,:,jp_sal) = zsn_tlin  (:,:,:)
460      rotn_tl(:,:,:) = zrotn_tlin(:,:,:)
461      hdivn_tl(:,:,:)= zdivn_tlin(:,:,:)
462      sshn_tl(:,:  ) = zsshn_tlin(:,:  )
463      un_tl  (:,:,:) = zun_tlin  (:,:,:)
464      vn_tl  (:,:,:) = zvn_tlin  (:,:,:)
465
466     !--------------------------------------------------------------------
467     ! Call the tangent routine: dy = L dx
468     !--------------------------------------------------------------------
469
470     CALL istate_init_tan
471
472     zrhd_tlout  (:,:,:) = rhd_tl  (:,:,:)
473     zrhop_tlout (:,:,:) = rhop_tl (:,:,:)
474     zgtu_tlout  (:,:  ) = gtsu_tl  (:,:,jp_tem  )
475     zgtv_tlout  (:,:  ) = gtsv_tl  (:,:,jp_tem  )
476     zgru_tlout  (:,:  ) = gru_tl  (:,:  )
477     zgrv_tlout  (:,:  ) = grv_tl  (:,:  )
478     zgsu_tlout  (:,:  ) = gtsu_tl  (:,:,jp_sal  )
479     zgsv_tlout  (:,:  ) = gtsv_tl  (:,:,jp_sal  )
480     zsshb_tlout (:,:  ) = sshb_tl (:,:  )
481     ztb_tlout   (:,:,:) = tsb_tl   (:,:,:,jp_tem)
482     zsb_tlout   (:,:,:) = tsb_tl   (:,:,:,jp_sal)
483     zub_tlout   (:,:,:) = ub_tl   (:,:,:)
484     zvb_tlout   (:,:,:) = vb_tl   (:,:,:)
485     zsshb_tlout (:,:  ) = sshb_tl (:,:  )
486
487     !--------------------------------------------------------------------
488     ! Initialize the adjoint variables: dy^* = W dy
489     !--------------------------------------------------------------------
490
491     DO jk = 1, jpk
492        DO jj = nldj, nlej
493           DO ji = nldi, nlei
494              zrhd_adin(ji,jj,jk)  = zrhd_tlout(ji,jj,jk) &
495                 &                 * e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk)&
496                 &                 * tmask(ji,jj,jk)
497              zrhop_adin(ji,jj,jk) = zrhop_tlout(ji,jj,jk) &
498                 &                 * e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk)&
499                 &                 * tmask(ji,jj,jk)
500              zrn2_adin(ji,jj,jk)  = zrn2_tlout(ji,jj,jk) &
501                 &                 * e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk)&
502                 &                 * tmask(ji,jj,jk)
503              zrotb_adin(ji,jj,jk) = zrotb_tlout(ji,jj,jk) &
504                 &                 * e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk)&
505                 &                 * tmask(ji,jj,jk)
506              zdivb_adin(ji,jj,jk) = zdivb_tlout(ji,jj,jk) &
507                 &                 * e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk)&
508                 &                 * tmask(ji,jj,jk)
509           END DO
510        END DO
511     END DO
512     DO jj = nldj, nlej
513        DO ji = nldi, nlei
514           zgtu_adin(ji,jj) = zgtu_tlout(ji,jj) &
515              &             * e1u(ji,jj) * e2u(ji,jj) * fse3u(ji,jj,1) &
516              &             * umask(ji,jj,1)
517           zgsu_adin(ji,jj) = zgsu_tlout(ji,jj) &
518              &             * e1u(ji,jj) * e2u(ji,jj) * fse3u(ji,jj,1) &
519              &             * umask(ji,jj,1)
520           zgru_adin(ji,jj) = zgru_tlout(ji,jj) &
521              &             * e1u(ji,jj) * e2u(ji,jj) * fse3u(ji,jj,1) &
522              &             * umask(ji,jj,1)
523           zgtv_adin(ji,jj) = zgtv_tlout(ji,jj) &
524              &             * e1v(ji,jj) * e2v(ji,jj) * fse3v(ji,jj,1) &
525              &             * vmask(ji,jj,1)
526           zgsv_adin(ji,jj) = zgsv_tlout(ji,jj) &
527              &             * e1v(ji,jj) * e2v(ji,jj) * fse3v(ji,jj,1) &
528              &             * vmask(ji,jj,1)
529           zgrv_adin(ji,jj) = zgrv_tlout(ji,jj) &
530              &             * e1v(ji,jj) * e2v(ji,jj) * fse3v(ji,jj,1) &
531              &             * vmask(ji,jj,1)
532        END DO
533     END DO
534     DO jk = 1, jpk
535        DO jj = nldj, nlej
536           DO ji = nldi, nlei
537              ztb_adin(ji,jj,jk)   = ztb_tlout(ji,jj,jk) &
538                 &                 * e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk)&
539                 &                 * tmask(ji,jj,jk)
540           END DO
541        END DO
542     END DO
543     DO jk = 1, jpk
544        DO jj = nldj, nlej
545           DO ji = nldi, nlei
546              zsb_adin(ji,jj,jk)   = zsb_tlout(ji,jj,jk) &
547                 &                 * e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk)&
548                 &                 * tmask(ji,jj,jk)
549           END DO
550        END DO
551     END DO
552     DO jk = 1, jpk
553        DO jj = nldj, nlej
554           DO ji = nldi, nlei
555              zub_adin(ji,jj,jk)   = zub_tlout(ji,jj,jk) &
556                 &                 * e1u(ji,jj) * e2u(ji,jj) * fse3u(ji,jj,jk)&
557                 &                 * umask(ji,jj,jk)
558           END DO
559        END DO
560     END DO
561     DO jk = 1, jpk
562        DO jj = nldj, nlej
563           DO ji = nldi, nlei
564              zvb_adin(ji,jj,jk)   = zvb_tlout(ji,jj,jk) &
565                 &                 * e1v(ji,jj) * e2v(ji,jj) * fse3v(ji,jj,jk)&
566                 &                 * vmask(ji,jj,jk)
567           END DO
568        END DO
569     END DO
570     DO jj = nldj, nlej
571        DO ji = nldi, nlei
572           zsshb_adin(ji,jj)    = zsshb_tlout(ji,jj) &
573              &                 * e1t(ji,jj) * e2t(ji,jj) * wesp_ssh &
574              &                 * tmask(ji,jj,1)
575        END DO
576     END DO
577
578      !--------------------------------------------------------------------
579      ! Compute the scalar product: ( L dx )^T W dy
580      !--------------------------------------------------------------------
581
582      zsp1_1    = DOT_PRODUCT( zrhd_tlout   , zrhd_adin   )
583      zsp1_2    = DOT_PRODUCT( zrhop_tlout  , zrhop_adin  )
584      zsp1_3    = DOT_PRODUCT( zgtu_tlout   , zgtu_adin   )
585      zsp1_4    = DOT_PRODUCT( zgru_tlout   , zgru_adin   )
586      zsp1_5    = DOT_PRODUCT( zgsu_tlout   , zgsu_adin   )
587      zsp1_6    = DOT_PRODUCT( zgtv_tlout   , zgtv_adin   )
588      zsp1_7    = DOT_PRODUCT( zgrv_tlout   , zgrv_adin   )
589      zsp1_8    = DOT_PRODUCT( zgsv_tlout   , zgsv_adin   )
590      zsp1_9    = DOT_PRODUCT( zub_tlout    , zub_adin    )
591      zsp1_10   = DOT_PRODUCT( zvb_tlout    , zvb_adin    )
592      zsp1_11   = DOT_PRODUCT( ztb_tlout    , ztb_adin    )
593      zsp1_12   = DOT_PRODUCT( zsb_tlout    , zsb_adin    )
594      zsp1_13   = DOT_PRODUCT( zsshb_tlout  , zsshb_adin  )
595      zsp1_14   = DOT_PRODUCT( zrotb_tlout  , zrotb_adin  )
596      zsp1_15   = DOT_PRODUCT( zdivb_tlout  , zdivb_adin  )
597      zsp1_16   = DOT_PRODUCT( zrn2_tlout   , zrn2_adin   )
598
599      zsp1      = zsp1_1 + zsp1_2  + zsp1_3  + zsp1_4  + &
600                & zsp1_5 + zsp1_6  + zsp1_7  + zsp1_8  + &
601                & zsp1_9 + zsp1_10 + zsp1_11 + zsp1_12 + &
602                & zsp1_13+ zsp1_14 + zsp1_15 + zsp1_16
603
604      !--------------------------------------------------------------------
605      ! Call the adjoint routine: dx^* = L^T dy^*
606      !--------------------------------------------------------------------
607
608      rhd_ad  (:,:,:) = zrhd_adin  (:,:,:)
609      rhop_ad (:,:,:) = zrhop_adin (:,:,:)
610      gtsu_ad  (:,:,jp_tem  ) = zgtu_adin  (:,:  )
611      gtsv_ad  (:,:,jp_tem  ) = zgtv_adin  (:,:  )
612      gru_ad  (:,:  ) = zgru_adin  (:,:  )
613      grv_ad  (:,:  ) = zgrv_adin  (:,:  )
614      gtsu_ad  (:,:,jp_sal  ) = zgsu_adin  (:,:  )
615      gtsv_ad  (:,:,jp_sal  ) = zgsv_adin  (:,:  )
616      ub_ad   (:,:,:) = zub_adin   (:,:,:)
617      vb_ad   (:,:,:) = zvb_adin   (:,:,:)
618      tsb_ad   (:,:,:,jp_tem) = ztb_adin   (:,:,:)
619      tsb_ad   (:,:,:,jp_sal) = zsb_adin   (:,:,:)
620      sshb_ad (:,:  ) = zsshb_adin (:,:  )
621      rotb_ad (:,:,:) = zrotb_adin (:,:,:)
622      hdivb_ad(:,:,:) = zdivb_adin (:,:,:)
623      rn2_ad  (:,:,:) = zrn2_adin  (:,:,:)
624
625      CALL istate_init_adj
626
627      ztn_adout  (:,:,:) = tsn_ad   (:,:,:,jp_tem)
628      zsn_adout  (:,:,:) = tsn_ad   (:,:,:,jp_sal)
629      zrotn_adout(:,:,:) = rotn_ad (:,:,:)
630      zdivn_adout(:,:,:) = hdivn_ad(:,:,:)
631      zun_adout  (:,:,:) = un_ad   (:,:,:)
632      zvn_adout  (:,:,:) = vn_ad   (:,:,:)
633      zsshn_adout(:,:  ) = sshn_ad (:,:  )
634
635      !--------------------------------------------------------------------
636      ! Compute the scalar product: dx^T L^T W dy
637      !--------------------------------------------------------------------
638
639      zsp2_1    = DOT_PRODUCT( ztn_tlin  , ztn_adout    )
640      zsp2_2    = DOT_PRODUCT( zsn_tlin  , zsn_adout    )
641      zsp2_3    = DOT_PRODUCT( zrotn_tlin, zrotn_adout  )
642      zsp2_4    = DOT_PRODUCT( zdivn_tlin, zdivn_adout  )
643      zsp2_5    = DOT_PRODUCT( zun_tlin  , zun_adout    )
644      zsp2_6    = DOT_PRODUCT( zvn_tlin  , zvn_adout    )
645      zsp2_7    = DOT_PRODUCT( zsshn_tlin, zsshn_adout  )
646
647      zsp2      = zsp2_1 + zsp2_2 + zsp2_3 + zsp2_4 + zsp2_5 + zsp2_6 + zsp2_7
648
649      ! Compare the scalar products
650
651      ! 14 char:'12345678901234'
652      cl_name = 'istate_tst    '
653      CALL prntst_adj( cl_name, kumadt, zsp1, zsp2 )
654
655      ! Deallocate memory
656      DEALLOCATE(        &
657         & ztn_tlin,     &
658         & zsn_tlin,     &
659         & ztn_adout,    &
660         & zsn_adout,    &
661         & zrotn_tlin,   &
662         & zdivn_tlin,   &
663         & zrotn_adout,  &
664         & zdivn_adout,  &
665         & z3r,          &
666         & z2r,          &
667         & zub_tlout,    &
668         & zvb_tlout,    &
669         & zsb_tlout,    &
670         & ztb_tlout,    &
671         & zsshb_tlout,  &
672         & zgtu_tlout,   &
673         & zgtv_tlout,   &
674         & zgsu_tlout,   &
675         & zgsv_tlout,   &
676         & zgru_tlout,   &
677         & zgrv_tlout,   &
678         & zrhd_tlout,   &
679         & zrhop_tlout,  &
680         & zub_adin,     &
681         & zvb_adin,     &
682         & zsb_adin,     &
683         & ztb_adin,     &
684         & zsshb_adin,   &
685         & zgtu_adin,    &
686         & zgtv_adin,    &
687         & zgsu_adin,    &
688         & zgsv_adin,    &
689         & zgru_adin,    &
690         & zgrv_adin,    &
691         & zrhd_adin,    &
692         & zrhop_adin,   &
693         & zrotb_adin,   &
694         & zdivb_adin,   &
695         & zrn2_adin,    &
696         & zrotb_tlout,  &
697         & zdivb_tlout,  &
698         & zrn2_tlout    &
699         & )
700
701   END SUBROUTINE istate_init_adj_tst
702
703   !!=====================================================================
704#endif
705END MODULE istate_tam
Note: See TracBrowser for help on using the repository browser.