Changeset 6140 for trunk/NEMOGCM/NEMO/OPA_SRC/CRS
- Timestamp:
- 2015-12-21T12:35:23+01:00 (8 years ago)
- Location:
- trunk/NEMOGCM/NEMO/OPA_SRC/CRS
- Files:
-
- 6 edited
Legend:
- Unmodified
- Added
- Removed
-
trunk/NEMOGCM/NEMO/OPA_SRC/CRS/crs.F90
r5215 r6140 11 11 USE in_out_manager 12 12 13 14 13 IMPLICIT NONE 15 14 PUBLIC 16 15 17 18 16 PUBLIC crs_dom_alloc ! Called from crsini.F90 19 17 PUBLIC crs_dom_alloc2 ! Called from crsini.F90 … … 161 159 INTEGER, PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: nmln_crs, hmld_crs, hmlp_crs, hmlpt_crs 162 160 163 ! Direction of lateral diffusion 164 165 161 !!---------------------------------------------------------------------- 162 !! NEMO/OPA 3.3 , NEMO Consortium (2010) 166 163 !! $Id$ 164 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 165 !!---------------------------------------------------------------------- 167 166 CONTAINS 168 167 … … 258 257 259 258 END FUNCTION crs_dom_alloc 260 259 260 261 261 INTEGER FUNCTION crs_dom_alloc2() 262 262 !!------------------------------------------------------------------- … … 272 272 crs_dom_alloc2 = MAXVAL(ierr) 273 273 274 END FUNCTION crs_dom_alloc2 274 END FUNCTION crs_dom_alloc2 275 275 276 276 277 SUBROUTINE dom_grid_glo … … 312 313 END SUBROUTINE dom_grid_glo 313 314 315 314 316 SUBROUTINE dom_grid_crs 315 317 !!-------------------------------------------------------------------- … … 318 320 !! ** Purpose : Save the parent grid information & Switch to coarse grid domain 319 321 !!--------------------------------------------------------------------- 320 321 322 ! 322 323 ! Switch to coarse grid domain … … 349 350 nlejt(:) = nlejt_crs(:) 350 351 njmppt(:) = njmppt_crs(:) 351 352 353 352 ! 354 353 END SUBROUTINE dom_grid_crs 355 354 356 357 355 !!====================================================================== 358 359 356 END MODULE crs 360 357 -
trunk/NEMOGCM/NEMO/OPA_SRC/CRS/crsdom.F90
r5302 r6140 30 30 !! Original. May 2012. (J. Simeon, C. Calone, G. Madec, C. Ethe) 31 31 !!=================================================================== 32 33 32 USE dom_oce ! ocean space and time domain and to get jperio 34 USE wrk_nemo ! work arrays35 33 USE crs ! domain for coarse grid 34 ! 36 35 USE in_out_manager 37 36 USE par_kind 38 37 USE crslbclnk 38 USE wrk_nemo ! work arrays 39 39 USE lib_mpp 40 41 40 42 41 IMPLICIT NONE … … 54 53 REAL(wp) :: r_inf = 1e+36 55 54 56 !! Substitutions 57 # include "domzgr_substitute.h90" 58 55 !!---------------------------------------------------------------------- 56 !! NEMO/OPA 3.3 , NEMO Consortium (2010) 59 57 !! $Id$ 58 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 59 !!---------------------------------------------------------------------- 60 60 CONTAINS 61 62 61 63 62 SUBROUTINE crs_dom_msk … … 133 132 END SUBROUTINE crs_dom_msk 134 133 134 135 135 SUBROUTINE crs_dom_coordinates( p_gphi, p_glam, cd_type, p_gphi_crs, p_glam_crs ) 136 136 !!---------------------------------------------------------------- … … 334 334 !! cd_type = grid type (T,U,V,F) for scale factors; for velocities (U or V) 335 335 !! cd_op = applied operation (SUM, VOL, WGT) 336 !! p_ fse3 = (Optional) parent grid vertical level thickness (fse3u or fse3v)336 !! p_e3 = (Optional) parent grid vertical level thickness (e3u or e3v) 337 337 !! ** Outputs : p_cfield2d_1 = (Optional) 2D field on coarse grid 338 338 !! p_cfield2d_2 = (Optional) 2D field on coarse grid … … 342 342 !! History. 4 Jun. Write for WGT and scale factors only 343 343 !!---------------------------------------------------------------- 344 !! 345 !! Arguments 346 CHARACTER(len=1), INTENT(in) :: cd_type ! grid type U,V 347 REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT(in) :: p_mask ! Parent grid U,V mask 348 REAL(wp), DIMENSION(jpi,jpj) , INTENT(in) :: p_e1 ! Parent grid U,V scale factors (e1) 349 REAL(wp), DIMENSION(jpi,jpj) , INTENT(in) :: p_e2 ! Parent grid U,V scale factors (e2) 350 REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT(in) :: p_e3 ! Parent grid vertical level thickness (fse3u, fse3v) 351 352 REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(out) :: p_fld1_crs ! Coarse grid box 3D quantity 353 REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(out) :: p_fld2_crs ! Coarse grid box 3D quantity 354 355 !! Local variables 356 REAL(wp) :: zdAm 357 INTEGER :: ji, jj, jk , ii, ij, je_2 358 359 REAL(wp), DIMENSION(:,:,:), POINTER :: zvol, zmask 344 CHARACTER(len=1), INTENT(in ) :: cd_type ! grid type U,V 345 REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT(in ) :: p_mask ! Parent grid U,V mask 346 REAL(wp), DIMENSION(jpi,jpj) , INTENT(in ) :: p_e1 ! Parent grid U,V scale factors (e1) 347 REAL(wp), DIMENSION(jpi,jpj) , INTENT(in ) :: p_e2 ! Parent grid U,V scale factors (e2) 348 REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT(in ) :: p_e3 ! Parent grid vertical level thickness (e3u, e3v) 349 REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT( out) :: p_fld1_crs ! Coarse grid box 3D quantity 350 REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT( out) :: p_fld2_crs ! Coarse grid box 3D quantity 351 ! 352 INTEGER :: ji, jj, jk , ii, ij, je_2 353 REAL(wp) :: zdAm 354 REAL(wp), DIMENSION(:,:,:), POINTER :: zvol, zmask 360 355 !!---------------------------------------------------------------- 361 362 CALL wrk_alloc( jpi, jpj, jpk,zvol, zmask )363 364 p_fld1_crs(:,:,:) = 0. 0365 p_fld2_crs(:,:,:) = 0. 0356 ! 357 CALL wrk_alloc( jpi,jpj,jpk, zvol, zmask ) 358 ! 359 p_fld1_crs(:,:,:) = 0._wp 360 p_fld2_crs(:,:,:) = 0._wp 366 361 367 362 DO jk = 1, jpk 368 363 zvol(:,:,jk) = p_e1(:,:) * p_e2(:,:) * p_e3(:,:,jk) 369 END DO370 371 zmask(:,:,:) = 0. 0364 END DO 365 366 zmask(:,:,:) = 0._wp 372 367 IF( cd_type == 'W' ) THEN 373 368 zmask(:,:,1) = p_mask(:,:,1) … … 469 464 !! p_pmask = parent grid mask (T,U,V,F) for scale factors; 470 465 !! for velocities (U or V) 471 !! p_ fse3 = parent grid vertical level thickness (fse3u or fse3v)466 !! p_e3 = parent grid vertical level thickness (e3u or e3v) 472 467 !! p_pfield = U or V on the parent grid 473 468 !! p_surf_crs = (Optional) Coarse grid weight for averaging … … 478 473 !! 5 Jun. Streamline for area-weighted average only ; separate scale factor and weights. 479 474 !!---------------------------------------------------------------- 480 !! 481 !! Arguments 482 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in) :: p_fld ! T, U, V or W on parent grid 483 CHARACTER(len=3), INTENT(in) :: cd_op ! Operation SUM, MAX or MIN 475 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in) :: p_fld ! T, U, V or W on parent grid 476 CHARACTER(len=3), INTENT(in) :: cd_op ! Operation SUM, MAX or MIN 484 477 CHARACTER(len=1), INTENT(in) :: cd_type ! grid type U,V 485 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in) :: p_mask ! Parent grid T,U,V mask486 REAL(wp), DIMENSION(jpi,jpj), INTENT(in), OPTIONAL :: p_e12 ! Parent grid T,U,V scale factors (e1 or e2)487 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in), OPTIONAL :: p_e3 ! Parent grid vertical level thickness (fse3u, fse3v)478 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in) :: p_mask ! Parent grid T,U,V mask 479 REAL(wp), DIMENSION(jpi,jpj), INTENT(in), OPTIONAL :: p_e12 ! Parent grid T,U,V scale factors (e1 or e2) 480 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in), OPTIONAL :: p_e3 ! Parent grid vertical level thickness (e3u, e3v) 488 481 REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(in), OPTIONAL :: p_surf_crs ! Coarse grid area-weighting denominator 489 REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(in), OPTIONAL :: p_mask_crs ! Coarse grid T,U,V maska 490 REAL(wp), INTENT(in) :: psgn ! sign 491 492 493 REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(out) :: p_fld_crs ! Coarse grid box 3D quantity 494 495 !! Local variables 496 INTEGER :: ji, jj, jk 497 INTEGER :: ii, ij, ijie, ijje, je_2 498 REAL(wp) :: zflcrs, zsfcrs 499 REAL(wp), DIMENSION(:,:,:), POINTER :: zsurf, zsurfmsk, zmask 482 REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(in), OPTIONAL :: p_mask_crs ! Coarse grid T,U,V maska 483 REAL(wp), INTENT(in) :: psgn ! sign 484 REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT( out) :: p_fld_crs ! Coarse grid box 3D quantity 485 ! 486 INTEGER :: ji, jj, jk 487 INTEGER :: ii, ij, ijie, ijje, je_2 488 REAL(wp) :: zflcrs, zsfcrs 489 REAL(wp), DIMENSION(:,:,:), POINTER :: zsurf, zsurfmsk, zmask 500 490 !!---------------------------------------------------------------- 501 502 p_fld_crs(:,:,:) = 0. 0503 491 ! 492 p_fld_crs(:,:,:) = 0._wp 493 ! 504 494 SELECT CASE ( cd_op ) 505 506 507 508 CALL wrk_alloc( jpi, jpj, jpk,zsurf, zsurfmsk )509 510 511 512 513 495 ! 496 CASE ( 'VOL' ) 497 ! 498 CALL wrk_alloc( jpi,jpj,jpk, zsurf, zsurfmsk ) 499 ! 500 SELECT CASE ( cd_type ) 501 ! 502 CASE( 'T', 'W' ) 503 IF( cd_type == 'T' ) THEN 514 504 DO jk = 1, jpk 515 505 zsurf (:,:,jk) = p_e12(:,:) * p_e3(:,:,jk) * p_mask(:,:,jk) … … 1136 1126 !! p_pmask = parent grid mask (T,U,V,F) for scale factors; 1137 1127 !! for velocities (U or V) 1138 !! p_ fse3 = parent grid vertical level thickness (fse3u or fse3v)1128 !! p_e3 = parent grid vertical level thickness (e3u or e3v) 1139 1129 !! p_pfield = U or V on the parent grid 1140 1130 !! p_surf_crs = (Optional) Coarse grid weight for averaging … … 1145 1135 !! 5 Jun. Streamline for area-weighted average only ; separate scale factor and weights. 1146 1136 !!---------------------------------------------------------------- 1147 !!1148 !! Arguments1149 1137 REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: p_fld ! T, U, V or W on parent grid 1150 1138 CHARACTER(len=3), INTENT(in) :: cd_op ! Operation SUM, MAX or MIN … … 1152 1140 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in) :: p_mask ! Parent grid T,U,V mask 1153 1141 REAL(wp), DIMENSION(jpi,jpj), INTENT(in), OPTIONAL :: p_e12 ! Parent grid T,U,V scale factors (e1 or e2) 1154 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in), OPTIONAL :: p_e3 ! Parent grid vertical level thickness ( fse3u, fse3v)1142 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in), OPTIONAL :: p_e3 ! Parent grid vertical level thickness (e3u, e3v) 1155 1143 REAL(wp), DIMENSION(jpi_crs,jpj_crs) , INTENT(in), OPTIONAL :: p_surf_crs ! Coarse grid area-weighting denominator 1156 1144 REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(in), OPTIONAL :: p_mask_crs ! Coarse grid T,U,V mask 1157 1145 REAL(wp), INTENT(in) :: psgn 1158 1159 1146 REAL(wp), DIMENSION(jpi_crs,jpj_crs) , INTENT(out) :: p_fld_crs ! Coarse grid box 3D quantity 1160 1161 !! Local variables 1147 ! 1162 1148 INTEGER :: ji, jj, jk ! dummy loop indices 1163 1149 INTEGER :: ijie, ijje, ii, ij, je_2 1164 1150 REAL(wp) :: zflcrs, zsfcrs 1165 1151 REAL(wp), DIMENSION(:,:), POINTER :: zsurfmsk 1166 1167 1152 !!---------------------------------------------------------------- 1168 1169 p_fld_crs(:,:) = 0. 01170 1153 ! 1154 p_fld_crs(:,:) = 0._wp 1155 ! 1171 1156 SELECT CASE ( cd_op ) 1172 1157 -
trunk/NEMOGCM/NEMO/OPA_SRC/CRS/crsdomwri.F90
r5215 r6140 33 33 PUBLIC crs_dom_wri ! routine called by crsini.F90 34 34 35 !!---------------------------------------------------------------------- 36 !! NEMO/OPA 3.3 , NEMO Consortium (2010) 35 37 !! $Id$ 38 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 39 !!---------------------------------------------------------------------- 36 40 CONTAINS 37 41 -
trunk/NEMOGCM/NEMO/OPA_SRC/CRS/crsfld.F90
r5836 r6140 33 33 34 34 !! * Substitutions 35 # include "zdfddm_substitute.h90"36 # include "domzgr_substitute.h90"37 35 # include "vectopt_loop_substitute.h90" 38 36 !!---------------------------------------------------------------------- … … 52 50 !! 2. At time of output, rescale [1] by dimension and time 53 51 !! to yield the spatial and temporal average. 54 !! See. diawri_dimg.h90,sbcmod.F9052 !! See. sbcmod.F90 55 53 !! 56 54 !! ** Method : … … 61 59 REAL(wp) :: z2dcrsu, z2dcrsv ! local scalars 62 60 ! 63 REAL(wp), POINTER, DIMENSION(:,:,:) :: z fse3t, zfse3u, zfse3v, zfse3w ! 3D workspace for e361 REAL(wp), POINTER, DIMENSION(:,:,:) :: ze3t, ze3u, ze3v, ze3w ! 3D workspace for e3 64 62 REAL(wp), POINTER, DIMENSION(:,:,:) :: zt, zt_crs 65 63 REAL(wp), POINTER, DIMENSION(:,:,:) :: zs, zs_crs … … 69 67 70 68 ! Initialize arrays 71 CALL wrk_alloc( jpi,jpj,jpk, z fse3t, zfse3w )72 CALL wrk_alloc( jpi,jpj,jpk, z fse3u, zfse3v )73 CALL wrk_alloc( jpi,jpj,jpk, zt , zs)74 ! 75 CALL wrk_alloc( jpi_crs, jpj_crs, jpk,zt_crs, zs_crs )69 CALL wrk_alloc( jpi,jpj,jpk, ze3t, ze3w ) 70 CALL wrk_alloc( jpi,jpj,jpk, ze3u, ze3v ) 71 CALL wrk_alloc( jpi,jpj,jpk, zt , zs ) 72 ! 73 CALL wrk_alloc( jpi_crs,jpj_crs,jpk, zt_crs, zs_crs ) 76 74 77 75 ! Depth work arrrays 78 z fse3t(:,:,:) = fse3t(:,:,:)79 z fse3u(:,:,:) = fse3u(:,:,:)80 z fse3v(:,:,:) = fse3v(:,:,:)81 z fse3w(:,:,:) = fse3w(:,:,:)76 ze3t(:,:,:) = e3t_n(:,:,:) 77 ze3u(:,:,:) = e3u_n(:,:,:) 78 ze3v(:,:,:) = e3v_n(:,:,:) 79 ze3w(:,:,:) = e3w_n(:,:,:) 82 80 83 81 IF( kt == nit000 ) THEN … … 107 105 ! Temperature 108 106 zt(:,:,:) = tsn(:,:,:,jp_tem) ; zt_crs(:,:,:) = 0._wp 109 CALL crs_dom_ope( zt, 'VOL', 'T', tmask, zt_crs, p_e12=e1e2t, p_e3=z fse3t, psgn=1.0 )107 CALL crs_dom_ope( zt, 'VOL', 'T', tmask, zt_crs, p_e12=e1e2t, p_e3=ze3t, psgn=1.0 ) 110 108 tsn_crs(:,:,:,jp_tem) = zt_crs(:,:,:) 111 109 … … 116 114 ! Salinity 117 115 zs(:,:,:) = tsn(:,:,:,jp_sal) ; zs_crs(:,:,:) = 0._wp 118 CALL crs_dom_ope( zs, 'VOL', 'T', tmask, zs_crs, p_e12=e1e2t, p_e3=z fse3t, psgn=1.0 )116 CALL crs_dom_ope( zs, 'VOL', 'T', tmask, zs_crs, p_e12=e1e2t, p_e3=ze3t, psgn=1.0 ) 119 117 tsn_crs(:,:,:,jp_sal) = zt_crs(:,:,:) 120 118 … … 123 121 124 122 ! U-velocity 125 CALL crs_dom_ope( un, 'SUM', 'U', umask, un_crs, p_e12=e2u, p_e3=z fse3u, p_surf_crs=e2e3u_msk, psgn=-1.0 )123 CALL crs_dom_ope( un, 'SUM', 'U', umask, un_crs, p_e12=e2u, p_e3=ze3u, p_surf_crs=e2e3u_msk, psgn=-1.0 ) 126 124 ! 127 125 zt(:,:,:) = 0._wp ; zs(:,:,:) = 0._wp ; zt_crs(:,:,:) = 0._wp ; zs_crs(:,:,:) = 0._wp … … 134 132 END DO 135 133 END DO 136 CALL crs_dom_ope( zt, 'SUM', 'U', umask, zt_crs, p_e12=e2u, p_e3=z fse3u, p_surf_crs=e2e3u_msk, psgn=-1.0 )137 CALL crs_dom_ope( zs, 'SUM', 'U', umask, zs_crs, p_e12=e2u, p_e3=z fse3u, p_surf_crs=e2e3u_msk, psgn=-1.0 )134 CALL crs_dom_ope( zt, 'SUM', 'U', umask, zt_crs, p_e12=e2u, p_e3=ze3u, p_surf_crs=e2e3u_msk, psgn=-1.0 ) 135 CALL crs_dom_ope( zs, 'SUM', 'U', umask, zs_crs, p_e12=e2u, p_e3=ze3u, p_surf_crs=e2e3u_msk, psgn=-1.0 ) 138 136 139 137 CALL iom_put( "uoce" , un_crs ) ! i-current … … 142 140 143 141 ! V-velocity 144 CALL crs_dom_ope( vn, 'SUM', 'V', vmask, vn_crs, p_e12=e1v, p_e3=z fse3v, p_surf_crs=e1e3v_msk, psgn=-1.0 )142 CALL crs_dom_ope( vn, 'SUM', 'V', vmask, vn_crs, p_e12=e1v, p_e3=ze3v, p_surf_crs=e1e3v_msk, psgn=-1.0 ) 145 143 ! 146 144 zt(:,:,:) = 0._wp ; zs(:,:,:) = 0._wp ; zt_crs(:,:,:) = 0._wp ; zs_crs(:,:,:) = 0._wp … … 153 151 END DO 154 152 END DO 155 CALL crs_dom_ope( zt, 'SUM', 'V', vmask, zt_crs, p_e12=e1v, p_e3=z fse3v, p_surf_crs=e1e3v_msk, psgn=-1.0 )156 CALL crs_dom_ope( zs, 'SUM', 'V', vmask, zs_crs, p_e12=e1v, p_e3=z fse3v, p_surf_crs=e1e3v_msk, psgn=-1.0 )153 CALL crs_dom_ope( zt, 'SUM', 'V', vmask, zt_crs, p_e12=e1v, p_e3=ze3v, p_surf_crs=e1e3v_msk, psgn=-1.0 ) 154 CALL crs_dom_ope( zs, 'SUM', 'V', vmask, zs_crs, p_e12=e1v, p_e3=ze3v, p_surf_crs=e1e3v_msk, psgn=-1.0 ) 157 155 158 156 CALL iom_put( "voce" , vn_crs ) ! i-current … … 162 160 163 161 ! Kinetic energy 164 CALL crs_dom_ope( rke, 'VOL', 'T', tmask, rke_crs, p_e12=e1e2t, p_e3=z fse3t, psgn=1.0 )162 CALL crs_dom_ope( rke, 'VOL', 'T', tmask, rke_crs, p_e12=e1e2t, p_e3=ze3t, psgn=1.0 ) 165 163 CALL iom_put( "eken", rke_crs ) 166 164 … … 188 186 IF( ln_crs_wn ) THEN 189 187 CALL crs_dom_ope( wn, 'SUM', 'W', tmask, wn_crs, p_e12=e1e2t, p_surf_crs=e1e2w_msk, psgn=1.0 ) 190 ! CALL crs_dom_ope( wn, 'VOL', 'W', tmask, wn_crs, p_e12=e1e2t, p_e3=z fse3w )188 ! CALL crs_dom_ope( wn, 'VOL', 'W', tmask, wn_crs, p_e12=e1e2t, p_e3=ze3w ) 191 189 ELSE 192 190 wn_crs(:,:,jpk) = 0._wp … … 199 197 200 198 ! avt, avs 199 !!gm BUG TOP always uses avs !!! 201 200 SELECT CASE ( nn_crs_kz ) 202 201 CASE ( 0 ) 203 CALL crs_dom_ope( avt, 'VOL', 'W', tmask, avt_crs, p_e12=e1e2t, p_e3=z fse3w, psgn=1.0 )202 CALL crs_dom_ope( avt, 'VOL', 'W', tmask, avt_crs, p_e12=e1e2t, p_e3=ze3w, psgn=1.0 ) 204 203 CASE ( 1 ) 205 CALL crs_dom_ope( avt, 'MAX', 'W', tmask, avt_crs, p_e12=e1e2t, p_e3=z fse3w, psgn=1.0 )204 CALL crs_dom_ope( avt, 'MAX', 'W', tmask, avt_crs, p_e12=e1e2t, p_e3=ze3w, psgn=1.0 ) 206 205 CASE ( 2 ) 207 CALL crs_dom_ope( avt, 'MIN', 'W', tmask, avt_crs, p_e12=e1e2t, p_e3=z fse3w, psgn=1.0 )206 CALL crs_dom_ope( avt, 'MIN', 'W', tmask, avt_crs, p_e12=e1e2t, p_e3=ze3w, psgn=1.0 ) 208 207 END SELECT 209 208 ! … … 211 210 212 211 ! sbc fields 213 CALL crs_dom_ope( sshn , 'VOL', 'T', tmask, sshn_crs , p_e12=e1e2t, p_e3=z fse3t, psgn=1.0 )212 CALL crs_dom_ope( sshn , 'VOL', 'T', tmask, sshn_crs , p_e12=e1e2t, p_e3=ze3t , psgn=1.0 ) 214 213 CALL crs_dom_ope( utau , 'SUM', 'U', umask, utau_crs , p_e12=e2u , p_surf_crs=e2u_crs , psgn=1.0 ) 215 214 CALL crs_dom_ope( vtau , 'SUM', 'V', vmask, vtau_crs , p_e12=e1v , p_surf_crs=e1v_crs , psgn=1.0 ) … … 233 232 234 233 ! free memory 235 CALL wrk_dealloc( jpi, jpj, jpk, zfse3t, zfse3w )236 CALL wrk_dealloc( jpi, jpj, jpk, zfse3u, zfse3v )237 CALL wrk_dealloc( jpi, jpj, jpk, zt, zs)238 CALL wrk_dealloc( jpi_crs, jpj_crs, jpk,zt_crs, zs_crs )234 CALL wrk_dealloc( jpi,jpj,jpk, ze3t, ze3w ) 235 CALL wrk_dealloc( jpi,jpj,jpk, ze3u, ze3v ) 236 CALL wrk_dealloc( jpi,jpj,jpk, zt , zs ) 237 CALL wrk_dealloc( jpi_crs,jpj_crs,jpk, zt_crs, zs_crs ) 239 238 ! 240 239 CALL iom_swap( "nemo" ) ! return back on high-resolution grid -
trunk/NEMOGCM/NEMO/OPA_SRC/CRS/crsini.F90
r5836 r6140 12 12 USE par_kind, ONLY: wp 13 13 USE par_oce ! For parameter jpi,jpj,jphgr_msh 14 USE dom_oce ! For parameters in par_oce (jperio, lk_vvl)14 USE dom_oce ! For parameters in par_oce 15 15 USE crs ! Coarse grid domain 16 16 USE phycst, ONLY: omega, rad ! physical constants … … 30 30 PUBLIC crs_init ! called by nemogcm.F90 module 31 31 32 !! * Substitutions 33 # include "domzgr_substitute.h90" 34 !!---------------------------------------------------------------------- 32 !!---------------------------------------------------------------------- 33 !! NEMO/OPA 3.3 , NEMO Consortium (2010) 35 34 !! $Id$ 35 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 36 36 !!---------------------------------------------------------------------- 37 37 CONTAINS … … 64 64 !! output C*dA or C*dV as summation not mran, then do mean (division) at moment of output. 65 65 !! As is, crsfun takes into account vvl. 66 !! Talked about pre-setting the surface array to avoid IF/ENDIF Sand division.66 !! Talked about pre-setting the surface array to avoid IF/ENDIF and division. 67 67 !! But have then to make that preset array here and elsewhere. 68 68 !! that is called every timestep... … … 73 73 INTEGER :: ierr ! allocation error status 74 74 INTEGER :: ios ! Local integer output status for namelist read 75 REAL(wp), DIMENSION(:,:,:), POINTER :: z fse3t, zfse3u, zfse3v, zfse3w75 REAL(wp), DIMENSION(:,:,:), POINTER :: ze3t, ze3u, ze3v, ze3w 76 76 77 77 NAMELIST/namcrs/ nn_factx, nn_facty, nn_binref, nn_msh_crs, nn_crs_kz, ln_crs_wn … … 187 187 188 188 ! 189 CALL wrk_alloc( jpi,jpj,jpk, z fse3t, zfse3u, zfse3v, zfse3w )190 ! 191 z fse3t(:,:,:) = fse3t(:,:,:)192 z fse3u(:,:,:) = fse3u(:,:,:)193 z fse3v(:,:,:) = fse3v(:,:,:)194 z fse3w(:,:,:) = fse3w(:,:,:)189 CALL wrk_alloc( jpi,jpj,jpk, ze3t, ze3u, ze3v, ze3w ) 190 ! 191 ze3t(:,:,:) = e3t_n(:,:,:) 192 ze3u(:,:,:) = e3u_n(:,:,:) 193 ze3v(:,:,:) = e3v_n(:,:,:) 194 ze3w(:,:,:) = e3w_n(:,:,:) 195 195 196 196 ! 3.d.2 Surfaces 197 CALL crs_dom_sfc( tmask, 'W', e1e2w_crs, e1e2w_msk, p_e1=e1t, p_e2=e2t 198 CALL crs_dom_sfc( umask, 'U', e2e3u_crs, e2e3u_msk, p_e2=e2u, p_e3=z fse3u )199 CALL crs_dom_sfc( vmask, 'V', e1e3v_crs, e1e3v_msk, p_e1=e1v, p_e3=z fse3v )197 CALL crs_dom_sfc( tmask, 'W', e1e2w_crs, e1e2w_msk, p_e1=e1t, p_e2=e2t ) 198 CALL crs_dom_sfc( umask, 'U', e2e3u_crs, e2e3u_msk, p_e2=e2u, p_e3=ze3u ) 199 CALL crs_dom_sfc( vmask, 'V', e1e3v_crs, e1e3v_msk, p_e1=e1v, p_e3=ze3v ) 200 200 201 201 facsurfu(:,:,:) = umask_crs(:,:,:) * e2e3u_msk(:,:,:) / e2e3u_crs(:,:,:) … … 204 204 ! 3.d.3 Vertical scale factors 205 205 ! 206 CALL crs_dom_e3( e1t, e2t, z fse3t, e1e2w_crs, 'T', tmask, e3t_crs, e3t_max_crs)207 CALL crs_dom_e3( e1u, e2u, z fse3u, e2e3u_crs, 'U', umask, e3u_crs, e3u_max_crs)208 CALL crs_dom_e3( e1v, e2v, z fse3v, e1e3v_crs, 'V', vmask, e3v_crs, e3v_max_crs)209 CALL crs_dom_e3( e1t, e2t, z fse3w, e1e2w_crs, 'W', tmask, e3w_crs, e3w_max_crs)206 CALL crs_dom_e3( e1t, e2t, ze3t, e1e2w_crs, 'T', tmask, e3t_crs, e3t_max_crs) 207 CALL crs_dom_e3( e1u, e2u, ze3u, e2e3u_crs, 'U', umask, e3u_crs, e3u_max_crs) 208 CALL crs_dom_e3( e1v, e2v, ze3v, e1e3v_crs, 'V', vmask, e3v_crs, e3v_max_crs) 209 CALL crs_dom_e3( e1t, e2t, ze3w, e1e2w_crs, 'W', tmask, e3w_crs, e3w_max_crs) 210 210 211 211 ! Replace 0 by e3t_0 or e3w_0 … … 222 222 223 223 ! 3.d.3 Vertical depth (meters) 224 CALL crs_dom_ope( gdept_0, 'MAX', 'T', tmask, gdept_crs, p_e3=z fse3t, psgn=1.0 )225 CALL crs_dom_ope( gdepw_0, 'MAX', 'W', tmask, gdepw_crs, p_e3=z fse3w, psgn=1.0 )224 CALL crs_dom_ope( gdept_0, 'MAX', 'T', tmask, gdept_crs, p_e3=ze3t, psgn=1.0 ) 225 CALL crs_dom_ope( gdepw_0, 'MAX', 'W', tmask, gdepw_crs, p_e3=ze3w, psgn=1.0 ) 226 226 227 227 … … 230 230 !--------------------------------------------------------- 231 231 ! 4.a. Ocean volume or area unmasked and masked 232 CALL crs_dom_facvol( tmask, 'T', e1t, e2t, z fse3t, ocean_volume_crs_t, facvol_t )232 CALL crs_dom_facvol( tmask, 'T', e1t, e2t, ze3t, ocean_volume_crs_t, facvol_t ) 233 233 ! 234 234 bt_crs(:,:,:) = ocean_volume_crs_t(:,:,:) * facvol_t(:,:,:) … … 237 237 WHERE( bt_crs /= 0._wp ) r1_bt_crs(:,:,:) = 1._wp / bt_crs(:,:,:) 238 238 239 CALL crs_dom_facvol( tmask, 'W', e1t, e2t, z fse3w, ocean_volume_crs_w, facvol_w )239 CALL crs_dom_facvol( tmask, 'W', e1t, e2t, ze3w, ocean_volume_crs_w, facvol_w ) 240 240 ! 241 241 !--------------------------------------------------------- … … 252 252 ! 7. Finish and clean-up 253 253 !--------------------------------------------------------- 254 CALL wrk_dealloc( jpi,jpj,jpk, z fse3t, zfse3u, zfse3v, zfse3w )254 CALL wrk_dealloc( jpi,jpj,jpk, ze3t, ze3u, ze3v, ze3w ) 255 255 ! 256 256 END SUBROUTINE crs_init -
trunk/NEMOGCM/NEMO/OPA_SRC/CRS/crslbclnk.F90
r5215 r6140 1 1 MODULE crslbclnk 2 3 2 !!====================================================================== 4 3 !! *** MODULE crslbclnk *** … … 7 6 !!===================================================================== 8 7 !! History : ! 2012-06 (J. Simeon, G. Madec, C. Ethe, C. Calone) Original code 9 8 !!---------------------------------------------------------------------- 9 USE par_kind, ONLY: wp 10 10 USE dom_oce 11 11 USE crs 12 ! 12 13 USE lbclnk 13 USE par_kind, ONLY: wp14 14 USE in_out_manager 15 16 17 15 18 16 INTERFACE crs_lbc_lnk … … 22 20 PUBLIC crs_lbc_lnk 23 21 22 !!---------------------------------------------------------------------- 23 !! NEMO/OPA 3.3 , NEMO Consortium (2010) 24 24 !! $Id$ 25 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 26 !!---------------------------------------------------------------------- 25 27 CONTAINS 26 28 … … 35 37 !! Upon exiting, switch back to full domain indices. 36 38 !!---------------------------------------------------------------------- 37 !! Arguments 38 CHARACTER(len=1) , INTENT(in ) :: cd_type1 ! grid type 39 REAL(wp) , INTENT(in ) :: psgn ! control of the sign 40 41 REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(inout) :: pt3d1 ! 3D array on which the lbc is applied 42 REAL(wp) , INTENT(in ), OPTIONAL :: pval ! valeur sur les halo 43 CHARACTER(len=3) , INTENT(in ), OPTIONAL :: cd_mpp ! MPP only (here do nothing) 44 45 !! local vairables 46 LOGICAL :: ll_grid_crs 47 REAL(wp) :: zval ! valeur sur les halo 48 39 CHARACTER(len=1) , INTENT(in ) :: cd_type1 ! grid type 40 REAL(wp) , INTENT(in ) :: psgn ! control of the sign 41 REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(inout) :: pt3d1 ! 3D array on which the lbc is applied 42 REAL(wp) , OPTIONAL, INTENT(in ) :: pval ! valeur sur les halo 43 CHARACTER(len=3) , OPTIONAL, INTENT(in ) :: cd_mpp ! MPP only (here do nothing) 44 ! 45 LOGICAL :: ll_grid_crs 46 REAL(wp) :: zval ! valeur sur les halo 49 47 !!---------------------------------------------------------------------- 50 48 ! 51 49 ll_grid_crs = ( jpi == jpi_crs ) 52 50 ! 53 51 IF( PRESENT(pval) ) THEN ; zval = pval 54 ELSE ; zval = 0. 052 ELSE ; zval = 0._wp 55 53 ENDIF 56 57 IF( .NOT. 58 54 ! 55 IF( .NOT.ll_grid_crs ) CALL dom_grid_crs ! Save the parent grid information & Switch to coarse grid domain 56 ! 59 57 IF( PRESENT( cd_mpp ) ) THEN ; CALL lbc_lnk( pt3d1, cd_type1, psgn, cd_mpp, pval=zval ) 60 58 ELSE ; CALL lbc_lnk( pt3d1, cd_type1, psgn, pval=zval ) 61 59 ENDIF 62 63 IF( .NOT. 64 60 ! 61 IF( .NOT.ll_grid_crs ) CALL dom_grid_glo ! Return to parent grid domain 62 ! 65 63 END SUBROUTINE crs_lbc_lnk_3d 64 66 65 67 66 SUBROUTINE crs_lbc_lnk_3d_gather( pt3d1, cd_type1, pt3d2, cd_type2, psgn ) … … 75 74 !! Upon exiting, switch back to full domain indices. 76 75 !!---------------------------------------------------------------------- 77 !! Arguments 78 CHARACTER(len=1) , INTENT(in ) :: cd_type1,cd_type2 ! grid type 79 REAL(wp) , INTENT(in ) :: psgn ! control of the sign 80 81 REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(inout) :: pt3d1,pt3d2 ! 3D array on which the lbc is applied 82 83 !! local vairables 84 LOGICAL :: ll_grid_crs 76 CHARACTER(len=1) , INTENT(in ) :: cd_type1, cd_type2 ! grid type 77 REAL(wp) , INTENT(in ) :: psgn ! control of the sign 78 REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(inout) :: pt3d1 , pt3d2 ! 3D array on which the lbc is applied 79 ! 80 LOGICAL :: ll_grid_crs 85 81 !!---------------------------------------------------------------------- 86 82 ! 87 83 ll_grid_crs = ( jpi == jpi_crs ) 88 89 IF( .NOT. 90 84 ! 85 IF( .NOT.ll_grid_crs ) CALL dom_grid_crs ! Save the parent grid information & Switch to coarse grid domain 86 ! 91 87 CALL lbc_lnk( pt3d1, cd_type1, pt3d2, cd_type2, psgn ) 92 93 IF( .NOT. 94 88 ! 89 IF( .NOT.ll_grid_crs ) CALL dom_grid_glo ! Return to parent grid domain 90 ! 95 91 END SUBROUTINE crs_lbc_lnk_3d_gather 96 92 … … 107 103 !! Upon exiting, switch back to full domain indices. 108 104 !!---------------------------------------------------------------------- 109 !! Arguments 110 CHARACTER(len=1) , INTENT(in ) :: cd_type ! grid type 111 REAL(wp) , INTENT(in ) :: psgn ! control of the sign 112 113 REAL(wp), DIMENSION(jpi_crs,jpj_crs), INTENT(inout) :: pt2d ! 2D array on which the lbc is applied 114 REAL(wp) , INTENT(in ), OPTIONAL :: pval ! valeur sur les halo 115 CHARACTER(len=3) , INTENT(in ), OPTIONAL :: cd_mpp ! MPP only (here do nothing) 116 !! local variables 117 118 LOGICAL :: ll_grid_crs 119 REAL(wp) :: zval ! valeur sur les halo 120 105 CHARACTER(len=1) , INTENT(in ) :: cd_type ! grid type 106 REAL(wp) , INTENT(in ) :: psgn ! control of the sign 107 REAL(wp), DIMENSION(jpi_crs,jpj_crs), INTENT(inout) :: pt2d ! 2D array on which the lbc is applied 108 REAL(wp) , OPTIONAL, INTENT(in ) :: pval ! valeur sur les halo 109 CHARACTER(len=3) , OPTIONAL, INTENT(in ) :: cd_mpp ! MPP only (here do nothing) 110 ! 111 LOGICAL :: ll_grid_crs 112 REAL(wp) :: zval ! valeur sur les halo 121 113 !!---------------------------------------------------------------------- 122 114 ! 123 115 ll_grid_crs = ( jpi == jpi_crs ) 124 116 ! 125 117 IF( PRESENT(pval) ) THEN ; zval = pval 126 ELSE ; zval = 0. 0118 ELSE ; zval = 0._wp 127 119 ENDIF 128 129 IF( .NOT. 130 120 ! 121 IF( .NOT.ll_grid_crs ) CALL dom_grid_crs ! Save the parent grid information & Switch to coarse grid domain 122 ! 131 123 IF( PRESENT( cd_mpp ) ) THEN ; CALL lbc_lnk( pt2d, cd_type, psgn, cd_mpp, pval=zval ) 132 124 ELSE ; CALL lbc_lnk( pt2d, cd_type, psgn, pval=zval ) 133 125 ENDIF 134 135 IF( .NOT. 136 126 ! 127 IF( .NOT.ll_grid_crs ) CALL dom_grid_glo ! Return to parent grid domain 128 ! 137 129 END SUBROUTINE crs_lbc_lnk_2d 138 130 139 131 !!====================================================================== 140 132 END MODULE crslbclnk
Note: See TracChangeset
for help on using the changeset viewer.