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 @ 4571

Last change on this file since 4571 was 3611, checked in by pabouttier, 12 years ago

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