| 1 | MODULE lbcnfd_tam |
|---|
| 2 | !!====================================================================== |
|---|
| 3 | !! *** MODULE lbcnfd *** |
|---|
| 4 | !! Ocean : north fold boundary conditions |
|---|
| 5 | !!====================================================================== |
|---|
| 6 | !! 9.0 ! 2009-03 (R. Benshila) Initial version |
|---|
| 7 | !! History of TAM: |
|---|
| 8 | !! NEMO 3.2 ! 2010-04 (F. Vigilant) Original code |
|---|
| 9 | !!---------------------------------------------------------------------- |
|---|
| 10 | !! * Modules used |
|---|
| 11 | USE oce ! ocean dynamics and tracers |
|---|
| 12 | USE dom_oce ! ocean space and time domain |
|---|
| 13 | USE in_out_manager ! I/O manager |
|---|
| 14 | |
|---|
| 15 | IMPLICIT NONE |
|---|
| 16 | PRIVATE |
|---|
| 17 | |
|---|
| 18 | INTERFACE lbc_nfd_adj |
|---|
| 19 | MODULE PROCEDURE lbc_nfd_3d_adj, lbc_nfd_2d_adj |
|---|
| 20 | END INTERFACE |
|---|
| 21 | |
|---|
| 22 | PUBLIC lbc_nfd_adj ! north fold conditions |
|---|
| 23 | PUBLIC lbc_nfd_adj_tst |
|---|
| 24 | !!---------------------------------------------------------------------- |
|---|
| 25 | |
|---|
| 26 | CONTAINS |
|---|
| 27 | |
|---|
| 28 | SUBROUTINE lbc_nfd_3d_adj( pt3d, cd_type, psgn ) |
|---|
| 29 | !!---------------------------------------------------------------------- |
|---|
| 30 | !! *** routine lbc_nfd_3d_adj *** |
|---|
| 31 | !! |
|---|
| 32 | !! ** Purpose : Adjoint of 3D lateral boundary condition : North fold |
|---|
| 33 | !! treatment without processor exchanges. |
|---|
| 34 | !! |
|---|
| 35 | !! ** Method : |
|---|
| 36 | !! |
|---|
| 37 | !! ** Action : pt3d with update value at its periphery |
|---|
| 38 | !! |
|---|
| 39 | !!---------------------------------------------------------------------- |
|---|
| 40 | !! * Arguments |
|---|
| 41 | CHARACTER(len=1) , INTENT( in ) :: & |
|---|
| 42 | cd_type ! define the nature of ptab array grid-points |
|---|
| 43 | ! ! = T , U , V , F , W points |
|---|
| 44 | ! ! = S : T-point, north fold treatment ??? |
|---|
| 45 | ! ! = G : F-point, north fold treatment ??? |
|---|
| 46 | REAL(wp), INTENT( in ) :: & |
|---|
| 47 | psgn ! control of the sign change |
|---|
| 48 | ! ! = -1. , the sign is changed if north fold boundary |
|---|
| 49 | ! ! = 1. , the sign is kept if north fold boundary |
|---|
| 50 | REAL(wp), DIMENSION(:,:,:), INTENT( inout ) :: & |
|---|
| 51 | pt3d ! 3D array on which the boundary condition is applied |
|---|
| 52 | |
|---|
| 53 | !! * Local declarations |
|---|
| 54 | INTEGER :: ji, jk |
|---|
| 55 | INTEGER :: ijt, iju, ijpj, ijpjm1 |
|---|
| 56 | |
|---|
| 57 | |
|---|
| 58 | SELECT CASE ( jpni ) |
|---|
| 59 | CASE ( 1 ) ! only one proc along I |
|---|
| 60 | ijpj = nlcj |
|---|
| 61 | CASE DEFAULT |
|---|
| 62 | ijpj = 4 |
|---|
| 63 | END SELECT |
|---|
| 64 | ijpjm1 = ijpj-1 |
|---|
| 65 | |
|---|
| 66 | DO jk = 1, jpk |
|---|
| 67 | |
|---|
| 68 | SELECT CASE ( npolj ) |
|---|
| 69 | |
|---|
| 70 | CASE ( 3 , 4 ) ! * North fold T-point pivot |
|---|
| 71 | |
|---|
| 72 | SELECT CASE ( cd_type ) |
|---|
| 73 | CASE ( 'T' , 'W' ) ! T-, W-point |
|---|
| 74 | DO ji = jpiglo, jpiglo/2+1, -1 |
|---|
| 75 | ijt = jpiglo-ji+2 |
|---|
| 76 | pt3d(ijt,ijpjm1,jk) = pt3d(ijt,ijpjm1,jk) + psgn * pt3d(ji,ijpjm1,jk) |
|---|
| 77 | pt3d(ji ,ijpjm1,jk) = 0.0_wp |
|---|
| 78 | END DO |
|---|
| 79 | DO ji = jpiglo, 2, -1 |
|---|
| 80 | ijt = jpiglo-ji+2 |
|---|
| 81 | pt3d(ijt,ijpj-2,jk) = pt3d(ijt,ijpj-2,jk) + psgn * pt3d(ji,ijpj,jk) |
|---|
| 82 | pt3d(ji ,ijpj ,jk) = 0.0_wp |
|---|
| 83 | END DO |
|---|
| 84 | CASE ( 'U' ) ! U-point |
|---|
| 85 | DO ji = jpiglo-1, jpiglo/2, -1 |
|---|
| 86 | iju = jpiglo-ji+1 |
|---|
| 87 | pt3d(iju,ijpjm1,jk) = pt3d(iju,ijpjm1,jk) + psgn * pt3d(ji,ijpjm1,jk) |
|---|
| 88 | pt3d(ji ,ijpjm1,jk) = 0.0_wp |
|---|
| 89 | END DO |
|---|
| 90 | DO ji = jpiglo-1, 1, -1 |
|---|
| 91 | iju = jpiglo-ji+1 |
|---|
| 92 | pt3d(iju,ijpj-2,jk) = pt3d(iju,ijpj-2,jk) + psgn * pt3d(ji,ijpj,jk) |
|---|
| 93 | pt3d(ji ,ijpj ,jk) = 0.0_wp |
|---|
| 94 | END DO |
|---|
| 95 | CASE ( 'V' ) ! V-point |
|---|
| 96 | DO ji = jpiglo, 2, -1 |
|---|
| 97 | ijt = jpiglo-ji+2 |
|---|
| 98 | pt3d(ijt,ijpj-3,jk) = pt3d(ijt,ijpj-3,jk) + psgn * pt3d(ji,ijpj ,jk) |
|---|
| 99 | pt3d(ji,ijpj ,jk) = 0.0_wp |
|---|
| 100 | pt3d(ijt,ijpj-2,jk) = pt3d(ijt,ijpj-2,jk) + psgn * pt3d(ji,ijpj-1,jk) |
|---|
| 101 | pt3d(ji,ijpj-1,jk) = 0.0_wp |
|---|
| 102 | END DO |
|---|
| 103 | CASE ( 'F' ) ! F-point |
|---|
| 104 | DO ji = jpiglo-1, 1, -1 |
|---|
| 105 | iju = jpiglo-ji+1 |
|---|
| 106 | pt3d(iju,ijpj-3,jk) = pt3d(iju,ijpj-3,jk) + psgn * pt3d(ji,ijpj ,jk) |
|---|
| 107 | pt3d(ji ,ijpj ,jk) = 0.0_wp |
|---|
| 108 | pt3d(iju,ijpj-2,jk) = pt3d(iju,ijpj-2,jk) + psgn * pt3d(ji,ijpj-1,jk) |
|---|
| 109 | pt3d(ji ,ijpj-1,jk) = 0.0_wp |
|---|
| 110 | END DO |
|---|
| 111 | END SELECT |
|---|
| 112 | |
|---|
| 113 | CASE ( 5 , 6 ) ! * North fold F-point pivot |
|---|
| 114 | |
|---|
| 115 | SELECT CASE ( cd_type ) |
|---|
| 116 | CASE ( 'T' , 'W' ) ! T-, W-point |
|---|
| 117 | DO ji = jpiglo, 1, -1 |
|---|
| 118 | ijt = jpiglo-ji+1 |
|---|
| 119 | pt3d(ijt,ijpj-1,jk) = pt3d(ijt,ijpj-1,jk) + psgn * pt3d(ji,ijpj,jk) |
|---|
| 120 | pt3d(ji ,ijpj ,jk) = 0.0_wp |
|---|
| 121 | END DO |
|---|
| 122 | CASE ( 'U' ) ! U-point |
|---|
| 123 | DO ji = jpiglo-1, 1, -1 |
|---|
| 124 | iju = jpiglo-ji |
|---|
| 125 | pt3d(iju,ijpj-1,jk) = pt3d(iju,ijpj-1,jk) + psgn * pt3d(ji,ijpj,jk) |
|---|
| 126 | pt3d(ji ,ijpj ,jk) = 0.0_wp |
|---|
| 127 | END DO |
|---|
| 128 | CASE ( 'V' ) ! V-point |
|---|
| 129 | DO ji = jpiglo, jpiglo/2+1, -1 |
|---|
| 130 | ijt = jpiglo-ji+1 |
|---|
| 131 | pt3d(ijt,ijpjm1,jk) = pt3d(ijt,ijpjm1,jk) + psgn * pt3d(ji,ijpjm1,jk) |
|---|
| 132 | pt3d(ji ,ijpjm1,jk) = 0.0_wp |
|---|
| 133 | END DO |
|---|
| 134 | DO ji = jpiglo, 1, -1 |
|---|
| 135 | ijt = jpiglo-ji+1 |
|---|
| 136 | pt3d(ijt,ijpj-2,jk) = pt3d(ijt,ijpj-2,jk) + psgn * pt3d(ji,ijpj,jk) |
|---|
| 137 | pt3d(ji ,ijpj ,jk) = 0.0_wp |
|---|
| 138 | END DO |
|---|
| 139 | CASE ( 'F' ) ! F-point |
|---|
| 140 | DO ji = jpiglo-1, jpiglo/2+1, -1 |
|---|
| 141 | iju = jpiglo-ji |
|---|
| 142 | pt3d(iju,ijpjm1,jk) = pt3d(iju,ijpjm1,jk) + psgn * pt3d(ji,ijpjm1,jk) |
|---|
| 143 | pt3d(ji ,ijpjm1,jk) = 0.0_wp |
|---|
| 144 | END DO |
|---|
| 145 | DO ji = jpiglo-1, 1, -1 |
|---|
| 146 | iju = jpiglo-ji |
|---|
| 147 | pt3d(iju,ijpj-2,jk) = pt3d(iju,ijpj-2,jk) + psgn * pt3d(ji,ijpj ,jk) |
|---|
| 148 | pt3d(ji ,ijpj ,jk) = 0.0_wp |
|---|
| 149 | END DO |
|---|
| 150 | END SELECT |
|---|
| 151 | |
|---|
| 152 | CASE DEFAULT ! * closed : the code probably never go through |
|---|
| 153 | |
|---|
| 154 | SELECT CASE ( cd_type) |
|---|
| 155 | CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points |
|---|
| 156 | pt3d(:, 1 ,jk) = 0.0_wp |
|---|
| 157 | pt3d(:,ijpj,jk) = 0.0_wp |
|---|
| 158 | CASE ( 'F' ) ! F-point |
|---|
| 159 | pt3d(:,ijpj,jk) = 0.0_wp |
|---|
| 160 | END SELECT |
|---|
| 161 | |
|---|
| 162 | END SELECT ! npolj |
|---|
| 163 | |
|---|
| 164 | END DO |
|---|
| 165 | |
|---|
| 166 | END SUBROUTINE lbc_nfd_3d_adj |
|---|
| 167 | |
|---|
| 168 | |
|---|
| 169 | SUBROUTINE lbc_nfd_2d_adj( pt2d, cd_type, psgn, pr2dj ) |
|---|
| 170 | !!---------------------------------------------------------------------- |
|---|
| 171 | !! *** routine lbc_nfd_2d *** |
|---|
| 172 | !! |
|---|
| 173 | !! ** Purpose : Adjoint of 2D lateral boundary condition : North fold |
|---|
| 174 | !! treatment without processor exchanges. |
|---|
| 175 | !! |
|---|
| 176 | !! ** Method : |
|---|
| 177 | !! |
|---|
| 178 | !! ** Action : pt2d with update value at its periphery |
|---|
| 179 | !! |
|---|
| 180 | !!---------------------------------------------------------------------- |
|---|
| 181 | !! * Arguments |
|---|
| 182 | CHARACTER(len=1) , INTENT( in ) :: & |
|---|
| 183 | cd_type ! define the nature of ptab array grid-points |
|---|
| 184 | ! ! = T , U , V , F , W points |
|---|
| 185 | ! ! = S : T-point, north fold treatment ??? |
|---|
| 186 | ! ! = G : F-point, north fold treatment ??? |
|---|
| 187 | REAL(wp), INTENT( in ) :: & |
|---|
| 188 | psgn ! control of the sign change |
|---|
| 189 | ! ! = -1. , the sign is changed if north fold boundary |
|---|
| 190 | ! ! = 1. , the sign is kept if north fold boundary |
|---|
| 191 | REAL(wp), DIMENSION(:,:), INTENT( inout ) :: & |
|---|
| 192 | pt2d ! 3D array on which the boundary condition is applied |
|---|
| 193 | INTEGER, OPTIONAL, INTENT(in) :: pr2dj |
|---|
| 194 | |
|---|
| 195 | !! * Local declarations |
|---|
| 196 | INTEGER :: ji, jl, ipr2dj |
|---|
| 197 | INTEGER :: ijt, iju, ijpj, ijpjm1 |
|---|
| 198 | |
|---|
| 199 | SELECT CASE ( jpni ) |
|---|
| 200 | CASE ( 1 ) ! only one proc along I |
|---|
| 201 | ijpj = nlcj |
|---|
| 202 | CASE DEFAULT |
|---|
| 203 | ijpj = 4 |
|---|
| 204 | END SELECT |
|---|
| 205 | |
|---|
| 206 | |
|---|
| 207 | IF( PRESENT(pr2dj) ) THEN |
|---|
| 208 | ipr2dj = pr2dj |
|---|
| 209 | IF (jpni .GT. 1) ijpj = ijpj + ipr2dj |
|---|
| 210 | ELSE |
|---|
| 211 | ipr2dj = 0 |
|---|
| 212 | ENDIF |
|---|
| 213 | |
|---|
| 214 | ijpjm1 = ijpj-1 |
|---|
| 215 | |
|---|
| 216 | |
|---|
| 217 | SELECT CASE ( npolj ) |
|---|
| 218 | |
|---|
| 219 | CASE ( 3, 4 ) ! * North fold T-point pivot |
|---|
| 220 | |
|---|
| 221 | SELECT CASE ( cd_type ) |
|---|
| 222 | |
|---|
| 223 | CASE ( 'T', 'S', 'W' ) |
|---|
| 224 | DO ji = jpiglo, jpiglo/2+1, -1 |
|---|
| 225 | ijt=jpiglo-ji+2 |
|---|
| 226 | pt2d(ijt,ijpj-1) = pt2d(ijt,ijpj-1) + psgn * pt2d(ji,ijpj-1) |
|---|
| 227 | pt2d(ji ,ijpj-1) = 0.0_wp |
|---|
| 228 | END DO |
|---|
| 229 | DO jl = ipr2dj, 0, -1 |
|---|
| 230 | DO ji = jpiglo, 2, -1 |
|---|
| 231 | ijt=jpiglo-ji+2 |
|---|
| 232 | pt2d(ijt,ijpj-2-jl) = pt2d(ijt,ijpj-2-jl) + psgn * pt2d(ji,ijpj+jl) |
|---|
| 233 | pt2d(ji ,ijpj+jl ) = 0.0_wp |
|---|
| 234 | END DO |
|---|
| 235 | END DO |
|---|
| 236 | CASE ( 'U' ) ! U-point |
|---|
| 237 | DO ji = jpiglo-1, jpiglo/2, -1 |
|---|
| 238 | iju = jpiglo-ji+1 |
|---|
| 239 | pt2d(iju,ijpjm1) = pt2d(iju,ijpjm1) + psgn * pt2d(ji,ijpjm1) |
|---|
| 240 | pt2d(ji,ijpjm1) = 0.0_wp |
|---|
| 241 | END DO |
|---|
| 242 | DO jl = ipr2dj, 0, -1 |
|---|
| 243 | DO ji = jpiglo-1, 1, -1 |
|---|
| 244 | iju = jpiglo-ji+1 |
|---|
| 245 | pt2d(iju,ijpj-2-jl) = pt2d(iju,ijpj-2-jl) + psgn * pt2d(ji,ijpj+jl) |
|---|
| 246 | pt2d(ji ,ijpj+jl ) = 0.0_wp |
|---|
| 247 | END DO |
|---|
| 248 | END DO |
|---|
| 249 | CASE ( 'V' ) ! V-point |
|---|
| 250 | DO jl = ipr2dj, -1, -1 |
|---|
| 251 | DO ji = jpiglo, 2, -1 |
|---|
| 252 | ijt = jpiglo-ji+2 |
|---|
| 253 | pt2d(ijt,ijpj-3-jl) = pt2d(ijt,ijpj-3-jl) + psgn * pt2d(ji,ijpj+jl) |
|---|
| 254 | pt2d(ji ,ijpj+jl ) = 0.0_wp |
|---|
| 255 | END DO |
|---|
| 256 | END DO |
|---|
| 257 | CASE ( 'F' , 'G' ) ! F-point |
|---|
| 258 | DO jl = ipr2dj, -1, -1 |
|---|
| 259 | DO ji = jpiglo-1, 1, -1 |
|---|
| 260 | iju = jpiglo-ji+1 |
|---|
| 261 | pt2d(iju,ijpj-3-jl) = pt2d(iju,ijpj-3-jl) + psgn * pt2d(ji,ijpj+jl) |
|---|
| 262 | pt2d(ji,ijpj+jl) = 0.0_wp |
|---|
| 263 | END DO |
|---|
| 264 | END DO |
|---|
| 265 | CASE ( 'I' ) ! ice U-V point |
|---|
| 266 | DO jl = ipr2dj, 0, -1 |
|---|
| 267 | DO ji = jpiglo, 3, -1 |
|---|
| 268 | iju = jpiglo - ji + 3 |
|---|
| 269 | pt2d(iju,ijpj-1-jl) = pt2d(iju,ijpj-1-jl) + psgn * pt2d(ji,ijpj+jl) |
|---|
| 270 | pt2d(ji,ijpj+jl) = 0.0_wp |
|---|
| 271 | END DO |
|---|
| 272 | pt2d(3,ijpj-1+jl) = pt2d(3,ijpj-1+jl) + psgn * pt2d(2,ijpj+jl) |
|---|
| 273 | pt2d(2,ijpj+jl) = 0.0_wp |
|---|
| 274 | END DO |
|---|
| 275 | END SELECT |
|---|
| 276 | |
|---|
| 277 | CASE ( 5, 6 ) ! * North fold F-point pivot |
|---|
| 278 | |
|---|
| 279 | SELECT CASE ( cd_type ) |
|---|
| 280 | CASE ( 'T' , 'W' ,'S' ) ! T-, W-point |
|---|
| 281 | DO jl = ipr2dj, 0, -1 |
|---|
| 282 | DO ji = jpiglo, 1, -1 |
|---|
| 283 | ijt = jpiglo-ji+1 |
|---|
| 284 | pt2d(ijt,ijpj-1-jl) = pt2d(ijt,ijpj-1-jl) + psgn * pt2d(ji,ijpj+jl) |
|---|
| 285 | pt2d(ji ,ijpj+jl ) = 0.0_wp |
|---|
| 286 | END DO |
|---|
| 287 | END DO |
|---|
| 288 | CASE ( 'U' ) ! U-point |
|---|
| 289 | DO jl = ipr2dj, 0, -1 |
|---|
| 290 | DO ji = jpiglo-1, 1, -1 |
|---|
| 291 | iju = jpiglo-ji |
|---|
| 292 | pt2d(iju,ijpj-1-jl) = pt2d(iju,ijpj-1-jl) + psgn * pt2d(ji,ijpj+jl) |
|---|
| 293 | pt2d(ji,ijpj+jl) = 0.0_wp |
|---|
| 294 | END DO |
|---|
| 295 | END DO |
|---|
| 296 | CASE ( 'V' ) ! V-point |
|---|
| 297 | DO ji = jpiglo, jpiglo/2+1, -1 |
|---|
| 298 | ijt = jpiglo-ji+1 |
|---|
| 299 | pt2d(ijt,ijpjm1) = pt2d(ijt,ijpjm1) + psgn * pt2d(ji,ijpjm1) |
|---|
| 300 | pt2d(ji ,ijpjm1) = 0.0_wp |
|---|
| 301 | END DO |
|---|
| 302 | DO jl = ipr2dj, 0, -1 |
|---|
| 303 | DO ji = jpiglo, 1, -1 |
|---|
| 304 | ijt = jpiglo-ji+1 |
|---|
| 305 | pt2d(ijt,ijpj-2-jl) = pt2d(ijt,ijpj-2-jl) + psgn * pt2d(ji,ijpj+jl) |
|---|
| 306 | pt2d(ji,ijpj+jl) = 0.0_wp |
|---|
| 307 | END DO |
|---|
| 308 | END DO |
|---|
| 309 | CASE ( 'F' , 'G' ) ! F-point |
|---|
| 310 | DO ji = jpiglo-1, jpiglo/2+1, -1 |
|---|
| 311 | iju = jpiglo-ji |
|---|
| 312 | pt2d(iju,ijpjm1) = pt2d(iju,ijpjm1) + psgn * pt2d(ji,ijpjm1) |
|---|
| 313 | pt2d(ji ,ijpjm1) = 0.0_wp |
|---|
| 314 | END DO |
|---|
| 315 | DO jl = ipr2dj, 0, -1 |
|---|
| 316 | DO ji = jpiglo-1, 1, -1 |
|---|
| 317 | iju = jpiglo-ji |
|---|
| 318 | pt2d(iju,ijpj-2-jl) = pt2d(iju,ijpj-2-jl) + psgn * pt2d(ji,ijpj+jl) |
|---|
| 319 | pt2d(ji ,ijpj+jl ) = 0.0_wp |
|---|
| 320 | END DO |
|---|
| 321 | END DO |
|---|
| 322 | CASE ( 'I' ) ! ice U-V point |
|---|
| 323 | DO jl = ipr2dj, 0, -1 |
|---|
| 324 | DO ji = jpiglo-1, 2, -1 |
|---|
| 325 | ijt = jpiglo - ji + 2 |
|---|
| 326 | pt2d(ji ,ijpj-1-jl) = pt2d(ji ,ijpj-1-jl) + 0.5 * pt2d(ji,ijpj+jl) |
|---|
| 327 | pt2d(ijt,ijpj-1-jl) = pt2d(ijt,ijpj-1-jl) + 0.5 * psgn * pt2d(ji,ijpj+jl) |
|---|
| 328 | pt2d(ji ,ijpj+jl ) = 0.0_wp |
|---|
| 329 | END DO |
|---|
| 330 | END DO |
|---|
| 331 | pt2d( 2 ,ijpj:ijpj+ipr2dj) = 0.0_wp |
|---|
| 332 | END SELECT |
|---|
| 333 | |
|---|
| 334 | CASE DEFAULT ! * closed : the code probably never go through |
|---|
| 335 | |
|---|
| 336 | SELECT CASE ( cd_type) |
|---|
| 337 | CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points |
|---|
| 338 | pt2d(:, 1:1-ipr2dj ) = 0.0_wp |
|---|
| 339 | pt2d(:,ijpj:ijpj+ipr2dj) = 0.0_wp |
|---|
| 340 | CASE ( 'F' ) ! F-point |
|---|
| 341 | pt2d(:,ijpj:ijpj+ipr2dj) = 0.0_wp |
|---|
| 342 | CASE ( 'I' ) ! ice U-V point |
|---|
| 343 | pt2d(:, 1:1-ipr2dj ) = 0.0_wp |
|---|
| 344 | pt2d(:,ijpj:ijpj+ipr2dj) = 0.0_wp |
|---|
| 345 | END SELECT |
|---|
| 346 | |
|---|
| 347 | END SELECT |
|---|
| 348 | |
|---|
| 349 | END SUBROUTINE lbc_nfd_2d_adj |
|---|
| 350 | |
|---|
| 351 | SUBROUTINE lbc_nfd_3d_adj_tst( kumadt ) |
|---|
| 352 | !!----------------------------------------------------------------------- |
|---|
| 353 | !! |
|---|
| 354 | !! *** ROUTINE lbc_nfd_3d_adj_tst *** |
|---|
| 355 | !! |
|---|
| 356 | !! ** Purpose : Test the adjoint routine. |
|---|
| 357 | !! |
|---|
| 358 | !! ** Method : Verify the scalar product |
|---|
| 359 | !! |
|---|
| 360 | !! ( L dx )^T W dy = dx^T L^T W dy |
|---|
| 361 | !! |
|---|
| 362 | !! where L = tangent routine |
|---|
| 363 | !! L^T = adjoint routine |
|---|
| 364 | !! W = diagonal matrix of scale factors |
|---|
| 365 | !! dx = input perturbation (random field) |
|---|
| 366 | !! dy = L dx |
|---|
| 367 | !! |
|---|
| 368 | !! ** Action : |
|---|
| 369 | !! |
|---|
| 370 | !! History : |
|---|
| 371 | !! ! 2010-09 (F. Vigilant) |
|---|
| 372 | !!----------------------------------------------------------------------- |
|---|
| 373 | !! * Modules used |
|---|
| 374 | USE gridrandom , ONLY: & ! Random Gaussian noise on grids |
|---|
| 375 | & grid_random |
|---|
| 376 | USE dotprodfld , ONLY: & ! Computes dot product for 3D and 2D fields |
|---|
| 377 | & dot_product |
|---|
| 378 | USE lbcnfd, ONLY: & |
|---|
| 379 | & lbc_nfd |
|---|
| 380 | USE tstool_tam , ONLY: & |
|---|
| 381 | & stdu, & |
|---|
| 382 | & stdv, & |
|---|
| 383 | & stdt, & |
|---|
| 384 | & prntst_adj |
|---|
| 385 | USE dom_oce , ONLY: & ! Ocean space and time domain |
|---|
| 386 | & e1u, & |
|---|
| 387 | & e2u, & |
|---|
| 388 | & e1v, & |
|---|
| 389 | & e2v, & |
|---|
| 390 | & e1t, & |
|---|
| 391 | & e2t, & |
|---|
| 392 | #if defined key_zco |
|---|
| 393 | & e3t_0, & |
|---|
| 394 | #else |
|---|
| 395 | & e3u, & |
|---|
| 396 | & e3v, & |
|---|
| 397 | #endif |
|---|
| 398 | & tmask, & |
|---|
| 399 | & umask, & |
|---|
| 400 | & vmask, & |
|---|
| 401 | & mig, & |
|---|
| 402 | & mjg, & |
|---|
| 403 | & nldi, & |
|---|
| 404 | & nldj, & |
|---|
| 405 | & nlei, & |
|---|
| 406 | & nlej |
|---|
| 407 | USE mppsumtam |
|---|
| 408 | !! * Arguments |
|---|
| 409 | INTEGER, INTENT(IN) :: & |
|---|
| 410 | & kumadt ! Output unit |
|---|
| 411 | |
|---|
| 412 | !! * Local declarations |
|---|
| 413 | REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: & |
|---|
| 414 | & zu_tlin, & ! Tangent input: ua_tl |
|---|
| 415 | & zv_tlin, & ! Tangent input: va_tl |
|---|
| 416 | & zt_tlin, & ! Tangent input: ub_tl |
|---|
| 417 | & zu_tlout, & ! Tangent output: ua_tl |
|---|
| 418 | & zv_tlout, & ! Tangent output: va_tl |
|---|
| 419 | & zt_tlout, & ! Tangent output: ua_tl |
|---|
| 420 | & zu_adin, & ! Tangent output: ua_ad |
|---|
| 421 | & zv_adin, & ! Tangent output: va_ad |
|---|
| 422 | & zt_adin, & ! Adjoint input: ua_ad |
|---|
| 423 | & z_adin, & ! Adjoint input: va_ad |
|---|
| 424 | & zu_adout, & ! Adjoint output: ua_ad |
|---|
| 425 | & zv_adout, & ! Adjoint output: va_ad |
|---|
| 426 | & zt_adout, & ! Adjoint oputput: ub_ad |
|---|
| 427 | & znu ! 3D random field for u |
|---|
| 428 | |
|---|
| 429 | REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: & |
|---|
| 430 | & zu_tl, & ! Tangent input: ua_tl |
|---|
| 431 | & zv_tl, & ! Tangent input: va_tl |
|---|
| 432 | & zt_tl, & ! Tangent input: ub_tl |
|---|
| 433 | & zu_ad, & ! Tangent output: ua_ad |
|---|
| 434 | & zv_ad, & ! Tangent output: va_ad |
|---|
| 435 | & zt_ad |
|---|
| 436 | REAL(wp) :: & |
|---|
| 437 | & zsp1, & ! scalar product involving the tangent routine |
|---|
| 438 | & zsp2 ! scalar product involving the adjoint routine |
|---|
| 439 | INTEGER, DIMENSION(jpi,jpj) :: & |
|---|
| 440 | & iseed_2d ! 2D seed for the random number generator |
|---|
| 441 | CHARACTER(len=1) :: & |
|---|
| 442 | & cd_type |
|---|
| 443 | INTEGER :: & |
|---|
| 444 | & indic, & |
|---|
| 445 | & istp |
|---|
| 446 | INTEGER :: & |
|---|
| 447 | & ji, & |
|---|
| 448 | & jj, & |
|---|
| 449 | & jk, & |
|---|
| 450 | & kmod, & |
|---|
| 451 | & jstp |
|---|
| 452 | CHARACTER (LEN=14) :: & |
|---|
| 453 | & cl_name |
|---|
| 454 | INTEGER :: & |
|---|
| 455 | & zijpj, ziglo, zip, zdiff |
|---|
| 456 | |
|---|
| 457 | ! Allocate memory |
|---|
| 458 | |
|---|
| 459 | zijpj = 4 |
|---|
| 460 | |
|---|
| 461 | ALLOCATE( & |
|---|
| 462 | & zu_tlin(jpiglo,zijpj,jpk), & |
|---|
| 463 | & zv_tlin(jpiglo,zijpj,jpk), & |
|---|
| 464 | & zt_tlin(jpiglo,zijpj,jpk), & |
|---|
| 465 | & zu_tlout(jpiglo,zijpj,jpk), & |
|---|
| 466 | & zv_tlout(jpiglo,zijpj,jpk), & |
|---|
| 467 | & zt_tlout(jpiglo,zijpj,jpk), & |
|---|
| 468 | & zu_adin(jpiglo,zijpj,jpk), & |
|---|
| 469 | & zv_adin(jpiglo,zijpj,jpk), & |
|---|
| 470 | & zt_adin(jpiglo,zijpj,jpk), & |
|---|
| 471 | & zu_adout(jpiglo,zijpj,jpk), & |
|---|
| 472 | & zv_adout(jpiglo,zijpj,jpk), & |
|---|
| 473 | & zt_adout(jpiglo,zijpj,jpk), & |
|---|
| 474 | & znu(jpi,jpj,jpk) & |
|---|
| 475 | & ) |
|---|
| 476 | |
|---|
| 477 | ALLOCATE( & |
|---|
| 478 | & zu_tl(jpiglo,zijpj,jpk), & |
|---|
| 479 | & zv_tl(jpiglo,zijpj,jpk), & |
|---|
| 480 | & zt_tl(jpiglo,zijpj,jpk), & |
|---|
| 481 | & zu_ad(jpiglo,zijpj,jpk), & |
|---|
| 482 | & zv_ad(jpiglo,zijpj,jpk), & |
|---|
| 483 | & zt_ad(jpiglo,zijpj,jpk) & |
|---|
| 484 | & ) |
|---|
| 485 | |
|---|
| 486 | zu_tlin (:,:,:) = 0.0_wp |
|---|
| 487 | zv_tlin (:,:,:) = 0.0_wp |
|---|
| 488 | zt_tlin (:,:,:) = 0.0_wp |
|---|
| 489 | zu_tlout(:,:,:) = 0.0_wp |
|---|
| 490 | zv_tlout(:,:,:) = 0.0_wp |
|---|
| 491 | zt_tlout(:,:,:) = 0.0_wp |
|---|
| 492 | zu_adin (:,:,:) = 0.0_wp |
|---|
| 493 | zv_adin (:,:,:) = 0.0_wp |
|---|
| 494 | zt_adin (:,:,:) = 0.0_wp |
|---|
| 495 | zu_adout(:,:,:) = 0.0_wp |
|---|
| 496 | zv_adout(:,:,:) = 0.0_wp |
|---|
| 497 | zt_adout(:,:,:) = 0.0_wp |
|---|
| 498 | |
|---|
| 499 | zu_tl (:,:,:) = 0.0_wp |
|---|
| 500 | zv_tl (:,:,:) = 0.0_wp |
|---|
| 501 | zt_tl (:,:,:) = 0.0_wp |
|---|
| 502 | zu_ad (:,:,:) = 0.0_wp |
|---|
| 503 | zv_ad (:,:,:) = 0.0_wp |
|---|
| 504 | zt_ad (:,:,:) = 0.0_wp |
|---|
| 505 | |
|---|
| 506 | ziglo = INT(jpiglo / (nlei - nldi) ) |
|---|
| 507 | zdiff = nlei - nldi |
|---|
| 508 | !-------------------------------------------------------------------- |
|---|
| 509 | ! Initialize the tangent input with random noise: dx |
|---|
| 510 | !-------------------------------------------------------------------- |
|---|
| 511 | DO jj = 1, jpj |
|---|
| 512 | DO ji = 1, jpi |
|---|
| 513 | iseed_2d(ji,jj) = - ( 456953 + & |
|---|
| 514 | & mig(ji) + ( mjg(jj) - 1 ) * jpiglo ) |
|---|
| 515 | END DO |
|---|
| 516 | END DO |
|---|
| 517 | CALL grid_random( iseed_2d, znu, 'U', 0.0_wp, stdu ) |
|---|
| 518 | DO jk = 1, jpk |
|---|
| 519 | DO jj = 1, 4 |
|---|
| 520 | DO ji = nldi, nlei |
|---|
| 521 | DO zip = 1, ziglo |
|---|
| 522 | zu_tlin(ji+(zip-1)*zdiff,jj,jk) = znu(ji,jj,jk) |
|---|
| 523 | ENDDO |
|---|
| 524 | END DO |
|---|
| 525 | END DO |
|---|
| 526 | END DO |
|---|
| 527 | DO jj = 1, jpj |
|---|
| 528 | DO ji = 1, jpi |
|---|
| 529 | iseed_2d(ji,jj) = - ( 3434334 + & |
|---|
| 530 | & mig(ji) + ( mjg(jj) - 1 ) * jpiglo ) |
|---|
| 531 | END DO |
|---|
| 532 | END DO |
|---|
| 533 | CALL grid_random( iseed_2d, znu, 'V', 0.0_wp, stdu ) |
|---|
| 534 | DO jk = 1, jpk |
|---|
| 535 | DO jj = 1, 4 |
|---|
| 536 | DO ji = nldi, nlei |
|---|
| 537 | DO zip = 1, ziglo |
|---|
| 538 | zv_tlin(ji+(zip-1)*zdiff,jj,jk) = znu(ji,jj,jk) |
|---|
| 539 | ENDDO |
|---|
| 540 | END DO |
|---|
| 541 | END DO |
|---|
| 542 | END DO |
|---|
| 543 | DO jj = 1, jpj |
|---|
| 544 | DO ji = 1, jpi |
|---|
| 545 | iseed_2d(ji,jj) = - ( 935678 + & |
|---|
| 546 | & mig(ji) + ( mjg(jj) - 1 ) * jpiglo ) |
|---|
| 547 | END DO |
|---|
| 548 | END DO |
|---|
| 549 | CALL grid_random( iseed_2d, znu, 'T', 0.0_wp, stdt ) |
|---|
| 550 | DO jk = 1, jpk |
|---|
| 551 | DO jj = 1, 4 |
|---|
| 552 | DO ji = nldi, nlei |
|---|
| 553 | DO zip = 1, ziglo |
|---|
| 554 | zt_tlin(ji+(zip-1)*zdiff,jj,jk) = znu(ji,jj,jk) |
|---|
| 555 | ENDDO |
|---|
| 556 | END DO |
|---|
| 557 | END DO |
|---|
| 558 | END DO |
|---|
| 559 | |
|---|
| 560 | !-------------------------------------------------------------------- |
|---|
| 561 | ! Call the tangent routine: dy = L dx |
|---|
| 562 | !-------------------------------------------------------------------- |
|---|
| 563 | zu_tl(:,:,:) = zu_tlin(:,:,:) |
|---|
| 564 | zv_tl(:,:,:) = zv_tlin(:,:,:) |
|---|
| 565 | zt_tl(:,:,:) = zt_tlin(:,:,:) |
|---|
| 566 | |
|---|
| 567 | CALL lbc_nfd( zu_tl, 'U', -1.0_wp ) |
|---|
| 568 | CALL lbc_nfd( zv_tl, 'V', -1.0_wp ) |
|---|
| 569 | CALL lbc_nfd( zt_tl, 'T', 1.0_wp ) |
|---|
| 570 | zu_tlout(:,:,:) = zu_tl(:,:,:) |
|---|
| 571 | zv_tlout(:,:,:) = zv_tl(:,:,:) |
|---|
| 572 | zt_tlout(:,:,:) = zt_tl(:,:,:) |
|---|
| 573 | |
|---|
| 574 | DO jk = 1, jpk |
|---|
| 575 | DO jj = 1,4 |
|---|
| 576 | DO ji = nldi, nlei |
|---|
| 577 | DO zip = 1, ziglo |
|---|
| 578 | zu_adin(ji+(zip-1)*zdiff,jj,jk) = zu_tlout(ji+(zip-1)*ziglo,jj,jk) & |
|---|
| 579 | & * e1u(ji,jj) * e2u(ji,jj) &!* fse3u(ji,jj,jk) & |
|---|
| 580 | & * umask(ji,jj,jk) |
|---|
| 581 | zv_adin(ji+(zip-1)*zdiff,jj,jk) = zv_tlout(ji+(zip-1)*ziglo,jj,jk) & |
|---|
| 582 | & * e1v(ji,jj) * e2v(ji,jj) &!* fse3v(ji,jj,jk) & |
|---|
| 583 | & * vmask(ji,jj,jk) |
|---|
| 584 | zt_adin(ji+(zip-1)*zdiff,jj,jk) = zt_tlout(ji+(zip-1)*ziglo,jj,jk) & |
|---|
| 585 | & * e1t(ji,jj) * e2t(ji,jj) &!* fse3t(ji,jj,jk) & |
|---|
| 586 | & * tmask(ji,jj,jk) |
|---|
| 587 | ENDDO |
|---|
| 588 | END DO |
|---|
| 589 | END DO |
|---|
| 590 | END DO |
|---|
| 591 | |
|---|
| 592 | ! DOT_PRODUCT |
|---|
| 593 | zsp1 = sum( & |
|---|
| 594 | & PACK(zu_tlout(:,:,:),.TRUE.) * & |
|---|
| 595 | & PACK( zu_adin(:,:,:),.TRUE.) ) |
|---|
| 596 | |
|---|
| 597 | zu_ad(:,:,:) = zu_adin(:,:,:) |
|---|
| 598 | zv_ad(:,:,:) = zv_adin(:,:,:) |
|---|
| 599 | zt_ad(:,:,:) = zt_adin(:,:,:) |
|---|
| 600 | |
|---|
| 601 | CALL lbc_nfd_adj( zu_ad, 'U', -1.0_wp ) |
|---|
| 602 | CALL lbc_nfd_adj( zv_ad, 'V', -1.0_wp ) |
|---|
| 603 | CALL lbc_nfd_adj( zt_ad, 'T', 1.0_wp ) |
|---|
| 604 | |
|---|
| 605 | zu_adout(:,:,:) = zu_ad(:,:,:) |
|---|
| 606 | zv_adout(:,:,:) = zv_ad(:,:,:) |
|---|
| 607 | zt_adout(:,:,:) = zt_ad(:,:,:) |
|---|
| 608 | |
|---|
| 609 | zsp2 = sum( & |
|---|
| 610 | & PACK(zu_tlin(:,:,:),.TRUE.) * & |
|---|
| 611 | & PACK( zu_adout(:,:,:),.TRUE.) ) |
|---|
| 612 | |
|---|
| 613 | cl_name = 'lbc_nfd U 3d' |
|---|
| 614 | CALL prntst_adj( cl_name, kumadt, zsp1, zsp2 ) |
|---|
| 615 | |
|---|
| 616 | zsp1 = sum( & |
|---|
| 617 | & PACK(zv_tlout(:,:,:),.TRUE.) * & |
|---|
| 618 | & PACK( zv_adin(:,:,:),.TRUE.) ) |
|---|
| 619 | |
|---|
| 620 | zsp2 = sum( & |
|---|
| 621 | & PACK(zv_tlin(:,:,:),.TRUE.) * & |
|---|
| 622 | & PACK( zv_adout(:,:,:),.TRUE.) ) |
|---|
| 623 | cl_name = 'lbc_nfd V 3d' |
|---|
| 624 | CALL prntst_adj( cl_name, kumadt, zsp1, zsp2 ) |
|---|
| 625 | |
|---|
| 626 | zsp1 = sum( & |
|---|
| 627 | & PACK(zt_tlout(:,:,:),.TRUE.) * & |
|---|
| 628 | & PACK( zt_adin(:,:,:),.TRUE.) ) |
|---|
| 629 | |
|---|
| 630 | zsp2 = sum( & |
|---|
| 631 | & PACK(zt_tlin(:,:,:),.TRUE.) * & |
|---|
| 632 | & PACK( zt_adout(:,:,:),.TRUE.) ) |
|---|
| 633 | cl_name = 'lbc_nfd T 3d' |
|---|
| 634 | CALL prntst_adj( cl_name, kumadt, zsp1, zsp2 ) |
|---|
| 635 | |
|---|
| 636 | END SUBROUTINE lbc_nfd_3d_adj_tst |
|---|
| 637 | |
|---|
| 638 | SUBROUTINE lbc_nfd_2d_adj_tst( kumadt ) |
|---|
| 639 | !!----------------------------------------------------------------------- |
|---|
| 640 | !! |
|---|
| 641 | !! *** ROUTINE lbc_nfd_2d_adj_tst *** |
|---|
| 642 | !! |
|---|
| 643 | !! ** Purpose : Test the adjoint routine. |
|---|
| 644 | !! |
|---|
| 645 | !! ** Method : Verify the scalar product |
|---|
| 646 | !! |
|---|
| 647 | !! ( L dx )^T W dy = dx^T L^T W dy |
|---|
| 648 | !! |
|---|
| 649 | !! where L = tangent routine |
|---|
| 650 | !! L^T = adjoint routine |
|---|
| 651 | !! W = diagonal matrix of scale factors |
|---|
| 652 | !! dx = input perturbation (random field) |
|---|
| 653 | !! dy = L dx |
|---|
| 654 | !! |
|---|
| 655 | !! ** Action : |
|---|
| 656 | !! |
|---|
| 657 | !! History : |
|---|
| 658 | !! ! 2010-09 (F. Vigilant) |
|---|
| 659 | !!----------------------------------------------------------------------- |
|---|
| 660 | !! * Modules used |
|---|
| 661 | USE gridrandom , ONLY: & ! Random Gaussian noise on grids |
|---|
| 662 | & grid_random |
|---|
| 663 | USE dotprodfld , ONLY: & ! Computes dot product for 3D and 2D fields |
|---|
| 664 | & dot_product |
|---|
| 665 | USE lbcnfd, ONLY: & |
|---|
| 666 | & lbc_nfd |
|---|
| 667 | USE tstool_tam , ONLY: & |
|---|
| 668 | & stdu, & |
|---|
| 669 | & stdv, & |
|---|
| 670 | & stdt, & |
|---|
| 671 | & prntst_adj |
|---|
| 672 | USE dom_oce , ONLY: & ! Ocean space and time domain |
|---|
| 673 | & e1u, & |
|---|
| 674 | & e2u, & |
|---|
| 675 | & e1v, & |
|---|
| 676 | & e2v, & |
|---|
| 677 | & e1t, & |
|---|
| 678 | & e2t, & |
|---|
| 679 | #if defined key_zco |
|---|
| 680 | & e3t_0, & |
|---|
| 681 | #else |
|---|
| 682 | & e3u, & |
|---|
| 683 | & e3v, & |
|---|
| 684 | #endif |
|---|
| 685 | & tmask, & |
|---|
| 686 | & umask, & |
|---|
| 687 | & vmask, & |
|---|
| 688 | & mig, & |
|---|
| 689 | & mjg, & |
|---|
| 690 | & nldi, & |
|---|
| 691 | & nldj, & |
|---|
| 692 | & nlei, & |
|---|
| 693 | & nlej |
|---|
| 694 | USE mppsumtam |
|---|
| 695 | !! * Arguments |
|---|
| 696 | INTEGER, INTENT(IN) :: & |
|---|
| 697 | & kumadt ! Output unit |
|---|
| 698 | |
|---|
| 699 | !! * Local declarations |
|---|
| 700 | REAL(wp), DIMENSION(:,:), ALLOCATABLE :: & |
|---|
| 701 | & zu_tlin, & ! Tangent input: ua_tl |
|---|
| 702 | & zv_tlin, & ! Tangent input: va_tl |
|---|
| 703 | & zt_tlin, & ! Tangent input: ub_tl |
|---|
| 704 | & zu_tlout, & ! Tangent output: ua_tl |
|---|
| 705 | & zv_tlout, & ! Tangent output: va_tl |
|---|
| 706 | & zt_tlout, & ! Tangent output: ua_tl |
|---|
| 707 | & zu_adin, & ! Tangent output: ua_ad |
|---|
| 708 | & zv_adin, & ! Tangent output: va_ad |
|---|
| 709 | & zt_adin, & ! Adjoint input: ua_ad |
|---|
| 710 | & z_adin, & ! Adjoint input: va_ad |
|---|
| 711 | & zu_adout, & ! Adjoint output: ua_ad |
|---|
| 712 | & zv_adout, & ! Adjoint output: va_ad |
|---|
| 713 | & zt_adout, & ! Adjoint oputput: ub_ad |
|---|
| 714 | & znu ! 3D random field for u |
|---|
| 715 | |
|---|
| 716 | REAL(wp), DIMENSION(:,:), ALLOCATABLE :: & |
|---|
| 717 | & zu_tl, & ! Tangent input: ua_tl |
|---|
| 718 | & zv_tl, & ! Tangent input: va_tl |
|---|
| 719 | & zt_tl, & ! Tangent input: ub_tl |
|---|
| 720 | & zu_ad, & ! Tangent output: ua_ad |
|---|
| 721 | & zv_ad, & ! Tangent output: va_ad |
|---|
| 722 | & zt_ad |
|---|
| 723 | REAL(wp) :: & |
|---|
| 724 | & zsp1, & ! scalar product involving the tangent routine |
|---|
| 725 | & zsp2 ! scalar product involving the adjoint routine |
|---|
| 726 | INTEGER, DIMENSION(jpi,jpj) :: & |
|---|
| 727 | & iseed_2d ! 2D seed for the random number generator |
|---|
| 728 | CHARACTER(len=1) :: & |
|---|
| 729 | & cd_type |
|---|
| 730 | INTEGER :: & |
|---|
| 731 | & indic, & |
|---|
| 732 | & istp |
|---|
| 733 | INTEGER :: & |
|---|
| 734 | & ji, & |
|---|
| 735 | & jj, & |
|---|
| 736 | & jk, & |
|---|
| 737 | & kmod, & |
|---|
| 738 | & jstp |
|---|
| 739 | CHARACTER (LEN=14) :: & |
|---|
| 740 | & cl_name |
|---|
| 741 | INTEGER :: & |
|---|
| 742 | & zijpj, ziglo, zip, zdiff |
|---|
| 743 | |
|---|
| 744 | ! Allocate memory |
|---|
| 745 | |
|---|
| 746 | zijpj = 4 |
|---|
| 747 | |
|---|
| 748 | ALLOCATE( & |
|---|
| 749 | & zu_tlin(jpiglo,zijpj), & |
|---|
| 750 | & zv_tlin(jpiglo,zijpj), & |
|---|
| 751 | & zt_tlin(jpiglo,zijpj), & |
|---|
| 752 | & zu_tlout(jpiglo,zijpj), & |
|---|
| 753 | & zv_tlout(jpiglo,zijpj), & |
|---|
| 754 | & zt_tlout(jpiglo,zijpj), & |
|---|
| 755 | & zu_adin(jpiglo,zijpj), & |
|---|
| 756 | & zv_adin(jpiglo,zijpj), & |
|---|
| 757 | & zt_adin(jpiglo,zijpj), & |
|---|
| 758 | & zu_adout(jpiglo,zijpj), & |
|---|
| 759 | & zv_adout(jpiglo,zijpj), & |
|---|
| 760 | & zt_adout(jpiglo,zijpj), & |
|---|
| 761 | & znu(jpi,jpj) & |
|---|
| 762 | & ) |
|---|
| 763 | |
|---|
| 764 | ALLOCATE( & |
|---|
| 765 | & zu_tl(jpiglo,zijpj), & |
|---|
| 766 | & zv_tl(jpiglo,zijpj), & |
|---|
| 767 | & zt_tl(jpiglo,zijpj), & |
|---|
| 768 | & zu_ad(jpiglo,zijpj), & |
|---|
| 769 | & zv_ad(jpiglo,zijpj), & |
|---|
| 770 | & zt_ad(jpiglo,zijpj) & |
|---|
| 771 | & ) |
|---|
| 772 | |
|---|
| 773 | zu_tlin (:,:) = 0.0_wp |
|---|
| 774 | zv_tlin (:,:) = 0.0_wp |
|---|
| 775 | zt_tlin (:,:) = 0.0_wp |
|---|
| 776 | zu_tlout(:,:) = 0.0_wp |
|---|
| 777 | zv_tlout(:,:) = 0.0_wp |
|---|
| 778 | zt_tlout(:,:) = 0.0_wp |
|---|
| 779 | zu_adin (:,:) = 0.0_wp |
|---|
| 780 | zv_adin (:,:) = 0.0_wp |
|---|
| 781 | zt_adin (:,:) = 0.0_wp |
|---|
| 782 | zu_adout(:,:) = 0.0_wp |
|---|
| 783 | zv_adout(:,:) = 0.0_wp |
|---|
| 784 | zt_adout(:,:) = 0.0_wp |
|---|
| 785 | |
|---|
| 786 | zu_tl (:,:) = 0.0_wp |
|---|
| 787 | zv_tl (:,:) = 0.0_wp |
|---|
| 788 | zt_tl (:,:) = 0.0_wp |
|---|
| 789 | zu_ad (:,:) = 0.0_wp |
|---|
| 790 | zv_ad (:,:) = 0.0_wp |
|---|
| 791 | zt_ad (:,:) = 0.0_wp |
|---|
| 792 | |
|---|
| 793 | ziglo = INT(jpiglo / (nlei - nldi) ) |
|---|
| 794 | zdiff = nlei - nldi |
|---|
| 795 | !-------------------------------------------------------------------- |
|---|
| 796 | ! Initialize the tangent input with random noise: dx |
|---|
| 797 | !-------------------------------------------------------------------- |
|---|
| 798 | DO jj = 1, jpj |
|---|
| 799 | DO ji = 1, jpi |
|---|
| 800 | iseed_2d(ji,jj) = - ( 456953 + & |
|---|
| 801 | & mig(ji) + ( mjg(jj) - 1 ) * jpiglo ) |
|---|
| 802 | END DO |
|---|
| 803 | END DO |
|---|
| 804 | CALL grid_random( iseed_2d, znu, 'U', 0.0_wp, stdu ) |
|---|
| 805 | DO jj = 1, 4 |
|---|
| 806 | DO ji = nldi, nlei |
|---|
| 807 | DO zip = 1, ziglo |
|---|
| 808 | zu_tlin(ji+(zip-1)*zdiff,jj) = znu(ji,jj) |
|---|
| 809 | END DO |
|---|
| 810 | END DO |
|---|
| 811 | END DO |
|---|
| 812 | DO jj = 1, jpj |
|---|
| 813 | DO ji = 1, jpi |
|---|
| 814 | iseed_2d(ji,jj) = - ( 3434334 + & |
|---|
| 815 | & mig(ji) + ( mjg(jj) - 1 ) * jpiglo ) |
|---|
| 816 | END DO |
|---|
| 817 | END DO |
|---|
| 818 | CALL grid_random( iseed_2d, znu, 'V', 0.0_wp, stdu ) |
|---|
| 819 | DO jj = 1, 4 |
|---|
| 820 | DO ji = nldi, nlei |
|---|
| 821 | DO zip = 1, ziglo |
|---|
| 822 | zv_tlin(ji+(zip-1)*zdiff,jj) = znu(ji,jj) |
|---|
| 823 | END DO |
|---|
| 824 | END DO |
|---|
| 825 | END DO |
|---|
| 826 | DO jj = 1, jpj |
|---|
| 827 | DO ji = 1, jpi |
|---|
| 828 | iseed_2d(ji,jj) = - ( 935678 + & |
|---|
| 829 | & mig(ji) + ( mjg(jj) - 1 ) * jpiglo ) |
|---|
| 830 | END DO |
|---|
| 831 | END DO |
|---|
| 832 | CALL grid_random( iseed_2d, znu, 'T', 0.0_wp, stdt ) |
|---|
| 833 | DO jj = 1, 4 |
|---|
| 834 | DO ji = nldi, nlei |
|---|
| 835 | DO zip = 1, ziglo |
|---|
| 836 | zt_tlin(ji+(zip-1)*zdiff,jj) = znu(ji,jj) |
|---|
| 837 | END DO |
|---|
| 838 | END DO |
|---|
| 839 | END DO |
|---|
| 840 | |
|---|
| 841 | !-------------------------------------------------------------------- |
|---|
| 842 | ! Call the tangent routine: dy = L dx |
|---|
| 843 | !-------------------------------------------------------------------- |
|---|
| 844 | zu_tl(:,:) = zu_tlin(:,:) |
|---|
| 845 | zv_tl(:,:) = zv_tlin(:,:) |
|---|
| 846 | zt_tl(:,:) = zt_tlin(:,:) |
|---|
| 847 | |
|---|
| 848 | CALL lbc_nfd( zu_tl, 'U', -1.0_wp ) |
|---|
| 849 | CALL lbc_nfd( zv_tl, 'V', -1.0_wp ) |
|---|
| 850 | CALL lbc_nfd( zt_tl, 'T', 1.0_wp ) |
|---|
| 851 | zu_tlout(:,:) = zu_tl(:,:) |
|---|
| 852 | zv_tlout(:,:) = zv_tl(:,:) |
|---|
| 853 | zt_tlout(:,:) = zt_tl(:,:) |
|---|
| 854 | |
|---|
| 855 | DO jj = 1,4 |
|---|
| 856 | DO ji = nldi, nlei |
|---|
| 857 | DO zip = 1, ziglo |
|---|
| 858 | zu_adin(ji+(zip-1)*zdiff,jj) = zu_tlout(ji+(zip-1)*ziglo,jj) & |
|---|
| 859 | & * e1u(ji,jj) * e2u(ji,jj) &!* fse3u(ji,jj) & |
|---|
| 860 | & * umask(ji,jj,1) |
|---|
| 861 | zv_adin(ji+(zip-1)*zdiff,jj) = zv_tlout(ji+(zip-1)*ziglo,jj) & |
|---|
| 862 | & * e1v(ji,jj) * e2v(ji,jj) &!* fse3v(ji,jj) & |
|---|
| 863 | & * vmask(ji,jj,1) |
|---|
| 864 | zt_adin(ji+(zip-1)*zdiff,jj) = zt_tlout(ji+(zip-1)*ziglo,jj) & |
|---|
| 865 | & * e1t(ji,jj) * e2t(ji,jj) &!* fse3t(ji,jj) & |
|---|
| 866 | & * tmask(ji,jj,1) |
|---|
| 867 | END DO |
|---|
| 868 | END DO |
|---|
| 869 | END DO |
|---|
| 870 | |
|---|
| 871 | zsp1 = sum( & |
|---|
| 872 | & PACK(zu_tlout(:,:),.TRUE.) * & |
|---|
| 873 | & PACK( zu_adin(:,:),.TRUE.) ) |
|---|
| 874 | zu_ad(:,:) = zu_adin(:,:) |
|---|
| 875 | zv_ad(:,:) = zv_adin(:,:) |
|---|
| 876 | zt_ad(:,:) = zt_adin(:,:) |
|---|
| 877 | |
|---|
| 878 | CALL lbc_nfd_adj( zu_ad, 'U', -1.0_wp ) |
|---|
| 879 | CALL lbc_nfd_adj( zv_ad, 'V', -1.0_wp ) |
|---|
| 880 | CALL lbc_nfd_adj( zt_ad, 'T', 1.0_wp ) |
|---|
| 881 | |
|---|
| 882 | zu_adout(:,:) = zu_ad(:,:) |
|---|
| 883 | zv_adout(:,:) = zv_ad(:,:) |
|---|
| 884 | zt_adout(:,:) = zt_ad(:,:) |
|---|
| 885 | |
|---|
| 886 | zsp2 = sum( & |
|---|
| 887 | & PACK(zu_tlin(:,:),.TRUE.) * & |
|---|
| 888 | & PACK( zu_adout(:,:),.TRUE.) ) |
|---|
| 889 | cl_name = 'lbc_nfd U 2d' |
|---|
| 890 | CALL prntst_adj( cl_name, kumadt, zsp1, zsp2 ) |
|---|
| 891 | |
|---|
| 892 | zsp1 = sum( & |
|---|
| 893 | & PACK(zv_tlout(:,:),.TRUE.) * & |
|---|
| 894 | & PACK( zv_adin(:,:),.TRUE.) ) |
|---|
| 895 | |
|---|
| 896 | zsp2 = sum( & |
|---|
| 897 | & PACK(zv_tlin(:,:),.TRUE.) * & |
|---|
| 898 | & PACK( zv_adout(:,:),.TRUE.) ) |
|---|
| 899 | cl_name = 'lbc_nfd V 2d' |
|---|
| 900 | CALL prntst_adj( cl_name, kumadt, zsp1, zsp2 ) |
|---|
| 901 | |
|---|
| 902 | zsp1 = sum( & |
|---|
| 903 | & PACK(zt_tlout(:,:),.TRUE.) * & |
|---|
| 904 | & PACK( zt_adin(:,:),.TRUE.) ) |
|---|
| 905 | |
|---|
| 906 | zsp2 = sum( & |
|---|
| 907 | & PACK(zt_tlin(:,:),.TRUE.) * & |
|---|
| 908 | & PACK( zt_adout(:,:),.TRUE.) ) |
|---|
| 909 | cl_name = 'lbc_nfd T 2d' |
|---|
| 910 | CALL prntst_adj( cl_name, kumadt, zsp1, zsp2 ) |
|---|
| 911 | |
|---|
| 912 | END SUBROUTINE lbc_nfd_2d_adj_tst |
|---|
| 913 | |
|---|
| 914 | SUBROUTINE lbc_nfd_adj_tst( kumadt ) |
|---|
| 915 | !!----------------------------------------------------------------------- |
|---|
| 916 | !! |
|---|
| 917 | !! *** ROUTINE lbc_nfd_adj_tst *** |
|---|
| 918 | !! |
|---|
| 919 | !! ** Purpose : Test the adjoint routine. |
|---|
| 920 | !! |
|---|
| 921 | !! ** Method : Verify the scalar product |
|---|
| 922 | !! |
|---|
| 923 | !! ( L dx )^T W dy = dx^T L^T W dy |
|---|
| 924 | !! |
|---|
| 925 | !! where L = tangent routine |
|---|
| 926 | !! L^T = adjoint routine |
|---|
| 927 | !! W = diagonal matrix of scale factors |
|---|
| 928 | !! dx = input perturbation (random field) |
|---|
| 929 | !! dy = L dx |
|---|
| 930 | !! |
|---|
| 931 | !! ** Action : |
|---|
| 932 | !! |
|---|
| 933 | !! History : |
|---|
| 934 | !! ! 2010-09 (F. Vigilant) |
|---|
| 935 | !!----------------------------------------------------------------------- |
|---|
| 936 | !! * Modules used |
|---|
| 937 | !! * Arguments |
|---|
| 938 | INTEGER, INTENT(IN) :: & |
|---|
| 939 | & kumadt ! Output unit |
|---|
| 940 | |
|---|
| 941 | CALL lbc_nfd_3d_adj_tst( kumadt ) |
|---|
| 942 | CALL lbc_nfd_2d_adj_tst( kumadt ) |
|---|
| 943 | |
|---|
| 944 | END SUBROUTINE lbc_nfd_adj_tst |
|---|
| 945 | !!====================================================================== |
|---|
| 946 | END MODULE lbcnfd_tam |
|---|
