MODULE tstool_tam !!========================================================================== !! *** MODULE tstool_tam : TAM testing utilities *** !!========================================================================== !! History of the NEMOTAM module: !! 3.0 ! 08-11 (A. Vidard) initial version USE par_oce, ONLY: & ! Ocean space and time domain variables & jpi, & & jpj, & & jpk, & & jpiglo, & & jpjglo USE dom_oce , ONLY: & ! Ocean space and time domain & e1u, & & e2u, & #if defined key_zco & e3t_0, & #else & e3u, & #endif & umask, & & mig, & & mjg, & & nldi, & & nldj, & & nlei, & & nlej USE par_kind , ONLY: & ! Precision variables & wp USE in_out_manager, ONLY: & ! I/O manager & lwp USE gridrandom , ONLY: & ! Random Gaussian noise on grids & grid_random USE dotprodfld , ONLY: & ! Computes dot product for 3D and 2D fields & dot_product IMPLICIT NONE PRIVATE REAL(KIND=wp), PUBLIC :: & ! random field standard deviation for: & stdu = 0.1_wp, & ! u-velocity & stdv = 0.1_wp, & ! v-velocity & stdw = 0.01_wp, & ! w-velocity #if defined key_obc & stds = 0.01_wp, & ! salinity & stdt = 0.20_wp, & ! temperature & stdssh = 0.005_wp, & ! sea surface height #else & stds = 0.1_wp, & ! salinity & stdt = 1.0_wp, & ! temperature & stdssh = 0.01_wp, & ! sea surface height #endif & stdemp = 0.01_wp, & ! evaporation minus precip 0.1_wp / SQRT( wesp_emp ) & stdqns = 1.0_wp, & ! non solar heat flux & stdqsr = 1.0_wp, & ! solar heat flux & stdgc = 0.1_wp, & ! gcx, gcb & stdr = 0.1_wp, & ! rotb, rhd & stdh = 0.1_wp ! hdivb PUBLIC & & prntst_adj, & & prntst_tlm # include "domzgr_substitute.h90" CONTAINS SUBROUTINE prntst_adj( cd_name, kumadt, psp1, psp2 ) CHARACTER(LEN=14), INTENT(in) :: cd_name REAL(wp), INTENT(in) :: psp1, psp2 INTEGER, INTENT(in) :: kumadt REAL(KIND=wp) :: & & zspdif, & ! scalar product difference & ztol ! accepted tolerance CHARACTER (LEN=47) :: & & FMT CHARACTER (LEN=9) :: & & cl_stat ! Accuracy status of adjoint routine (ok or warning) ! Compare the scalar products zspdif = ABS( psp1 - psp2 ) IF ( psp1 /= 0.0_wp ) zspdif = zspdif / ABS( psp1 ) ztol = EPSILON( zspdif ) * 10._wp IF ( zspdif < ztol ) THEN cl_stat = ' ok ' ELSEIF ( zspdif < ztol*1000._wp ) THEN cl_stat = ' warning ' ELSE cl_stat = 'RED ALERT' ENDIF IF (lwp) THEN FMT = "(A14,1X,E20.15,2X,E20.15,2X,E6.1,1X,E6.1,1x,A9)" WRITE(kumadt,FMT) cd_name, psp1, psp2, zspdif, ztol, cl_stat CALL FLUSH( kumadt ) ENDIF END SUBROUTINE prntst_adj SUBROUTINE prntst_tlm( cd_name, kumadt, psp1, psp2 ) CHARACTER(LEN=14), INTENT(in) :: cd_name REAL(wp), INTENT(in) :: psp1, psp2 INTEGER, INTENT(in) :: kumadt REAL(KIND=wp) :: & & zspratio ! scalar product difference CHARACTER (LEN=47) :: & & FMT CHARACTER (LEN=9) :: & & cl_stat ! Accuracy status of adjoint routine (ok or warning) ! Compare the scalar products IF ( psp1 /= 0.0_wp ) zspratio = 100 * psp1 / psp2 IF (lwp) THEN FMT = "(A14,1X,E20.13,2X,E20.15,2X,E6.1,1X)" WRITE(kumadt,FMT) cd_name, psp1, psp2, zspratio CALL FLUSH( kumadt ) ENDIF END SUBROUTINE prntst_tlm SUBROUTINE example_adj_tst( kumadt ) !!----------------------------------------------------------------------- !! !! *** ROUTINE example_adj_tst *** !! !! ** 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 !! * Local declarations INTEGER :: & & ji, & ! dummy loop indices & jj, & & jk INTEGER, DIMENSION(jpi,jpj) :: & & iseed_2d ! 2D seed for the random number generator REAL(KIND=wp) :: & & zsp1, & ! scalar product involving the tangent routine & zsp2 ! scalar product involving the adjoint routine REAL(KIND=wp), DIMENSION(:,:,:), ALLOCATABLE :: & & z_tlin , & ! Tangent input & z_tlout, & ! Tangent output & z_adin , & ! Adjoint input & z_adout, & ! Adjoint output & zr ! 3D random field CHARACTER(LEN=14) :: & & cl_name ! Allocate memory ALLOCATE( & & z_tlin( jpi,jpj,jpk), & & z_tlout(jpi,jpj,jpk), & & z_adin( jpi,jpj,jpk), & & z_adout(jpi,jpj,jpk), & & zr( jpi,jpj,jpk) & & ) !================================================================== ! 1) dx = ( un_tl, vn_tl, hdivn_tl ) and ! dy = ( hdivb_tl, hdivn_tl ) !================================================================== !-------------------------------------------------------------------- ! Reset the tangent and adjoint variables !-------------------------------------------------------------------- z_tlin( :,:,:) = 0.0_wp z_tlout(:,:,:) = 0.0_wp z_adin( :,:,:) = 0.0_wp z_adout(:,:,:) = 0.0_wp zr( :,:,:) = 0.0_wp !-------------------------------------------------------------------- ! Initialize the tangent input with random noise: dx !-------------------------------------------------------------------- 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, 'U', 0.0_wp, stdr ) z_tlin(:,:,:) = zr(:,:,:) CALL example_tan !-------------------------------------------------------------------- ! Initialize the adjoint variables: dy^* = W dy !-------------------------------------------------------------------- DO jk = 1, jpk DO jj = nldj, nlej DO ji = nldi, nlei z_adin(ji,jj,jk) = z_tlout(ji,jj,jk) & & * e1u(ji,jj) * e2u(ji,jj) * fse3u(ji,jj,jk) & & * umask(ji,jj,jk) END DO END DO END DO !-------------------------------------------------------------------- ! Compute the scalar product: ( L dx )^T W dy !-------------------------------------------------------------------- zsp1 = DOT_PRODUCT( z_tlout, z_adin ) !-------------------------------------------------------------------- ! Call the adjoint routine: dx^* = L^T dy^* !-------------------------------------------------------------------- CALL example_adj zsp2 = DOT_PRODUCT( z_tlin, z_adout ) ! 14 char:'12345678901234' cl_name = 'example_adj ' CALL prntst_adj( cl_name, kumadt, zsp1, zsp2 ) DEALLOCATE( & & z_tlin, & & z_tlout, & & z_adin, & & z_adout, & & zr & & ) END SUBROUTINE example_adj_tst SUBROUTINE example_tan END SUBROUTINE example_tan SUBROUTINE example_adj END SUBROUTINE example_adj END MODULE tstool_tam