- Timestamp:
- 2011-06-27T13:18:25+02:00 (13 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/2011/dev_r2787_LOCEAN3_TRA_TRP/NEMOGCM/NEMO/OPA_SRC/LDF/ldfslp.F90
r2772 r2789 116 116 !!---------------------------------------------------------------------- 117 117 USE wrk_nemo, ONLY: wrk_in_use, wrk_not_released 118 USE oce , ONLY: z gru=> ua , zww => va ! (ua,va) used as workspace119 USE oce , ONLY: zgrv => ta , zwz => sa ! (ta,sa) used as workspace120 USE wrk_nemo, ONLY: zdzr => wrk_3d_1 118 USE oce , ONLY: zwz => ua , zww => va ! (ua,va) used as workspace 119 USE oce , ONLY: tsa ! (tsa) used as workspace 120 USE wrk_nemo, ONLY: zdzr => wrk_3d_1 ! 3D workspace 121 121 !! 122 122 INTEGER , INTENT(in) :: kt ! ocean time-step index … … 131 131 REAL(wp) :: zcj, zfj, zav, zbv, zaj, zbj ! - - 132 132 REAL(wp) :: zck, zfk, zbw ! - - 133 REAL(wp), POINTER, DIMENSION(:,:,:) :: zgru, zgrv 133 134 !!---------------------------------------------------------------------- 134 135 … … 136 137 CALL ctl_stop('ldf_slp: requested workspace arrays are unavailable') ; RETURN 137 138 ENDIF 139 ! 140 zgru => tsa(:,:,:,1) 141 zgrv => tsa(:,:,:,2) 138 142 139 143 zeps = 1.e-20_wp !== Local constant initialization ==! … … 379 383 ENDIF 380 384 ! 381 IF( wrk_not_released(3, 1) ) CALL ctl_stop('ldf_slp: failed to release workspace arrays')385 IF( wrk_not_released(3, 1) ) CALL ctl_stop('ldf_slp: failed to release workspace arrays.') 382 386 ! 383 387 END SUBROUTINE ldf_slp … … 399 403 !!---------------------------------------------------------------------- 400 404 USE wrk_nemo, ONLY: wrk_in_use, wrk_not_released 401 USE oce , ONLY: zdit => ua , zdis => va ! (ua,va) used as workspace402 USE oce , ONLY: zdjt => ta , zdjs => sa ! (ta,sa) used as workspace403 USE wrk_nemo, ONLY: zdkt => wrk_3d_2 , zdks => wrk_3d_3 ! 3D workspace404 USE wrk_nemo, ONLY: zalpha => wrk_3d_4 , zbeta => wrk_3d_5 ! alpha, beta at T points, at depth fsgdept405 405 USE wrk_nemo, ONLY: z1_mlbw => wrk_2d_1 406 ! 407 INTEGER, INTENT( in ) :: kt ! ocean time-step index 408 ! 409 INTEGER :: ji, jj, jk, jl, ip, jp, kp ! dummy loop indices 406 USE wrk_nemo, ONLY: zalpha => wrk_3d_2 , zbeta => wrk_3d_3 ! alpha, beta at T points, at depth fsgdept 407 USE wrk_nemo, ONLY: zdits => wrk_4d_1 , zdjts => wrk_4d_2, zdkts => wrk_4d_3 ! 4D workspace 408 !! 409 INTEGER, INTENT( in ) :: kt ! ocean time-step index 410 !! 411 INTEGER :: ji, jj, jk, jn, jl, ip, jp, kp ! dummy loop indices 410 412 INTEGER :: iku, ikv ! local integer 411 413 REAL(wp) :: zfacti, zfactj, zatempw,zatempu,zatempv ! local scalars … … 416 418 !!---------------------------------------------------------------------- 417 419 418 IF( wrk_in_use( 3, 2,3,4,5) .OR. wrk_in_use(2, 1) )THEN419 CALL ctl_stop('ldf_slp_grif: requested workspace arrays are unavailable') ; RETURN420 END IF421 420 IF( wrk_in_use(4, 1,2,3) .OR. wrk_in_use(3, 2,3) .OR. wrk_in_use(2, 1) ) THEN 421 CALL ctl_stop('ldf_slp_grif: ERROR: requested workspace arrays are unavailable.') ; RETURN 422 END IF 423 ! 422 424 !--------------------------------! 423 425 ! Some preliminary calculation ! … … 426 428 CALL eos_alpbet( tsb, zalpha, zbeta ) !== before thermal and haline expension coeff. at T-points ==! 427 429 ! 428 DO jk = 1, jpkm1 !== before lateral T & S gradients at T-level jk ==! 429 DO jj = 1, jpjm1 430 DO ji = 1, fs_jpim1 ! vector opt. 431 zdit(ji,jj,jk) = ( tb(ji+1,jj,jk) - tb(ji,jj,jk) ) * umask(ji,jj,jk) ! i-gradient of T and S at jj 432 zdis(ji,jj,jk) = ( sb(ji+1,jj,jk) - sb(ji,jj,jk) ) * umask(ji,jj,jk) 433 zdjt(ji,jj,jk) = ( tb(ji,jj+1,jk) - tb(ji,jj,jk) ) * vmask(ji,jj,jk) ! j-gradient of T and S at jj 434 zdjs(ji,jj,jk) = ( sb(ji,jj+1,jk) - sb(ji,jj,jk) ) * vmask(ji,jj,jk) 435 END DO 436 END DO 437 END DO 438 IF( ln_zps ) THEN ! partial steps: correction at the last level 430 DO jn = 1, jpts 431 DO jk = 1, jpkm1 !== before lateral T & S gradients at T-level jk ==! 432 DO jj = 1, jpjm1 433 DO ji = 1, fs_jpim1 ! vector opt. 434 zdits(ji,jj,jk,jn) = ( tsb(ji+1,jj,jk,jn) - tsb(ji,jj,jk,jn) ) * umask(ji,jj,jk) ! i-gradient of T and S at jj 435 zdjts(ji,jj,jk,jn) = ( tsb(ji,jj+1,jk,jn) - tsb(ji,jj,jk,jn) ) * vmask(ji,jj,jk) ! j-gradient of T and S at jj 436 END DO 437 END DO 438 END DO 439 IF( ln_zps ) THEN ! partial steps: correction at the last level 439 440 # if defined key_vectopt_loop 440 DO jj = 1, 1441 DO ji = 1, jpij-jpi ! vector opt. (forced unrolling)441 DO jj = 1, 1 442 DO ji = 1, jpij-jpi ! vector opt. (forced unrolling) 442 443 # else 443 DO jj = 1, jpjm1444 DO ji = 1, jpim1444 DO jj = 1, jpjm1 445 DO ji = 1, jpim1 445 446 # endif 446 zdit(ji,jj,mbku(ji,jj)) = gtsu(ji,jj,jp_tem) ! i-gradient of T and S 447 zdis(ji,jj,mbku(ji,jj)) = gtsu(ji,jj,jp_sal) 448 zdjt(ji,jj,mbkv(ji,jj)) = gtsv(ji,jj,jp_tem) ! j-gradient of T and S 449 zdjs(ji,jj,mbkv(ji,jj)) = gtsv(ji,jj,jp_sal) 450 END DO 451 END DO 452 ENDIF 453 ! 454 zdkt(:,:,1) = 0._wp !== before vertical T & S gradient at w-level ==! 455 zdks(:,:,1) = 0._wp 456 DO jk = 2, jpk 457 zdkt(:,:,jk) = ( tb(:,:,jk-1) - tb(:,:,jk) ) * tmask(:,:,jk) 458 zdks(:,:,jk) = ( sb(:,:,jk-1) - sb(:,:,jk) ) * tmask(:,:,jk) 459 END DO 460 ! 447 zdits(ji,jj,mbku(ji,jj),jn) = gtsu(ji,jj,jn) ! i-gradient of T and S 448 zdjts(ji,jj,mbkv(ji,jj),jn) = gtsv(ji,jj,jn) ! j-gradient of T and S 449 END DO 450 END DO 451 ENDIF 452 ! 453 zdkts(:,:,1,jn) = 0._wp !== before vertical T & S gradient at w-level ==! 454 DO jk = 2, jpk 455 zdkts(:,:,jk,jn) = ( tsb(:,:,jk-1,jn) - tsb(:,:,jk,jn) ) * tmask(:,:,jk) 456 END DO 457 ! 458 END DO 461 459 ! 462 460 DO jl = 0, 1 !== density i-, j-, and k-gradients ==! … … 465 463 DO jj = 1, jpjm1 ! NB: not masked due to the minimum value set 466 464 DO ji = 1, fs_jpim1 ! vector opt. 467 zdxrho_raw = ( zalpha(ji+ip,jj ,jk) * zdit (ji,jj,jk) + zbeta(ji+ip,jj ,jk) * zdis(ji,jj,jk) ) / e1u(ji,jj)468 zdyrho_raw = ( zalpha(ji ,jj+jp,jk) * zdjt (ji,jj,jk) + zbeta(ji ,jj+jp,jk) * zdjs(ji,jj,jk) ) / e2v(ji,jj)465 zdxrho_raw = ( zalpha(ji+ip,jj ,jk) * zdits(ji,jj,jk,jp_tem) + zbeta(ji+ip,jj ,jk) * zdits(ji,jj,jk,jp_sal) ) / e1u(ji,jj) 466 zdyrho_raw = ( zalpha(ji ,jj+jp,jk) * zdjts(ji,jj,jk,jp_tem) + zbeta(ji ,jj+jp,jk) * zdjts(ji,jj,jk,jp_sal) ) / e2v(ji,jj) 469 467 zdxrho(ji+ip,jj ,jk,1-ip) = SIGN( MAX( repsln, ABS( zdxrho_raw ) ), zdxrho_raw ) ! keep the sign 470 468 zdyrho(ji ,jj+jp,jk,1-jp) = SIGN( MAX( repsln, ABS( zdyrho_raw ) ), zdyrho_raw ) … … 477 475 DO jj = 1, jpj ! NB: not masked due to the minimum value set 478 476 DO ji = 1, jpi ! vector opt. 479 zdzrho_raw = ( zalpha(ji,jj,jk) * zdkt (ji,jj,jk+kp) + zbeta(ji,jj,jk) * zdks(ji,jj,jk+kp) ) &477 zdzrho_raw = ( zalpha(ji,jj,jk) * zdkts(ji,jj,jk+kp,jp_tem) + zbeta(ji,jj,jk) * zdkts(ji,jj,jk+kp,jp_sal) ) & 480 478 & / fse3w(ji,jj,jk+kp) 481 479 zdzrho(ji ,jj ,jk, kp) = - MIN( - repsln, zdzrho_raw ) ! force zdzrho >= repsln … … 600 598 CALL lbc_lnk( wslp2, 'W', 1. ) ! lateral boundary confition on wslp2 only ==>>> gm : necessary ? to be checked 601 599 ! 602 IF( wrk_not_released(3, 2,3,4,5) .OR. & 603 wrk_not_released(2, 1) ) CALL ctl_stop('ldf_slp_grif: failed to release workspace arrays') 600 IF( wrk_not_released(4, 1,2,3) .OR. & 601 wrk_not_released(3, 2,3 ) .OR. & 602 wrk_not_released(2, 1 ) ) CALL ctl_stop('ldf_slp_grif: ERROR: failed to release workspace arrays.') 604 603 ! 605 604 END SUBROUTINE ldf_slp_grif
Note: See TracChangeset
for help on using the changeset viewer.
