Changeset 31 for trunk/NEMO/OPA_SRC/DYN
- Timestamp:
- 2004-02-17T10:19:59+01:00 (20 years ago)
- Location:
- trunk/NEMO/OPA_SRC/DYN
- Files:
-
- 3 edited
-
dynspg_fsc.F90 (modified) (9 diffs)
-
dynspg_fsc_atsk.F90 (modified) (8 diffs)
-
dynspg_rl.F90 (modified) (8 diffs)
Legend:
- Unmodified
- Added
- Removed
-
trunk/NEMO/OPA_SRC/DYN/dynspg_fsc.F90
r3 r31 41 41 42 42 !! * Shared module variables 43 LOGICAL, PUBLIC, PARAMETER :: lk_dynspg_fsc = .TRUE. ! free surface constant volume flag43 LOGICAL, PUBLIC, PARAMETER :: lk_dynspg_fsc = .TRUE. !: free surface constant volume flag 44 44 45 45 !! * Substitutions … … 80 80 !! where (spgu,spgv) are given by: 81 81 !! spgu = vertical sum[ e3u (ub+ 2 rdt ua ) ] 82 !! - g 2 rdt hu /e1u di[sshn + emp]82 !! - grav 2 rdt hu /e1u di[sshn + emp] 83 83 !! spgv = vertical sum[ e3v (vb+ 2 rdt va) ] 84 !! - g 2 rdt hv /e2v dj[sshn + emp]84 !! - grav 2 rdt hv /e2v dj[sshn + emp] 85 85 !! and define the first guess from previous computation : 86 86 !! zbtd = btda … … 127 127 spgu(:,:) = 0.e0 ! surface pressur gradient (i-direction) 128 128 spgv(:,:) = 0.e0 ! surface pressur gradient (j-direction) 129 IF( .NOT.ln_rstart ) THEN130 sshb(:,:) = 0.e0 ! before sea-surface height131 sshn(:,:) = 0.e0 ! now sea-surface height132 ENDIF133 129 ENDIF 134 130 … … 140 136 IF( neuler == 0 .AND. kt == nit000 ) z2dt = rdt 141 137 ! coefficients 142 z2dtg = g * z2dt138 z2dtg = grav * z2dt 143 139 zraur = 1. / rauw 144 znugdt = rnu * g * z2dt140 znugdt = rnu * grav * z2dt 145 141 znurau = znugdt * zraur 146 #if defined key_mpp 147 ! Mpp : export boundary values of to neighboring processors148 !!bug : I don t understand why this only in mpp????149 CALL lbc_lnk( ua, 'U', -1. )150 CALL lbc_lnk( va, 'V', -1. )151 #endif 142 IF( lk_mpp ) THEN 143 ! Mpp : export boundary values of to neighboring processors 144 !!bug : I don t understand why this only in mpp???? ==> Can be suppressed, no? 145 CALL lbc_lnk( ua, 'U', -1. ) 146 CALL lbc_lnk( va, 'V', -1. ) 147 ENDIF 152 148 153 149 ! 1. Surface pressure gradient (now) … … 155 151 DO jj = 2, jpjm1 156 152 DO ji = fs_2, fs_jpim1 ! vector opt. 157 zspgu = - g * ( sshn(ji+1,jj) - sshn(ji,jj) ) / e1u(ji,jj)158 zspgv = - g * ( sshn(ji,jj+1) - sshn(ji,jj) ) / e2v(ji,jj)153 zspgu = - grav * ( sshn(ji+1,jj) - sshn(ji,jj) ) / e1u(ji,jj) 154 zspgv = - grav * ( sshn(ji,jj+1) - sshn(ji,jj) ) / e2v(ji,jj) 159 155 zegu = + znurau * ( emp (ji+1,jj) - emp (ji,jj) ) / e1u(ji,jj) 160 156 zegv = + znurau * ( emp (ji,jj+1) - emp (ji,jj) ) / e2v(ji,jj) … … 222 218 ! vertical sum 223 219 !CDIR NOLOOPCHG 224 DO jk = 1, jpkm1 225 #if defined key_vectopt_loop 226 DO ji = 1, jpij ! vector opt. 227 spgu(ji,1) = spgu(ji,1) + fse3u(ji,1,jk) * ua(ji,1,jk) 228 spgv(ji,1) = spgv(ji,1) + fse3v(ji,1,jk) * va(ji,1,jk) 229 END DO 230 #else 231 DO jj = 2, jpjm1 232 DO ji = 2, jpim1 ! NO vector opt. 233 spgu(ji,jj) = spgu(ji,jj) + fse3u(ji,jj,jk) * ua(ji,jj,jk) 234 spgv(ji,jj) = spgv(ji,jj) + fse3v(ji,jj,jk) * va(ji,jj,jk) 235 END DO 236 END DO 237 #endif 238 END DO 220 IF( lk_vopt_loop ) THEN ! vector opt., forced unroll 221 DO jk = 1, jpkm1 222 DO ji = 1, jpij 223 spgu(ji,1) = spgu(ji,1) + fse3u(ji,1,jk) * ua(ji,1,jk) 224 spgv(ji,1) = spgv(ji,1) + fse3v(ji,1,jk) * va(ji,1,jk) 225 END DO 226 END DO 227 ELSE ! No vector opt. 228 DO jk = 1, jpkm1 229 DO jj = 2, jpjm1 230 DO ji = 2, jpim1 231 spgu(ji,jj) = spgu(ji,jj) + fse3u(ji,jj,jk) * ua(ji,jj,jk) 232 spgv(ji,jj) = spgv(ji,jj) + fse3v(ji,jj,jk) * va(ji,jj,jk) 233 END DO 234 END DO 235 END DO 236 ENDIF 239 237 240 238 ! transport: multiplied by the horizontal scale factor … … 274 272 END DO 275 273 END DO 276 #if defined key_mpp 277 CALL mpp_sum( rnorme ) 278 #endif 274 IF( lk_mpp ) CALL mpp_sum( rnorme ) ! sum over the global domain 275 279 276 epsr = eps * eps * rnorme 280 277 ncut = 0 … … 296 293 CALL sol_pcg( kindic ) 297 294 ELSEIF( nsolv == 2 ) THEN ! successive-over-relaxation 298 CALL sol_sor( k t, kindic )295 CALL sol_sor( kindic ) 299 296 ELSEIF( nsolv == 3 ) THEN ! FETI solver 300 297 CALL sol_fet( kindic ) … … 391 388 !! Default case : Empty module No standart free surface cst volume 392 389 !!---------------------------------------------------------------------- 393 LOGICAL, PUBLIC, PARAMETER :: lk_dynspg_fsc = .FALSE. ! free surface constant volume flag390 LOGICAL, PUBLIC, PARAMETER :: lk_dynspg_fsc = .FALSE. !: free surface constant volume flag 394 391 CONTAINS 395 392 SUBROUTINE dyn_spg_fsc( kt, kindic ) ! Empty routine 396 WRITE(*,*) kt, kindic393 WRITE(*,*) 'dyn_spg_fsc: You should not have seen this print! error?', kt, kindic 397 394 END SUBROUTINE dyn_spg_fsc 398 395 #endif -
trunk/NEMO/OPA_SRC/DYN/dynspg_fsc_atsk.F90
r3 r31 43 43 44 44 !! * Shares module variables 45 LOGICAL, PUBLIC, PARAMETER :: lk_dynspg_fsc_tsk = .TRUE. ! free surf. cst vol. flag45 LOGICAL, PUBLIC, PARAMETER :: lk_dynspg_fsc_tsk = .TRUE. !: free surf. cst vol. flag 46 46 47 47 !! * Substitutions … … 81 81 !! where (spgu,spgv) are given by: 82 82 !! spgu = vertical sum[ e3u (ub+ 2 rdt ua ) ] 83 !! - g 2 rdt hu /e1u di[sshn + emp]83 !! - grav 2 rdt hu /e1u di[sshn + emp] 84 84 !! spgv = vertical sum[ e3v (vb+ 2 rdt va) ] 85 !! - g 2 rdt hv /e2v dj[sshn + emp]85 !! - grav 2 rdt hv /e2v dj[sshn + emp] 86 86 !! and define the first guess from previous computation : 87 87 !! zbtd = btda … … 128 128 spgu(:,:) = 0.e0 ! surface pressure gradient (i-direction) 129 129 spgv(:,:) = 0.e0 ! surface pressure gradient (j-direction) 130 IF( .NOT.ln_rstart ) THEN131 sshb(:,:) = 0.e0 ! before sea-surface height132 sshn(:,:) = 0.e0 ! now sea-surface height133 ENDIF134 130 ENDIF 135 131 … … 141 137 IF( neuler == 0 .AND. kt == nit000 ) z2dt = rdt 142 138 ! coefficients 143 z2dtg = g * z2dt139 z2dtg = grav * z2dt 144 140 zraur = 1. / rauw 145 znugdt = rnu * g * z2dt141 znugdt = rnu * grav * z2dt 146 142 znurau = znugdt * zraur 147 #if defined key_mpp 148 ! Mpp : export boundary values of to neighboring processors 149 !!bug ??? why only in mpp? is it really needed??? 150 CALL lbc_lnk( ua, 'U' , -1. ) 151 CALL lbc_lnk( va, 'V' , -1. ) 152 #endif 143 IF( lk_mpp ) THEN 144 ! Mpp : export boundary values of to neighboring processors 145 !!bug ??? why only in mpp? is it really needed??? 146 CALL lbc_lnk( ua, 'U' , -1. ) 147 CALL lbc_lnk( va, 'V' , -1. ) 148 ENDIF 149 153 150 ! ! =============== 154 151 DO jj = 2, jpjm1 ! Vertical slab … … 157 154 ! ---------------------------- 158 155 DO ji = 2, jpim1 159 zspgu = - g* ( sshn(ji+1,jj) - sshn(ji,jj) ) / e1u(ji,jj)160 zspgv = - g* ( sshn(ji,jj+1) - sshn(ji,jj) ) / e2v(ji,jj)156 zspgu = - grav * ( sshn(ji+1,jj) - sshn(ji,jj) ) / e1u(ji,jj) 157 zspgv = - grav * ( sshn(ji,jj+1) - sshn(ji,jj) ) / e2v(ji,jj) 161 158 zegu = + znurau * ( emp (ji+1,jj) - emp (ji,jj) ) / e1u(ji,jj) 162 159 zegv = + znurau * ( emp (ji,jj+1) - emp (ji,jj) ) / e2v(ji,jj) … … 286 283 END DO 287 284 END DO 288 #if defined key_mpp 289 CALL mpp_sum( rnorme ) 290 #endif 285 IF( lk_mpp ) CALL mpp_sum( rnorme ) ! sum over the global domain 286 291 287 epsr = eps * eps * rnorme 292 288 ncut = 0 … … 310 306 CALL sol_pcg( kindic ) 311 307 ELSEIF( nsolv == 2 ) THEN ! successive-over-relaxation 312 CALL sol_sor( k t, kindic )308 CALL sol_sor( kindic ) 313 309 ELSEIF( nsolv == 3 ) THEN ! FETI solver 314 310 CALL sol_fet( kindic ) … … 400 396 !! Default case : Empty module 401 397 !!---------------------------------------------------------------------- 402 LOGICAL, PUBLIC, PARAMETER :: lk_dynspg_fsc_tsk = .FALSE. ! free surf. cst vol. flag398 LOGICAL, PUBLIC, PARAMETER :: lk_dynspg_fsc_tsk = .FALSE. !: free surf. cst vol. flag 403 399 CONTAINS 404 400 SUBROUTINE dyn_spg_fsc_atsk( kt, kindic ) ! Empty module 405 WRITE(*,*) kt, kindic401 WRITE(*,*) 'dyn_spg_fsc_atsk: You should not have seen this print! error?', kt, kindic 406 402 END SUBROUTINE dyn_spg_fsc_atsk 407 403 #endif -
trunk/NEMO/OPA_SRC/DYN/dynspg_rl.F90
r3 r31 36 36 37 37 !! * Shared module variables 38 LOGICAL, PUBLIC, PARAMETER :: lk_dynspg_rl = .TRUE. !rigid-lid flag38 LOGICAL, PUBLIC, PARAMETER :: lk_dynspg_rl = .TRUE. !: rigid-lid flag 39 39 40 40 !! * Substitutions 41 41 # include "domzgr_substitute.h90" 42 42 # include "vectopt_loop_substitute.h90" 43 # include "obc_vectopt_loop_substitute.h90" 43 44 !!---------------------------------------------------------------------- 44 45 !! OPA 9.0 , LODYC-IPSL (2003) … … 115 116 spgu(:,:) = 0.e0 ! surface pressure gradient (i-direction) 116 117 spgv(:,:) = 0.e0 ! surface pressure gradient (j-direction) 117 bsfb(:,:) = 0.e0 ! before barotropic stream-function118 bsfn(:,:) = 0.e0 ! now barotropic stream-function119 bsfd(:,:) = 0.e0 ! barotropic stream-function trend120 118 ENDIF 121 119 … … 209 207 END DO 210 208 END DO 211 # if defined key_mpp 212 CALL mpp_sum( rnorme ) 213 # endif 209 IF( lk_mpp ) CALL mpp_sum( rnorme ) ! sum over the global domain 210 214 211 epsr = eps*eps*rnorme 215 212 ncut = 0 … … 229 226 CALL sol_pcg( kindic ) 230 227 CASE( 2 ) ! successive-over-relaxation 231 CALL sol_sor( k t, kindic )228 CALL sol_sor( kindic ) 232 229 CASE( 3 ) ! FETI solver 233 230 CALL sol_fet( kindic ) … … 400 397 END DO 401 398 END DO 402 # if defined key_mpp 403 CALL mppobc( bebnd, jpjed, jpjef, jpieob, 3*3, 2, jpj ) 404 # endif 399 IF( lk_mpp ) CALL mppobc( bebnd, jpjed, jpjef, jpieob, 3*3, 2, jpj ) 405 400 ENDIF 406 401 … … 436 431 END DO 437 432 END DO 438 # if defined key_mpp 439 CALL mppobc( bwbnd, jpjwd, jpjwf, jpiwob, 3*3, 2, jpj ) 440 # endif 433 IF( lk_mpp ) CALL mppobc( bwbnd, jpjwd, jpjwf, jpiwob, 3*3, 2, jpj ) 441 434 ENDIF 442 435 … … 472 465 END DO 473 466 END DO 474 # if defined key_mpp 475 CALL mppobc( bnbnd, jpind, jpinf, jpjnob, 3*3, 1, jpi ) 476 # endif 467 IF( lk_mpp ) CALL mppobc( bnbnd, jpind, jpinf, jpjnob, 3*3, 1, jpi ) 477 468 ENDIF 478 469 479 470 IF( lpsouthobc ) THEN 480 ! njsob,(jpsd,jpsf) 481 IF( kt < nit000+3 .AND. .NOT.ln_rstart ) THEN 482 DO ji = nis0m1, nis1 483 ! fields itm2 <== itm 484 bsbnd(ji,ib ,itm2) = bsbnd(ji,ib ,itm) 485 bsbnd(ji,ibm ,itm2) = bsbnd(ji,ibm ,itm) 486 bsbnd(ji,ibm2,itm2) = bsbnd(ji,ibm2,itm) 487 bsbnd(ji,ib ,itm ) = bsbnd(ji,ib ,it ) 488 END DO 489 ELSE 490 DO jj = fs_njs0, fs_njs1 ! vector opt. 471 ! njsob,(jpsd,jpsf) 472 IF( kt < nit000+3 .AND. .NOT.ln_rstart ) THEN 491 473 DO ji = nis0m1, nis1 474 ! fields itm2 <== itm 492 475 bsbnd(ji,ib ,itm2) = bsbnd(ji,ib ,itm) 493 476 bsbnd(ji,ibm ,itm2) = bsbnd(ji,ibm ,itm) 494 477 bsbnd(ji,ibm2,itm2) = bsbnd(ji,ibm2,itm) 495 ! fields itm <== it plus time filter at the boundary 496 bsbnd(jj,ib ,itm ) = atfp * ( bsbnd(jj,ib,itm) + bsfn(ji,jj) ) + atfp1 * bsbnd(jj,ib,it) 497 bsbnd(ji,ibm ,itm ) = bsbnd(ji,ibm ,it ) 498 bsbnd(ji,ibm2,itm ) = bsbnd(ji,ibm2,it ) 499 END DO 500 END DO 501 ENDIF 502 DO jj = fs_njs0, fs_njs1 ! vector opt. 503 DO ji = nis0m1, nis1 504 ! fields it <== now (kt+1) 505 bsbnd(ji,ib ,it ) = bsfn (ji,jj ) 506 bsbnd(ji,ibm ,it ) = bsfn (ji,jj+1) 507 bsbnd(ji,ibm2,it ) = bsfn (ji,jj+2) 508 END DO 509 END DO 510 # if defined key_mpp 511 CALL mppobc( bsbnd, jpisd, jpisf, jpjsob, 3*3, 1, jpi ) 512 # endif 478 bsbnd(ji,ib ,itm ) = bsbnd(ji,ib ,it ) 479 END DO 480 ELSE 481 DO jj = fs_njs0, fs_njs1 ! vector opt. 482 DO ji = nis0m1, nis1 483 bsbnd(ji,ib ,itm2) = bsbnd(ji,ib ,itm) 484 bsbnd(ji,ibm ,itm2) = bsbnd(ji,ibm ,itm) 485 bsbnd(ji,ibm2,itm2) = bsbnd(ji,ibm2,itm) 486 ! fields itm <== it plus time filter at the boundary 487 bsbnd(jj,ib ,itm ) = atfp * ( bsbnd(jj,ib,itm) + bsfn(ji,jj) ) + atfp1 * bsbnd(jj,ib,it) 488 bsbnd(ji,ibm ,itm ) = bsbnd(ji,ibm ,it ) 489 bsbnd(ji,ibm2,itm ) = bsbnd(ji,ibm2,it ) 490 END DO 491 END DO 492 ENDIF 493 DO jj = fs_njs0, fs_njs1 ! vector opt. 494 DO ji = nis0m1, nis1 495 ! fields it <== now (kt+1) 496 bsbnd(ji,ib ,it ) = bsfn (ji,jj ) 497 bsbnd(ji,ibm ,it ) = bsfn (ji,jj+1) 498 bsbnd(ji,ibm2,it ) = bsfn (ji,jj+2) 499 END DO 500 END DO 501 IF( lk_mpp ) CALL mppobc( bsbnd, jpisd, jpisf, jpjsob, 3*3, 1, jpi ) 513 502 ENDIF 514 503 # endif … … 547 536 !! 'key_dynspg_rl' NO rigid lid 548 537 !!---------------------------------------------------------------------- 549 LOGICAL, PUBLIC, PARAMETER :: lk_dynspg_rl = .FALSE. ! rigid-lid flag538 LOGICAL, PUBLIC, PARAMETER :: lk_dynspg_rl = .FALSE. !: rigid-lid flag 550 539 CONTAINS 551 540 SUBROUTINE dyn_spg_rl( kt, kindic ) ! Empty routine 552 WRITE(*,*) kt, kindic541 WRITE(*,*) 'dyn_spg_rl: You should not have seen this print! error?', kt, kindic 553 542 END SUBROUTINE dyn_spg_rl 554 543 #endif
Note: See TracChangeset
for help on using the changeset viewer.
