| [1885] | 1 | MODULE dynspg_tam |
|---|
| 2 | !!---------------------------------------------------------------------- |
|---|
| 3 | !! This software is governed by the CeCILL licence (Version 2) |
|---|
| 4 | !!---------------------------------------------------------------------- |
|---|
| 5 | #if defined key_tam |
|---|
| 6 | !!====================================================================== |
|---|
| 7 | !! *** MODULE dynspg_tam *** |
|---|
| 8 | !! Ocean dynamics: surface pressure gradient control |
|---|
| 9 | !! Tangent and Adjoint Module |
|---|
| 10 | !!====================================================================== |
|---|
| 11 | !! History of the direct module: |
|---|
| 12 | !! 9.0 ! 05-12 (C. Talandier, G. Madec) Original code |
|---|
| 13 | !! 9.0 ! 05-12 (V. Garnier) dyn_spg_ctl: Original code |
|---|
| 14 | !! History of the T&A module: |
|---|
| 15 | !! 9.0 ! 08-06 (A. Vidard) Skeleton |
|---|
| 16 | !! ! 08-11 (A. Vidard) nemo v3 |
|---|
| 17 | !! ! 09-03 (A. Weaver) dynspg_flt_tam |
|---|
| 18 | !!---------------------------------------------------------------------- |
|---|
| 19 | !! dyn_spg_tan : update the dynamics trend with the surface pressure |
|---|
| 20 | !! gradient (tangent routine) |
|---|
| 21 | !! dyn_spg_adj : update the dynamics trend with the surface pressure |
|---|
| 22 | !! gradient (adjoint routine) |
|---|
| 23 | !! dyn_spg_adj_tst : Test of the adjoint routine |
|---|
| 24 | !!---------------------------------------------------------------------- |
|---|
| 25 | USE par_kind , ONLY: & ! Precision variables |
|---|
| 26 | & wp |
|---|
| 27 | USE par_oce , ONLY: & ! Ocean space and time domain variables |
|---|
| 28 | & lk_esopa |
|---|
| 29 | #if defined key_obc |
|---|
| 30 | USE obc_oce , ONLY: & ! ocean open boundary conditions |
|---|
| 31 | & ln_vol_cst, & |
|---|
| 32 | & ln_obc_fla |
|---|
| 33 | #endif |
|---|
| 34 | USE dynspg_oce , ONLY: & ! surface pressure gradient variables |
|---|
| 35 | & lk_dynspg_flt, & |
|---|
| 36 | & lk_dynspg_ts, & |
|---|
| 37 | & lk_dynspg_exp, & |
|---|
| 38 | & lk_dynspg_rl |
|---|
| 39 | USE in_out_manager, ONLY: & ! I/O manager |
|---|
| 40 | & lwp, & |
|---|
| 41 | & numout, & |
|---|
| 42 | & nit000, & |
|---|
| 43 | & nitend, & |
|---|
| 44 | & ctl_stop |
|---|
| 45 | USE dom_oce , ONLY: & ! Ocean space and time domain |
|---|
| 46 | & rdt, & |
|---|
| 47 | & rdtbt |
|---|
| 48 | |
|---|
| 49 | ! USE dynspg_exp_tam ! surface pressure gradient (dyn_spg_exp routine) |
|---|
| 50 | ! USE dynspg_ts_tam ! surface pressure gradient (dyn_spg_ts routine) |
|---|
| 51 | ! USE dynspg_rl_tam ! surface pressure gradient (dyn_spg_rl routine) |
|---|
| 52 | USE dynspg_flt_tam ! surface pressure gradient (dyn_spg_flt routine) |
|---|
| 53 | |
|---|
| 54 | IMPLICIT NONE |
|---|
| 55 | PRIVATE |
|---|
| 56 | |
|---|
| 57 | !! * Accessibility |
|---|
| 58 | PUBLIC dyn_spg_tan, & ! routine called by steptan module |
|---|
| 59 | & dyn_spg_adj, & ! routine called by stepadj module |
|---|
| [2587] | 60 | & dyn_spg_adj_tst ! routine controlling adjoint tests |
|---|
| 61 | #if defined key_tst_tlm |
|---|
| 62 | PUBLIC dyn_spg_tlm_tst |
|---|
| 63 | #endif |
|---|
| [1885] | 64 | |
|---|
| 65 | !! * module variables |
|---|
| 66 | INTEGER :: nspg = 0 ! type of surface pressure gradient scheme defined from lk_dynspg_... |
|---|
| 67 | |
|---|
| 68 | !! * Substitutions |
|---|
| 69 | # include "domzgr_substitute.h90" |
|---|
| 70 | # include "vectopt_loop_substitute.h90" |
|---|
| 71 | |
|---|
| 72 | CONTAINS |
|---|
| 73 | |
|---|
| 74 | SUBROUTINE dyn_spg_tan( kt, kindic ) |
|---|
| 75 | !!---------------------------------------------------------------------- |
|---|
| 76 | !! *** ROUTINE dyn_spg_tan *** |
|---|
| 77 | !! |
|---|
| 78 | !! ** Purpose of the direct routine: |
|---|
| 79 | !! compute the lateral ocean dynamics physics. |
|---|
| 80 | !!---------------------------------------------------------------------- |
|---|
| 81 | INTEGER, INTENT( IN ) :: & |
|---|
| 82 | & kt ! ocean time-step index |
|---|
| 83 | INTEGER, INTENT( OUT ) :: & |
|---|
| 84 | & kindic ! solver flag |
|---|
| 85 | !!---------------------------------------------------------------------- |
|---|
| 86 | |
|---|
| 87 | IF( kt == nit000 ) CALL dyn_spg_ctl_tam ! initialisation & control of options |
|---|
| 88 | |
|---|
| 89 | SELECT CASE ( nspg ) ! compute surf. pressure gradient |
|---|
| 90 | ! trend and add it to the general trend |
|---|
| 91 | CASE ( 0 ) |
|---|
| 92 | CALL ctl_stop ( 'dyn_spg_exp_tan not available yet' ) |
|---|
| 93 | !!! CALL dyn_spg_exp_tan( kt ) ! explicit |
|---|
| 94 | CASE ( 1 ) |
|---|
| 95 | CALL ctl_stop ( 'dyn_spg_ts_tan not available yet' ) |
|---|
| 96 | !!! CALL dyn_spg_ts_tan ( kt ) ! time-splitting |
|---|
| 97 | CASE ( 2 ) |
|---|
| 98 | CALL dyn_spg_flt_tan( kt, kindic ) ! filtered |
|---|
| 99 | CASE ( 3 ) |
|---|
| 100 | CALL ctl_stop ( 'dyn_spg_rl_tan not available yet' ) |
|---|
| 101 | !!! CALL dyn_spg_rl_tan ( kt, kindic ) ! rigid lid |
|---|
| 102 | ! |
|---|
| 103 | END SELECT |
|---|
| 104 | ! |
|---|
| 105 | END SUBROUTINE dyn_spg_tan |
|---|
| 106 | |
|---|
| 107 | SUBROUTINE dyn_spg_adj( kt, kindic ) |
|---|
| 108 | !!---------------------------------------------------------------------- |
|---|
| 109 | !! *** ROUTINE dyn_spg_adj *** |
|---|
| 110 | !! |
|---|
| 111 | !! ** Purpose of the direct routine: |
|---|
| 112 | !! compute the lateral ocean dynamics physics. |
|---|
| 113 | !!---------------------------------------------------------------------- |
|---|
| 114 | INTEGER, INTENT( IN ) :: & |
|---|
| 115 | & kt ! ocean time-step index |
|---|
| 116 | INTEGER, INTENT( OUT ) :: & |
|---|
| 117 | & kindic ! solver flag |
|---|
| 118 | !!---------------------------------------------------------------------- |
|---|
| 119 | |
|---|
| 120 | IF( kt == nitend ) CALL dyn_spg_ctl_tam ! initialisation & control of options |
|---|
| 121 | |
|---|
| 122 | SELECT CASE ( nspg ) ! compute surf. pressure gradient |
|---|
| 123 | ! trend and add it to the general trend |
|---|
| 124 | CASE ( 0 ) |
|---|
| 125 | CALL ctl_stop ( 'dyn_spg_exp_adj not available yet' ) |
|---|
| 126 | !!! CALL dyn_spg_exp_adj( kt ) ! explicit |
|---|
| 127 | CASE ( 1 ) |
|---|
| 128 | CALL ctl_stop ( 'dyn_spg_ts_adj not available yet' ) |
|---|
| 129 | !!! CALL dyn_spg_ts_adj ( kt ) ! time-splitting |
|---|
| 130 | CASE ( 2 ) |
|---|
| 131 | CALL dyn_spg_flt_adj( kt, kindic ) ! filtered |
|---|
| 132 | CASE ( 3 ) |
|---|
| 133 | CALL ctl_stop ( 'dyn_spg_rl_adj not available yet' ) |
|---|
| 134 | !!! CALL dyn_spg_rl_adj ( kt, kindic ) ! rigid lid |
|---|
| 135 | ! |
|---|
| 136 | END SELECT |
|---|
| 137 | ! |
|---|
| 138 | END SUBROUTINE dyn_spg_adj |
|---|
| 139 | |
|---|
| 140 | SUBROUTINE dyn_spg_adj_tst( kumadt ) |
|---|
| 141 | !!----------------------------------------------------------------------- |
|---|
| 142 | !! |
|---|
| 143 | !! *** ROUTINE dyn_spg_flt_adj_tst *** |
|---|
| 144 | !! |
|---|
| 145 | !! ** Purpose : Test the adjoint routine. |
|---|
| 146 | !! |
|---|
| 147 | !! ** Method : Verify the scalar product |
|---|
| 148 | !! |
|---|
| 149 | !! ( L dx )^T W dy = dx^T L^T W dy |
|---|
| 150 | !! |
|---|
| 151 | !! where L = tangent routine |
|---|
| 152 | !! L^T = adjoint routine |
|---|
| 153 | !! W = diagonal matrix of scale factors |
|---|
| 154 | !! dx = input perturbation (random field) |
|---|
| 155 | !! dy = L dx |
|---|
| 156 | !! |
|---|
| 157 | !! ** Action : Call the appropriate test routine depending on the |
|---|
| 158 | !! choice of free surface. |
|---|
| 159 | !! |
|---|
| 160 | !! History : |
|---|
| 161 | !! ! 09-01 (A. Weaver) |
|---|
| 162 | !!----------------------------------------------------------------------- |
|---|
| 163 | !! * Modules used |
|---|
| 164 | |
|---|
| 165 | !! * Arguments |
|---|
| 166 | INTEGER, INTENT(IN) :: & |
|---|
| 167 | & kumadt ! Output unit |
|---|
| 168 | |
|---|
| 169 | CALL dyn_spg_ctl_tam ! initialisation & control of options |
|---|
| 170 | |
|---|
| 171 | SELECT CASE ( nspg ) |
|---|
| 172 | CASE ( 0 ) |
|---|
| 173 | CALL ctl_stop ( 'dyn_spg_exp_adj_tst not available yet' ) |
|---|
| 174 | !!! CALL dyn_spg_exp_adj_tst( kumadt ) ! explicit |
|---|
| 175 | CASE ( 1 ) |
|---|
| 176 | CALL ctl_stop ( 'dyn_spg_ts_adj_tst not available yet' ) |
|---|
| 177 | !!! CALL dyn_spg_ts_adj_tst ( kumadt ) ! time-splitting |
|---|
| 178 | CASE ( 2 ) |
|---|
| 179 | CALL dyn_spg_flt_adj_tst( kumadt ) ! filtered |
|---|
| 180 | CASE ( 3 ) |
|---|
| 181 | CALL ctl_stop ( 'dyn_spg_rl_adj_tst not available yet' ) |
|---|
| 182 | !!! CALL dyn_spg_rl_adj_tst ( kumadt ) ! rigid lid |
|---|
| 183 | ! |
|---|
| 184 | END SELECT |
|---|
| 185 | ! |
|---|
| 186 | END SUBROUTINE dyn_spg_adj_tst |
|---|
| 187 | |
|---|
| 188 | SUBROUTINE dyn_spg_ctl_tam |
|---|
| 189 | !!--------------------------------------------------------------------- |
|---|
| 190 | !! *** ROUTINE dyn_spg_ctl_tam *** |
|---|
| 191 | !! |
|---|
| 192 | !! ** Purpose : Control the consistency between cpp options for |
|---|
| 193 | !! surface pressure gradient schemes |
|---|
| 194 | !!---------------------------------------------------------------------- |
|---|
| 195 | !! * Local declarations |
|---|
| 196 | INTEGER :: & |
|---|
| 197 | & ioptio |
|---|
| 198 | |
|---|
| 199 | !!---------------------------------------------------------------------- |
|---|
| 200 | |
|---|
| 201 | ! Parameter control and print |
|---|
| 202 | ! --------------------------- |
|---|
| 203 | ! Control print |
|---|
| 204 | IF(lwp) THEN |
|---|
| 205 | WRITE(numout,*) |
|---|
| 206 | WRITE(numout,*) 'dyn_spg_ctl_tam : choice of the surface pressure gradient scheme' |
|---|
| 207 | WRITE(numout,*) '~~~~~~~~~~~~~~~' |
|---|
| 208 | WRITE(numout,*) ' Explicit free surface lk_dynspg_exp = ', lk_dynspg_exp |
|---|
| 209 | WRITE(numout,*) ' Free surface with time splitting lk_dynspg_ts = ', lk_dynspg_ts |
|---|
| 210 | WRITE(numout,*) ' Filtered free surface cst volume lk_dynspg_flt = ', lk_dynspg_flt |
|---|
| 211 | WRITE(numout,*) ' Rigid-lid case lk_dynspg_rl = ', lk_dynspg_rl |
|---|
| 212 | ENDIF |
|---|
| 213 | |
|---|
| 214 | ! Control of surface pressure gradient scheme options |
|---|
| 215 | ! --------------------------------------------------- |
|---|
| 216 | ioptio = 0 |
|---|
| 217 | IF(lk_dynspg_exp) ioptio = ioptio + 1 |
|---|
| 218 | IF(lk_dynspg_ts ) ioptio = ioptio + 1 |
|---|
| 219 | IF(lk_dynspg_flt) ioptio = ioptio + 1 |
|---|
| 220 | IF(lk_dynspg_rl ) ioptio = ioptio + 1 |
|---|
| 221 | |
|---|
| 222 | IF( ( ioptio > 1 .AND. .NOT. lk_esopa ) .OR. ioptio == 0 ) & |
|---|
| 223 | & CALL ctl_stop( ' Choose only one surface pressure gradient scheme with a key cpp' ) |
|---|
| 224 | |
|---|
| 225 | IF( lk_esopa ) nspg = -1 |
|---|
| 226 | IF( lk_dynspg_exp) nspg = 0 |
|---|
| 227 | IF( lk_dynspg_ts ) nspg = 1 |
|---|
| 228 | IF( lk_dynspg_flt) nspg = 2 |
|---|
| 229 | IF( lk_dynspg_rl ) nspg = 3 |
|---|
| 230 | IF( nspg == 13 ) nspg = 3 |
|---|
| 231 | |
|---|
| 232 | IF( lk_esopa ) nspg = -1 |
|---|
| 233 | |
|---|
| 234 | IF(lwp) THEN |
|---|
| 235 | WRITE(numout,*) |
|---|
| 236 | IF( nspg == -1 ) WRITE(numout,*) ' ESOPA test All scheme used except rigid-lid' |
|---|
| 237 | IF( nspg == 0 ) WRITE(numout,*) ' explicit free surface' |
|---|
| 238 | IF( nspg == 1 ) WRITE(numout,*) ' free surface with time splitting scheme' |
|---|
| 239 | IF( nspg == 2 ) WRITE(numout,*) ' filtered free surface' |
|---|
| 240 | IF( nspg == 3 ) WRITE(numout,*) ' rigid-lid' |
|---|
| 241 | IF( nspg == 10 ) WRITE(numout,*) ' explicit free surface with j-k-i loop' |
|---|
| 242 | IF( nspg == 11 ) WRITE(numout,*) ' time splitting free surface with j-k-i loop' |
|---|
| 243 | IF( nspg == 12 ) WRITE(numout,*) ' filtered free surface with j-k-i loop' |
|---|
| 244 | ENDIF |
|---|
| 245 | |
|---|
| 246 | ! Control of timestep choice |
|---|
| 247 | ! -------------------------- |
|---|
| 248 | IF( lk_dynspg_ts ) THEN |
|---|
| 249 | IF( MOD( rdt , rdtbt ) /= 0. ) & |
|---|
| 250 | & CALL ctl_stop( ' The barotropic timestep must be an integer divisor of the baroclinic timestep' ) |
|---|
| 251 | ENDIF |
|---|
| 252 | |
|---|
| 253 | #if defined key_obc |
|---|
| 254 | ! Conservation of ocean volume (key_dynspg_flt) |
|---|
| 255 | ! --------------------------------------------- |
|---|
| 256 | IF( lk_dynspg_flt ) ln_vol_cst = .true. |
|---|
| 257 | |
|---|
| 258 | ! Application of Flather's algorithm at open boundaries |
|---|
| 259 | ! ----------------------------------------------------- |
|---|
| 260 | IF( lk_dynspg_flt ) ln_obc_fla = .false. |
|---|
| 261 | IF( lk_dynspg_exp ) ln_obc_fla = .true. |
|---|
| 262 | IF( lk_dynspg_ts ) ln_obc_fla = .true. |
|---|
| 263 | #endif |
|---|
| 264 | |
|---|
| 265 | END SUBROUTINE dyn_spg_ctl_tam |
|---|
| [2587] | 266 | #if defined key_tst_tlm |
|---|
| [1885] | 267 | SUBROUTINE dyn_spg_tlm_tst( kumadt ) |
|---|
| 268 | !!----------------------------------------------------------------------- |
|---|
| 269 | !! |
|---|
| 270 | !! *** ROUTINE dyn_spg_tlm_tst *** |
|---|
| 271 | !! |
|---|
| 272 | !! ** Purpose : Test the tangent linear routine. |
|---|
| 273 | !! |
|---|
| 274 | !! ** Method : Verify the relative error Er of the linear model |
|---|
| 275 | !! |
|---|
| 276 | !! Er = 100 norm( En ) / norm( L(t0,tn) gamma dx0 ) |
|---|
| 277 | !! --> zero when gamma --> zero |
|---|
| 278 | !! |
|---|
| 279 | !! where En = Nn( gamma dx0 ) - L(t0, tn ) gamma dx0 |
|---|
| 280 | !! L = Linear routine |
|---|
| 281 | !! Nn = Perturbation evolution ( M( x0 + gamma dx0 ) - M( x0 ) ) |
|---|
| 282 | !! gamma dx0 = input perturbation (random field) |
|---|
| 283 | !! |
|---|
| 284 | !! History : |
|---|
| 285 | !! ! 09-06 (F. Vigilant) |
|---|
| 286 | !!----------------------------------------------------------------------- |
|---|
| 287 | !! * Modules used |
|---|
| 288 | |
|---|
| 289 | !! * Arguments |
|---|
| 290 | INTEGER, INTENT(IN) :: & |
|---|
| 291 | & kumadt ! Output unit |
|---|
| 292 | |
|---|
| 293 | CALL dyn_spg_ctl_tam ! initialisation & control of options |
|---|
| 294 | |
|---|
| 295 | SELECT CASE ( nspg ) |
|---|
| 296 | CASE ( 0 ) |
|---|
| 297 | CALL ctl_stop ( 'dyn_spg_exp_adj_tst not available yet' ) |
|---|
| 298 | !!! CALL dyn_spg_exp_adj_tst( kumadt ) ! explicit |
|---|
| 299 | CASE ( 1 ) |
|---|
| 300 | CALL ctl_stop ( 'dyn_spg_ts_adj_tst not available yet' ) |
|---|
| 301 | !!! CALL dyn_spg_ts_adj_tst ( kumadt ) ! time-splitting |
|---|
| 302 | CASE ( 2 ) |
|---|
| 303 | CALL dyn_spg_flt_tlm_tst( kumadt ) ! filtered |
|---|
| 304 | CASE ( 3 ) |
|---|
| 305 | CALL ctl_stop ( 'dyn_spg_rl_adj_tst not available yet' ) |
|---|
| 306 | !!! CALL dyn_spg_rl_adj_tst ( kumadt ) ! rigid lid |
|---|
| 307 | ! |
|---|
| 308 | END SELECT |
|---|
| 309 | ! |
|---|
| 310 | END SUBROUTINE dyn_spg_tlm_tst |
|---|
| 311 | |
|---|
| 312 | !!====================================================================== |
|---|
| 313 | #endif |
|---|
| [2587] | 314 | #endif |
|---|
| [1885] | 315 | END MODULE dynspg_tam |
|---|
