MODULE tranxt_tam #ifdef key_tam !!====================================================================== !! *** MODULE tranxt_tam *** !! Ocean active tracers: time stepping on temperature and salinity !! Tangent and Adjoint module !!====================================================================== !! History of the direct module: !! 7.0 ! 91-11 (G. Madec) Original code !! ! 93-03 (M. Guyon) symetrical conditions !! ! 96-02 (G. Madec & M. Imbard) opa release 8.0 !! 8.0 ! 96-04 (A. Weaver) Euler forward step !! 8.2 ! 99-02 (G. Madec, N. Grima) semi-implicit pressure grad. !! NEMO 1.0 ! 2002-08 (G. Madec) F90: Free form and module !! - ! 2002-11 (C. Talandier, A-M Treguier) Open boundaries !! - ! 2005-04 (C. Deltel) Add Asselin trend in the ML budget !! 2.0 ! 2006-02 (L. Debreu, C. Mazauric) Agrif implementation !! 3.0 ! 2008-06 (G. Madec) time stepping always done in trazd !! History of the TAM module: !! 2.0 ! 2008-09 (A. Vidard) tam of the 2006-02 version !! 3.0 ! 2008-11 (A. Vidard) tam of the 2008-06 version !! - ! 2009-01 (A. Weaver) corrections to test !!---------------------------------------------------------------------- !!---------------------------------------------------------------------- !! tra_nxt_tan : time stepping on temperature and salinity (tangent) !! tra_nxt_adj : time stepping on temperature and salinity (adjoint) !!---------------------------------------------------------------------- USE par_kind , ONLY: & ! Precision variables & wp USE par_oce , ONLY: & ! Ocean space and time domain variables & jpi, & & jpj, & & jpk, & & jpkm1, & & jpiglo USE oce , ONLY: &! ocean dynamics and tracers variables & ln_dynhpg_imp USE oce_tam , ONLY: &! ocean dynamics and tracers variables & tn_tl, & & tb_tl, & & ta_tl, & & sn_tl, & & sb_tl, & & sa_tl, & & tn_ad, & & tb_ad, & & ta_ad, & & sn_ad, & & sb_ad, & & sa_ad USE zdf_oce , ONLY: & & ln_zdfexp USE dom_oce , ONLY: & ! ocean space and time domain variables & neuler, & & rdt, & & atfp, & & atfp1, & & e1t, & & e2t, & # if defined key_vvl & e3t_1, & # else # if defined key_zco & e3t_0, & # else & e3t, & # endif # endif & tmask, & & mig, & & mjg, & & nldi, & & nldj, & & nlei, & & nlej USE in_out_manager, ONLY: & ! I/O manager & lwp, & & numout, & & nitend, & & nit000 USE lbclnk , ONLY: & & lbc_lnk USE lbclnk_tam , ONLY: & & lbc_lnk_adj USE gridrandom , ONLY: & ! Random Gaussian noise on grids & grid_random USE dotprodfld , ONLY: & ! Computes dot product for 3D and 2D fields & dot_product USE paresp , ONLY: & ! Weights for an energy-type scalar product & wesp_t, & & wesp_s USE tstool_tam , ONLY: & & prntst_adj, & ! & stdt, & ! stdev for temperature & stds ! salinity #if defined key_obc # if defined key_pomme_r025 USE obc_oce USE obctra_tam # else Error, OBC not ready. # endif #endif IMPLICIT NONE PRIVATE !! * Routine accessibility PUBLIC tra_nxt_tan ! routine called by step_tam.F90 PUBLIC tra_nxt_adj ! routine called by step_tam.F90 PUBLIC tra_nxt_adj_tst ! routine called by tst.F90 !! * Substitutions # include "domzgr_substitute.h90" CONTAINS SUBROUTINE tra_nxt_tan( kt ) !!---------------------------------------------------------------------- !! *** ROUTINE tranxt_tan *** !! !! ** Purpose of the direct routine: !! Apply the boundary condition on the after temperature !! and salinity fields, achieved the time stepping by adding !! the Asselin filter on now fields and swapping the fields. !! !! ** Method : At this stage of the computation, ta and sa are the !! after temperature and salinity as the time stepping has !! been performed in trazdf_imp or trazdf_exp module. !! !! - Apply lateral boundary conditions on (ta,sa) !! at the local domain boundaries through lbc_lnk call, !! at the radiative open boundaries (lk_obc=T), !! at the relaxed open boundaries (lk_bdy=T), and !! at the AGRIF zoom boundaries (lk_agrif=T) !! !! - Apply the Asselin time filter on now fields, !! save in (ta,sa) an average over the three time levels !! which will be used to compute rdn and thus the semi-implicit !! hydrostatic pressure gradient (ln_dynhpg_imp = T), and !! swap tracer fields to prepare the next time_step. !! This can be summurized for tempearture as: !! zt = (ta+2tn+tb)/4 ln_dynhpg_imp = T !! zt = 0 otherwise !! tb = tn + atfp*[ tb - 2 tn + ta ] !! tn = ta !! ta = zt (NB: reset to 0 after eos_bn2 call) !! !! ** Action : - update (tb,sb) and (tn,sn) !! - (ta,sa) time averaged (t,s) (ln_dynhpg_imp = T) !!---------------------------------------------------------------------- !! INTEGER, INTENT(in) :: kt ! ocean time-step index !! !! INTEGER :: ji, jj, jk ! dummy loop indices REAL(wp) :: zttl, zstl ! temporary scalars REAL(wp) :: zfact ! temporary scalar !!---------------------------------------------------------------------- IF( kt == nit000 ) THEN IF(lwp) WRITE(numout,*) IF(lwp) WRITE(numout,*) 'tra_nxt_tan : achieve the time stepping by Asselin filter and array swap' IF(lwp) WRITE(numout,*) '~~~~~~~' ENDIF ! Update after tracer on domain lateral boundaries ! CALL lbc_lnk( ta_tl, 'T', 1. ) ! local domain boundaries (T-point, unchanged sign) CALL lbc_lnk( sa_tl, 'T', 1. ) ! #if defined key_obc CALL obc_tra_tan( kt ) ! OBC open boundaries #endif #if defined key_bdy error "bdy not available in tangent yet" #endif #if defined key_agrif error "agrif not available in tangent yet" #endif ! Asselin time filter and swap of arrays ! IF( neuler == 0 .AND. kt == nit000 ) THEN ! Euler 1st time step : swap only DO jk = 1, jpkm1 tb_tl(:,:,jk) = tn_tl(:,:,jk) ! ta, sa remain at their values which sb_tl(:,:,jk) = sn_tl(:,:,jk) ! correspond to tn, sn after the sawp tn_tl(:,:,jk) = ta_tl(:,:,jk) sn_tl(:,:,jk) = sa_tl(:,:,jk) END DO ! ELSE ! Leap-Frog : filter + swap ! IF( ln_dynhpg_imp ) THEN ! semi-implicit hpg case DO jk = 1, jpkm1 ! (save the averaged of the 3 time steps DO jj = 1, jpj ! in the after fields) DO ji = 1, jpi zttl = ( ta_tl(ji,jj,jk) + 2. * tn_tl(ji,jj,jk) + tb_tl(ji,jj,jk) ) * 0.25 zstl = ( sa_tl(ji,jj,jk) + 2. * sn_tl(ji,jj,jk) + sb_tl(ji,jj,jk) ) * 0.25 tb_tl(ji,jj,jk) = atfp * ( tb_tl(ji,jj,jk) + ta_tl(ji,jj,jk) ) + atfp1 * tn_tl(ji,jj,jk) sb_tl(ji,jj,jk) = atfp * ( sb_tl(ji,jj,jk) + sa_tl(ji,jj,jk) ) + atfp1 * sn_tl(ji,jj,jk) tn_tl(ji,jj,jk) = ta_tl(ji,jj,jk) sn_tl(ji,jj,jk) = sa_tl(ji,jj,jk) ta_tl(ji,jj,jk) = zttl sa_tl(ji,jj,jk) = zstl END DO END DO END DO ELSE ! explicit hpg case DO jk = 1, jpkm1 DO jj = 1, jpj DO ji = 1, jpi tb_tl(ji,jj,jk) = atfp * ( tb_tl(ji,jj,jk) + ta_tl(ji,jj,jk) ) + atfp1 * tn_tl(ji,jj,jk) sb_tl(ji,jj,jk) = atfp * ( sb_tl(ji,jj,jk) + sa_tl(ji,jj,jk) ) + atfp1 * sn_tl(ji,jj,jk) tn_tl(ji,jj,jk) = ta_tl(ji,jj,jk) sn_tl(ji,jj,jk) = sa_tl(ji,jj,jk) END DO END DO END DO ENDIF ! ENDIF #if defined key_agrif ! Update tracer at AGRIF zoom boundaries error " Agrif not in tangent yet" #endif ! END SUBROUTINE tra_nxt_tan SUBROUTINE tra_nxt_adj( kt ) !!---------------------------------------------------------------------- !! *** ROUTINE tranxt_adj *** !! !! ** Purpose of the direct routine: !! Apply the boundary condition on the after temperature !! and salinity fields, achieved the time stepping by adding !! the Asselin filter on now fields and swapping the fields. !! !! ** Method : At this stage of the computation, ta and sa are the !! after temperature and salinity as the time stepping has !! been performed in trazdf_imp or trazdf_exp module. !! !! - Apply lateral boundary conditions on (ta,sa) !! at the local domain boundaries through lbc_lnk call, !! at the radiative open boundaries (lk_obc=T), !! at the relaxed open boundaries (lk_bdy=T), and !! at the AGRIF zoom boundaries (lk_agrif=T) !! !! - Apply the Asselin time filter on now fields, !! save in (ta,sa) an average over the three time levels !! which will be used to compute rdn and thus the semi-implicit !! hydrostatic pressure gradient (ln_dynhpg_imp = T), and !! swap tracer fields to prepare the next time_step. !! This can be summurized for tempearture as: !! zt = (ta+2tn+tb)/4 ln_dynhpg_imp = T !! zt = 0 otherwise !! tb = tn + atfp*[ tb - 2 tn + ta ] !! tn = ta !! ta = zt (NB: reset to 0 after eos_bn2 call) !! !! ** Action : - update (tb,sb) and (tn,sn) !! - (ta,sa) time averaged (t,s) (ln_dynhpg_imp = T) !!---------------------------------------------------------------------- !! INTEGER, INTENT(in) :: kt ! ocean time-step index !! !! INTEGER :: ji, jj, jk ! dummy loop indices REAL(wp) :: ztad, zsad ! temporary scalars REAL(wp) :: zfact ! temporary scalar !!---------------------------------------------------------------------- IF( kt == nitend ) THEN IF(lwp) WRITE(numout,*) IF(lwp) WRITE(numout,*) 'tra_nxt_adj : achieve the time stepping by Asselin filter and array swap' IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~' ENDIF #if defined key_agrif ! Update tracer at AGRIF zoom boundaries error " Agrif not in adjoint yet" #endif ! Asselin time filter and swap of arrays ! IF( neuler == 0 .AND. kt == nit000 ) THEN ! Euler 1st time step : swap only DO jk = 1, jpkm1 ta_ad(:,:,jk) = ta_ad(:,:,jk) + tn_ad(:,:,jk) sa_ad(:,:,jk) = sa_ad(:,:,jk) + sn_ad(:,:,jk) tn_ad(:,:,jk) = tb_ad(:,:,jk) sn_ad(:,:,jk) = sb_ad(:,:,jk) tb_ad(:,:,jk) = 0.0_wp sb_ad(:,:,jk) = 0.0_wp END DO ! ELSE ! Leap-Frog : filter + swap ! IF( ln_dynhpg_imp ) THEN ! semi-implicite hpg case DO jk = 1, jpkm1 ! (save the averaged of the 3 time steps DO jj = 1, jpj ! in the after fields) DO ji = 1, jpi ztad = ta_ad(ji,jj,jk) zsad = sa_ad(ji,jj,jk) ta_ad(ji,jj,jk) = tn_ad(ji,jj,jk) + tb_ad(ji,jj,jk) * atfp tn_ad(ji,jj,jk) = tb_ad(ji,jj,jk) * atfp1 tb_ad(ji,jj,jk) = tb_ad(ji,jj,jk) * atfp sa_ad(ji,jj,jk) = sn_ad(ji,jj,jk) + sb_ad(ji,jj,jk) * atfp sn_ad(ji,jj,jk) = sb_ad(ji,jj,jk) * atfp1 sb_ad(ji,jj,jk) = sb_ad(ji,jj,jk) * atfp ta_ad(ji,jj,jk) = ta_ad(ji,jj,jk) + ztad * 0.25_wp tn_ad(ji,jj,jk) = tn_ad(ji,jj,jk) + ztad * 0.5_wp tb_ad(ji,jj,jk) = tb_ad(ji,jj,jk) + ztad * 0.25_wp sa_ad(ji,jj,jk) = sa_ad(ji,jj,jk) + zsad * 0.25_wp sn_ad(ji,jj,jk) = sn_ad(ji,jj,jk) + zsad * 0.5_wp sb_ad(ji,jj,jk) = sb_ad(ji,jj,jk) + zsad * 0.25_wp END DO END DO END DO ELSE ! explicit hpg case DO jk = 1, jpkm1 DO jj = 1, jpj DO ji = 1, jpi ta_ad(ji,jj,jk) = ta_ad(ji,jj,jk) + tn_ad(ji,jj,jk) sa_ad(ji,jj,jk) = sa_ad(ji,jj,jk) + sn_ad(ji,jj,jk) ta_ad(ji,jj,jk) = ta_ad(ji,jj,jk) + atfp * tb_ad(ji,jj,jk) tn_ad(ji,jj,jk) = atfp1 * tb_ad(ji,jj,jk) tb_ad(ji,jj,jk) = atfp * tb_ad(ji,jj,jk) sa_ad(ji,jj,jk) = sa_ad(ji,jj,jk) + atfp * sb_ad(ji,jj,jk) sn_ad(ji,jj,jk) = atfp1 * sb_ad(ji,jj,jk) sb_ad(ji,jj,jk) = atfp * sb_ad(ji,jj,jk) END DO END DO END DO ENDIF ! ENDIF #if defined key_agrif error "agrif not available in tangent yet" #endif #if defined key_bdy error "bdy not available in tangent yet" #endif #if defined key_obc CALL obc_tra_adj( kt ) ! OBC open boundaries #endif ! Update after tracer on domain lateral boundaries ! CALL lbc_lnk_adj( ta_ad, 'T', 1. ) ! local domain boundaries (T-point, unchanged sign) CALL lbc_lnk_adj( sa_ad, 'T', 1. ) ! END SUBROUTINE tra_nxt_adj SUBROUTINE tra_nxt_adj_tst( kumadt ) !!----------------------------------------------------------------------- !! !! *** ROUTINE tra_nxt_adj_tst : TEST OF tra_nxt_adj *** !! !! ** Purpose : Test the adjoint routine. !! !! ** Method : Verify the scalar product !! !! ( L dx )^T W dy = dx^T L^T W dy !! !! where L = tangent routine !! L^T = adjoint routine !! W = diagonal matrix of scale factors !! dx = input perturbation (random field) !! dy = L dx !! !! History : !! ! 08-08 (A. Vidard) !!----------------------------------------------------------------------- !! * Modules used !! * Arguments INTEGER, INTENT(IN) :: & & kumadt ! Output unit INTEGER :: & & ji, & ! dummy loop indices & jj, & & jk INTEGER, DIMENSION(jpi,jpj) :: & & iseed_2d ! 2D seed for the random number generator !! * Local declarations REAL(KIND=wp), DIMENSION(:,:,:), ALLOCATABLE :: & & zsb_tlin, &! Tangent input : before salinity & ztb_tlin, &! Tangent input : before temperature & zsa_tlin, &! Tangent input : after salinity & zta_tlin, &! Tangent input : after temperature & zsn_tlin, &! Tangent input : now salinity & ztn_tlin, &! Tangent input : now temperature & zsb_tlout, &! Tangent output: before salinity & ztb_tlout, &! Tangent output: before temperature & zsa_tlout, &! Tangent output: after salinity & zta_tlout, &! Tangent output: after temperature & zsn_tlout, &! Tangent output: now salinity & ztn_tlout, &! Tangent output: now temperature & zsb_adin, &! Adjoint input : before salinity & ztb_adin, &! Adjoint input : before temperature & zsa_adin, &! Adjoint input : after salinity & zta_adin, &! Adjoint input : after temperature & zsn_adin, &! Adjoint input : now salinity & ztn_adin, &! Adjoint input : now temperature & zsb_adout, &! Adjoint output: before salinity & ztb_adout, &! Adjoint output: before temperature & zsa_adout, &! Adjoint output: after salinity & zta_adout, &! Adjoint output: after temperature & zsn_adout, &! Adjoint output: now salinity & ztn_adout, &! Adjoint output: now temperature & zr ! 3D field REAL(KIND=wp) :: & & zsp1, & ! scalar product involving the tangent routine & zsp1_1, & ! scalar product involving the tangent routine & zsp1_2, & ! scalar product involving the tangent routine & zsp1_3, & ! scalar product involving the tangent routine & zsp1_4, & ! scalar product involving the tangent routine & zsp1_5, & ! scalar product involving the tangent routine & zsp1_6, & ! scalar product involving the tangent routine & zsp2, & ! scalar product involving the adjoint routine & zsp2_1, & ! scalar product involving the adjoint routine & zsp2_2, & ! scalar product involving the adjoint routine & zsp2_3, & ! scalar product involving the adjoint routine & zsp2_4, & ! scalar product involving the adjoint routine & zsp2_5, & ! scalar product involving the adjoint routine & zsp2_6 ! scalar product involving the adjoint routine CHARACTER(LEN=14) :: & & cl_name ALLOCATE( & & zsb_tlin(jpi,jpj,jpk), &! Tangent input : before salinity & ztb_tlin(jpi,jpj,jpk), &! Tangent input : before temperature & zsa_tlin(jpi,jpj,jpk), &! Tangent input : after salinity & zta_tlin(jpi,jpj,jpk), &! Tangent input : after temperature & zsn_tlin(jpi,jpj,jpk), &! Tangent input : now salinity & ztn_tlin(jpi,jpj,jpk), &! Tangent input : now temperature & zsb_tlout(jpi,jpj,jpk), &! Tangent output: before salinity & ztb_tlout(jpi,jpj,jpk), &! Tangent output: before temperature & zsa_tlout(jpi,jpj,jpk), &! Tangent output: after salinity & zta_tlout(jpi,jpj,jpk), &! Tangent output: after temperature & zsn_tlout(jpi,jpj,jpk), &! Tangent output: now salinity & ztn_tlout(jpi,jpj,jpk), &! Tangent output: now temperature & zsb_adin(jpi,jpj,jpk), &! Adjoint input : before salinity & ztb_adin(jpi,jpj,jpk), &! Adjoint input : before temperature & zsa_adin(jpi,jpj,jpk), &! Adjoint input : after salinity & zta_adin(jpi,jpj,jpk), &! Adjoint input : after temperature & zsn_adin(jpi,jpj,jpk), &! Adjoint input : now salinity & ztn_adin(jpi,jpj,jpk), &! Adjoint input : now temperature & zsb_adout(jpi,jpj,jpk), &! Adjoint output: before salinity & ztb_adout(jpi,jpj,jpk), &! Adjoint output: before temperature & zsa_adout(jpi,jpj,jpk), &! Adjoint output: after salinity & zta_adout(jpi,jpj,jpk), &! Adjoint output: after temperature & zsn_adout(jpi,jpj,jpk), &! Adjoint output: now salinity & ztn_adout(jpi,jpj,jpk), &! Adjoint output: now temperature & zr (jpi,jpj,jpk) &! 3D field & ) !================================================================== ! 1) dx = ( tb_tl, tn_tl, ta_tl, dy = ( tb_tl, tn_tl, ta_tl, ! sb_tl, sn_tl, sa_tl ) and sb_tl, sn_tl, sa_tl ) !================================================================== !-------------------------------------------------------------------- ! Reset the tangent and adjoint variables !-------------------------------------------------------------------- zsa_tlin(:,:,:) = 0.0_wp zta_tlin(:,:,:) = 0.0_wp zsb_tlin(:,:,:) = 0.0_wp ztb_tlin(:,:,:) = 0.0_wp zsn_tlin(:,:,:) = 0.0_wp ztn_tlin(:,:,:) = 0.0_wp zsa_adin(:,:,:) = 0.0_wp zta_adin(:,:,:) = 0.0_wp zsb_adin(:,:,:) = 0.0_wp ztb_adin(:,:,:) = 0.0_wp zsn_adin(:,:,:) = 0.0_wp ztn_adin(:,:,:) = 0.0_wp sb_tl(:,:,:) = 0.0_wp tb_tl(:,:,:) = 0.0_wp sa_tl(:,:,:) = 0.0_wp ta_tl(:,:,:) = 0.0_wp sn_tl(:,:,:) = 0.0_wp tn_tl(:,:,:) = 0.0_wp sb_ad(:,:,:) = 0.0_wp tb_ad(:,:,:) = 0.0_wp sa_ad(:,:,:) = 0.0_wp ta_ad(:,:,:) = 0.0_wp sn_ad(:,:,:) = 0.0_wp tn_ad(:,:,:) = 0.0_wp DO jj = 1, jpj DO ji = 1, jpi iseed_2d(ji,jj) = - ( 785483 + & & mig(ji) + ( mjg(jj) - 1 ) * jpiglo ) END DO END DO CALL grid_random( iseed_2d, zr, 'T', 0.0_wp, stds ) DO jk = 1, jpk DO jj = nldj, nlej DO ji = nldi, nlei zsb_tlin(ji,jj,jk) = zr(ji,jj,jk) END DO END DO END DO DO jj = 1, jpj DO ji = 1, jpi iseed_2d(ji,jj) = - ( 358606 + & & mig(ji) + ( mjg(jj) - 1 ) * jpiglo ) END DO END DO CALL grid_random( iseed_2d, zr, 'T', 0.0_wp, stdt ) DO jk = 1, jpk DO jj = nldj, nlej DO ji = nldi, nlei ztb_tlin(ji,jj,jk) = zr(ji,jj,jk) END DO END DO END DO DO jj = 1, jpj DO ji = 1, jpi iseed_2d(ji,jj) = - ( 596035 + & & mig(ji) + ( mjg(jj) - 1 ) * jpiglo ) END DO END DO CALL grid_random( iseed_2d, zr, 'T', 0.0_wp, stds ) DO jk = 1, jpk DO jj = nldj, nlej DO ji = nldi, nlei zsa_tlin(ji,jj,jk) = zr(ji,jj,jk) END DO END DO END DO DO jj = 1, jpj DO ji = 1, jpi iseed_2d(ji,jj) = - ( 523432 + & & mig(ji) + ( mjg(jj) - 1 ) * jpiglo ) END DO END DO CALL grid_random( iseed_2d, zr, 'T', 0.0_wp, stdt ) DO jk = 1, jpk DO jj = nldj, nlej DO ji = nldi, nlei zta_tlin(ji,jj,jk) = zr(ji,jj,jk) END DO END DO END DO DO jj = 1, jpj DO ji = 1, jpi iseed_2d(ji,jj) = - ( 263957 + & & mig(ji) + ( mjg(jj) - 1 ) * jpiglo ) END DO END DO CALL grid_random( iseed_2d, zr, 'T', 0.0_wp, stds ) DO jk = 1, jpk DO jj = nldj, nlej DO ji = nldi, nlei zsn_tlin(ji,jj,jk) = zr(ji,jj,jk) END DO END DO END DO DO jj = 1, jpj DO ji = 1, jpi iseed_2d(ji,jj) = - ( 459031 + & & mig(ji) + ( mjg(jj) - 1 ) * jpiglo ) END DO END DO CALL grid_random( iseed_2d, zr, 'T', 0.0_wp, stdt ) DO jk = 1, jpk DO jj = nldj, nlej DO ji = nldi, nlei ztn_tlin(ji,jj,jk) = zr(ji,jj,jk) END DO END DO END DO sb_tl(:,:,:) = zsb_tlin(:,:,:) tb_tl(:,:,:) = ztb_tlin(:,:,:) sa_tl(:,:,:) = zsa_tlin(:,:,:) ta_tl(:,:,:) = zta_tlin(:,:,:) sn_tl(:,:,:) = zsn_tlin(:,:,:) tn_tl(:,:,:) = ztn_tlin(:,:,:) CALL tra_nxt_tan( nit000 + 1 ) zsa_tlout(:,:,:) = sa_tl(:,:,:) zta_tlout(:,:,:) = ta_tl(:,:,:) zsb_tlout(:,:,:) = sb_tl(:,:,:) ztb_tlout(:,:,:) = tb_tl(:,:,:) zsn_tlout(:,:,:) = sn_tl(:,:,:) ztn_tlout(:,:,:) = tn_tl(:,:,:) !-------------------------------------------------------------------- ! Initialize the adjoint variables: dy^* = W dy !-------------------------------------------------------------------- DO jk = 1, jpk DO jj = nldj, nlej DO ji = nldi, nlei zsa_adin(ji,jj,jk) = zsa_tlout(ji,jj,jk) & & * e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) & & * tmask(ji,jj,jk) * wesp_s(jk) zta_adin(ji,jj,jk) = zta_tlout(ji,jj,jk) & & * e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) & & * tmask(ji,jj,jk) * wesp_t(jk) zsb_adin(ji,jj,jk) = zsb_tlout(ji,jj,jk) & & * e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) & & * tmask(ji,jj,jk) * wesp_s(jk) ztb_adin(ji,jj,jk) = ztb_tlout(ji,jj,jk) & & * e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) & & * tmask(ji,jj,jk) * wesp_t(jk) zsn_adin(ji,jj,jk) = zsn_tlout(ji,jj,jk) & & * e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) & & * tmask(ji,jj,jk) * wesp_s(jk) ztn_adin(ji,jj,jk) = ztn_tlout(ji,jj,jk) & & * e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) & & * tmask(ji,jj,jk) * wesp_t(jk) END DO END DO END DO !-------------------------------------------------------------------- ! Compute the scalar product: ( L dx )^T W dy !-------------------------------------------------------------------- zsp1_1 = DOT_PRODUCT( zsa_tlout , zsa_adin ) zsp1_2 = DOT_PRODUCT( zta_tlout , zta_adin ) zsp1_3 = DOT_PRODUCT( zsb_tlout , zsb_adin ) zsp1_4 = DOT_PRODUCT( ztb_tlout , ztb_adin ) zsp1_5 = DOT_PRODUCT( zsn_tlout , zsn_adin ) zsp1_6 = DOT_PRODUCT( ztn_tlout , ztn_adin ) zsp1 = zsp1_1 + zsp1_2 + zsp1_3 + zsp1_4 + zsp1_5 + zsp1_6 !-------------------------------------------------------------------- ! Call the adjoint routine: dx^* = L^T dy^* !-------------------------------------------------------------------- sa_ad(:,:,:) = zsa_adin(:,:,:) ta_ad(:,:,:) = zta_adin(:,:,:) sb_ad(:,:,:) = zsb_adin(:,:,:) tb_ad(:,:,:) = ztb_adin(:,:,:) sn_ad(:,:,:) = zsn_adin(:,:,:) tn_ad(:,:,:) = ztn_adin(:,:,:) CALL tra_nxt_adj ( nit000 + 1 ) zsb_adout(:,:,:) = sb_ad(:,:,:) ztb_adout(:,:,:) = tb_ad(:,:,:) zsa_adout(:,:,:) = sa_ad(:,:,:) zta_adout(:,:,:) = ta_ad(:,:,:) zsn_adout(:,:,:) = sn_ad(:,:,:) ztn_adout(:,:,:) = tn_ad(:,:,:) !-------------------------------------------------------------------- ! Compute the scalar product: dx^T L^T W dy !-------------------------------------------------------------------- zsp2_1 = DOT_PRODUCT( zsb_tlin , zsb_adout ) zsp2_2 = DOT_PRODUCT( ztb_tlin , ztb_adout ) zsp2_3 = DOT_PRODUCT( zsa_tlin , zsa_adout ) zsp2_4 = DOT_PRODUCT( zta_tlin , zta_adout ) zsp2_5 = DOT_PRODUCT( zsn_tlin , zsn_adout ) zsp2_6 = DOT_PRODUCT( ztn_tlin , ztn_adout ) zsp2 = zsp2_1 + zsp2_2 + zsp2_3 + zsp2_4 + zsp2_5 + zsp2_6 ! Compare the scalar products ! 14 char:'12345678901234' cl_name = 'tra_nxt_adj ' CALL prntst_adj( cl_name, kumadt, zsp1, zsp2 ) DEALLOCATE( & & zsb_tlin, & & ztb_tlin, & & zsa_tlin, & & zta_tlin, & & zsn_tlin, & & ztn_tlin, & & zsb_tlout, & & ztb_tlout, & & zsa_tlout, & & zta_tlout, & & zsn_tlout, & & ztn_tlout, & & zsb_adin, & & ztb_adin, & & zsa_adin, & & zta_adin, & & zsn_adin, & & ztn_adin, & & zsb_adout, & & ztb_adout, & & zsa_adout, & & zta_adout, & & zsn_adout, & & ztn_adout, & & zr & & ) END SUBROUTINE tra_nxt_adj_tst !!====================================================================== #endif END MODULE tranxt_tam