Changeset 5601 for branches/2015/dev_r5003_MERCATOR6_CRS
- Timestamp:
- 2015-07-16T11:04:29+02:00 (9 years ago)
- Location:
- branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO
- Files:
-
- 38 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/CRS/crs.F90
r5105 r5601 147 147 148 148 ! Physical and dynamical ocean fields for output or passing to TOP, time-mean fields 149 REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: tsb_crs,tsn_crs 149 REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: tsb_crs,tsn_crs,rab_crs_n 150 150 REAL(wp), DIMENSION(:,:,:) , ALLOCATABLE :: un_crs, vn_crs, wn_crs, rke_crs 151 151 REAL(wp), DIMENSION(:,:,:) , ALLOCATABLE :: ub_crs, vb_crs … … 163 163 REAL(wp), PUBLIC, DIMENSION(:,:) , ALLOCATABLE :: rnf_crs 164 164 165 REAL(wp), PUBLIC, DIMENSION(:,:,:) , ALLOCATABLE :: uslp_crs, wslpi_crs !: i_slope at U- and W-points 166 REAL(wp), PUBLIC, DIMENSION(:,:,:) , ALLOCATABLE :: vslp_crs, wslpj_crs !: j-slope at V- and W-points 167 168 ! Horizontal diffusion 169 #if defined key_traldf_c3d 170 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: ahtt_crs, ahtu_crs, ahtv_crs, ahtw_crs !: ** 3D coefficients ** at T-,U-,V-,W-points 171 #elif defined key_traldf_c2d 172 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ahtt_crs, ahtu_crs, ahtv_crs, ahtw_crs !: ** 2D coefficients ** at T-,U-,V-,W-points 173 #elif defined key_traldf_c1d 174 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: ahtt_crs, ahtu_crs, ahtv_crs, ahtw_crs !: ** 1D coefficients ** at T-,U-,V-,W-points 175 #else 176 REAL(wp), PUBLIC :: ahtt_crs, ahtu_crs, ahtv_crs, ahtw_crs !: ** 0D coefficients ** at T-,U-,V-,W-points 177 #endif 178 165 179 ! Vertical diffusion 166 180 REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:,:) :: avt_crs !: vert. diffusivity coef. [m2/s] at w-point for temp … … 184 198 !!------------------------------------------------------------------- 185 199 !! Local variables 186 INTEGER, DIMENSION(1 4) :: ierr200 INTEGER, DIMENSION(15) :: ierr 187 201 188 202 ierr(:) = 0 … … 246 260 & hdivb_crs(jpi_crs,jpj_crs,jpk) , hdivn_crs(jpi_crs,jpj_crs,jpk) , & 247 261 & rke_crs(jpi_crs,jpj_crs,jpk), rhop_crs(jpi_crs,jpj_crs,jpk) , & 248 & rb2_crs(jpi_crs,jpj_crs,jpk) ,rhd_crs(jpi_crs,jpj_crs,jpk) , &249 & gtsu_crs(jpi_crs,jpj_crs,jp k) ,gtsv_crs(jpi_crs,jpj_crs,jpk) , &262 & rb2_crs(jpi_crs,jpj_crs,jpk) ,rhd_crs(jpi_crs,jpj_crs,jpk) , rab_crs_n(jpi_crs,jpj_crs,jpk,jpts) , & 263 & gtsu_crs(jpi_crs,jpj_crs,jpts) ,gtsv_crs(jpi_crs,jpj_crs,jpts) , & 250 264 gru_crs(jpi_crs,jpj_crs) ,grv_crs(jpi_crs,jpj_crs) , STAT=ierr(11)) 251 265 … … 256 270 & fr_i_crs(jpi_crs,jpj_crs), sfx_crs(jpi_crs ,jpj_crs), fmmflx_crs(jpi_crs ,jpj_crs), STAT=ierr(12) ) 257 271 272 #if defined key_traldf_c3d 273 ALLOCATE( ahtt_crs(jpi_crs,jpj_crs,jpk) , ahtu_crs(jpi_crs,jpj_crs,jpk) , ahtv_crs(jpi_crs,jpj_crs,jpk) , ahtw_crs(jpi_crs,jpj_crs,jpk) , STAT=ierr(13) ) 274 #elif defined key_traldf_c2d 275 ALLOCATE( ahtt_crs(jpi_crs,jpj_crs ) , ahtu_crs(jpi_crs,jpj_crs ) , ahtv_crs(jpi_crs,jpj_crs ) , ahtw_crs(jpi_crs,jpj_crs ) , STAT=ierr(13) ) 276 #elif defined key_traldf_c1d 277 ALLOCATE( ahtt_crs( jpk) , ahtu_crs( jpk) , ahtv_crs( jpk) , ahtw_crs( jpk) , STAT=ierr(13) ) 278 #endif 279 258 280 ALLOCATE( tsn_crs(jpi_crs,jpj_crs,jpk,jpts), tsb_crs(jpi_crs,jpj_crs,jpk,jpts), avt_crs(jpi_crs,jpj_crs,jpk), & 259 281 # if defined key_zdfddm 260 282 & avs_crs(jpi_crs,jpj_crs,jpk), & 261 283 # endif 262 & STAT=ierr(1 3) )284 & STAT=ierr(14) ) 263 285 264 286 ALLOCATE( nmln_crs(jpi_crs,jpj_crs) , hmld_crs(jpi_crs,jpj_crs) , & 265 & hmlp_crs(jpi_crs,jpj_crs) , hmlpt_crs(jpi_crs,jpj_crs) , STAT=ierr(1 4) )287 & hmlp_crs(jpi_crs,jpj_crs) , hmlpt_crs(jpi_crs,jpj_crs) , STAT=ierr(15) ) 266 288 267 289 crs_dom_alloc1 = MAXVAL(ierr) -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/CRS/crsdom.F90
r5105 r5601 1633 1633 ENDIF 1634 1634 ELSE 1635 DO ji = nistr, niend, nn_factx 1636 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 1635 1637 je_2 = mjs_crs(2) 1636 1638 zflcrs = & … … 1646 1648 ! 1647 1649 p_fld_crs(ii,2) = zflcrs 1650 ENDDO 1648 1651 ENDIF 1649 1652 … … 2070 2073 ENDDO 2071 2074 ENDDO 2075 2076 2077 !first level 2072 2078 DO ji = nistr, niend, nn_factx 2073 2079 ii = ( ji - mis_crs(2) ) * rfactx_r + 2 … … 2219 2225 END SELECT 2220 2226 2221 WRITE(narea+200,*)"TOTO",nldj_crs,mjs_crs(1), mje_crs(1),mjs_crs(2), mje_crs(2),mjs_crs(3), mje_crs(3),mjs_crs(4), mje_crs(4) ; CALL FLUSH(narea+200)2227 !WRITE(narea+200,*)"TOTO",nldj_crs,mjs_crs(1), mje_crs(1),mjs_crs(2), mje_crs(2),mjs_crs(3), mje_crs(3),mjs_crs(4), mje_crs(4) ; CALL FLUSH(narea+200) 2222 2228 2223 2229 SELECT CASE ( cd_type ) … … 2270 2276 & + zsurfmsk(ji,jj+2,jk) + zsurfmsk(ji+1,jj+2,jk) + zsurfmsk(ji+2,jj+2,jk) 2271 2277 2272 !cbr2273 iji=117 ; ijj=2112274 iji=iji-nimpp_crs+1 ; ijj=ijj-njmpp_crs+12275 IF( ii==iji .AND. ij==ijj .AND. jk==74 )THEN2276 WRITE(narea+5000,*)"SFC W =======> "2277 WRITE(narea+5000,*)ii,ij,jk2278 WRITE(narea+5000,*)ji,jj2279 WRITE(narea+5000,*)zsurfmsk(ji,jj ,jk) , zsurfmsk(ji+1,jj ,jk) , zsurfmsk(ji+2,jj ,jk)2280 WRITE(narea+5000,*)zsurfmsk(ji,jj+1,jk) , zsurfmsk(ji+1,jj+1,jk) , zsurfmsk(ji+2,jj+1,jk)2281 WRITE(narea+5000,*)zsurfmsk(ji,jj+2,jk) , zsurfmsk(ji+1,jj+2,jk) , zsurfmsk(ji+2,jj+2,jk)2282 WRITE(narea+5000,*) p_surf_crs (ii,ij,jk), p_surf_crs_msk(ii,ij,jk)2283 ENDIF2284 2285 2286 2278 ENDDO 2287 2279 ENDDO … … 2333 2325 & + zsurfmsk(ji+2,jj+1,jk) & 2334 2326 & + zsurfmsk(ji+2,jj+2,jk) 2335 !cbr2336 !iji=117 ; ijj=2112337 !iji=iji-nimpp_crs+1 ; ijj=ijj-njmpp_crs+12338 !IF( ii==iji .AND. ij==ijj .AND. jk==74 )THEN2339 !WRITE(narea+5000,*)"SFC U =======> "2340 !WRITE(narea+5000,*)ii,ij,jk2341 !WRITE(narea+5000,*)ji,jj2342 !WRITE(narea+5000,*)mis_crs(2),rfactx_r , ( ji - 1 - mis_crs(2) ) * rfactx_r2343 !WRITE(narea+5000,*)zsurf(ji+2,jj ,jk),zsurf(ji+2,jj+1,jk),zsurf(ji+2,jj+2,jk)2344 !WRITE(narea+5000,*)zsurfmsk(ji+2,jj ,jk),zsurfmsk(ji+2,jj+1,jk),zsurfmsk(ji+2,jj+2,jk)2345 !WRITE(narea+5000,*)p_surf_crs (ii,ij,jk),p_surf_crs_msk(ii,ij,jk)2346 !ENDIF2347 !iji=116 ; ijj=2112348 !iji=iji-nimpp_crs+1 ; ijj=ijj-njmpp_crs+12349 !IF( ii==iji .AND. ij==ijj .AND. jk==74 )THEN2350 !WRITE(narea+5000,*)"SFC U =======> "2351 !WRITE(narea+5000,*)ii,ij,jk2352 !WRITE(narea+5000,*)ji,jj2353 !WRITE(narea+5000,*)zsurf(ji+2,jj ,jk),zsurf(ji+2,jj+1,jk),zsurf(ji+2,jj+2,jk)2354 !WRITE(narea+5000,*)zsurfmsk(ji+2,jj ,jk),zsurfmsk(ji+2,jj+1,jk),zsurfmsk(ji+2,jj+2,jk)2355 !WRITE(narea+5000,*)p_surf_crs (ii,ij,jk),p_surf_crs_msk(ii,ij,jk)2356 !ENDIF2357 2327 ENDDO 2358 2328 ENDDO … … 2395 2365 p_surf_crs (ii,ij,jk) = zsurf(ji,jj+2,jk) + zsurf(ji+1,jj+2,jk) + zsurf(ji+2,jj+2,jk) 2396 2366 p_surf_crs_msk(ii,ij,jk) = zsurfmsk(ji,jj+2,jk) + zsurfmsk(ji+1,jj+2,jk) + zsurfmsk(ji+2,jj+2,jk) 2397 iji=117 ; ijj=2102398 iji=iji-nimpp_crs+1 ; ijj=ijj-njmpp_crs+12399 IF( ii==iji .AND. ij==ijj .AND. jk==74 )THEN2400 WRITE(narea+5000,*)"SFC V =======> "2401 WRITE(narea+5000,*)ii,ij,jk2402 WRITE(narea+5000,*)ji,jj2403 WRITE(narea+5000,*)zsurfmsk(ji,jj+2,jk),zsurfmsk(ji+1,jj+2,jk),zsurfmsk(ji+2,jj+2,jk)2404 WRITE(narea+5000,*)p_surf_crs (ii,ij,jk),p_surf_crs_msk(ii,ij,jk)2405 ENDIF2367 !iji=117 ; ijj=210 2368 !iji=iji-nimpp_crs+1 ; ijj=ijj-njmpp_crs+1 2369 !IF( ii==iji .AND. ij==ijj .AND. jk==74 )THEN 2370 !WRITE(narea+5000,*)"SFC V =======> " 2371 !WRITE(narea+5000,*)ii,ij,jk 2372 !WRITE(narea+5000,*)ji,jj 2373 !WRITE(narea+5000,*)zsurfmsk(ji,jj+2,jk),zsurfmsk(ji+1,jj+2,jk),zsurfmsk(ji+2,jj+2,jk) 2374 !WRITE(narea+5000,*)p_surf_crs (ii,ij,jk),p_surf_crs_msk(ii,ij,jk) 2375 !ENDIF 2406 2376 ENDDO 2407 2377 ENDDO … … 2409 2379 2410 2380 END SELECT 2411 DO jk=1,jpk2412 DO ji=1,jpi_crs2413 DO jj=1,jpj_crs2414 IF( p_surf_crs_msk(ji,jj,jk) .NE. p_surf_crs_msk(ji,jj,jk) )WRITE(narea+200,*)"SFC 4 ",ji,jj,jk,p_surf_crs_msk(ji,jj,jk) ; call flush(narea+200)2415 ENDDO2416 ENDDO2417 ENDDO2381 !DO jk=1,jpk 2382 !DO ji=1,jpi_crs 2383 !DO jj=1,jpj_crs 2384 ! IF( p_surf_crs_msk(ji,jj,jk) .NE. p_surf_crs_msk(ji,jj,jk) )WRITE(narea+200,*)"SFC 4 ",ji,jj,jk,p_surf_crs_msk(ji,jj,jk) ; call flush(narea+200) 2385 !ENDDO 2386 !ENDDO 2387 !ENDDO 2418 2388 CALL crs_lbc_lnk( p_surf_crs , cd_type, 1.0, pval=1.0 ) 2419 2389 CALL crs_lbc_lnk( p_surf_crs_msk, cd_type, 1.0, pval=1.0 ) … … 2449 2419 jpi_crs = ( jpiglo_crs - 2 * jpreci + (jpni-1) ) / jpni + 2 * jpreci 2450 2420 jpj_crs = ( jpjglo_crsm1 - 2 * jprecj + (jpnj-1) ) / jpnj + 2 * jprecj 2451 WRITE(narea+200,*)"jpj_crs noso = ", jpj_crs , noso2421 !WRITE(narea+200,*)"jpj_crs noso = ", jpj_crs , noso 2452 2422 IF( noso < 0 ) jpj_crs = jpj_crs + 1 ! add a local band on southern processors ! celle qui est faite de zeros 2453 WRITE(narea+200,*)"jpj_crs = ", jpj_crs2423 !WRITE(narea+200,*)"jpj_crs = ", jpj_crs 2454 2424 2455 2425 jpi_crsm1 = jpi_crs - 1 … … 2487 2457 !cbr 2488 2458 DO jn = 1, jpnij 2489 WRITE(narea+200,*)"=====> jn",jn ; call flush(narea+200)2459 !WRITE(narea+200,*)"=====> jn",jn ; call flush(narea+200) 2490 2460 2491 2461 !proc jn … … 2506 2476 ENDIF 2507 2477 2508 WRITE(narea+200,*)ii,ij ; call flush(narea+200)2509 WRITE(narea+200,*)"iproc iprocso ",iproc,iprocso2510 WRITE(narea+200,*)"jpiglo jpjglo ",jpiglo,jpjglo2511 WRITE(narea+200,*)"ibonit(jn) ibonjt(jn) ",ibonit(jn),ibonjt(jn) ; call flush(narea+200)2512 WRITE(narea+200,*)"nimppt(jn) njmppt(jn) ",nimppt(jn),njmppt(jn) ; call flush(narea+200)2513 WRITE(narea+200,*)"loc jpj nldjt(jn),nlejt(jn),nlcjt(jn) ",jpj, nldjt(jn),nlejt(jn),nlcjt(jn) ; call flush(narea+200)2514 WRITE(narea+200,*)"glo jpj nldjt(jn),nlejt(jn),nlcjt(jn) ",jpj, nldjt(jn)+njmppt(jn)-1,nlejt(jn)+njmppt(jn)-1,nlcjt(jn) ; call flush(narea+200)2478 !WRITE(narea+200,*)ii,ij ; call flush(narea+200) 2479 !WRITE(narea+200,*)"iproc iprocso ",iproc,iprocso 2480 !WRITE(narea+200,*)"jpiglo jpjglo ",jpiglo,jpjglo 2481 !WRITE(narea+200,*)"ibonit(jn) ibonjt(jn) ",ibonit(jn),ibonjt(jn) ; call flush(narea+200) 2482 !WRITE(narea+200,*)"nimppt(jn) njmppt(jn) ",nimppt(jn),njmppt(jn) ; call flush(narea+200) 2483 !WRITE(narea+200,*)"loc jpj nldjt(jn),nlejt(jn),nlcjt(jn) ",jpj, nldjt(jn),nlejt(jn),nlcjt(jn) ; call flush(narea+200) 2484 !WRITE(narea+200,*)"glo jpj nldjt(jn),nlejt(jn),nlcjt(jn) ",jpj, nldjt(jn)+njmppt(jn)-1,nlejt(jn)+njmppt(jn)-1,nlcjt(jn) ; call flush(narea+200) 2515 2485 2516 2486 !dimension selon j … … 2519 2489 !iprocno=nfipproc(ii,ij+1) 2520 2490 !iprocno=iprocno+1 2521 WRITE(narea+200,*)"ii,ij+1 ",ii,ij+1; call flush(narea+200)2522 WRITE(narea+200,*)"njmppt jn njmpptno(jn) ",njmppt(jn),njmpptno(jn); call flush(narea+200)2523 WRITE(narea+200,*)"jpjglo",jpjglo ; call flush(narea+200)2524 2525 WRITE(narea+200,*)REAL( ( jpjglo - (njmppt (jn) - 1) ) / nn_facty, wp ),REAL( ( jpjglo - (njmpptno(jn) - 1) ) / nn_facty, wp ); call flush(narea+200)2526 WRITE(narea+200,*)AINT( REAL( ( jpjglo - (njmppt (jn) - 1) ) / nn_facty, wp ) ),AINT( REAL( ( jpjglo - (njmpptno(jn) - 1) ) / nn_facty, wp ) ); call flush(narea+200)2491 !WRITE(narea+200,*)"ii,ij+1 ",ii,ij+1; call flush(narea+200) 2492 !WRITE(narea+200,*)"njmppt jn njmpptno(jn) ",njmppt(jn),njmpptno(jn); call flush(narea+200) 2493 !WRITE(narea+200,*)"jpjglo",jpjglo ; call flush(narea+200) 2494 2495 !WRITE(narea+200,*)REAL( ( jpjglo - (njmppt (jn) - 1) ) / nn_facty, wp ),REAL( ( jpjglo - (njmpptno(jn) - 1) ) / nn_facty, wp ); call flush(narea+200) 2496 !WRITE(narea+200,*)AINT( REAL( ( jpjglo - (njmppt (jn) - 1) ) / nn_facty, wp ) ),AINT( REAL( ( jpjglo - (njmpptno(jn) - 1) ) / nn_facty, wp ) ); call flush(narea+200) 2527 2497 2528 2498 nlejt_crs(jn) = AINT( REAL( ( jpjglo - (njmppt (jn) - 1) ) / nn_facty, wp ) ) & … … 2532 2502 ENDIF 2533 2503 !==> nbondj = -1 au sud, 0 au milieu, 1 au nord, 2 si jpnj=1 2534 WRITE(narea+200,*)"nlejt_crs(jn) ",nlejt_crs(jn) ; call flush(narea+200)2504 !WRITE(narea+200,*)"nlejt_crs(jn) ",nlejt_crs(jn) ; call flush(narea+200) 2535 2505 !!!noso== nbre de proc sud du proc sur lequel on tourne !!!! ; dangeureux car on est ds une boucle sur jn 2536 2506 IF( iprocso < 0 .AND. ibonjt(jn) == -1 ) nlejt_crs(jn) = nlejt_crs(jn) + 1 2537 2507 SELECT CASE( ibonjt(jn) ) 2538 2508 CASE ( -1 ) 2539 WRITE(narea+200,*)"MOD( jpjglo - njmppt(jn), nn_facty)",MOD( jpjglo - njmppt(jn), nn_facty) ; call flush(narea+200)2509 !WRITE(narea+200,*)"MOD( jpjglo - njmppt(jn), nn_facty)",MOD( jpjglo - njmppt(jn), nn_facty) ; call flush(narea+200) 2540 2510 IF( MOD( jpjglo - njmppt(jn), nn_facty) > 0 ) nlejt_crs(jn) = nlejt_crs(jn) + 1 ! au cas où il reste des lignes en bas 2541 2511 IF( nldjt(jn) == 1 ) nlejt_crs(jn) = nlejt_crs(jn) + 1 … … 2558 2528 STOP 2559 2529 END SELECT 2560 WRITE(narea+200,*)"jpj_crs, nldjt_crs(jn),nlejt_crs(jn),nlcjt_crs(jn) " ; call flush(narea+200)2561 WRITE(narea+200,*) jpj_crs, nldjt_crs(jn),nlejt_crs(jn),nlcjt_crs(jn) ; call flush(narea+200)2530 !WRITE(narea+200,*)"jpj_crs, nldjt_crs(jn),nlejt_crs(jn),nlcjt_crs(jn) " ; call flush(narea+200) 2531 !WRITE(narea+200,*) jpj_crs, nldjt_crs(jn),nlejt_crs(jn),nlcjt_crs(jn) ; call flush(narea+200) 2562 2532 IF( nlcjt_crs(jn) > jpj_crs )THEN 2563 2533 jpj_crs = jpj_crs + 1 … … 2572 2542 njmppt_crs(jn) = 2 + ANINT(REAL((njmppt(jn) + 1 - MOD( jpjglo , nn_facty )) / nn_facty, wp ) ) 2573 2543 ENDIF 2574 WRITE(narea+200,*)"tutu loc ",jn,jpj_crs, nldjt_crs(jn),nlejt_crs(jn),nlcjt_crs(jn) ; call flush(narea+200)2575 WRITE(narea+200,*)"tutu glo ",jn,jpj_crs, nldjt_crs(jn)+njmppt_crs(jn)-1,nlejt_crs(jn)+njmppt_crs(jn)-1,nlcjt_crs(jn)+njmppt_crs(jn)-1 ; call flush(narea+200)2544 !WRITE(narea+200,*)"tutu loc ",jn,jpj_crs, nldjt_crs(jn),nlejt_crs(jn),nlcjt_crs(jn) ; call flush(narea+200) 2545 !WRITE(narea+200,*)"tutu glo ",jn,jpj_crs, nldjt_crs(jn)+njmppt_crs(jn)-1,nlejt_crs(jn)+njmppt_crs(jn)-1,nlcjt_crs(jn)+njmppt_crs(jn)-1 ; call flush(narea+200) 2576 2546 2577 2547 … … 2583 2553 nleit_crs(jn) = AINT( REAL( ( nimppt(jn ) - 1 + nlcit(jn ) ) / nn_factx, wp) ) 2584 2554 ELSE 2585 WRITE(narea+200,*)"njmppt jn njmpptea(jn) ",nimppt(jn),nimpptea(jn); call flush(narea+200)2586 WRITE(narea+200,*)"nlcit (jn) nlcitea(jn) ) ",nlcit (jn),nlcitea(jn); call flush(narea+200)2555 !WRITE(narea+200,*)"njmppt jn njmpptea(jn) ",nimppt(jn),nimpptea(jn); call flush(narea+200) 2556 !WRITE(narea+200,*)"nlcit (jn) nlcitea(jn) ) ",nlcit (jn),nlcitea(jn); call flush(narea+200) 2587 2557 nleit_crs(jn) = AINT( REAL( ( nimppt (jn) - 1 + nlcit (jn) ) / nn_factx, wp) ) & 2588 2558 & - AINT( REAL( ( nimpptea(jn) - 1 + nlcitea(jn) ) / nn_factx, wp) ) 2589 2559 ENDIF 2590 WRITE(narea+200,*)"nleji_crs(jn),noso ",nleit_crs(jn); call flush(narea+200)2560 !WRITE(narea+200,*)"nleji_crs(jn),noso ",nleit_crs(jn); call flush(narea+200) 2591 2561 2592 2562 … … 2611 2581 STOP 2612 2582 END SELECT 2613 WRITE(narea+200,*)"jpi_crs, nldit_crs(jn),nleit_crs(jn),nlcit_crs(jn) ",jpi_crs, nldit_crs(jn),nleit_crs(jn),nlcit_crs(jn) ; call flush(narea+200)2583 !WRITE(narea+200,*)"jpi_crs, nldit_crs(jn),nleit_crs(jn),nlcit_crs(jn) ",jpi_crs, nldit_crs(jn),nleit_crs(jn),nlcit_crs(jn) ; call flush(narea+200) 2614 2584 nimppt_crs(jn) = ANINT( REAL( (nimppt(jn) + 1 ) / nn_factx, wp ) ) + 1 2615 2585 2616 WRITE(narea+200,*)"tutu loc ",jn,jpi_crs, nldit_crs(jn),nleit_crs(jn),nlcit_crs(jn) ; call flush(narea+200)2617 WRITE(narea+200,*)"tutu glo ",jn,jpi_crs, nldit_crs(jn)+nimppt_crs(jn)-1,nleit_crs(jn)+nimppt_crs(jn)-1,nlcit_crs(jn)+nimppt_crs(jn)-1 ; call flush(narea+200)2586 !WRITE(narea+200,*)"tutu loc ",jn,jpi_crs, nldit_crs(jn),nleit_crs(jn),nlcit_crs(jn) ; call flush(narea+200) 2587 !WRITE(narea+200,*)"tutu glo ",jn,jpi_crs, nldit_crs(jn)+nimppt_crs(jn)-1,nleit_crs(jn)+nimppt_crs(jn)-1,nlcit_crs(jn)+nimppt_crs(jn)-1 ; call flush(narea+200) 2618 2588 2619 2589 nfiimpp_crs(ii,ij) = nimppt_crs(jn) 2620 WRITE(narea+200,*)"tutu nimppt_crs(jn) ",ii,ij,nimppt_crs(jn) ; call flush(narea+200)2590 !WRITE(narea+200,*)"tutu nimppt_crs(jn) ",ii,ij,nimppt_crs(jn) ; call flush(narea+200) 2621 2591 2622 2592 ENDDO … … 2628 2598 nfiimpp_crs(ji,jj) = iimppt_crs 2629 2599 IF( jn .GE. 1 )nimppt_crs(jn) = iimppt_crs 2630 PRINT*," nfiimpp_crs(ji,jj) ",ji,jj,jn,nfiimpp(ji,jj),nfiimpp_crs(ji,jj)2600 !PRINT*," nfiimpp_crs(ji,jj) ",ji,jj,jn,nfiimpp(ji,jj),nfiimpp_crs(ji,jj) 2631 2601 ENDDO 2632 2602 ENDDO … … 2657 2627 2658 2628 !============================================================================================== 2659 write(narea+200,*)"jpi_crs,nldi_crs,nlei_crs,nlci_crs,nimpp_crs,nldi_crs+nimpp_crs-1,nlei_crs+nimpp_crs-1" ; call flush(narea+200)2660 write(narea+200,*)jpi_crs,nldi_crs,nlei_crs,nlci_crs,nimpp_crs,nldi_crs+nimpp_crs-1,nlei_crs+nimpp_crs-1 ; call flush(narea+200)2661 write(narea+200,*)"jpj_crs,nldj_crs,nlej_crs,nlcj_crs,njmpp_crs,nldj_crs+njmpp_crs-1,nlej_crs+njmpp_crs-1" ; call flush(narea+200)2662 write(narea+200,*)jpj_crs,nldj_crs,nlej_crs,nlcj_crs,njmpp_crs,nldj_crs+njmpp_crs-1,nlej_crs+njmpp_crs-1 ; call flush(narea+200)2663 write(narea+200,*)"nfsloop_crs nfeloop_crs ",nfsloop_crs,nfeloop_crs ; call flush(narea+200)2629 !write(narea+200,*)"jpi_crs,nldi_crs,nlei_crs,nlci_crs,nimpp_crs,nldi_crs+nimpp_crs-1,nlei_crs+nimpp_crs-1" ; call flush(narea+200) 2630 !write(narea+200,*)jpi_crs,nldi_crs,nlei_crs,nlci_crs,nimpp_crs,nldi_crs+nimpp_crs-1,nlei_crs+nimpp_crs-1 ; call flush(narea+200) 2631 !write(narea+200,*)"jpj_crs,nldj_crs,nlej_crs,nlcj_crs,njmpp_crs,nldj_crs+njmpp_crs-1,nlej_crs+njmpp_crs-1" ; call flush(narea+200) 2632 !write(narea+200,*)jpj_crs,nldj_crs,nlej_crs,nlcj_crs,njmpp_crs,nldj_crs+njmpp_crs-1,nlej_crs+njmpp_crs-1 ; call flush(narea+200) 2633 !write(narea+200,*)"nfsloop_crs nfeloop_crs ",nfsloop_crs,nfeloop_crs ; call flush(narea+200) 2664 2634 2665 2635 ! No coarsening with zoom … … 2671 2641 DO ji = 1, jpi_crs 2672 2642 mig_crs(ji) = ji + nimpp_crs - 1 2673 WRITE(narea+200,*)"fifi ",ji,mig_crs(ji) ; call flush(narea+200)2643 !WRITE(narea+200,*)"fifi ",ji,mig_crs(ji) ; call flush(narea+200) 2674 2644 ENDDO 2675 2645 DO jj = 1, jpj_crs 2676 2646 mjg_crs(jj) = jj + njmpp_crs - 1! 2677 WRITE(narea+200,*)"fufu ",jj,mjg_crs(jj) ; call flush(narea+200)2647 !WRITE(narea+200,*)"fufu ",jj,mjg_crs(jj) ; call flush(narea+200) 2678 2648 ENDDO 2679 2649 … … 2681 2651 mi0_crs(ji) = MAX( 1, MIN( ji - nimpp_crs + 1 , jpi_crs + 1 ) ) 2682 2652 mi1_crs(ji) = MAX( 0, MIN( ji - nimpp_crs + 1 , jpi_crs ) ) 2683 WRITE(narea+200,*)"mi ",ji,mi0_crs(ji),mi1_crs(ji) ; call flush(narea+200)2653 !WRITE(narea+200,*)"mi ",ji,mi0_crs(ji),mi1_crs(ji) ; call flush(narea+200) 2684 2654 ENDDO 2685 2655 … … 2687 2657 mj0_crs(jj) = MAX( 1, MIN( jj - njmpp_crs + 1 , jpj_crs + 1 ) ) 2688 2658 mj1_crs(jj) = MAX( 0, MIN( jj - njmpp_crs + 1 , jpj_crs ) ) 2689 WRITE(narea+200,*)"mj ",jj, mj0_crs(jj),mj1_crs(jj) ; call flush(narea+200)2659 !WRITE(narea+200,*)"mj ",jj, mj0_crs(jj),mj1_crs(jj) ; call flush(narea+200) 2690 2660 ENDDO 2691 2661 … … 2810 2780 mjs2_crs(jpjglo_crs-jj+2) = ijjs 2811 2781 mje2_crs(jpjglo_crs-jj+2) = ijje 2812 WRITE(narea+200,*)"jpjglo_crs-jj+2,ijje,ijjs ",jpjglo_crs-jj+2,ijjs,ijje ; call flush(narea+200)2782 !WRITE(narea+200,*)"jpjglo_crs-jj+2,ijje,ijjs ",jpjglo_crs-jj+2,ijjs,ijje ; call flush(narea+200) 2813 2783 ENDDO 2814 2784 … … 2871 2841 mje_crs(:) = mje2_crs(:) 2872 2842 ELSE 2873 write(narea+200,*)"njmpp ",njmpp2843 !write(narea+200,*)"njmpp ",njmpp 2874 2844 DO jj = 1, nlej_crs 2875 write(narea+200,*)jj,"mjs2_crs mje2_crs ",mjg_crs(jj),mjs2_crs(mjg_crs(jj)),mje2_crs(mjg_crs(jj)) ; call flush(narea+200)2845 !write(narea+200,*)jj,"mjs2_crs mje2_crs ",mjg_crs(jj),mjs2_crs(mjg_crs(jj)),mje2_crs(mjg_crs(jj)) ; call flush(narea+200) 2876 2846 mjs_crs(jj) = mjs2_crs(mjg_crs(jj)) - njmpp + 1 2877 2847 mje_crs(jj) = mje2_crs(mjg_crs(jj)) - njmpp + 1 2878 write(narea+200,*)"mjs_crs mje_crs ",mjs_crs(jj),mje_crs(jj) ; call flush(narea+200)2848 !write(narea+200,*)"mjs_crs mje_crs ",mjs_crs(jj),mje_crs(jj) ; call flush(narea+200) 2879 2849 ENDDO 2880 write(narea+200,*)"nimpp ",nimpp2850 !write(narea+200,*)"nimpp ",nimpp 2881 2851 DO ji = 1, nlei_crs 2882 write(narea+200,*)ji,"mis2_crs mie2_crs ",mig_crs(ji),mis2_crs(mig_crs(ji)),mie2_crs(mig_crs(ji)) ; call flush(narea+200)2852 !write(narea+200,*)ji,"mis2_crs mie2_crs ",mig_crs(ji),mis2_crs(mig_crs(ji)),mie2_crs(mig_crs(ji)) ; call flush(narea+200) 2883 2853 mis_crs(ji) = mis2_crs(mig_crs(ji)) - nimpp + 1 2884 2854 mie_crs(ji) = mie2_crs(mig_crs(ji)) - nimpp + 1 2885 write(narea+200,*)"mis_crs mie_crs ",mis_crs(jj),mie_crs(jj) ; call flush(narea+200)2855 !write(narea+200,*)"mis_crs mie_crs ",mis_crs(jj),mie_crs(jj) ; call flush(narea+200) 2886 2856 ENDDO 2887 2857 ENDIF 2888 2858 ! 2889 IF( nlcj_crs -1 .GT. nlej_crs )WRITE(narea+200,*)"tutututu",nlcj_crs,nlej_crs ; call flush(narea+200)2859 !IF( nlcj_crs -1 .GT. nlej_crs )WRITE(narea+200,*)"tutututu",nlcj_crs,nlej_crs ; call flush(narea+200) 2890 2860 nistr = mis_crs(2) ; niend = mis_crs(nlci_crs - 1) 2891 2861 njstr = mjs_crs(3) ; njend = mjs_crs(nlcj_crs - 1) -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/CRS/crsdomwri.F90
r4294 r5601 205 205 CALL iom_rstput( 0, 0, inum4, 'e3u', e3u_crs ) 206 206 CALL iom_rstput( 0, 0, inum4, 'e3v', e3v_crs ) 207 CALL iom_rstput( 0, 0, inum4, 'e3t_max_crs', e3t_max_crs ) 208 CALL iom_rstput( 0, 0, inum4, 'e3w_max_crs', e3w_max_crs ) 207 209 ELSE 208 210 DO jj = 1,jpj_crs -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/CRS/crsfld.F90
r5105 r5601 17 17 USE zdf_oce ! vertical physics: ocean fields 18 18 USE zdfddm ! vertical physics: double diffusion 19 USe zdfmxl 19 20 USE lbclnk ! ocean lateral boundary conditions (or mpp link) 20 21 USE in_out_manager ! I/O manager … … 25 26 USE crslbclnk 26 27 USE iom 28 USE zdfmxl_crs 27 29 28 30 IMPLICIT NONE … … 64 66 REAL(wp), POINTER, DIMENSION(:,:,:) :: zfse3t, zfse3u, zfse3v, zfse3w ! 3D workspace for e3 65 67 REAL(wp), POINTER, DIMENSION(:,:,:) :: zt, zs 68 REAL(wp), POINTER, DIMENSION(:,:) :: z2d,z2d_crs 66 69 REAL(wp), POINTER, DIMENSION(:,:,:) :: zt_crs, zs_crs ! 67 70 REAL(wp) :: z2dcrsu, z2dcrsv … … 71 74 INTEGER :: iji,ijj 72 75 !! 73 !!---------------------------------------------------------------------- 74 ! 75 !IF(narea==267)WRITE(narea+5000,*)"========================================> crsfldt ",kt 76 !!---------------------------------------------------------------------- 76 77 77 78 IF( nn_timing == 1 ) CALL timing_start('crs_fld') … … 80 81 CALL wrk_alloc( jpi, jpj, jpk, zfse3t, zfse3w ) 81 82 CALL wrk_alloc( jpi, jpj, jpk, zfse3u, zfse3v ) 82 CALL wrk_alloc( jpi, jpj, jpk, zt, zs ) 83 CALL wrk_alloc( jpi, jpj, jpk, zt, zs ) 84 CALL wrk_alloc( jpi, jpj, z2d ) 83 85 ! 84 86 CALL wrk_alloc( jpi_crs, jpj_crs, jpk, zt_crs, zs_crs ) 87 CALL wrk_alloc( jpi_crs, jpj_crs, z2d_crs ) 85 88 86 89 ! Depth work arrrays … … 130 133 zs(:,:,:) = tsb(:,:,:,jp_sal) ; zs_crs(:,:,:) = 0._wp 131 134 CALL crs_dom_ope( zs, 'VOL', 'T', tmask, zs_crs, p_e12=e1e2t, p_e3=zfse3t, psgn=1.0 ) 132 tsb_crs(:,:,:,jp_sal) = z t_crs(:,:,:)135 tsb_crs(:,:,:,jp_sal) = zs_crs(:,:,:) 133 136 zs(:,:,:) = tsn(:,:,:,jp_sal) ; zs_crs(:,:,:) = 0._wp 134 137 CALL crs_dom_ope( zs, 'VOL', 'T', tmask, zs_crs, p_e12=e1e2t, p_e3=zfse3t, psgn=1.0 ) 135 tsn_crs(:,:,:,jp_sal) = z t_crs(:,:,:)138 tsn_crs(:,:,:,jp_sal) = zs_crs(:,:,:) 136 139 137 140 CALL iom_put( "soce" , tsn_crs(:,:,:,jp_sal) ) ! sal … … 162 165 163 166 ! V-velocity 164 !IF(narea==267)WRITE(narea+5000,*)"deg vb_crs"165 167 CALL crs_dom_ope( vb, 'SUM', 'V', vmask, vb_crs, p_e12=e1v, p_e3=zfse3v, p_surf_crs=e1e3v_msk, psgn=-1.0 ) 166 !IF(narea==267)WRITE(narea+5000,*)"deg vn_crs"167 168 CALL crs_dom_ope( vn, 'SUM', 'V', vmask, vn_crs, p_e12=e1v, p_e3=zfse3v, p_surf_crs=e1e3v_msk, psgn=-1.0 ) 168 !IF(narea==267)WRITE(narea+5000,*)"1 vn_crs(17,5,74) = ",vn_crs(17,5,74),vmask_crs(17,5,74),vn(46,13,74),vn(47,13,74),vn(48,13,74)169 169 vb_crs(:,:,:) = vb_crs(:,:,:)*vmask_crs(:,:,:) 170 170 vn_crs(:,:,:) = vn_crs(:,:,:)*vmask_crs(:,:,:) 171 !IF(narea==267)WRITE(narea+5000,*)"2 vn_crs(17,5,74) = ",vn_crs(17,5,74),vmask_crs(17,5,74),vn(46,13,74),vn(47,13,74),vn(48,13,74)172 171 ! 173 172 zt(:,:,:) = 0._wp ; zs(:,:,:) = 0._wp ; zt_crs(:,:,:) = 0._wp ; zs_crs(:,:,:) = 0._wp … … 209 208 ! 210 209 !cbr 211 !212 210 !bug1: il manquait le facvol_t(ji,jj,jk) ds la division ; ca creait des grosses erreurs de Wcrs ( vu en recalculant la divergence 3D ) 213 211 !bug2: mm test que bug1: on n'obtient tjs pas zero … … 215 213 !exp (117,211,74) : e1*e2*e3=235206030060.005 / ocean_volume_crs_t * facvol = 235205585307.810 216 214 ! e1*e2*e3-cean_volume_crs_t * facvol/(cean_volume_crs_t * facvol) ~1.e-6) 217 !IF( ocean_volume_crs_t(ji,jj,jk) .NE. 0._wp ) hdivn_crs(ji,jj,jk) = ( z2dcrsu + z2dcrsv ) / (facvol_t(ji,jj,jk)*ocean_volume_crs_t(ji,jj,jk))218 !IF( ocean_volume_crs_t(ji,jj,jk) .NE. 0._wp ) hdivn_crs(ji,jj,jk) = ( z2dcrsu + z2dcrsv ) / (e1t_crs(ji,jj)*e2t_crs(ji,jj)*e3t_crs(ji,jj,jk))219 215 IF( ocean_volume_crs_t(ji,jj,jk) .NE. 0._wp ) hdivn_crs(ji,jj,jk) = ( z2dcrsu + z2dcrsv ) 220 216 221 !iji=117 ; ijj=211222 !iji=iji-nimpp_crs+1 ; ijj=ijj-njmpp_crs+1223 !IF( ji==iji .AND. jj==ijj )THEN224 !WRITE(narea+5000,*)"hdivn_crs =======> "225 !WRITE(narea+5000,*) "u" ,jk,un_crs(ji ,jj ,jk) ,e2e3u_msk(ji ,jj ,jk),un_crs(ji ,jj ,jk)*e2e3u_msk(ji ,jj ,jk)226 !WRITE(narea+5000,*) "um1",jk,un_crs(ji-1,jj ,jk) , e2e3u_msk(ji-1,jj ,jk),un_crs(ji-1,jj ,jk) * e2e3u_msk(ji-1,jj ,jk)227 !WRITE(narea+5000,*) "v",jk,vn_crs(ji ,jj ,jk) , e1e3v_msk(ji ,jj ,jk),vn_crs(ji ,jj ,jk) * e1e3v_msk(ji ,jj ,jk)228 !WRITE(narea+5000,*) "vm1",jk,vn_crs(ji ,jj-1,jk) , e1e3v_msk(ji ,jj-1,jk),vn_crs(ji ,jj-1,jk) * e1e3v_msk(ji ,jj-1,jk)229 !WRITE(narea+5000,*) "t1 ",jk,z2dcrsu,z2dcrsv, z2dcrsu + z2dcrsv,hdivn_crs(ji,jj,jk)230 !WRITE(narea+5000,*) "t2 ",jk,e1t_crs(ji,jj),e2t_crs(ji,jj),e3t_crs(ji,jj,jk),e1t_crs(ji,jj)*e2t_crs(ji,jj)*e3t_crs(ji,jj,jk)231 !WRITE(narea+5000,*) "t3 ",jk,ocean_volume_crs_t(ji,jj,jk),facvol_t(ji,jj,jk),facvol_t(ji,jj,jk)*ocean_volume_crs_t(ji,jj,jk)232 !WRITE(narea+5000,*) "t4 ",jk, ( z2dcrsu + z2dcrsv ) / (facvol_t(ji,jj,jk)*ocean_volume_crs_t(ji,jj,jk))233 !WRITE(narea+5000,*) "t5 ",jk, ( z2dcrsu + z2dcrsv ) / (e1t_crs(ji,jj)*e2t_crs(ji,jj)*e3t_crs(ji,jj,jk))234 !ENDIF235 236 237 !IF( crs_volt_wgt(ji,jj,jk) .NE. 0._wp ) hdivn_crs(ji,jj,jk) = ( z2dcrsu + z2dcrsv ) / crs_volt_wgt(ji,jj,jk)238 217 z2dcrsu = ( ub_crs(ji ,jj ,jk) * e2e3u_msk(ji ,jj ,jk) ) & 239 218 & - ( ub_crs(ji-1,jj ,jk) * e2e3u_msk(ji-1,jj ,jk) ) … … 251 230 252 231 253 ! DO jk = 1, jpkm1 ! Interior value254 ! DO jj = 1, jpj_crs255 ! DO ji = 1, jpi_crs256 ! IF( e3t_crs(ji,jj,jk) .NE. e3t_crs(ji,jj,jk) )WRITE(narea+200,*)"e3t_crs",e3t_crs(ji,jj,jk) ; call flush(narea+200)257 ! IF( hdivn_crs(ji,jj,jk) .NE. hdivn_crs(ji,jj,jk) )WRITE(narea+200,*)"hdivn_crs",hdivn_crs(ji,jj,jk) ; call flush(narea+200)258 ! END DO259 ! END DO260 ! END DO261 262 232 ! W-velocity 263 233 IF( ln_crs_wn ) THEN … … 266 236 wn_crs(:,:,jpk) = 0._wp 267 237 DO jk = jpkm1, 1, -1 268 !cbr wn_crs(:,:,jk) = wn_crs(:,:,jk+1) - e3t_crs(:,:,jk) * hdivn_crs(:,:,jk)269 238 wn_crs(:,:,jk) = e1e2w_msk(:,:,jk+1)*wn_crs(:,:,jk+1) - hdivn_crs(:,:,jk) 270 239 WHERE( e1e2w_msk(:,:,jk) .NE. 0._wp ) wn_crs(:,:,jk) = wn_crs(:,:,jk) /e1e2w_msk(:,:,jk) … … 286 255 ! 287 256 CALL iom_put( "avt", avt_crs ) ! Kz 288 257 258 !deja dasn step CALL zdf_mxl_crs(kt) 259 260 289 261 ! sbc fields 290 262 … … 303 275 CALL crs_dom_ope( fr_i , 'SUM', 'T', tmask, fr_i_crs , p_e12=e1e2t, p_surf_crs=e1e2t_crs, psgn=1.0 ) 304 276 277 z2d=REAL(nmln,wp) 278 CALL crs_dom_ope( z2d , 'MAX', 'T', tmask, z2d_crs , p_e12=e1e2t, p_surf_crs=e1e2t_crs, psgn=1.0 ) 279 nmln_crs=INT(z2d_crs) 280 nmln_crs=MAX(nlb10,nmln_crs) 281 305 282 CALL iom_put( "ssh" , sshn_crs ) ! ssh output 306 283 CALL iom_put( "utau" , utau_crs ) ! i-tau output … … 313 290 CALL iom_put( "ice_cover", fr_i_crs ) ! ice cover output 314 291 315 !cbr316 !IF(narea==267)WRITE(narea+5000,*)"vn_crs(17,5,74) = ",vn_crs(17,5,74)317 !ji=117 ; jj=211 ; jk=74318 !ji=ji-nimpp_crs+1 ; jj=jj-njmpp_crs+1319 !IF( ji .GE. 2 .AND. ji .LE. jpi_crs-1 .AND. jj .GE. 2 .AND. jj .LE. jpj_crs-1 )THEN320 !WRITE(narea+5000,*)"=======> kt ",kt321 !WRITE(narea+5000,*)ji,jj,glamt(ji,jj),gphit(ji,jj)322 !WRITE(narea+5000,*)"um1 crs ",umask_crs(ji-1,jj,jk),e2e3u_msk(ji-1,jj,jk),un_crs(ji-1,jj,jk),umask_crs(ji-1,jj,jk)*e2e3u_msk(ji-1,jj,jk)*un_crs(ji-1,jj,jk)323 !WRITE(narea+5000,*)"u crs ",umask_crs(ji,jj,jk),e2e3u_msk(ji,jj,jk),un_crs(ji,jj,jk),umask_crs(ji,jj,jk)*e2e3u_msk(ji,jj,jk)*un_crs(ji,jj,jk)324 !WRITE(narea+5000,*)"vm1 crs ",vmask_crs(ji,jj-1,jk),e1e3v_msk(ji,jj-1,jk),vn_crs(ji,jj-1,jk),vmask_crs(ji,jj-1,jk)*e1e3v_msk(ji,jj-1,jk)*vn_crs(ji,jj-1,jk)325 !WRITE(narea+5000,*)"v crs ",vmask_crs(ji,jj,jk),e1e3v_msk(ji,jj,jk),vn_crs(ji,jj,jk),vmask_crs(ji,jj,jk)*e1e3v_msk(ji,jj,jk)*vn_crs(ji,jj,jk)326 !WRITE(narea+5000,*)"wp1 crs ",tmask_crs(ji,jj,jk+1),e1e2w_msk(ji,jj,jk+1),wn_crs(ji,jj,jk+1),tmask_crs(ji,jj,jk+1)*e1e2w_msk(ji,jj,jk+1)*wn_crs(ji,jj,jk+1)327 !WRITE(narea+5000,*)"w crs ",tmask_crs(ji,jj,jk),e1e2w_msk(ji,jj,jk),wn_crs(ji,jj,jk),tmask_crs(ji,jj,jk)*e1e2w_msk(ji,jj,jk)*wn_crs(ji,jj,jk)328 !z = umask_crs(ji,jj,jk)*e2e3u_msk(ji,jj,jk)*un_crs(ji,jj,jk) - umask_crs(ji-1,jj,jk)*e2e3u_msk(ji-1,jj,jk)*un_crs(ji-1,jj,jk) + &329 ! vmask_crs(ji,jj,jk)*e1e3v_msk(ji,jj,jk)*vn_crs(ji,jj,jk) - vmask_crs(ji,jj-1,jk)*e1e3v_msk(ji,jj-1,jk)*vn_crs(ji,jj-1,jk) + &330 ! tmask_crs(ji,jj,jk)*e1e2w_msk(ji,jj,jk)*wn_crs(ji,jj,jk) - tmask_crs(ji,jj,jk+1)*e1e2w_msk(ji,jj,jk+1)*wn_crs(ji,jj,jk+1)331 !WRITE(narea+5000,*)"sum ",z332 !ijie = mie_crs(ji)333 !ijis = mis_crs(ji)334 !ijje = mje_crs(jj)335 !ijjs = mjs_crs(jj)336 !DO i=ijis,ijie337 ! DO j=ijjs,ijje338 ! WRITE(narea+5000,*)"tmask",i,j,tmask(i,j,jk)339 ! ENDDO340 !ENDDO341 342 !z=0._wp343 !zsm=0._wp344 !DO i=ijis,ijie345 ! DO j=ijjs,ijje346 ! WRITE(narea+5000,*)"w",i,j,tmask(i,j,jk),e1t(i,j),e2t(i,j),e1t(i,j)*e2t(i,j),wn(i,j,jk)347 ! z=z+tmask(i,j,jk)*e1t(i,j)*e2t(i,j)*wn(i,j,jk)348 ! zsm=zsm+tmask(i,j,jk)*e1t(i,j)*e2t(i,j)349 ! ENDDO350 !ENDDO351 352 !zw=z353 !WRITE(narea+5000,*)"w sum ",zsm,zw354 !z=0._wp355 !zsm=0._wp356 !DO i=ijis,ijie357 ! DO j=ijjs,ijje358 ! WRITE(narea+5000,*)"wp1 ",i,j,tmask(i,j,jk+1),e1t(i,j),e2t(i,j),e1t(i,j)*e2t(i,j),wn(i,j,jk+1)359 ! z=z+tmask(i,j,jk+1)*e1t(i,j)*e2t(i,j)*wn(i,j,jk+1)360 ! zsm=zsm+tmask(i,j,jk+1)*e1t(i,j)*e2t(i,j)361 ! ENDDO362 !ENDDO363 !zwp1=z364 !WRITE(narea+5000,*)"wp1 sum ",zsm,zwp1365 !z=0._wp366 !zsm=0._wp367 !i=ijis-1368 !DO j=ijjs,ijje369 ! WRITE(narea+5000,*)"um1",i,j,umask(i,j,jk),e2u(i,j),e3u_0(i,j,jk),e2u(i,j)*e3u_0(i,j,jk),un(i,j,jk)370 ! z=z+e2u(i,j)*e3u_0(i,j,jk)*un(i,j,jk)371 ! zsm=zsm+e2u(i,j)*e3u_0(i,j,jk)*umask(i,j,jk)372 !ENDDO373 !zum1=z374 !WRITE(narea+5000,*)"um1 sum ",zsm,zum1375 !z=0._wp376 !zsm=0._wp377 !i=ijie378 !DO j=ijjs,ijje379 ! WRITE(narea+5000,*)"u",i,j,umask(i,j,jk),e2u(i,j),e3u_0(i,j,jk),e2u(i,j)*e3u_0(i,j,jk),un(i,j,jk)380 ! z=z+e2u(i,j)*e3u_0(i,j,jk)*un(i,j,jk)381 ! zsm=zsm+e2u(i,j)*e3u_0(i,j,jk)*umask(i,j,jk)382 !ENDDO383 !zu=z384 !WRITE(narea+5000,*)"u sum ",zsm,zu385 !z=0._wp386 !zsm=0._wp387 !j=ijjs-1388 !DO i=ijis,ijie389 ! WRITE(narea+5000,*)"vm1",i,j,vmask(i,j,jk),e1v(i,j),e3v_0(i,j,jk),e1v(i,j)*e3v_0(i,j,jk),vn(i,j,jk)390 ! z=z+e1v(i,j)*e3v_0(i,j,jk)*vn(i,j,jk)391 ! zsm=zsm+e1v(i,j)*e3v_0(i,j,jk)*vmask(i,j,jk)392 !ENDDO393 !zvm1=z394 !WRITE(narea+5000,*)"vm1 sum ",zsm,zvm1395 !z=0._wp396 !zsm=0._wp397 !j=ijje398 !DO i=ijis,ijie399 ! WRITE(narea+5000,*)"v",i,j,vmask(i,j,jk),e1v(i,j),e3v_0(i,j,jk),e1v(i,j)*e3v_0(i,j,jk),vn(i,j,jk)400 ! z=z+e1v(i,j)*e3v_0(i,j,jk)*vn(i,j,jk)401 ! zsm=zsm+e1v(i,j)*e3v_0(i,j,jk)*vmask(i,j,jk)402 !ENDDO403 !zv=z404 !WRITE(narea+5000,*)"v sum ",zv405 !WRITE(narea+5000,*)"sum ",zw+zwp1+zum1+zu+zvm1+zv406 !DO i=ijis,ijie407 ! DO j=ijjs,ijje408 ! WRITE(narea+5000,*)"msk",i,j,tmask(i,j,jk),umask(i,j,jk),vmask(i,j,jk)409 ! WRITE(narea+5000,*)"vel",i,j,un(i,j,jk),vn(i,j,jk),wn(i,j,jk)410 ! ENDDO411 !ENDDO412 413 !DO i=ijis,ijie414 ! DO j=ijjs,ijje415 ! z = un(i,j,jk)*e2u(i,j)*e3u_0(i,j,jk)*umask(i,j,jk) - un(i-1,j,jk)*e2u(i-1,j)*e3u_0(i-1,j,jk)*umask(i-1,j,jk) + &416 ! vn(i,j,jk)*e1v(i,j)*e3v_0(i,j,jk)*vmask(i,j,jk) - vn(i,j-1,jk)*e1v(i,j-1)*e3v_0(i,j-1,jk)*vmask(i,j-1,jk) + &417 ! wn(i,j,jk)*e2t(i,j)*e1t(i,j)*tmask(i,j,jk) - wn(i,j,jk+1)*e2t(i,j)*e1t(i,j)*tmask(i,j,jk+1)418 ! WRITE(narea+5000,*)"div ",i,j,jk,z419 ! ENDDO420 !ENDDO421 422 !ENDIF423 424 425 426 292 ! free memory 427 293 CALL wrk_dealloc( jpi, jpj, jpk, zfse3t, zfse3w ) 428 294 CALL wrk_dealloc( jpi, jpj, jpk, zfse3u, zfse3v ) 429 CALL wrk_dealloc( jpi, jpj, jpk, zt, zs ) 295 CALL wrk_dealloc( jpi, jpj, jpk, zt, zs ) 296 CALL wrk_dealloc( jpi, jpj, z2d ) 430 297 CALL wrk_dealloc( jpi_crs, jpj_crs, jpk, zt_crs, zs_crs ) 298 CALL wrk_dealloc( jpi_crs, jpj_crs, z2d_crs ) 431 299 ! 432 300 CALL iom_swap( "nemo" ) ! return back on high-resolution grid -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/CRS/crsini.F90
r5105 r5601 20 20 USE crslbclnk 21 21 USE lib_mpp 22 USE ldftra_crs 22 23 23 24 IMPLICIT NONE … … 179 180 CASE ( 0, 1, 4 ) ! mesh on the sphere 180 181 181 zmin=MINVAL(ABS(gphif_crs(:,:)));zmax=MAXVAL(ABS(gphif_crs(:,:)));CALL mpp_min(zmin);CALL mpp_max(zmax);IF(lwp)WRITE(numout,*)"gphif_crs",zmin,zmax182 182 ff_crs(:,:) = 2. * omega * SIN( rad * gphif_crs(:,:) ) 183 183 … … 206 206 e1e3v_msk(:,:,:)=0._wp 207 207 CALL crs_dom_sfc( tmask, 'W', e1e2w_crs, e1e2w_msk, p_e1=e1t, p_e2=e2t ) 208 WRITE(narea+200,*)"e1e2w_crs(2,18,1) ",e1e2w_crs(2,18,1)209 208 CALL crs_dom_sfc( umask, 'U', e2e3u_crs, e2e3u_msk, p_e2=e2u, p_e3=zfse3u ) 210 209 CALL crs_dom_sfc( vmask, 'V', e1e3v_crs, e1e3v_msk, p_e1=e1v, p_e3=zfse3v ) … … 212 211 !cbr facsurfu(:,:,:) = umask_crs(:,:,:) * e2e3u_msk(:,:,:) / e2e3u_crs(:,:,:) 213 212 !cbr facsurfv(:,:,:) = vmask_crs(:,:,:) * e1e3v_msk(:,:,:) / e1e3v_crs(:,:,:) 214 WRITE(narea+200,*)'umask_crs ',SHAPE(umask_crs)215 WRITE(narea+200,*)jpi,jpj,jpk216 WRITE(narea+200,*)"e1e2w_crs(2,18,1) ",e1e2w_crs(2,18,1)217 CALL flush(narea+200)218 219 213 DO jk=1,jpk 220 214 DO ji=1,jpi_crs … … 222 216 223 217 facsurfu(ji,jj,jk) = umask_crs(ji,jj,jk) * e2e3u_msk(ji,jj,jk) 224 225 IF( facsurfu(ji,jj,jk) .NE. facsurfu(ji,jj,jk) )WRITE(narea+200,*)'BUG1',facsurfu(ji,jj,jk);call flush(narea+200) 226 IF( e2e3u_crs(ji,jj,jk) .NE. e2e3u_crs(ji,jj,jk) ) WRITE(narea+200,*)'BUG2',e2e3u_crs(ji,jj,jk);call flush(narea+200) 227 IF( e2e3u_msk(ji,jj,jk) .NE. e2e3u_msk(ji,jj,jk) ) WRITE(narea+200,*)'BUG3',e2e3u_msk(ji,jj,jk) ;call flush(narea+200) 228 IF( e1e2w_msk(ji,jj,jk) .NE. e1e2w_msk(ji,jj,jk) ) WRITE(narea+200,*)'BUG4',ji,jj,jk,e1e2w_msk(ji,jj,jk) ;call flush(narea+200) 229 IF( tmask(ji,jj,jk) .NE. tmask(ji,jj,jk) ) WRITE(narea+200,*)'BUG4',tmask(ji,jj,jk) ;call flush(narea+200) 230 IF( e1t(ji,jj) .NE. e1t(ji,jj) ) WRITE(narea+200,*)'BUG5',e1t(ji,jj) ;call flush(narea+200) 231 IF( e1t(ji,jj) .NE. e2t(ji,jj) ) WRITE(narea+200,*)'BUG6',e2t(ji,jj) ;call flush(narea+200) 218 IF( e2e3u_crs(ji,jj,jk) .NE. 0._wp ) facsurfu(ji,jj,jk) = facsurfu(ji,jj,jk) / e2e3u_crs(ji,jj,jk) 232 219 233 220 facsurfv(ji,jj,jk) = vmask_crs(ji,jj,jk) * e1e3v_msk(ji,jj,jk) … … 264 251 265 252 ! 3.d.3 Vertical depth (meters) 253 !cbr: il semblerait que p_e3=... ne soit pas utile ici !!!!!!!!! 266 254 CALL crs_dom_ope( gdept_0, 'MAX', 'T', tmask, gdept_crs, p_e3=zfse3t, psgn=1.0 ) 267 255 CALL crs_dom_ope( gdepw_0, 'MAX', 'W', tmask, gdepw_crs, p_e3=zfse3w, psgn=1.0 ) … … 271 259 ! 4. Coarse grid ocean volume and averaging weights 272 260 !--------------------------------------------------------- 273 ! 4.a. Ocean volume or area unmasked and masked274 261 CALL crs_dom_facvol( tmask, 'T', e1t, e2t, zfse3t, ocean_volume_crs_t, facvol_t ) 275 262 ! … … 280 267 281 268 CALL crs_dom_facvol( tmask, 'W', e1t, e2t, zfse3w, ocean_volume_crs_w, facvol_w ) 282 ! 283 !--------------------------------------------------------- 284 ! 5. Write out coarse meshmask (see OPA_SRC/DOM/domwri.F90 for ideas later) 269 270 271 !--------------------------------------------------------- 272 ! 5. Coarse grid ocean volume and averaging weights 273 !--------------------------------------------------------- 274 !CALL dom_grid_crs ! Save the parent grid information & Switch to coarse grid domain 275 !CALL ldf_tra_crs_init 276 !CALL dom_grid_glo ! Return to parent grid domain 277 278 279 ! 280 !--------------------------------------------------------- 281 ! 6. Write out coarse meshmask (see OPA_SRC/DOM/domwri.F90 for ideas later) 285 282 !--------------------------------------------------------- 286 283 … … 300 297 CALL wrk_dealloc(jpi, jpj, jpk, zfse3t, zfse3u, zfse3v, zfse3w ) 301 298 299 IF( nn_timing == 1 ) CALL timing_stop('crs_init') 302 300 303 301 END SUBROUTINE crs_init -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/DIA/diafwb.F90
r4990 r5601 438 438 ENDIF 439 439 440 IF( nn_timing == 1 ) CALL timing_st art('dia_fwb')440 IF( nn_timing == 1 ) CALL timing_stop('dia_fwb') 441 441 442 442 9005 FORMAT(1X,A,ES24.16) -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/DIA/diawri.F90
r4990 r5601 143 143 144 144 IF( lk_vvl ) THEN 145 z3d(:,:,:) = tsn(:,:,:,jp_tem) * fse3t_n(:,:,:)145 z3d(:,:,:) = tsn(:,:,:,jp_tem) !cbr * fse3t_n(:,:,:) 146 146 CALL iom_put( "toce" , z3d ) ! heat content 147 147 DO jj = 1, jpj -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/DOM/domzgr.F90
r4990 r5601 525 525 ! 526 526 ENDIF 527 IF( ln_zps .OR. ln_sco ) THEN ! zps or sco : read meter bathymetry527 IF( ln_zps .OR. ln_sco .OR. ln_zco ) THEN ! zps or sco : read meter bathymetry 528 528 CALL iom_open ( 'bathy_meter.nc', inum ) 529 529 CALL iom_get ( inum, jpdom_data, 'Bathymetry', bathy ) -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/LBC/lbcnfd.F90
r4686 r5601 629 629 SELECT CASE ( cd_type) 630 630 CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points 631 pt3dl(:, 1 , jk) = 0.e0632 pt3dl(:,ijpj, jk) = 0.e0631 pt3dl(:, 1 ,:) = 0.e0 632 pt3dl(:,ijpj,:) = 0.e0 633 633 CASE ( 'F' ) ! F-point 634 pt3dl(:,ijpj, jk) = 0.e0634 pt3dl(:,ijpj,:) = 0.e0 635 635 END SELECT 636 636 ! -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/LBC/mppini.F90
r5010 r5601 253 253 DO ji = 2, jpni 254 254 iimppt(ji,jj) = iimppt(ji-1,jj) + ilcit(ji-1,jj) - nreci 255 !cbr256 WRITE(narea+200,*)"iimppt",ji,jj,ilcit(ji-1,jj),nreci,iimppt(ji-1,jj),iimppt(ji,jj)257 255 END DO 258 256 END DO … … 367 365 nimpp = nimppt(narea) 368 366 njmpp = njmppt(narea) 369 WRITE(narea+200,*)"jpi,jpj,nlci,nlcj,nldi,nldj,nlei,nlej"370 WRITE(narea+200,*)jpi,jpj,nlci,nlcj,nldi,nldj,nlei,nlej ; call flush(narea+200) !cbr371 WRITE(narea+200,*)"nldi+nimpp-1,nldj+njmpp-1,nlei+nimpp-1,nlej+njmpp-1" ; call flush(narea+200) !cbr372 WRITE(narea+200,*)nldi+nimpp-1,nldj+njmpp-1,nlei+nimpp-1,nlej+njmpp-1 ; call flush(narea+200) !cbr373 367 374 368 ! Save processor layout in layout.dat file -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/LBC/mppini_2.h90
r5007 r5601 196 196 ii = 1 + MOD(jarea-1,jpni) 197 197 ij = 1 + (jarea-1)/jpni 198 write(narea+200,*)"mppini_2 ====== > ",jarea,ii,ij199 198 ili = ilci(ii,ij) 200 199 ilj = ilcj(ii,ij) … … 207 206 IF( MOD(jarea,jpni) == 0 ) ibondi(ii,ij) = 1 208 207 IF( jpni == 1 ) ibondi(ii,ij) = 2 209 write(narea+200,*)"titi",jarea,ii,ij,MOD(jarea,jpni),ibondi(ii,ij) ; call flush(narea+200)210 208 ! 2.4 Subdomain neighbors 211 209 212 210 iproc = jarea - 1 213 211 ioso(ii,ij) = iproc - jpni 214 write(narea+200,*)"mppini_2 0: ",ii,ij,iproc,jpni,ioso(ii,ij) ; call flush(narea+200)215 212 iowe(ii,ij) = iproc - 1 216 213 ioea(ii,ij) = iproc + 1 … … 281 278 ENDIF 282 279 ENDIF 283 write(narea+200,*)"titi",jarea,ibondi(ii,ij) ; call flush(narea+200)284 280 ipolj(ii,ij) = 0 285 281 IF( jperio == 3 .OR. jperio == 4 ) THEN … … 311 307 ibonit(icont+1) = ibondi(ii,ij) 312 308 ibonjt(icont+1) = ibondj(ii,ij) 313 write(narea+200,*)"titi 1 ",icont+1,ibonit(icont+1) ; call flush(narea+200)314 309 ENDIF 315 310 END DO … … 424 419 ii = iin(narea) 425 420 ij = ijn(narea) 426 write(narea+200,*)"mppini_2 a ",noso,ii,ij,ioso(ii,ij),jpni*jpnj-1 ; call flush(narea+200)427 421 IF( ioso(ii,ij) >= 0 .AND. ioso(ii,ij) <= (jpni*jpnj-1) ) THEN 428 422 iiso = 1 + MOD(ioso(ii,ij),jpni) 429 423 ijso = 1 + (ioso(ii,ij))/jpni 430 424 noso = ipproc(iiso,ijso) 431 write(narea+200,*)"mppini_2 b ",iiso,ijso,noso ; call flush(narea+200)432 425 ELSE 433 426 noso = -1 -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/LDF/ldfslp.F90
r4990 r5601 35 35 USE timing ! Timing 36 36 USE lib_fortran ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) 37 USE iom 37 38 38 39 IMPLICIT NONE … … 230 231 END DO 231 232 CALL lbc_lnk( zwz, 'U', -1. ) ; CALL lbc_lnk( zww, 'V', -1. ) ! lateral boundary conditions 233 232 234 ! 233 235 ! !* horizontal Shapiro filter … … 445 447 446 448 ENDIF 449 450 CALL iom_put("zgru",zgru) 451 CALL iom_put("zgrv",zgrv) 452 CALL iom_put("zdzr",zdzr) 453 CALL iom_put("zwz",zwz) 454 CALL iom_put("zww",zww) 455 CALL iom_put("uslp",uslp) 456 CALL iom_put("vslp",vslp) 447 457 448 458 CALL wrk_dealloc( jpi,jpj,jpk, zwz, zww, zdzr, zgru, zgrv ) -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/LDF/ldfslp_crs.F90
r5105 r5601 21 21 !! ldf_slp_init : initialization of the slopes computation 22 22 !!---------------------------------------------------------------------- 23 USE oce ! ocean dynamics and tracers24 !USE dom_oce ! ocean space and time domain23 !USE oce ! ocean dynamics and tracers 24 !USE dom_oce ! ocean space and time domain 25 25 USE ldftra_oce ! lateral diffusion: traceur 26 26 USE ldfdyn_oce ! lateral diffusion: dynamics … … 34 34 USE timing ! Timing 35 35 USE crs 36 USE iom 36 37 37 38 IMPLICIT NONE … … 45 46 ! !! Madec operator 46 47 ! Arrays allocated in ldf_slp_init() routine once we know whether we're using the Griffies or Madec operator 47 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: uslp_crs, wslpi_crs !: i_slope at U- and W-points48 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: vslp_crs, wslpj_crs !: j-slope at V- and W-points49 48 ! !! Griffies operator 50 49 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: wslp2 !: wslp**2 from Griffies quarter cells … … 113 112 !!---------------------------------------------------------------------- 114 113 ! 115 IF( nn_timing == 1 ) CALL timing_start('ldf_slp ')114 IF( nn_timing == 1 ) CALL timing_start('ldf_slp_crs') 116 115 ! 117 116 CALL wrk_alloc( jpi_crs,jpj_crs,jpk, zwz, zww, zdzr, zgru, zgrv ) … … 126 125 ! 127 126 DO jk = 1, jpk !== i- & j-gradient of density ==! 128 DO jj = 1, jpj m1129 DO ji = 1, fs_jpim1 ! vector opt.127 DO jj = 1, jpj_crsm1 128 DO ji = 1, jpi_crsm1 ! vector opt. 130 129 zgru(ji,jj,jk) = umask_crs(ji,jj,jk) * ( prd(ji+1,jj ,jk) - prd(ji,jj,jk) ) 131 130 zgrv(ji,jj,jk) = vmask_crs(ji,jj,jk) * ( prd(ji ,jj+1,jk) - prd(ji,jj,jk) ) … … 134 133 END DO 135 134 IF( ln_zps ) THEN ! partial steps correction at the bottom ocean level 136 # if defined key_vectopt_loop 137 DO jj = 1, 1 138 DO ji = 1, jpij-jpi ! vector opt. (forced unrolling) 139 # else 140 DO jj = 1, jpjm1 141 DO ji = 1, jpim1 142 # endif 135 DO jj = 1, jpj_crsm1 136 DO ji = 1, jpi_crsm1 143 137 zgru(ji,jj,mbku_crs(ji,jj)) = gru_crs(ji,jj) 144 138 zgrv(ji,jj,mbkv_crs(ji,jj)) = grv_crs(ji,jj) … … 146 140 END DO 147 141 ENDIF 148 !WRITE(numout,*) ' zgrv (ji,jj,jk-1)' , zgrv (:,:,:)149 !WRITE(numout,*) ' grv_crs (ji,jj,jk-1)' ,grv_crs (:,:)150 142 ! 151 143 zdzr(:,:,1) = 0._wp !== Local vertical density gradient at T-point == ! (evaluated from N^2) 152 144 DO jk = 2, jpkm1 153 145 ! ! trick: tmask(ik ) = 0 => all pn2 = 0 => zdzr = 0 154 ! 155 ! 156 ! ! umask(ik+1) /= 0 => all pn2 /= 0 => zdzr divides by 2157 ! 146 ! ! else tmask(ik+1) = 0 => pn2(ik+1) = 0 => zdzr divides by 1 147 ! ! zdzr = d/dz(prd)= - ( prd ) / grav * mk(pn2) -- at t point 148 ! ! umask(ik+1) /= 0 => all pn2 /= 0 => zdzr divides by 2 149 ! ! NB: 1/(tmask+1) = (1-.5*tmask) substitute a / by a * ==> faster 158 150 zdzr(:,:,jk) = zm1_g * ( prd(:,:,jk) + 1._wp ) & 159 151 & * ( pn2(:,:,jk) + pn2(:,:,jk+1) ) * ( 1._wp - 0.5_wp * tmask_crs(:,:,jk+1) ) … … 163 155 CALL ldf_slp_mxl_crs( prd, pn2, zgru, zgrv, zdzr ) ! output: uslpml, vslpml, wslpiml, wslpjml 164 156 165 166 157 ! I. slopes at u and v point | uslp = d/di( prd ) / d/dz( prd ) 167 158 ! =========================== | vslp = d/dj( prd ) / d/dz( prd ) 168 159 ! 169 160 DO jk = 2, jpkm1 !* Slopes at u and v points 170 DO jj = 2, jpj m1171 DO ji = fs_2, fs_jpim1 ! vector opt.161 DO jj = 2, jpj_crsm1 162 DO ji = 2, jpi_crsm1 ! vector opt. 172 163 ! ! horizontal and vertical density gradient at u- and v-points 173 164 zau = zgru(ji,jj,jk) / e1u_crs(ji,jj) … … 177 168 ! ! bound the slopes: abs(zw.)<= 1/100 and zb..<0 178 169 ! ! + kxz max= ah slope max =< e1 e3 /(pi**2 2 dt) 179 !IF( umask_crs(ji,jj,jk) .NE. 0._wp .AND. e3u_max_crs(ji,jj,jk)==0._wp )WRITE(narea+3000,*)"bug zbu ",umask_crs(ji,jj,jk),e3u_max_crs(ji,jj,jk) ; CALL flush(narea+3000)180 !IF( e3u_max_crs(ji,jj,jk)==0._wp )WRITE(narea+3000,*)"bug zbu1 ",ji,jj,jk,umask_crs(ji,jj,jk),e3u_max_crs(ji,jj,jk) ; CALL flush(narea+3000)181 170 zbu = MIN( zbu, -100._wp* ABS( zau ) , -7.e+3_wp/e3u_max_crs(ji,jj,jk)* ABS( zau ) ) 182 171 zbv = MIN( zbv, -100._wp* ABS( zav ) , -7.e+3_wp/e3v_max_crs(ji,jj,jk)* ABS( zav ) ) 183 184 !cc zbu = MIN( zbu, -100._wp* ABS( zau ) , -7.e+3_wp/e3u_crs(ji,jj,jk)* ABS( zau ) ) 185 !cc zbv = MIN( zbv, -100._wp* ABS( zav ) , -7.e+3_wp/e3v_crs(ji,jj,jk)* ABS( zav ) ) 186 187 172 !cc zbu = MIN( zbu, -100._wp* ABS( zau ) , -7.e+3_wp/e3u_crs(ji,jj,jk)* ABS( zau ) ) 173 !cc zbv = MIN( zbv, -100._wp* ABS( zav ) , -7.e+3_wp/e3v_crs(ji,jj,jk)* ABS( zav ) ) 188 174 ! ! uslp and vslp output in zwz and zww, resp. 189 175 zfi = MAX( omlmask(ji,jj,jk), omlmask(ji+1,jj,jk) ) … … 210 196 END DO 211 197 CALL crs_lbc_lnk( zwz, 'U', -1. ) ; CALL crs_lbc_lnk( zww, 'V', -1. ) ! lateral boundary conditions 198 CALL iom_put("zwz_crs",zwz) 199 CALL iom_put("zww_crs",zww) 212 200 ! 213 201 ! !* horizontal Shapiro filter 214 202 DO jk = 2, jpkm1 215 DO jj = 2, jpj m1, MAX(1, jpj-3) ! rows jj=2 and =jpjm1 only216 DO ji = 2, jpi m1203 DO jj = 2, jpj_crsm1, MAX(1, jpj_crs-3) ! rows jj=2 and =jpjm1 only 204 DO ji = 2, jpi_crsm1 217 205 uslp_crs(ji,jj,jk) = z1_16 * ( zwz(ji-1,jj-1,jk) + zwz(ji+1,jj-1,jk) & 218 206 & + zwz(ji-1,jj+1,jk) + zwz(ji+1,jj+1,jk) & … … 227 215 END DO 228 216 END DO 229 DO jj = 3, jpj -2 ! other rows230 DO ji = fs_2, fs_jpim1 ! vector opt.217 DO jj = 3, jpj_crs-2 ! other rows 218 DO ji = 2, jpi_crsm1 ! vector opt. 231 219 uslp_crs(ji,jj,jk) = z1_16 * ( zwz(ji-1,jj-1,jk) + zwz(ji+1,jj-1,jk) & 232 220 & + zwz(ji-1,jj+1,jk) + zwz(ji+1,jj+1,jk) & … … 242 230 END DO 243 231 ! !* decrease along coastal boundaries 244 DO jj = 2, jpj m1245 DO ji = fs_2, fs_jpim1 ! vector opt.232 DO jj = 2, jpj_crsm1 233 DO ji = 2, jpi_crsm1 ! vector opt. 246 234 uslp_crs(ji,jj,jk) = uslp_crs(ji,jj,jk) * ( umask_crs(ji,jj+1,jk) + umask_crs(ji,jj-1,jk ) ) * 0.5_wp & 247 235 & * ( umask_crs(ji,jj ,jk) + umask_crs(ji,jj ,jk+1) ) * 0.5_wp … … 257 245 ! 258 246 DO jk = 2, jpkm1 259 DO jj = 2, jpj m1260 DO ji = fs_2, fs_jpim1 ! vector opt.247 DO jj = 2, jpj_crsm1 248 DO ji = 2, jpi_crsm1 ! vector opt. 261 249 ! !* Local vertical density gradient evaluated from N^2 262 250 zbw = zm1_2g * pn2 (ji,jj,jk) * ( prd (ji,jj,jk) + prd (ji,jj,jk-1) + 2. ) … … 281 269 zwz(ji,jj,jk) = ( zai / ( zbi - zeps ) * ( 1._wp - zfk ) + zck * wslpiml(ji,jj) * zfk ) * tmask_crs(ji,jj,jk) 282 270 zww(ji,jj,jk) = ( zaj / ( zbj - zeps ) * ( 1._wp - zfk ) + zck * wslpjml(ji,jj) * zfk ) * tmask_crs(ji,jj,jk) 283 !WRITE(numout,*) ' wslpiml(ji,jj)' , wslpiml(ji,jj)284 !WRITE(numout,*) ' zbj' , zbj285 !WRITE(numout,*) ' zeps' , zeps286 !WRITE(numout,*) ' zaj' , zaj287 288 289 271 !!gm modif to suppress omlmask.... (as in Griffies operator) 290 272 ! ! ! jk must be >= ML level for zfk=1. otherwise zfk=0. … … 301 283 ! !* horizontal Shapiro filter 302 284 DO jk = 2, jpkm1 303 DO jj = 2, jpj m1, MAX(1, jpj-3) ! rows jj=2 and =jpjm1 only304 DO ji = 2, jpi m1285 DO jj = 2, jpj_crsm1, MAX(1, jpj-3) ! rows jj=2 and =jpjm1 only 286 DO ji = 2, jpi_crsm1 305 287 zcofw = tmask_crs(ji,jj,jk) * z1_16 306 288 wslpi_crs(ji,jj,jk) = ( zwz(ji-1,jj-1,jk) + zwz(ji+1,jj-1,jk) & … … 317 299 END DO 318 300 END DO 319 DO jj = 3, jpj -2 ! other rows320 DO ji = fs_2, fs_jpim1 ! vector opt.301 DO jj = 3, jpj_crs-2 ! other rows 302 DO ji = 2, jpi_crsm1 ! vector opt. 321 303 zcofw = tmask_crs(ji,jj,jk) * z1_16 322 304 wslpi_crs(ji,jj,jk) = ( zwz(ji-1,jj-1,jk) + zwz(ji+1,jj-1,jk) & … … 334 316 END DO 335 317 ! !* decrease along coastal boundaries 336 DO jj = 2, jpj m1337 DO ji = fs_2, fs_jpim1 ! vector opt.318 DO jj = 2, jpj_crsm1 319 DO ji = 2, jpi_crsm1 ! vector opt. 338 320 zck = ( umask_crs(ji,jj,jk) + umask_crs(ji-1,jj,jk) ) & 339 321 & * ( vmask_crs(ji,jj,jk) + vmask_crs(ji,jj-1,jk) ) * 0.25 … … 344 326 END DO 345 327 346 ! III. Specific grid points347 ! ===========================348 !! cc !349 ! IF( cp_cfg == "orca" .AND. jp_cfg == 4 ) THEN ! ORCA_R4 configuration: horizontal diffusion in specific area350 ! ! ! Gibraltar Strait351 ! ij0 = 50 ; ij1 = 53352 ! ii0 = 69 ; ii1 = 71 ; uslp ( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) , : ) = 0._wp353 ! ij0 = 51 ; ij1 = 53354 ! ii0 = 68 ; ii1 = 71 ; vslp ( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) , : ) = 0._wp355 ! ii0 = 69 ; ii1 = 71 ; wslpi( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) , : ) = 0._wp356 ! ii0 = 69 ; ii1 = 71 ; wslpj( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) , : ) = 0._wp357 ! !358 ! ! ! Mediterrannean Sea359 ! ij0 = 49 ; ij1 = 56360 ! ii0 = 71 ; ii1 = 90 ; uslp ( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) , : ) = 0._wp361 ! ij0 = 50 ; ij1 = 56362 ! ii0 = 70 ; ii1 = 90 ; vslp ( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) , : ) = 0._wp363 ! ii0 = 71 ; ii1 = 90 ; wslpi( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) , : ) = 0._wp364 ! ii0 = 71 ; ii1 = 90 ; wslpj( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) , : ) = 0._wp365 ! ENDIF366 !! cc367 368 328 ! IV. Lateral boundary conditions 369 329 ! =============================== 370 CALL crs_lbc_lnk( uslp_crs , 'U', -1. ) ; CALL crs_lbc_lnk( vslp_crs , 'V', -1. ) 330 CALL crs_lbc_lnk( uslp_crs , 'U', -1. ) 331 CALL crs_lbc_lnk( vslp_crs , 'V', -1. ) 371 332 CALL crs_lbc_lnk( wslpi_crs, 'W', -1. ) ; CALL crs_lbc_lnk( wslpj_crs, 'W', -1. ) 372 !WRITE(numout,*) ' zww' , zww(:,:,:) 373 !WRITE(numout,*) ' wslpj_crs' , wslpj_crs(:,:,:) 374 ! IF(ln_ctl) THEN 375 ! CALL prt_ctl(tab3d_1=uslp , clinfo1=' slp - u : ', tab3d_2=vslp, clinfo2=' v : ', kdim=jpk) 376 ! CALL prt_ctl(tab3d_1=wslpi, clinfo1=' slp - wi: ', tab3d_2=wslpj, clinfo2=' wj: ', kdim=jpk) 377 ! ENDIF 378 ! 379 CALL wrk_dealloc( jpi,jpj,jpk, zwz, zww, zdzr, zgru, zgrv ) 380 ! 381 IF( nn_timing == 1 ) CALL timing_stop('ldf_slp') 333 ! 334 CALL iom_swap( "nemo_crs" ) ! swap on the coarse grid 335 CALL iom_put("zgru_crs",zgru) 336 CALL iom_put("zgrv_crs",zgrv) 337 CALL iom_put("zdzr_crs",zdzr) 338 CALL iom_put("zwz_crs",zwz) 339 CALL iom_put("zww_crs",zww) 340 CALL iom_put("uslp_crs",uslp_crs) 341 CALL iom_put("vslp_crs",vslp_crs) 342 CALL iom_swap( "nemo" ) ! swap on the coarse grid 343 ! 344 CALL wrk_dealloc( jpi_crs,jpj_crs,jpk, zwz, zww, zdzr, zgru, zgrv ) 345 ! 346 IF( nn_timing == 1 ) CALL timing_stop('ldf_slp_crs') 382 347 ! 383 348 END SUBROUTINE ldf_slp_crs 384 385 386 SUBROUTINE ldf_slp_grif_crs ( kt )387 !!----------------------------------------------------------------------388 !! *** ROUTINE ldf_slp_grif ***389 !!390 !! ** Purpose : Compute the squared slopes of neutral surfaces (slope391 !! of iso-pycnal surfaces referenced locally) (ln_traldf_grif=T)392 !! at W-points using the Griffies quarter-cells.393 !!394 !! ** Method : calculates alpha and beta at T-points395 !!396 !! ** Action : - triadi_g, triadj_g T-pts i- and j-slope triads relative to geopot. (used for eiv)397 !! - triadi , triadj T-pts i- and j-slope triads relative to model-coordinate398 !! - wslp2 squared slope of neutral surfaces at w-points.399 !!----------------------------------------------------------------------400 INTEGER, INTENT( in ) :: kt ! ocean time-step index401 !!402 INTEGER :: ji, jj, jk, jl, ip, jp, kp ! dummy loop indices403 INTEGER :: iku, ikv ! local integer404 REAL(wp) :: zfacti, zfactj ! local scalars405 REAL(wp) :: znot_thru_surface ! local scalars406 REAL(wp) :: zdit, zdis, zdjt, zdjs, zdkt, zdks, zbu, zbv, zbti, zbtj407 REAL(wp) :: zdxrho_raw, zti_coord, zti_raw, zti_lim, zti_g_raw, zti_g_lim408 REAL(wp) :: zdyrho_raw, ztj_coord, ztj_raw, ztj_lim, ztj_g_raw, ztj_g_lim409 REAL(wp) :: zdzrho_raw410 REAL(wp) :: zbeta0411 REAL(wp), POINTER, DIMENSION(:,:) :: z1_mlbw412 REAL(wp), POINTER, DIMENSION(:,:,:) :: zalbet413 REAL(wp), POINTER, DIMENSION(:,:,:,:) :: zdxrho , zdyrho, zdzrho ! Horizontal and vertical density gradients414 REAL(wp), POINTER, DIMENSION(:,:,:,:) :: zti_mlb, ztj_mlb ! for Griffies operator only415 !!----------------------------------------------------------------------416 !417 IF( nn_timing == 1 ) CALL timing_start('ldf_slp_grif')418 !419 CALL wrk_alloc( jpi,jpj, z1_mlbw )420 CALL wrk_alloc( jpi,jpj,jpk, zalbet )421 CALL wrk_alloc( jpi,jpj,jpk,2, zdxrho , zdyrho, zdzrho, klstart = 0 )422 CALL wrk_alloc( jpi,jpj, 2,2, zti_mlb, ztj_mlb, kkstart = 0, klstart = 0 )423 !424 !--------------------------------!425 ! Some preliminary calculation !426 !--------------------------------!427 !428 CALL eos_alpbet_crs( tsb_crs, zalbet, zbeta0 ) !== before local thermal/haline expension ratio at T-points ==!429 !430 DO jl = 0, 1 !== unmasked before density i- j-, k-gradients ==!431 !432 ip = jl ; jp = jl ! guaranteed nonzero gradients ( absolute value larger than repsln)433 DO jk = 1, jpkm1 ! done each pair of triad434 DO jj = 1, jpjm1 ! NB: not masked ==> a minimum value is set435 DO ji = 1, fs_jpim1 ! vector opt.436 zdit = ( tsb(ji+1,jj,jk,jp_tem) - tsb(ji,jj,jk,jp_tem) ) ! i-gradient of T & S at u-point437 zdis = ( tsb(ji+1,jj,jk,jp_sal) - tsb(ji,jj,jk,jp_sal) )438 zdjt = ( tsb(ji,jj+1,jk,jp_tem) - tsb(ji,jj,jk,jp_tem) ) ! j-gradient of T & S at v-point439 zdjs = ( tsb(ji,jj+1,jk,jp_sal) - tsb(ji,jj,jk,jp_sal) )440 zdxrho_raw = ( - zalbet(ji+ip,jj ,jk) * zdit + zbeta0*zdis ) / e1u(ji,jj)441 zdyrho_raw = ( - zalbet(ji ,jj+jp,jk) * zdjt + zbeta0*zdjs ) / e2v(ji,jj)442 zdxrho(ji+ip,jj ,jk,1-ip) = SIGN( MAX( repsln, ABS( zdxrho_raw ) ), zdxrho_raw ) ! keep the sign443 zdyrho(ji ,jj+jp,jk,1-jp) = SIGN( MAX( repsln, ABS( zdyrho_raw ) ), zdyrho_raw )444 END DO445 END DO446 END DO447 !448 IF( ln_zps.and.l_grad_zps ) THEN ! partial steps: correction of i- & j-grad on bottom449 # if defined key_vectopt_loop450 DO jj = 1, 1451 DO ji = 1, jpij-jpi ! vector opt. (forced unrolling)452 # else453 DO jj = 1, jpjm1454 DO ji = 1, jpim1455 # endif456 iku = mbku_crs(ji,jj) ; ikv = mbkv_crs(ji,jj) ! last ocean level (u- & v-points)457 zdit = gtsu_crs(ji,jj,jp_tem) ; zdjt = gtsv_crs(ji,jj,jp_tem) ! i- & j-gradient of Temperature458 zdis = gtsu_crs(ji,jj,jp_sal) ; zdjs = gtsv_crs(ji,jj,jp_sal) ! i- & j-gradient of Salinity459 zdxrho_raw = ( - zalbet(ji+ip,jj ,iku) * zdit + zbeta0*zdis ) / e1u(ji,jj)460 zdyrho_raw = ( - zalbet(ji ,jj+jp,ikv) * zdjt + zbeta0*zdjs ) / e2v(ji,jj)461 zdxrho(ji+ip,jj ,iku,1-ip) = SIGN( MAX( repsln, ABS( zdxrho_raw ) ), zdxrho_raw ) ! keep the sign462 zdyrho(ji ,jj+jp,ikv,1-jp) = SIGN( MAX( repsln, ABS( zdyrho_raw ) ), zdyrho_raw )463 END DO464 END DO465 ENDIF466 !467 END DO468 469 DO kp = 0, 1 !== unmasked before density i- j-, k-gradients ==!470 DO jk = 1, jpkm1 ! done each pair of triad471 DO jj = 1, jpj ! NB: not masked ==> a minimum value is set472 DO ji = 1, jpi ! vector opt.473 IF( jk+kp > 1 ) THEN ! k-gradient of T & S a jk+kp474 zdkt = ( tsb(ji,jj,jk+kp-1,jp_tem) - tsb(ji,jj,jk+kp,jp_tem) )475 zdks = ( tsb(ji,jj,jk+kp-1,jp_sal) - tsb(ji,jj,jk+kp,jp_sal) )476 ELSE477 zdkt = 0._wp ! 1st level gradient set to zero478 zdks = 0._wp479 ENDIF480 zdzrho_raw = ( - zalbet(ji ,jj ,jk) * zdkt + zbeta0*zdks ) / fse3w(ji,jj,jk+kp)481 zdzrho(ji ,jj ,jk, kp) = - MIN( - repsln, zdzrho_raw ) ! force zdzrho >= repsln482 END DO483 END DO484 END DO485 END DO486 !487 DO jj = 1, jpj !== Reciprocal depth of the w-point below ML base ==!488 DO ji = 1, jpi489 jk = MIN( nmln_crs(ji,jj), mbkt_crs(ji,jj) ) + 1 ! MIN in case ML depth is the ocean depth490 z1_mlbw(ji,jj) = 1._wp / gdepw_crs(ji,jj,jk)491 END DO492 END DO493 !494 ! !== intialisations to zero ==!495 !496 wslp2 (:,:,:) = 0._wp ! wslp2 will be cumulated 3D field set to zero497 triadi_g(:,:,1,:,:) = 0._wp ; triadi_g(:,:,jpk,:,:) = 0._wp ! set surface and bottom slope to zero498 triadj_g(:,:,1,:,:) = 0._wp ; triadj_g(:,:,jpk,:,:) = 0._wp499 !!gm _iso set to zero missing500 triadi (:,:,1,:,:) = 0._wp ; triadj (:,:,jpk,:,:) = 0._wp ! set surface and bottom slope to zero501 triadj (:,:,1,:,:) = 0._wp ; triadj (:,:,jpk,:,:) = 0._wp502 503 !-------------------------------------!504 ! Triads just below the Mixed Layer !505 !-------------------------------------!506 !507 DO jl = 0, 1 ! calculate slope of the 4 triads immediately ONE level below mixed-layer base508 DO kp = 0, 1 ! with only the slope-max limit and MASKED509 DO jj = 1, jpjm1510 DO ji = 1, fs_jpim1511 ip = jl ; jp = jl512 jk = MIN( nmln_crs(ji+ip,jj) , mbkt_crs(ji+ip,jj) ) + 1 ! ML level+1 (MIN in case ML depth is the ocean depth)513 ! Add s-coordinate slope at t-points (do this by *subtracting* gradient of depth)514 zti_g_raw = ( zdxrho(ji+ip,jj,jk-kp,1-ip) / zdzrho(ji+ip,jj,jk-kp,kp) &515 & - ( gdept_crs(ji+1,jj,jk-kp) - gdept_crs(ji,jj,jk-kp) ) / e1u_crs(ji,jj) ) * umask_crs(ji,jj,jk)516 jk = MIN( nmln_crs(ji,jj+jp) , mbkt_crs(ji,jj+jp) ) + 1517 ztj_g_raw = ( zdyrho(ji,jj+jp,jk-kp,1-jp) / zdzrho(ji,jj+jp,jk-kp,kp) &518 & - ( gdept_crs(ji,jj+1,jk-kp) - gdept_crs(ji,jj,jk-kp) ) / e2v_crs(ji,jj) ) * vmask_crs(ji,jj,jk)519 zti_mlb(ji+ip,jj ,1-ip,kp) = SIGN( MIN( rn_slpmax, ABS( zti_g_raw ) ), zti_g_raw )520 ztj_mlb(ji ,jj+jp,1-jp,kp) = SIGN( MIN( rn_slpmax, ABS( ztj_g_raw ) ), ztj_g_raw )521 END DO522 END DO523 END DO524 END DO525 526 !-------------------------------------!527 ! Triads with surface limits !528 !-------------------------------------!529 !530 DO kp = 0, 1 ! k-index of triads531 DO jl = 0, 1532 ip = jl ; jp = jl ! i- and j-indices of triads (i-k and j-k planes)533 DO jk = 1, jpkm1534 ! Must mask contribution to slope from dz/dx at constant s for triads jk=1,kp=0 that poke up though ocean surface535 znot_thru_surface = REAL( 1-1/(jk+kp), wp ) !jk+kp=1,=0.; otherwise=1.0536 DO jj = 1, jpjm1537 DO ji = 1, fs_jpim1 ! vector opt.538 !539 ! Calculate slope relative to geopotentials used for GM skew fluxes540 ! Add s-coordinate slope at t-points (do this by *subtracting* gradient of depth)541 ! Limit by slope *relative to geopotentials* by rn_slpmax, and mask by psi-point542 ! masked by umask taken at the level of dz(rho)543 !544 ! raw slopes: unmasked unbounded slopes (relative to geopotential (zti_g) and model surface (zti)545 !546 zti_raw = zdxrho(ji+ip,jj ,jk,1-ip) / zdzrho(ji+ip,jj ,jk,kp) ! unmasked547 ztj_raw = zdyrho(ji ,jj+jp,jk,1-jp) / zdzrho(ji ,jj+jp,jk,kp)548 549 ! Must mask contribution to slope for triad jk=1,kp=0 that poke up though ocean surface550 zti_coord = znot_thru_surface * ( gdept_crs(ji+1,jj ,jk) - gdept_crs(ji,jj,jk) ) / e1u_crs(ji,jj)551 ztj_coord = znot_thru_surface * ( gdept_crs(ji ,jj+1,jk) - gdept_crs(ji,jj,jk) ) / e2v_crs(ji,jj) ! unmasked552 zti_g_raw = zti_raw - zti_coord ! ref to geopot surfaces553 ztj_g_raw = ztj_raw - ztj_coord554 zti_g_lim = SIGN( MIN( rn_slpmax, ABS( zti_g_raw ) ), zti_g_raw )555 ztj_g_lim = SIGN( MIN( rn_slpmax, ABS( ztj_g_raw ) ), ztj_g_raw )556 !557 ! Below ML use limited zti_g as is & mask558 ! Inside ML replace by linearly reducing sx_mlb towards surface & mask559 !560 zfacti = REAL( 1 - 1/(1 + (jk+kp-1)/nmln_crs(ji+ip,jj)), wp ) ! k index of uppermost point(s) of triad is jk+kp-1561 zfactj = REAL( 1 - 1/(1 + (jk+kp-1)/nmln_crs(ji,jj+jp)), wp ) ! must be .ge. nmln(ji,jj) for zfact=1562 ! ! otherwise zfact=0563 zti_g_lim = ( zfacti * zti_g_lim &564 & + ( 1._wp - zfacti ) * zti_mlb(ji+ip,jj,1-ip,kp) &565 & * fsdepw(ji+ip,jj,jk+kp) * z1_mlbw(ji+ip,jj) ) * umask_crs(ji,jj,jk+kp)566 ztj_g_lim = ( zfactj * ztj_g_lim &567 & + ( 1._wp - zfactj ) * ztj_mlb(ji,jj+jp,1-jp,kp) &568 & * fsdepw(ji,jj+jp,jk+kp) * z1_mlbw(ji,jj+jp) ) * vmask_crs(ji,jj,jk+kp)569 !570 triadi_g(ji+ip,jj ,jk,1-ip,kp) = zti_g_lim571 triadj_g(ji ,jj+jp,jk,1-jp,kp) = ztj_g_lim572 !573 ! Get coefficients of isoneutral diffusion tensor574 ! 1. Utilise gradients *relative* to s-coordinate, so add t-point slopes (*subtract* depth gradients)575 ! 2. We require that isoneutral diffusion gives no vertical buoyancy flux576 ! i.e. 33 term = (real slope* 31, 13 terms)577 ! To do this, retain limited sx**2 in vertical flux, but divide by real slope for 13/31 terms578 ! Equivalent to tapering A_iso = sx_limited**2/(real slope)**2579 !580 zti_lim = ( zti_g_lim + zti_coord ) * umask_crs(ji,jj,jk+kp) ! remove coordinate slope => relative to coordinate surfaces581 ztj_lim = ( ztj_g_lim + ztj_coord ) * vmask_crs(ji,jj,jk+kp)582 !583 IF( ln_triad_iso ) THEN584 zti_raw = zti_lim**2 / zti_raw585 ztj_raw = ztj_lim**2 / ztj_raw586 zti_raw = SIGN( MIN( ABS(zti_lim), ABS( zti_raw ) ), zti_raw )587 ztj_raw = SIGN( MIN( ABS(ztj_lim), ABS( ztj_raw ) ), ztj_raw )588 zti_lim = zfacti * zti_lim &589 & + ( 1._wp - zfacti ) * zti_raw590 ztj_lim = zfactj * ztj_lim &591 & + ( 1._wp - zfactj ) * ztj_raw592 ENDIF593 triadi(ji+ip,jj ,jk,1-ip,kp) = zti_lim594 triadj(ji ,jj+jp,jk,1-jp,kp) = ztj_lim595 !596 zbu = e1u(ji ,jj) * e2u(ji ,jj) * fse3u(ji ,jj,jk )597 zbv = e1v(ji ,jj) * e2v(ji ,jj) * fse3v(ji ,jj,jk )598 zbti = e1t(ji+ip,jj) * e2t(ji+ip,jj) * fse3w(ji+ip,jj,jk+kp)599 zbtj = e1t(ji,jj+jp) * e2t(ji,jj+jp) * fse3w(ji,jj+jp,jk+kp)600 !601 !!gm this may inhibit vectorization on Vect Computers, and even on scalar computers.... ==> to be checked602 wslp2 (ji+ip,jj,jk+kp) = wslp2(ji+ip,jj,jk+kp) + 0.25_wp * zbu / zbti * zti_g_lim**2 ! masked603 wslp2 (ji,jj+jp,jk+kp) = wslp2(ji,jj+jp,jk+kp) + 0.25_wp * zbv / zbtj * ztj_g_lim**2604 END DO605 END DO606 END DO607 END DO608 END DO609 !610 wslp2(:,:,1) = 0._wp ! force the surface wslp to zero611 612 CALL crs_lbc_lnk( wslp2, 'W', 1. ) ! lateral boundary confition on wslp2 only ==>>> gm : necessary ? to be checked613 !614 CALL wrk_dealloc( jpi,jpj, z1_mlbw )615 CALL wrk_dealloc( jpi,jpj,jpk, zalbet )616 CALL wrk_dealloc( jpi,jpj,jpk,2, zdxrho , zdyrho, zdzrho, klstart = 0 )617 CALL wrk_dealloc( jpi,jpj, 2,2, zti_mlb, ztj_mlb, kkstart = 0, klstart = 0 )618 !619 IF( nn_timing == 1 ) CALL timing_stop('ldf_slp_grif')620 !621 END SUBROUTINE ldf_slp_grif_crs622 623 349 624 350 SUBROUTINE ldf_slp_mxl_crs( prd, pn2, p_gru, p_grv, p_dzr ) … … 657 383 zm1_2g = -0.5_wp / grav 658 384 ! 659 uslpml (1,:) = 0._wp ; uslpml (jpi ,:) = 0._wp660 vslpml (1,:) = 0._wp ; vslpml (jpi ,:) = 0._wp661 wslpiml(1,:) = 0._wp ; wslpiml(jpi ,:) = 0._wp662 wslpjml(1,:) = 0._wp ; wslpjml(jpi ,:) = 0._wp385 uslpml (1,:) = 0._wp ; uslpml (jpi_crs,:) = 0._wp 386 vslpml (1,:) = 0._wp ; vslpml (jpi_crs,:) = 0._wp 387 wslpiml(1,:) = 0._wp ; wslpiml(jpi_crs,:) = 0._wp 388 wslpjml(1,:) = 0._wp ; wslpjml(jpi_crs,:) = 0._wp 663 389 ! 664 390 ! !== surface mixed layer mask ! 665 391 DO jk = 1, jpk ! =1 inside the mixed layer, =0 otherwise 666 # if defined key_vectopt_loop 667 DO jj = 1, 1 668 DO ji = 1, jpij ! vector opt. (forced unrolling) 669 # else 670 DO jj = 1, jpj 671 DO ji = 1, jpi 672 # endif 392 DO jj = 1, jpj_crs 393 DO ji = 1, jpi_crs 673 394 ik = nmln_crs(ji,jj) - 1 674 395 IF( jk <= ik ) THEN ; omlmask(ji,jj,jk) = 1._wp … … 690 411 !----------------------------------------------------------------------- 691 412 ! 692 # if defined key_vectopt_loop 693 DO jj = 1, 1 694 DO ji = jpi+2, jpij-jpi-1 ! vector opt. (forced unrolling) 695 # else 696 DO jj = 2, jpjm1 697 DO ji = 2, jpim1 698 # endif 413 DO jj = 2, jpj_crsm1 414 DO ji = 2, jpi_crsm1 699 415 ! !== Slope at u- & v-points just below the Mixed Layer ==! 700 416 ! … … 744 460 ! 745 461 IF( nn_timing == 1 ) CALL timing_stop('ldf_slp_mxl') 746 ! WRITE(numout,*) ' uslp_crs' , MAXVAL(uslp_crs(:,:,:)) , MINVAL(uslp_crs(:,:,:))747 ! WRITE(numout,*) ' vslp_crs' , vslp_crs748 ! WRITE(numout,*) ' uslpml' , uslpml749 ! WRITE(numout,*) ' vslpml' , vslpml750 ! WRITE(numout,*) ' wslpiml' , wslpiml751 ! WRITE(numout,*) ' wslpjml' , wslpjml752 ! WRITE(numout,*) ' wslpi_crs' , wslpi_crs(:,:,2)753 ! WRITE(numout,*) ' wslpj_crs_mxl' , wslpj_crs(:,:,:)754 755 462 ! 756 463 END SUBROUTINE ldf_slp_mxl_crs … … 774 481 IF(lwp) THEN 775 482 WRITE(numout,*) 776 WRITE(numout,*) 'ldf_slp_init : direction of lateral mixing'483 WRITE(numout,*) 'ldf_slp_init_crs : direction of lateral mixing' 777 484 WRITE(numout,*) '~~~~~~~~~~~~' 778 485 ENDIF 779 486 780 487 IF( ln_traldf_grif ) THEN ! Griffies operator : triad of slopes 781 ALLOCATE( triadi_g(jpi ,jpj,jpk,0:1,0:1) , triadj_g(jpi,jpj,jpk,0:1,0:1) , wslp2(jpi,jpj,jpk) , STAT=ierr )782 ALLOCATE( triadi (jpi ,jpj,jpk,0:1,0:1) , triadj (jpi,jpj,jpk,0:1,0:1) , STAT=ierr )488 ALLOCATE( triadi_g(jpi_crs,jpj_crs,jpk,0:1,0:1) , triadj_g(jpi_crs,jpj_crs,jpk,0:1,0:1) , wslp2(jpi_crs,jpj_crs,jpk) , STAT=ierr ) 489 ALLOCATE( triadi (jpi_crs,jpj_crs,jpk,0:1,0:1) , triadj (jpi_crs,jpj_crs,jpk,0:1,0:1) , STAT=ierr ) 783 490 IF( ierr > 0 ) CALL ctl_stop( 'STOP', 'ldf_slp_init : unable to allocate Griffies operator slope' ) 784 491 ! … … 786 493 ! 787 494 ELSE ! Madec operator : slopes at u-, v-, and w-points 788 ALLOCATE( uslp_crs(jpi ,jpj,jpk) , vslp_crs(jpi,jpj,jpk) , wslpi_crs(jpi,jpj,jpk) , wslpj_crs(jpi,jpj,jpk) , &789 & omlmask(jpi ,jpj,jpk) , uslpml(jpi,jpj) , vslpml(jpi,jpj) , wslpiml(jpi,jpj) , wslpjml(jpi,jpj) , STAT=ierr )495 ALLOCATE( uslp_crs(jpi_crs,jpj_crs,jpk) , vslp_crs(jpi_crs,jpj_crs,jpk) , wslpi_crs(jpi_crs,jpj_crs,jpk) , wslpj_crs(jpi_crs,jpj_crs,jpk) , & 496 & omlmask(jpi_crs,jpj_crs,jpk) , uslpml(jpi_crs,jpj_crs) , vslpml(jpi_crs,jpj_crs) , wslpiml(jpi_crs,jpj_crs) , wslpjml(jpi_crs,jpj_crs) , STAT=ierr ) 790 497 IF( ierr > 0 ) CALL ctl_stop( 'STOP', 'ldf_slp_init : unable to allocate Madec operator slope ' ) 791 498 … … 807 514 ! set the slope of diffusion to the slope of s-surfaces 808 515 ! ( c a u t i o n : minus sign as fsdep has positive value ) 809 !WRITE(narea+3000,*)"ldfslp ",MINVAL(gdept_crs),MAXVAL(gdept_crs) ; call flush(narea+3000)810 !WRITE(narea+3000,*)"ldfslp ",MINVAL(vmask_crs),MAXVAL(vmask_crs) ; call flush(narea+3000)811 !WRITE(narea+3000,*)"ldfslp ",MINVAL(e2v_crs),MAXVAL(e2v_crs) ; call flush(narea+3000)812 516 DO jk = 1, jpk 813 DO jj = 2, jpj m1814 DO ji = fs_2, fs_jpim1 ! vector opt.517 DO jj = 2, jpj_crsm1 518 DO ji = 2, jpi_crsm1 ! vector opt. 815 519 !cbr uslp_crs (ji,jj,jk) = -1./e1u_crs(ji,jj) * ( gdept_crs(ji+1,jj,jk) - gdept_crs(ji ,jj ,jk) ) * umask_crs(ji,jj,jk) 816 520 !vslp_crs (ji,jj,jk) = -1./e2v_crs(ji,jj) * ( gdept_crs(ji,jj+1,jk) - gdept_crs(ji ,jj ,jk) ) * vmask_crs(ji,jj,jk) … … 832 536 ENDIF 833 537 ENDIF 834 ! WRITE(numout,*) ' wslpi_crs' , wslpi_crs835 538 ! 836 539 IF( nn_timing == 1 ) CALL timing_stop('ldf_slp_init') … … 849 552 WRITE(*,*) 'ldf_slp: You should not have seen this print! error?', kt, prd(1,1,1), pn2(1,1,1) 850 553 END SUBROUTINE ldf_slp_crs 554 SUBROUTINE ldf_slp_init_crs ! Dummy routine 555 END SUBROUTINE ldf_slp_init_crs 556 #endif 557 851 558 SUBROUTINE ldf_slp_grif_crs( kt ) ! Dummy routine 852 559 INTEGER, INTENT(in) :: kt 853 560 WRITE(*,*) 'ldf_slp_grif: You should not have seen this print! error?', kt 854 561 END SUBROUTINE ldf_slp_grif_crs 855 SUBROUTINE ldf_slp_init_crs ! Dummy routine856 END SUBROUTINE ldf_slp_init_crs857 #endif858 562 859 563 !!====================================================================== -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/TRA/eosbn2_crs.F90
r5105 r5601 15 15 !! - ! 2002-11 (G. Madec, A. Bozec) partial step, eos_insitu_2d 16 16 !! - ! 2003-08 (G. Madec) F90, free form 17 !! 3.0 ! 2006-08 (G. Madec) add tfreez function 17 !! 3.0 ! 2006-08 (G. Madec) add tfreez function (now eos_fzp function) 18 18 !! 3.3 ! 2010-05 (C. Ethe, G. Madec) merge TRC-TRA 19 !! - ! 2010-10 (G. Nurser, G. Madec) add eos_alpbet used in ldfslp 19 !! - ! 2010-10 (G. Nurser, G. Madec) add alpha/beta used in ldfslp 20 !! 3.7 ! 2012-03 (F. Roquet, G. Madec) add primitive of alpha and beta used in PE computation 21 !! - ! 2012-05 (F. Roquet) add Vallis and original JM95 equation of state 22 !! - ! 2013-04 (F. Roquet, G. Madec) add eos_rab, change bn2 computation and reorganize the module 23 !! - ! 2014-09 (F. Roquet) add TEOS-10, S-EOS, and modify EOS-80 20 24 !!---------------------------------------------------------------------- 21 25 … … 23 27 !! eos : generic interface of the equation of state 24 28 !! eos_insitu : Compute the in situ density 25 !! eos_insitu_pot : Compute the insitu and surface referenced potential 26 !! volumic mass 29 !! eos_insitu_pot : Compute the insitu and surface referenced potential volumic mass 27 30 !! eos_insitu_2d : Compute the in situ density for 2d fields 28 !! eos_bn2 : Compute the Brunt-Vaisala frequency 29 !! eos_alpbet : calculates the in situ thermal/haline expansion ratio 30 !! tfreez : Compute the surface freezing temperature 31 !! bn2 : Compute the Brunt-Vaisala frequency 32 !! eos_rab : generic interface of in situ thermal/haline expansion ratio 33 !! eos_rab_3d : compute in situ thermal/haline expansion ratio 34 !! eos_rab_2d : compute in situ thermal/haline expansion ratio for 2d fields 35 !! eos_fzp_2d : freezing temperature for 2d fields 36 !! eos_fzp_0d : freezing temperature for scalar 31 37 !! eos_init : set eos parameters (namelist) 32 38 !!---------------------------------------------------------------------- 33 USE dom_oce! ocean space and time domain39 USE crs ! ocean space and time domain 34 40 USE phycst ! physical constants 35 USE zdfddm ! vertical physics: double diffusion 36 USE in_out_manager ! I/O manager 37 USE lib_mpp ! MPP library 41 ! 42 !USE in_out_manager ! I/O manager 43 !USE lib_mpp ! MPP library 44 !USE lib_fortran ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) 38 45 USE prtctl ! Print control 39 46 USE wrk_nemo ! Memory Allocation 47 USE crslbclnk ! ocean lateral boundary conditions 40 48 USE timing ! Timing 41 USE crs42 49 43 50 IMPLICIT NONE … … 46 53 ! !! * Interface 47 54 INTERFACE eos_crs 48 MODULE PROCEDURE eos_insitu_ crs, eos_insitu_pot_crs, eos_insitu_2d_crs55 MODULE PROCEDURE eos_insitu_pot , eos_insitu_2d 49 56 END INTERFACE 50 INTERFACE bn2_crs 51 MODULE PROCEDURE eos_bn2_crs 57 ! 58 INTERFACE eos_rab_crs 59 MODULE PROCEDURE rab_crs_3d, rab_crs_2d, rab_crs_0d 52 60 END INTERFACE 53 61 ! 54 62 PUBLIC eos_crs ! called by step, istate, tranpc and zpsgrd modules 63 PUBLIC bn2_crs ! called by step module 64 PUBLIC eos_rab_crs ! called by ldfslp, zdfddm, trabbl 55 65 PUBLIC eos_init_crs ! called by istate module 56 PUBLIC bn2_crs ! called by step module57 PUBLIC eos_alpbet_crs ! called by ldfslp module58 PUBLIC tfreez_crs ! called by sbcice_... modules59 66 60 67 ! !!* Namelist (nameos) * 61 68 INTEGER , PUBLIC :: nn_eos = 0 !: = 0/1/2 type of eq. of state and Brunt-Vaisala frequ. 62 REAL(wp), PUBLIC :: rn_alpha = 2.0e-4_wp !: thermal expension coeff. (linear equation of state) 63 REAL(wp), PUBLIC :: rn_beta = 7.7e-4_wp !: saline expension coeff. (linear equation of state) 64 65 REAL(wp), PUBLIC :: ralpbet_crs !: alpha / beta ratio 69 LOGICAL , PUBLIC :: ln_useCT = .FALSE. ! determine if eos_pt_from_ct is used to compute sst_m 70 71 ! !!! simplified eos coefficients 72 ! default value: Vallis 2006 73 REAL(wp) :: rn_a0 = 1.6550e-1_wp ! thermal expansion coeff. 74 REAL(wp) :: rn_b0 = 7.6554e-1_wp ! saline expansion coeff. 75 REAL(wp) :: rn_lambda1 = 5.9520e-2_wp ! cabbeling coeff. in T^2 76 REAL(wp) :: rn_lambda2 = 5.4914e-4_wp ! cabbeling coeff. in S^2 77 REAL(wp) :: rn_mu1 = 1.4970e-4_wp ! thermobaric coeff. in T 78 REAL(wp) :: rn_mu2 = 1.1090e-5_wp ! thermobaric coeff. in S 79 REAL(wp) :: rn_nu = 2.4341e-3_wp ! cabbeling coeff. in theta*salt 80 81 ! TEOS10/EOS80 parameters 82 REAL(wp) :: r1_S0, r1_T0, r1_Z0, rdeltaS 83 84 ! EOS parameters 85 REAL(wp) :: EOS000 , EOS100 , EOS200 , EOS300 , EOS400 , EOS500 , EOS600 86 REAL(wp) :: EOS010 , EOS110 , EOS210 , EOS310 , EOS410 , EOS510 87 REAL(wp) :: EOS020 , EOS120 , EOS220 , EOS320 , EOS420 88 REAL(wp) :: EOS030 , EOS130 , EOS230 , EOS330 89 REAL(wp) :: EOS040 , EOS140 , EOS240 90 REAL(wp) :: EOS050 , EOS150 91 REAL(wp) :: EOS060 92 REAL(wp) :: EOS001 , EOS101 , EOS201 , EOS301 , EOS401 93 REAL(wp) :: EOS011 , EOS111 , EOS211 , EOS311 94 REAL(wp) :: EOS021 , EOS121 , EOS221 95 REAL(wp) :: EOS031 , EOS131 96 REAL(wp) :: EOS041 97 REAL(wp) :: EOS002 , EOS102 , EOS202 98 REAL(wp) :: EOS012 , EOS112 99 REAL(wp) :: EOS022 100 REAL(wp) :: EOS003 , EOS103 101 REAL(wp) :: EOS013 102 103 ! ALPHA parameters 104 REAL(wp) :: ALP000 , ALP100 , ALP200 , ALP300 , ALP400 , ALP500 105 REAL(wp) :: ALP010 , ALP110 , ALP210 , ALP310 , ALP410 106 REAL(wp) :: ALP020 , ALP120 , ALP220 , ALP320 107 REAL(wp) :: ALP030 , ALP130 , ALP230 108 REAL(wp) :: ALP040 , ALP140 109 REAL(wp) :: ALP050 110 REAL(wp) :: ALP001 , ALP101 , ALP201 , ALP301 111 REAL(wp) :: ALP011 , ALP111 , ALP211 112 REAL(wp) :: ALP021 , ALP121 113 REAL(wp) :: ALP031 114 REAL(wp) :: ALP002 , ALP102 115 REAL(wp) :: ALP012 116 REAL(wp) :: ALP003 117 118 ! BETA parameters 119 REAL(wp) :: BET000 , BET100 , BET200 , BET300 , BET400 , BET500 120 REAL(wp) :: BET010 , BET110 , BET210 , BET310 , BET410 121 REAL(wp) :: BET020 , BET120 , BET220 , BET320 122 REAL(wp) :: BET030 , BET130 , BET230 123 REAL(wp) :: BET040 , BET140 124 REAL(wp) :: BET050 125 REAL(wp) :: BET001 , BET101 , BET201 , BET301 126 REAL(wp) :: BET011 , BET111 , BET211 127 REAL(wp) :: BET021 , BET121 128 REAL(wp) :: BET031 129 REAL(wp) :: BET002 , BET102 130 REAL(wp) :: BET012 131 REAL(wp) :: BET003 132 133 ! PEN parameters 134 REAL(wp) :: PEN000 , PEN100 , PEN200 , PEN300 , PEN400 135 REAL(wp) :: PEN010 , PEN110 , PEN210 , PEN310 136 REAL(wp) :: PEN020 , PEN120 , PEN220 137 REAL(wp) :: PEN030 , PEN130 138 REAL(wp) :: PEN040 139 REAL(wp) :: PEN001 , PEN101 , PEN201 140 REAL(wp) :: PEN011 , PEN111 141 REAL(wp) :: PEN021 142 REAL(wp) :: PEN002 , PEN102 143 REAL(wp) :: PEN012 144 145 ! ALPHA_PEN parameters 146 REAL(wp) :: APE000 , APE100 , APE200 , APE300 147 REAL(wp) :: APE010 , APE110 , APE210 148 REAL(wp) :: APE020 , APE120 149 REAL(wp) :: APE030 150 REAL(wp) :: APE001 , APE101 151 REAL(wp) :: APE011 152 REAL(wp) :: APE002 153 154 ! BETA_PEN parameters 155 REAL(wp) :: BPE000 , BPE100 , BPE200 , BPE300 156 REAL(wp) :: BPE010 , BPE110 , BPE210 157 REAL(wp) :: BPE020 , BPE120 158 REAL(wp) :: BPE030 159 REAL(wp) :: BPE001 , BPE101 160 REAL(wp) :: BPE011 161 REAL(wp) :: BPE002 66 162 67 163 !! * Substitutions … … 69 165 # include "vectopt_loop_substitute.h90" 70 166 !!---------------------------------------------------------------------- 71 !! NEMO/OPA 3. 3 , NEMO Consortium (2010)72 !! $Id: eosbn2.F90 3294 2012-01-28 16:44:18Z rblod$167 !! NEMO/OPA 3.7 , NEMO Consortium (2014) 168 !! $Id: eosbn2.F90 4990 2014-12-15 16:42:49Z timgraham $ 73 169 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 74 170 !!---------------------------------------------------------------------- 75 171 CONTAINS 76 172 77 SUBROUTINE eos_insitu_crs( pts, prd ) 78 !!---------------------------------------------------------------------- 79 !! *** ROUTINE eos_insitu *** 80 !! 81 !! ** Purpose : Compute the in situ density (ratio rho/rau0) from 82 !! potential temperature and salinity using an equation of state 83 !! defined through the namelist parameter nn_eos. 84 !! 85 !! ** Method : 3 cases: 86 !! nn_eos = 0 : Jackett and McDougall (1994) equation of state. 87 !! the in situ density is computed directly as a function of 88 !! potential temperature relative to the surface (the opa t 89 !! variable), salt and pressure (assuming no pressure variation 90 !! along geopotential surfaces, i.e. the pressure p in decibars 91 !! is approximated by the depth in meters. 92 !! prd(t,s,p) = ( rho(t,s,p) - rau0 ) / rau0 93 !! with pressure p decibars 94 !! potential temperature t deg celsius 95 !! salinity s psu 96 !! reference volumic mass rau0 kg/m**3 97 !! in situ volumic mass rho kg/m**3 98 !! in situ density anomalie prd no units 99 !! Check value: rho = 1060.93298 kg/m**3 for p=10000 dbar, 100 !! t = 40 deg celcius, s=40 psu 101 !! nn_eos = 1 : linear equation of state function of temperature only 102 !! prd(t) = 0.0285 - rn_alpha * t 103 !! nn_eos = 2 : linear equation of state function of temperature and 104 !! salinity 105 !! prd(t,s) = rn_beta * s - rn_alpha * tn - 1. 106 !! Note that no boundary condition problem occurs in this routine 107 !! as pts are defined over the whole domain. 108 !! 109 !! ** Action : compute prd , the in situ density (no units) 110 !! 111 !! References : Jackett and McDougall, J. Atmos. Ocean. Tech., 1994 112 !!---------------------------------------------------------------------- 113 !! 114 REAL(wp), DIMENSION(:,:,:,:), INTENT(in ) :: pts ! 1 : potential temperature [Celcius] 115 ! ! 2 : salinity [psu] 116 REAL(wp), DIMENSION(:,:,:) , INTENT( out) :: prd ! in situ density [-] 117 !! 118 INTEGER :: ji, jj, jk ! dummy loop indices 119 REAL(wp) :: zt , zs , zh , zsr ! local scalars 120 REAL(wp) :: zr1, zr2, zr3, zr4 ! - - 121 REAL(wp) :: zrhop, ze, zbw, zb ! - - 122 REAL(wp) :: zd , zc , zaw, za ! - - 123 REAL(wp) :: zb1, za1, zkw, zk0 ! - - 124 REAL(wp) :: zrau0r ! - - 125 REAL(wp), POINTER, DIMENSION(:,:,:) :: zws 126 !!---------------------------------------------------------------------- 127 128 ! 129 IF( nn_timing == 1 ) CALL timing_start('eos') 130 ! 131 CALL wrk_alloc( jpi, jpj, jpk, zws ) 132 ! 133 SELECT CASE( nn_eos ) 134 ! 135 CASE( 0 ) !== Jackett and McDougall (1994) formulation ==! 136 zrau0r = 1.e0 / rau0 137 !CDIR NOVERRCHK 138 zws(:,:,:) = SQRT( ABS( pts(:,:,:,jp_sal) ) ) 139 ! 140 DO jk = 1, jpkm1 141 DO jj = 1, jpj 142 DO ji = 1, jpi 143 zt = pts (ji,jj,jk,jp_tem) 144 zs = pts (ji,jj,jk,jp_sal) 145 zh = gdept_crs(ji,jj,jk) ! depth 146 zsr= zws (ji,jj,jk) ! square root salinity 147 ! 148 ! compute volumic mass pure water at atm pressure 149 zr1= ( ( ( ( 6.536332e-9_wp *zt - 1.120083e-6_wp )*zt + 1.001685e-4_wp )*zt & 150 & -9.095290e-3_wp )*zt + 6.793952e-2_wp )*zt + 999.842594_wp 151 ! seawater volumic mass atm pressure 152 zr2= ( ( ( 5.3875e-9_wp*zt-8.2467e-7_wp ) *zt+7.6438e-5_wp ) *zt & 153 & -4.0899e-3_wp ) *zt+0.824493_wp 154 zr3= ( -1.6546e-6_wp*zt+1.0227e-4_wp ) *zt-5.72466e-3_wp 155 zr4= 4.8314e-4_wp 156 ! 157 ! potential volumic mass (reference to the surface) 158 zrhop= ( zr4*zs + zr3*zsr + zr2 ) *zs + zr1 159 ! 160 ! add the compression terms 161 ze = ( -3.508914e-8_wp*zt-1.248266e-8_wp ) *zt-2.595994e-6_wp 162 zbw= ( 1.296821e-6_wp*zt-5.782165e-9_wp ) *zt+1.045941e-4_wp 163 zb = zbw + ze * zs 164 ! 165 zd = -2.042967e-2_wp 166 zc = (-7.267926e-5_wp*zt+2.598241e-3_wp ) *zt+0.1571896_wp 167 zaw= ( ( 5.939910e-6_wp*zt+2.512549e-3_wp ) *zt-0.1028859_wp ) *zt - 4.721788_wp 168 za = ( zd*zsr + zc ) *zs + zaw 169 ! 170 zb1= (-0.1909078_wp*zt+7.390729_wp ) *zt-55.87545_wp 171 za1= ( ( 2.326469e-3_wp*zt+1.553190_wp) *zt-65.00517_wp ) *zt+1044.077_wp 172 zkw= ( ( (-1.361629e-4_wp*zt-1.852732e-2_wp ) *zt-30.41638_wp ) *zt + 2098.925_wp ) *zt+190925.6_wp 173 zk0= ( zb1*zsr + za1 )*zs + zkw 174 ! 175 ! masked in situ density anomaly 176 prd(ji,jj,jk) = ( zrhop / ( 1.0_wp - zh / ( zk0 - zh * ( za - zh * zb ) ) ) & 177 & - rau0 ) * zrau0r * tmask_crs(ji,jj,jk) 178 END DO 179 END DO 180 END DO 181 ! 182 CASE( 1 ) !== Linear formulation function of temperature only ==! 183 DO jk = 1, jpkm1 184 prd(:,:,jk) = ( 0.0285_wp - rn_alpha * pts(:,:,jk,jp_tem) ) * tmask_crs(:,:,jk) 185 END DO 186 ! 187 CASE( 2 ) !== Linear formulation function of temperature and salinity ==! 188 DO jk = 1, jpkm1 189 prd(:,:,jk) = ( rn_beta * pts(:,:,jk,jp_sal) - rn_alpha * pts(:,:,jk,jp_tem) ) * tmask_crs(:,:,jk) 190 END DO 191 ! 192 END SELECT 193 ! 194 ! IF(ln_ctl) CALL prt_ctl( tab3d_1=prd, clinfo1=' eos : ', ovlap=1, kdim=jpk ) 195 ! 196 CALL wrk_dealloc( jpi, jpj, jpk, zws ) 197 ! 198 IF( nn_timing == 1 ) CALL timing_stop('eos') 199 ! 200 END SUBROUTINE eos_insitu_crs 201 202 203 SUBROUTINE eos_insitu_pot_crs( pts, prd, prhop ) 173 SUBROUTINE eos_insitu_pot( pts, prd, prhop, pdep ) 204 174 !!---------------------------------------------------------------------- 205 175 !! *** ROUTINE eos_insitu_pot *** … … 210 180 !! namelist parameter nn_eos. 211 181 !! 212 !! ** Method :213 !! nn_eos = 0 : Jackett and McDougall (1994) equation of state.214 !! the in situ density is computed directly as a function of215 !! potential temperature relative to the surface (the opa t216 !! variable), salt and pressure (assuming no pressure variation217 !! along geopotential surfaces, i.e. the pressure p in decibars218 !! is approximated by the depth in meters.219 !! prd(t,s,p) = ( rho(t,s,p) - rau0 ) / rau0220 !! rhop(t,s) = rho(t,s,0)221 !! with pressure p decibars222 !! potential temperature t deg celsius223 !! salinity s psu224 !! reference volumic mass rau0 kg/m**3225 !! in situ volumic mass rho kg/m**3226 !! in situ density anomalie prd no units227 !!228 !! Check value: rho = 1060.93298 kg/m**3 for p=10000 dbar,229 !! t = 40 deg celcius, s=40 psu230 !!231 !! nn_eos = 1 : linear equation of state function of temperature only232 !! prd(t) = ( rho(t) - rau0 ) / rau0 = 0.028 - rn_alpha * t233 !! rhop(t,s) = rho(t,s)234 !!235 !! nn_eos = 2 : linear equation of state function of temperature and236 !! salinity237 !! prd(t,s) = ( rho(t,s) - rau0 ) / rau0238 !! = rn_beta * s - rn_alpha * tn - 1.239 !! rhop(t,s) = rho(t,s)240 !! Note that no boundary condition problem occurs in this routine241 !! as (tn,sn) or (ta,sa) are defined over the whole domain.242 !!243 182 !! ** Action : - prd , the in situ density (no units) 244 183 !! - prhop, the potential volumic mass (Kg/m3) 245 184 !! 246 !! References : Jackett and McDougall, J. Atmos. Ocean. Tech., 1994 247 !! Brown and Campana, Mon. Weather Rev., 1978 248 !!---------------------------------------------------------------------- 249 !! 250 REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(in ) :: pts ! 1 : potential temperature [Celcius] 185 !!---------------------------------------------------------------------- 186 REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk,jpts), INTENT(in ) :: pts ! 1 : potential temperature [Celcius] 251 187 ! ! 2 : salinity [psu] 252 REAL(wp), DIMENSION(jpi,jpj,jpk ), INTENT( out) :: prd ! in situ density [-] 253 REAL(wp), DIMENSION(jpi,jpj,jpk ), INTENT( out) :: prhop ! potential density (surface referenced) 254 ! 255 INTEGER :: ji, jj, jk ! dummy loop indices 256 REAL(wp) :: zt, zs, zh, zsr, zr1, zr2, zr3, zr4, zrhop, ze, zbw ! local scalars 257 REAL(wp) :: zb, zd, zc, zaw, za, zb1, za1, zkw, zk0, zrau0r ! - - 258 REAL(wp), POINTER, DIMENSION(:,:,:) :: zws 259 !!---------------------------------------------------------------------- 260 ! 261 IF( nn_timing == 1 ) CALL timing_start('eos-p') 262 ! 263 CALL wrk_alloc( jpi, jpj, jpk, zws ) 188 REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk ), INTENT( out) :: prd ! in situ density [-] 189 REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk ), INTENT( out) :: prhop ! potential density (surface referenced) 190 REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk ), INTENT(in ) :: pdep ! depth [m] 191 ! 192 INTEGER :: ji, jj, jk ! dummy loop indices 193 REAL(wp) :: zt , zh , zs , ztm ! local scalars 194 REAL(wp) :: zn , zn0, zn1, zn2, zn3 ! - - 195 !!---------------------------------------------------------------------- 196 ! 197 IF( nn_timing == 1 ) CALL timing_start('eos-pot_crs') 264 198 ! 265 199 SELECT CASE ( nn_eos ) 266 200 ! 267 CASE( 0 ) !== Jackett and McDougall (1994) formulation ==! 268 zrau0r = 1.e0 / rau0 269 !CDIR NOVERRCHK 270 zws(:,:,:) = SQRT( ABS( pts(:,:,:,jp_sal) ) ) 201 CASE( -1, 0 ) !== polynomial TEOS-10 / EOS-80 ==! 271 202 ! 272 203 DO jk = 1, jpkm1 273 DO jj = 1, jpj 274 DO ji = 1, jpi 275 zt = pts (ji,jj,jk,jp_tem) 276 zs = pts (ji,jj,jk,jp_sal) 277 zh = gdept_crs(ji,jj,jk) ! depth 278 zsr= zws (ji,jj,jk) ! square root salinity 279 ! 280 ! compute volumic mass pure water at atm pressure 281 zr1= ( ( ( ( 6.536332e-9_wp*zt-1.120083e-6_wp )*zt+1.001685e-4_wp )*zt & 282 & -9.095290e-3_wp )*zt+6.793952e-2_wp )*zt+999.842594_wp 283 ! seawater volumic mass atm pressure 284 zr2= ( ( ( 5.3875e-9_wp*zt-8.2467e-7_wp ) *zt+7.6438e-5_wp ) *zt & 285 & -4.0899e-3_wp ) *zt+0.824493_wp 286 zr3= ( -1.6546e-6_wp*zt+1.0227e-4_wp ) *zt-5.72466e-3_wp 287 zr4= 4.8314e-4_wp 288 ! 289 ! potential volumic mass (reference to the surface) 290 zrhop= ( zr4*zs + zr3*zsr + zr2 ) *zs + zr1 291 ! 292 ! save potential volumic mass 293 prhop(ji,jj,jk) = zrhop * tmask_crs(ji,jj,jk) 294 ! 295 ! add the compression terms 296 ze = ( -3.508914e-8_wp*zt-1.248266e-8_wp ) *zt-2.595994e-6_wp 297 zbw= ( 1.296821e-6_wp*zt-5.782165e-9_wp ) *zt+1.045941e-4_wp 298 zb = zbw + ze * zs 299 ! 300 zd = -2.042967e-2_wp 301 zc = (-7.267926e-5_wp*zt+2.598241e-3_wp ) *zt+0.1571896_wp 302 zaw= ( ( 5.939910e-6_wp*zt+2.512549e-3_wp ) *zt-0.1028859_wp ) *zt - 4.721788_wp 303 za = ( zd*zsr + zc ) *zs + zaw 304 ! 305 zb1= ( -0.1909078_wp *zt+7.390729_wp ) *zt-55.87545_wp 306 za1= ( ( 2.326469e-3_wp*zt+1.553190_wp ) *zt-65.00517_wp ) *zt + 1044.077_wp 307 zkw= ( ( (-1.361629e-4_wp*zt-1.852732e-2_wp ) *zt-30.41638_wp ) *zt + 2098.925_wp ) *zt+190925.6_wp 308 zk0= ( zb1*zsr + za1 )*zs + zkw 309 ! 310 ! masked in situ density anomaly 311 prd(ji,jj,jk) = ( zrhop / ( 1.0_wp - zh / ( zk0 - zh * ( za - zh * zb ) ) ) & 312 & - rau0 ) * zrau0r * tmask_crs(ji,jj,jk) 204 DO jj = 1, jpj_crs 205 DO ji = 1, jpi_crs 206 ! 207 zh = pdep(ji,jj,jk) * r1_Z0 ! depth 208 zt = pts (ji,jj,jk,jp_tem) * r1_T0 ! temperature 209 zs = SQRT( ABS( pts(ji,jj,jk,jp_sal) + rdeltaS ) * r1_S0 ) ! square root salinity 210 ztm = tmask_crs(ji,jj,jk) ! tmask 211 ! 212 zn3 = EOS013*zt & 213 & + EOS103*zs+EOS003 214 ! 215 zn2 = (EOS022*zt & 216 & + EOS112*zs+EOS012)*zt & 217 & + (EOS202*zs+EOS102)*zs+EOS002 218 ! 219 zn1 = (((EOS041*zt & 220 & + EOS131*zs+EOS031)*zt & 221 & + (EOS221*zs+EOS121)*zs+EOS021)*zt & 222 & + ((EOS311*zs+EOS211)*zs+EOS111)*zs+EOS011)*zt & 223 & + (((EOS401*zs+EOS301)*zs+EOS201)*zs+EOS101)*zs+EOS001 224 ! 225 zn0 = (((((EOS060*zt & 226 & + EOS150*zs+EOS050)*zt & 227 & + (EOS240*zs+EOS140)*zs+EOS040)*zt & 228 & + ((EOS330*zs+EOS230)*zs+EOS130)*zs+EOS030)*zt & 229 & + (((EOS420*zs+EOS320)*zs+EOS220)*zs+EOS120)*zs+EOS020)*zt & 230 & + ((((EOS510*zs+EOS410)*zs+EOS310)*zs+EOS210)*zs+EOS110)*zs+EOS010)*zt & 231 & + (((((EOS600*zs+EOS500)*zs+EOS400)*zs+EOS300)*zs+EOS200)*zs+EOS100)*zs+EOS000 232 ! 233 zn = ( ( zn3 * zh + zn2 ) * zh + zn1 ) * zh + zn0 234 ! 235 prhop(ji,jj,jk) = zn0 * ztm ! potential density referenced at the surface 236 ! 237 prd(ji,jj,jk) = ( zn * r1_rau0 - 1._wp ) * ztm ! density anomaly (masked) 313 238 END DO 314 239 END DO 315 240 END DO 316 241 ! 317 CASE( 1 ) !== Linear formulation = F( temperature ) ==! 242 CASE( 1 ) !== simplified EOS ==! 243 ! 318 244 DO jk = 1, jpkm1 319 prd (:,:,jk) = ( 0.0285_wp - rn_alpha * pts(:,:,jk,jp_tem) ) * tmask_crs(:,:,jk) 320 prhop(:,:,jk) = ( 1.e0_wp + prd (:,:,jk) ) * rau0 * tmask_crs(:,:,jk) 245 DO jj = 1, jpj_crs 246 DO ji = 1, jpi_crs 247 zt = pts (ji,jj,jk,jp_tem) - 10._wp 248 zs = pts (ji,jj,jk,jp_sal) - 35._wp 249 zh = pdep (ji,jj,jk) 250 ztm = tmask_crs(ji,jj,jk) 251 ! ! potential density referenced at the surface 252 zn = - rn_a0 * ( 1._wp + 0.5_wp*rn_lambda1*zt ) * zt & 253 & + rn_b0 * ( 1._wp - 0.5_wp*rn_lambda2*zs ) * zs & 254 & - rn_nu * zt * zs 255 prhop(ji,jj,jk) = ( rau0 + zn ) * ztm 256 ! ! density anomaly (masked) 257 zn = zn - ( rn_a0 * rn_mu1 * zt + rn_b0 * rn_mu2 * zs ) * zh 258 prd(ji,jj,jk) = zn * r1_rau0 * ztm 259 ! 260 END DO 261 END DO 321 262 END DO 322 263 ! 323 CASE( 2 ) !== Linear formulation = F( temperature , salinity ) ==!324 DO jk = 1, jpkm1325 prd (:,:,jk) = ( rn_beta * pts(:,:,jk,jp_sal) - rn_alpha * pts(:,:,jk,jp_tem) ) * tmask_crs(:,:,jk)326 prhop(:,:,jk) = ( 1.e0_wp + prd (:,:,jk) ) * rau0 * tmask_crs(:,:,jk)327 END DO328 !329 264 END SELECT 330 265 ! 331 ! IF(ln_ctl) CALL prt_ctl( tab3d_1=prd, clinfo1=' eos-p: ', tab3d_2=prhop, clinfo2=' pot : ', ovlap=1, kdim=jpk ) 332 ! 333 CALL wrk_dealloc( jpi, jpj, jpk, zws ) 334 ! 335 IF( nn_timing == 1 ) CALL timing_stop('eos-p') 336 ! 337 END SUBROUTINE eos_insitu_pot_crs 338 339 340 SUBROUTINE eos_insitu_2d_crs( pts, pdep, prd ) 266 IF(ln_ctl) CALL prt_ctl( tab3d_1=prd, clinfo1=' eos-pot: ', tab3d_2=prhop, clinfo2=' pot : ', ovlap=1, kdim=jpk ) 267 ! 268 IF( nn_timing == 1 ) CALL timing_stop('eos-pot_crs') 269 ! 270 END SUBROUTINE eos_insitu_pot 271 272 SUBROUTINE eos_insitu_2d( pts, pdep, prd ) 341 273 !!---------------------------------------------------------------------- 342 274 !! *** ROUTINE eos_insitu_2d *** … … 346 278 !! defined through the namelist parameter nn_eos. * 2D field case 347 279 !! 348 !! ** Method : 349 !! nn_eos = 0 : Jackett and McDougall (1994) equation of state. 350 !! the in situ density is computed directly as a function of 351 !! potential temperature relative to the surface (the opa t 352 !! variable), salt and pressure (assuming no pressure variation 353 !! along geopotential surfaces, i.e. the pressure p in decibars 354 !! is approximated by the depth in meters. 355 !! prd(t,s,p) = ( rho(t,s,p) - rau0 ) / rau0 356 !! with pressure p decibars 357 !! potential temperature t deg celsius 358 !! salinity s psu 359 !! reference volumic mass rau0 kg/m**3 360 !! in situ volumic mass rho kg/m**3 361 !! in situ density anomalie prd no units 362 !! Check value: rho = 1060.93298 kg/m**3 for p=10000 dbar, 363 !! t = 40 deg celcius, s=40 psu 364 !! nn_eos = 1 : linear equation of state function of temperature only 365 !! prd(t) = 0.0285 - rn_alpha * t 366 !! nn_eos = 2 : linear equation of state function of temperature and 367 !! salinity 368 !! prd(t,s) = rn_beta * s - rn_alpha * tn - 1. 369 !! Note that no boundary condition problem occurs in this routine 370 !! as pts are defined over the whole domain. 371 !! 372 !! ** Action : - prd , the in situ density (no units) 373 !! 374 !! References : Jackett and McDougall, J. Atmos. Ocean. Tech., 1994 375 !!---------------------------------------------------------------------- 376 !! 377 REAL(wp), DIMENSION(jpi,jpj,jpts), INTENT(in ) :: pts ! 1 : potential temperature [Celcius] 280 !! ** Action : - prd , the in situ density (no units) (unmasked) 281 !! 282 !!---------------------------------------------------------------------- 283 REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpts), INTENT(in ) :: pts ! 1 : potential temperature [Celcius] 378 284 ! ! 2 : salinity [psu] 379 REAL(wp), DIMENSION(jpi,jpj) , INTENT(in ) :: pdep ! depth [m] 380 REAL(wp), DIMENSION(jpi,jpj) , INTENT( out) :: prd ! in situ density 381 !! 382 INTEGER :: ji, jj ! dummy loop indices 383 REAL(wp) :: zt, zs, zh, zsr, zr1, zr2, zr3, zr4, zrhop, ze, zbw ! temporary scalars 384 REAL(wp) :: zb, zd, zc, zaw, za, zb1, za1, zkw, zk0, zmask ! - - 385 REAL(wp), POINTER, DIMENSION(:,:) :: zws 386 !!---------------------------------------------------------------------- 387 ! 388 !WRITE(numout,*) ' pts1 ' , pts(:,:,1) 389 !WRITE(numout,*) ' pts2 ' , pts(:,:,2) 390 !WRITE(numout,*) ' jpi ' , jpi 391 !WRITE(numout,*) ' fs_jpim1 ' , fs_jpim1 392 !WRITE(numout,*) ' dim ' , size(pts,1) 393 IF( nn_timing == 1 ) CALL timing_start('eos2d') 394 ! 395 CALL wrk_alloc( jpi, jpj, zws ) 396 ! 397 285 REAL(wp), DIMENSION(jpi_crs,jpj_crs) , INTENT(in ) :: pdep ! depth [m] 286 REAL(wp), DIMENSION(jpi_crs,jpj_crs) , INTENT( out) :: prd ! in situ density 287 ! 288 INTEGER :: ji, jj, jk ! dummy loop indices 289 REAL(wp) :: zt , zh , zs ! local scalars 290 REAL(wp) :: zn , zn0, zn1, zn2, zn3 ! - - 291 !!---------------------------------------------------------------------- 292 ! 293 IF( nn_timing == 1 ) CALL timing_start('eos2d') 294 ! 398 295 prd(:,:) = 0._wp 399 296 ! 400 297 SELECT CASE( nn_eos ) 401 298 ! 402 CASE( 0 ) !== Jackett and McDougall (1994) formulation ==! 403 ! 404 !CDIR NOVERRCHK 405 DO jj = 1, jpjm1 406 !CDIR NOVERRCHK 407 DO ji = 1, fs_jpim1 ! vector opt. 408 zws(ji,jj) = SQRT( ABS( pts(ji,jj,jp_sal) ) ) 299 CASE( -1, 0 ) !== polynomial TEOS-10 / EOS-80 ==! 300 ! 301 DO jj = 1, jpj_crsm1 302 DO ji = 1, jpi_crsm1 ! vector opt. 303 ! 304 zh = pdep(ji,jj) * r1_Z0 ! depth 305 zt = pts (ji,jj,jp_tem) * r1_T0 ! temperature 306 zs = SQRT( ABS( pts(ji,jj,jp_sal) + rdeltaS ) * r1_S0 ) ! square root salinity 307 ! 308 zn3 = EOS013*zt & 309 & + EOS103*zs+EOS003 310 ! 311 zn2 = (EOS022*zt & 312 & + EOS112*zs+EOS012)*zt & 313 & + (EOS202*zs+EOS102)*zs+EOS002 314 ! 315 zn1 = (((EOS041*zt & 316 & + EOS131*zs+EOS031)*zt & 317 & + (EOS221*zs+EOS121)*zs+EOS021)*zt & 318 & + ((EOS311*zs+EOS211)*zs+EOS111)*zs+EOS011)*zt & 319 & + (((EOS401*zs+EOS301)*zs+EOS201)*zs+EOS101)*zs+EOS001 320 ! 321 zn0 = (((((EOS060*zt & 322 & + EOS150*zs+EOS050)*zt & 323 & + (EOS240*zs+EOS140)*zs+EOS040)*zt & 324 & + ((EOS330*zs+EOS230)*zs+EOS130)*zs+EOS030)*zt & 325 & + (((EOS420*zs+EOS320)*zs+EOS220)*zs+EOS120)*zs+EOS020)*zt & 326 & + ((((EOS510*zs+EOS410)*zs+EOS310)*zs+EOS210)*zs+EOS110)*zs+EOS010)*zt & 327 & + (((((EOS600*zs+EOS500)*zs+EOS400)*zs+EOS300)*zs+EOS200)*zs+EOS100)*zs+EOS000 328 ! 329 zn = ( ( zn3 * zh + zn2 ) * zh + zn1 ) * zh + zn0 330 ! 331 prd(ji,jj) = zn * r1_rau0 - 1._wp ! unmasked in situ density anomaly 332 ! 409 333 END DO 410 334 END DO 411 DO jj = 1, jpjm1 412 DO ji = 1, fs_jpim1 ! vector opt. 413 zmask = tmask_crs(ji,jj,1) ! land/sea bottom mask = surf. mask 414 zt = pts (ji,jj,jp_tem) ! interpolated T 415 zs = pts (ji,jj,jp_sal) ! interpolated S 416 zsr = zws (ji,jj) ! square root of interpolated S 417 zh = pdep (ji,jj) ! depth at the partial step level 418 ! 419 ! compute volumic mass pure water at atm pressure 420 zr1 = ( ( ( ( 6.536332e-9_wp*zt-1.120083e-6_wp )*zt+1.001685e-4_wp )*zt & 421 & -9.095290e-3_wp )*zt+6.793952e-2_wp )*zt+999.842594_wp 422 ! seawater volumic mass atm pressure 423 zr2 = ( ( ( 5.3875e-9_wp*zt-8.2467e-7_wp )*zt+7.6438e-5_wp ) *zt & 424 & -4.0899e-3_wp ) *zt+0.824493_wp 425 zr3 = ( -1.6546e-6_wp*zt+1.0227e-4_wp ) *zt-5.72466e-3_wp 426 zr4 = 4.8314e-4_wp 427 ! 428 ! potential volumic mass (reference to the surface) 429 zrhop= ( zr4*zs + zr3*zsr + zr2 ) *zs + zr1 430 ! 431 ! add the compression terms 432 ze = ( -3.508914e-8_wp*zt-1.248266e-8_wp ) *zt-2.595994e-6_wp 433 zbw= ( 1.296821e-6_wp*zt-5.782165e-9_wp ) *zt+1.045941e-4_wp 434 zb = zbw + ze * zs 435 ! 436 zd = -2.042967e-2_wp 437 zc = (-7.267926e-5_wp*zt+2.598241e-3_wp ) *zt+0.1571896_wp 438 zaw= ( ( 5.939910e-6_wp*zt+2.512549e-3_wp ) *zt-0.1028859_wp ) *zt -4.721788_wp 439 za = ( zd*zsr + zc ) *zs + zaw 440 ! 441 zb1= (-0.1909078_wp *zt+7.390729_wp ) *zt-55.87545_wp 442 za1= ( ( 2.326469e-3_wp*zt+1.553190_wp ) *zt-65.00517_wp ) *zt+1044.077_wp 443 zkw= ( ( (-1.361629e-4_wp*zt-1.852732e-2_wp ) *zt-30.41638_wp ) *zt & 444 & +2098.925_wp ) *zt+190925.6_wp 445 zk0= ( zb1*zsr + za1 )*zs + zkw 446 ! 447 ! masked in situ density anomaly 448 prd(ji,jj) = ( zrhop / ( 1.0_wp - zh / ( zk0 - zh * ( za - zh * zb ) ) ) - rau0 ) / rau0 * zmask 335 ! 336 CALL crs_lbc_lnk( prd, 'T', 1. ) ! Lateral boundary conditions 337 ! 338 CASE( 1 ) !== simplified EOS ==! 339 ! 340 DO jj = 1, jpj_crsm1 341 DO ji = 1, jpi_crsm1 ! vector opt. 342 ! 343 zt = pts (ji,jj,jp_tem) - 10._wp 344 zs = pts (ji,jj,jp_sal) - 35._wp 345 zh = pdep (ji,jj) ! depth at the partial step level 346 ! 347 zn = - rn_a0 * ( 1._wp + 0.5_wp*rn_lambda1*zt + rn_mu1*zh ) * zt & 348 & + rn_b0 * ( 1._wp - 0.5_wp*rn_lambda2*zs - rn_mu2*zh ) * zs & 349 & - rn_nu * zt * zs 350 ! 351 prd(ji,jj) = zn * r1_rau0 ! unmasked in situ density anomaly 352 ! 449 353 END DO 450 354 END DO 451 355 ! 452 CASE( 1 ) !== Linear formulation = F( temperature ) ==! 453 DO jj = 1, jpjm1 454 DO ji = 1, fs_jpim1 ! vector opt. 455 prd(ji,jj) = ( 0.0285_wp - rn_alpha * pts(ji,jj,jp_tem) ) * tmask_crs(ji,jj,1) 456 END DO 457 END DO 458 ! 459 CASE( 2 ) !== Linear formulation = F( temperature , salinity ) ==! 460 DO jj = 1, jpjm1 461 DO ji = 1, fs_jpim1 ! vector opt. 462 prd(ji,jj) = ( rn_beta * pts(ji,jj,jp_sal) - rn_alpha * pts(ji,jj,jp_tem) ) * tmask_crs(ji,jj,1) 463 END DO 464 END DO 356 CALL crs_lbc_lnk( prd, 'T', 1. ) ! Lateral boundary conditions 465 357 ! 466 358 END SELECT 467 !WRITE(numout,*) ' prd ' , prd(:,:) 468 !WRITE(numout,*) ' zws ' , zws(:,:) 469 !WRITE(numout,*) ' pdep ' , pdep(:,:) 470 471 472 473 ! IF(ln_ctl) CALL prt_ctl( tab2d_1=prd, clinfo1=' eos2d: ' ) 474 ! 475 CALL wrk_dealloc( jpi, jpj, zws ) 476 ! 477 IF( nn_timing == 1 ) CALL timing_stop('eos2d') 478 ! 479 END SUBROUTINE eos_insitu_2d_crs 480 481 482 SUBROUTINE eos_bn2_crs( pts, pn2 ) 483 !!---------------------------------------------------------------------- 484 !! *** ROUTINE eos_bn2 *** 485 !! 486 !! ** Purpose : Compute the local Brunt-Vaisala frequency at the time- 487 !! step of the input arguments 488 !! 489 !! ** Method : 490 !! * nn_eos = 0 : UNESCO sea water properties 491 !! The brunt-vaisala frequency is computed using the polynomial 492 !! polynomial expression of McDougall (1987): 493 !! N^2 = grav * beta * ( alpha/beta*dk[ t ] - dk[ s ] )/e3w 494 !! If lk_zdfddm=T, the heat/salt buoyancy flux ratio Rrau is 495 !! computed and used in zdfddm module : 496 !! Rrau = alpha/beta * ( dk[ t ] / dk[ s ] ) 497 !! * nn_eos = 1 : linear equation of state (temperature only) 498 !! N^2 = grav * rn_alpha * dk[ t ]/e3w 499 !! * nn_eos = 2 : linear equation of state (temperature & salinity) 500 !! N^2 = grav * (rn_alpha * dk[ t ] - rn_beta * dk[ s ] ) / e3w 501 !! The use of potential density to compute N^2 introduces e r r o r 502 !! in the sign of N^2 at great depths. We recommand the use of 503 !! nn_eos = 0, except for academical studies. 504 !! Macro-tasked on horizontal slab (jk-loop) 505 !! N.B. N^2 is set to zero at the first level (JK=1) in inidtr 506 !! and is never used at this level. 507 !! 508 !! ** Action : - pn2 : the brunt-vaisala frequency 509 !! 510 !! References : McDougall, J. Phys. Oceanogr., 17, 1950-1964, 1987. 511 !!---------------------------------------------------------------------- 512 REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(in ) :: pts ! 1 : potential temperature [Celcius] 513 ! ! 2 : salinity [psu] 514 REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT( out) :: pn2 ! Brunt-Vaisala frequency [s-1] 515 !! 516 INTEGER :: ji, jj, jk ! dummy loop indices 517 REAL(wp) :: zgde3w, zt, zs, zh, zalbet, zbeta ! local scalars 518 #if defined key_zdfddm 519 REAL(wp) :: zds ! local scalars 520 #endif 521 !!---------------------------------------------------------------------- 522 523 ! 524 IF( nn_timing == 1 ) CALL timing_start('bn2') 525 ! 526 ! pn2 : interior points only (2=< jk =< jpkm1 ) 527 ! -------------------------- 528 ! 529 SELECT CASE( nn_eos ) 530 ! 531 CASE( 0 ) !== Jackett and McDougall (1994) formulation ==! 532 DO jk = 2, jpkm1 533 DO jj = 1, jpj 534 DO ji = 1, jpi 535 zgde3w = grav / e3w_max_crs(ji,jj,jk) 536 zt = 0.5 * ( pts(ji,jj,jk,jp_tem) + pts(ji,jj,jk-1,jp_tem) ) ! potential temperature at w-pt 537 zs = 0.5 * ( pts(ji,jj,jk,jp_sal) + pts(ji,jj,jk-1,jp_sal) ) - 35.0 ! salinity anomaly (s-35) at w-pt 538 zh = gdepw_crs(ji,jj,jk) ! depth in meters at w-point 539 ! 540 zalbet = ( ( ( - 0.255019e-07_wp * zt + 0.298357e-05_wp ) * zt & ! ratio alpha/beta 541 & - 0.203814e-03_wp ) * zt & 542 & + 0.170907e-01_wp ) * zt & 543 & + 0.665157e-01_wp & 544 & + ( - 0.678662e-05_wp * zs & 545 & - 0.846960e-04_wp * zt + 0.378110e-02_wp ) * zs & 546 & + ( ( - 0.302285e-13_wp * zh & 547 & - 0.251520e-11_wp * zs & 548 & + 0.512857e-12_wp * zt * zt ) * zh & 549 & - 0.164759e-06_wp * zs & 550 & +( 0.791325e-08_wp * zt - 0.933746e-06_wp ) * zt & 551 & + 0.380374e-04_wp ) * zh 359 ! 360 IF(ln_ctl) CALL prt_ctl( tab2d_1=prd, clinfo1=' eos2d: ' ) 361 ! 362 IF( nn_timing == 1 ) CALL timing_stop('eos2d') 363 ! 364 END SUBROUTINE eos_insitu_2d 365 366 SUBROUTINE rab_crs_3d( pts, pab ) 367 !!---------------------------------------------------------------------- 368 !! *** ROUTINE rab_3d *** 369 !! 370 !! ** Purpose : Calculates thermal/haline expansion ratio at T-points 371 !! 372 !! ** Method : calculates alpha / beta at T-points 373 !! 374 !! ** Action : - pab : thermal/haline expansion ratio at T-points 375 !!---------------------------------------------------------------------- 376 REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk,jpts), INTENT(in ) :: pts ! pot. temperature & salinity 377 REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk,jpts), INTENT( out) :: pab ! thermal/haline expansion ratio 378 ! 379 INTEGER :: ji, jj, jk ! dummy loop indices 380 REAL(wp) :: zt , zh , zs , ztm ! local scalars 381 REAL(wp) :: zn , zn0, zn1, zn2, zn3 ! - - 382 !!---------------------------------------------------------------------- 383 ! 384 IF( nn_timing == 1 ) CALL timing_start('rab_3d') 385 ! 386 SELECT CASE ( nn_eos ) 387 ! 388 CASE( -1, 0 ) !== polynomial TEOS-10 / EOS-80 ==! 389 ! 390 DO jk = 1, jpkm1 391 DO jj = 1, jpj_crs 392 DO ji = 1, jpi_crs 393 ! 394 zh = gdept_crs(ji,jj,jk) * r1_Z0 ! depth 395 zt = pts (ji,jj,jk,jp_tem) * r1_T0 ! temperature 396 zs = SQRT( ABS( pts(ji,jj,jk,jp_sal) + rdeltaS ) * r1_S0 ) ! square root salinity 397 ztm = tmask_crs(ji,jj,jk) ! tmask 398 ! 399 ! alpha 400 zn3 = ALP003 401 ! 402 zn2 = ALP012*zt + ALP102*zs+ALP002 403 ! 404 zn1 = ((ALP031*zt & 405 & + ALP121*zs+ALP021)*zt & 406 & + (ALP211*zs+ALP111)*zs+ALP011)*zt & 407 & + ((ALP301*zs+ALP201)*zs+ALP101)*zs+ALP001 552 408 ! 553 zbeta = ( ( -0.415613e-09_wp * zt + 0.555579e-07_wp ) * zt & ! beta 554 & - 0.301985e-05_wp ) * zt & 555 & + 0.785567e-03_wp & 556 & + ( 0.515032e-08_wp * zs & 557 & + 0.788212e-08_wp * zt - 0.356603e-06_wp ) * zs & 558 & + ( ( 0.121551e-17_wp * zh & 559 & - 0.602281e-15_wp * zs & 560 & - 0.175379e-14_wp * zt + 0.176621e-12_wp ) * zh & 561 & + 0.408195e-10_wp * zs & 562 & + ( - 0.213127e-11_wp * zt + 0.192867e-09_wp ) * zt & 563 & - 0.121555e-07_wp ) * zh 409 zn0 = ((((ALP050*zt & 410 & + ALP140*zs+ALP040)*zt & 411 & + (ALP230*zs+ALP130)*zs+ALP030)*zt & 412 & + ((ALP320*zs+ALP220)*zs+ALP120)*zs+ALP020)*zt & 413 & + (((ALP410*zs+ALP310)*zs+ALP210)*zs+ALP110)*zs+ALP010)*zt & 414 & + ((((ALP500*zs+ALP400)*zs+ALP300)*zs+ALP200)*zs+ALP100)*zs+ALP000 564 415 ! 565 !cbr zgde3w: divide by 0 566 !pn2(ji,jj,jk) = zgde3w * zbeta * tmask_crs(ji,jj,jk) & ! N^2 567 ! & * ( zalbet * ( pts(ji,jj,jk-1,jp_tem) - pts(ji,jj,jk,jp_tem) ) & 568 ! & - ( pts(ji,jj,jk-1,jp_sal) - pts(ji,jj,jk,jp_sal) ) ) 569 pn2(ji,jj,jk) = zbeta * tmask_crs(ji,jj,jk) & ! N^2 570 & * ( zalbet * ( pts(ji,jj,jk-1,jp_tem) - pts(ji,jj,jk,jp_tem) ) & 571 & - ( pts(ji,jj,jk-1,jp_sal) - pts(ji,jj,jk,jp_sal) ) ) 572 IF( e3w_max_crs(ji,jj,jk) .NE. 0._wp ) pn2(ji,jj,jk) = zgde3w * e3w_max_crs(ji,jj,jk) 573 574 #if defined key_zdfddm 575 ! !!bug **** caution a traiter zds=dk[S]= 0 !!!! 576 zds = ( pts(ji,jj,jk-1,jp_sal) - pts(ji,jj,jk,jp_sal) ) ! Rrau = (alpha / beta) (dk[t] / dk[s]) 577 IF ( ABS( zds) <= 1.e-20_wp ) zds = 1.e-20_wp 578 rrau(ji,jj,jk) = zalbet * ( pts(ji,jj,jk-1,jp_tem) - pts(ji,jj,jk,jp_tem) ) / zds 579 #endif 416 zn = ( ( zn3 * zh + zn2 ) * zh + zn1 ) * zh + zn0 417 ! 418 pab(ji,jj,jk,jp_tem) = zn * r1_rau0 * ztm 419 ! 420 ! beta 421 zn3 = BET003 422 ! 423 zn2 = BET012*zt + BET102*zs+BET002 424 ! 425 zn1 = ((BET031*zt & 426 & + BET121*zs+BET021)*zt & 427 & + (BET211*zs+BET111)*zs+BET011)*zt & 428 & + ((BET301*zs+BET201)*zs+BET101)*zs+BET001 429 ! 430 zn0 = ((((BET050*zt & 431 & + BET140*zs+BET040)*zt & 432 & + (BET230*zs+BET130)*zs+BET030)*zt & 433 & + ((BET320*zs+BET220)*zs+BET120)*zs+BET020)*zt & 434 & + (((BET410*zs+BET310)*zs+BET210)*zs+BET110)*zs+BET010)*zt & 435 & + ((((BET500*zs+BET400)*zs+BET300)*zs+BET200)*zs+BET100)*zs+BET000 436 ! 437 zn = ( ( zn3 * zh + zn2 ) * zh + zn1 ) * zh + zn0 438 ! 439 pab(ji,jj,jk,jp_sal) = zn / zs * r1_rau0 * ztm 440 ! 580 441 END DO 581 442 END DO 582 443 END DO 583 444 ! 584 CASE( 1 ) !== Linear formulation = F( temperature ) ==! 585 DO jk = 2, jpkm1 586 pn2(:,:,jk) = grav * rn_alpha * ( pts(:,:,jk-1,jp_tem) - pts(:,:,jk,jp_tem) ) / e3w_max_crs(:,:,jk) * tmask_crs(:,:,jk) 587 END DO 588 ! 589 CASE( 2 ) !== Linear formulation = F( temperature , salinity ) ==! 590 DO jk = 2, jpkm1 591 !cbr: bug divide by 0. 592 !pn2(:,:,jk) = grav * ( rn_alpha * ( pts(:,:,jk-1,jp_tem) - pts(:,:,jk,jp_tem) ) & 593 ! & - rn_beta * ( pts(:,:,jk-1,jp_sal) - pts(:,:,jk,jp_sal) ) ) & 594 ! & / e3w_max_crs(:,:,jk) * tmask_crs(:,:,jk) 595 pn2(:,:,jk) = grav * ( rn_alpha * ( pts(:,:,jk-1,jp_tem) - pts(:,:,jk,jp_tem) ) & 596 & - rn_beta * ( pts(:,:,jk-1,jp_sal) - pts(:,:,jk,jp_sal) ) ) & 597 & * tmask_crs(:,:,jk) 598 DO jj = 1, jpj 599 DO ji = 1, jpi 600 IF( e3w_max_crs(ji,jj,jk) .NE. 0._wp ) pn2(ji,jj,jk) = pn2(ji,jj,jk) / e3w_max_crs(ji,jj,jk) 601 ENDDO 602 ENDDO 603 END DO 604 #if defined key_zdfddm 605 DO jk = 2, jpkm1 ! Rrau = (alpha / beta) (dk[t] / dk[s]) 606 DO jj = 1, jpj 607 DO ji = 1, jpi 608 zds = ( pts(ji,jj,jk-1,jp_sal) - pts(ji,jj,jk,jp_sal) ) 609 IF ( ABS( zds ) <= 1.e-20_wp ) zds = 1.e-20_wp 610 rrau(ji,jj,jk) = ralpbet_crs * ( pts(ji,jj,jk-1,jp_tem) - pts(ji,jj,jk,jp_tem) ) / zds 445 CASE( 1 ) !== simplified EOS ==! 446 ! 447 DO jk = 1, jpkm1 448 DO jj = 1, jpj_crs 449 DO ji = 1, jpi_crs 450 zt = pts (ji,jj,jk,jp_tem) - 10._wp ! pot. temperature anomaly (t-T0) 451 zs = pts (ji,jj,jk,jp_sal) - 35._wp ! abs. salinity anomaly (s-S0) 452 zh = gdept_crs(ji,jj,jk) ! depth in meters at t-point 453 ztm = tmask_crs(ji,jj,jk) ! land/sea bottom mask = surf. mask 454 ! 455 zn = rn_a0 * ( 1._wp + rn_lambda1*zt + rn_mu1*zh ) + rn_nu*zs 456 pab(ji,jj,jk,jp_tem) = zn * r1_rau0 * ztm ! alpha 457 ! 458 zn = rn_b0 * ( 1._wp - rn_lambda2*zs - rn_mu2*zh ) - rn_nu*zt 459 pab(ji,jj,jk,jp_sal) = zn * r1_rau0 * ztm ! beta 460 ! 611 461 END DO 612 462 END DO 613 463 END DO 614 #endif615 END SELECT616 617 ! IF(ln_ctl) CALL prt_ctl( tab3d_1=pn2, clinfo1=' bn2 : ', ovlap=1, kdim=jpk )618 #if defined key_zdfddm619 ! IF(ln_ctl) CALL prt_ctl( tab3d_1=rrau, clinfo1=' rrau : ', ovlap=1, kdim=jpk )620 #endif621 !622 IF( nn_timing == 1 ) CALL timing_stop('bn2')623 !624 END SUBROUTINE eos_bn2_crs625 626 627 SUBROUTINE eos_alpbet_crs( pts, palpbet, beta0 )628 !!----------------------------------------------------------------------629 !! *** ROUTINE eos_alpbet ***630 !!631 !! ** Purpose : Calculates the in situ thermal/haline expansion ratio at T-points632 !!633 !! ** Method : calculates alpha / beta ratio at T-points634 !! * nn_eos = 0 : UNESCO sea water properties635 !! The alpha/beta ratio is returned as 3-D array palpbet using the polynomial636 !! polynomial expression of McDougall (1987).637 !! Scalar beta0 is returned = 1.638 !! * nn_eos = 1 : linear equation of state (temperature only)639 !! The ratio is undefined, so we return alpha as palpbet640 !! Scalar beta0 is returned = 0.641 !! * nn_eos = 2 : linear equation of state (temperature & salinity)642 !! The alpha/beta ratio is returned as ralpbet643 !! Scalar beta0 is returned = 1.644 !!645 !! ** Action : - palpbet : thermal/haline expansion ratio at T-points646 !! : beta0 : 1. or 0.647 !!----------------------------------------------------------------------648 REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(in ) :: pts ! pot. temperature & salinity649 REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT( out) :: palpbet ! thermal/haline expansion ratio650 REAL(wp), INTENT( out) :: beta0 ! set = 1 except with case 1 eos, rho=rho(T)651 !!652 INTEGER :: ji, jj, jk ! dummy loop indices653 REAL(wp) :: zt, zs, zh ! local scalars654 !!----------------------------------------------------------------------655 !656 IF( nn_timing == 1 ) CALL timing_start('eos_alpbet')657 !658 SELECT CASE ( nn_eos )659 !660 CASE ( 0 ) ! Jackett and McDougall (1994) formulation661 DO jk = 1, jpk662 DO jj = 1, jpj663 DO ji = 1, jpi664 zt = pts(ji,jj,jk,jp_tem) ! potential temperature665 zs = pts(ji,jj,jk,jp_sal) - 35._wp ! salinity anomaly (s-35)666 zh = fsdept(ji,jj,jk) ! depth in meters667 !668 palpbet(ji,jj,jk) = &669 & ( ( ( - 0.255019e-07_wp * zt + 0.298357e-05_wp ) * zt &670 & - 0.203814e-03_wp ) * zt &671 & + 0.170907e-01_wp ) * zt &672 & + 0.665157e-01_wp &673 & + ( - 0.678662e-05_wp * zs &674 & - 0.846960e-04_wp * zt + 0.378110e-02_wp ) * zs &675 & + ( ( - 0.302285e-13_wp * zh &676 & - 0.251520e-11_wp * zs &677 & + 0.512857e-12_wp * zt * zt ) * zh &678 & - 0.164759e-06_wp * zs &679 & +( 0.791325e-08_wp * zt - 0.933746e-06_wp ) * zt &680 & + 0.380374e-04_wp ) * zh681 END DO682 END DO683 END DO684 beta0 = 1._wp685 !686 CASE ( 1 ) !== Linear formulation = F( temperature ) ==!687 palpbet(:,:,:) = rn_alpha688 beta0 = 0._wp689 !690 CASE ( 2 ) !== Linear formulation = F( temperature , salinity ) ==!691 palpbet(:,:,:) = ralpbet_crs692 beta0 = 1._wp693 464 ! 694 465 CASE DEFAULT … … 699 470 END SELECT 700 471 ! 701 IF( nn_timing == 1 ) CALL timing_stop('eos_alpbet') 702 ! 703 END SUBROUTINE eos_alpbet_crs 704 705 706 FUNCTION tfreez_crs( psal ) RESULT( ptf ) 472 IF(ln_ctl) CALL prt_ctl( tab3d_1=pab(:,:,:,jp_tem), clinfo1=' rab_3d_t: ', & 473 & tab3d_2=pab(:,:,:,jp_sal), clinfo2=' rab_3d_s : ', ovlap=1, kdim=jpk ) 474 ! 475 IF( nn_timing == 1 ) CALL timing_stop('rab_3d') 476 ! 477 END SUBROUTINE rab_crs_3d 478 479 SUBROUTINE rab_crs_2d( pts, pdep, pab ) 480 !!---------------------------------------------------------------------- 481 !! *** ROUTINE rab_2d *** 482 !! 483 !! ** Purpose : Calculates thermal/haline expansion ratio for a 2d field (unmasked) 484 !! 485 !! ** Action : - pab : thermal/haline expansion ratio at T-points 486 !!---------------------------------------------------------------------- 487 REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpts) , INTENT(in ) :: pts ! pot. temperature & salinity 488 REAL(wp), DIMENSION(jpi_crs,jpj_crs) , INTENT(in ) :: pdep ! depth [m] 489 REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpts) , INTENT( out) :: pab ! thermal/haline expansion ratio 490 ! 491 INTEGER :: ji, jj, jk ! dummy loop indices 492 REAL(wp) :: zt , zh , zs ! local scalars 493 REAL(wp) :: zn , zn0, zn1, zn2, zn3 ! - - 494 !!---------------------------------------------------------------------- 495 ! 496 IF( nn_timing == 1 ) CALL timing_start('rab_2d') 497 ! 498 pab(:,:,:) = 0._wp 499 ! 500 SELECT CASE ( nn_eos ) 501 ! 502 CASE( -1, 0 ) !== polynomial TEOS-10 / EOS-80 ==! 503 ! 504 DO jj = 1, jpj_crsm1 505 DO ji = 1, jpi_crsm1 ! vector opt. 506 ! 507 zh = pdep(ji,jj) * r1_Z0 ! depth 508 zt = pts (ji,jj,jp_tem) * r1_T0 ! temperature 509 zs = SQRT( ABS( pts(ji,jj,jp_sal) + rdeltaS ) * r1_S0 ) ! square root salinity 510 ! 511 ! alpha 512 zn3 = ALP003 513 ! 514 zn2 = ALP012*zt + ALP102*zs+ALP002 515 ! 516 zn1 = ((ALP031*zt & 517 & + ALP121*zs+ALP021)*zt & 518 & + (ALP211*zs+ALP111)*zs+ALP011)*zt & 519 & + ((ALP301*zs+ALP201)*zs+ALP101)*zs+ALP001 520 ! 521 zn0 = ((((ALP050*zt & 522 & + ALP140*zs+ALP040)*zt & 523 & + (ALP230*zs+ALP130)*zs+ALP030)*zt & 524 & + ((ALP320*zs+ALP220)*zs+ALP120)*zs+ALP020)*zt & 525 & + (((ALP410*zs+ALP310)*zs+ALP210)*zs+ALP110)*zs+ALP010)*zt & 526 & + ((((ALP500*zs+ALP400)*zs+ALP300)*zs+ALP200)*zs+ALP100)*zs+ALP000 527 ! 528 zn = ( ( zn3 * zh + zn2 ) * zh + zn1 ) * zh + zn0 529 ! 530 pab(ji,jj,jp_tem) = zn * r1_rau0 531 ! 532 ! beta 533 zn3 = BET003 534 ! 535 zn2 = BET012*zt + BET102*zs+BET002 536 ! 537 zn1 = ((BET031*zt & 538 & + BET121*zs+BET021)*zt & 539 & + (BET211*zs+BET111)*zs+BET011)*zt & 540 & + ((BET301*zs+BET201)*zs+BET101)*zs+BET001 541 ! 542 zn0 = ((((BET050*zt & 543 & + BET140*zs+BET040)*zt & 544 & + (BET230*zs+BET130)*zs+BET030)*zt & 545 & + ((BET320*zs+BET220)*zs+BET120)*zs+BET020)*zt & 546 & + (((BET410*zs+BET310)*zs+BET210)*zs+BET110)*zs+BET010)*zt & 547 & + ((((BET500*zs+BET400)*zs+BET300)*zs+BET200)*zs+BET100)*zs+BET000 548 ! 549 zn = ( ( zn3 * zh + zn2 ) * zh + zn1 ) * zh + zn0 550 ! 551 pab(ji,jj,jp_sal) = zn / zs * r1_rau0 552 ! 553 ! 554 END DO 555 END DO 556 ! 557 CALL crs_lbc_lnk( pab(:,:,jp_tem), 'T', 1. ) ! Lateral boundary conditions 558 CALL crs_lbc_lnk( pab(:,:,jp_sal), 'T', 1. ) 559 ! 560 CASE( 1 ) !== simplified EOS ==! 561 ! 562 DO jj = 1, jpj_crsm1 563 DO ji = 1, jpi_crsm1 ! vector opt. 564 ! 565 zt = pts (ji,jj,jp_tem) - 10._wp ! pot. temperature anomaly (t-T0) 566 zs = pts (ji,jj,jp_sal) - 35._wp ! abs. salinity anomaly (s-S0) 567 zh = pdep (ji,jj) ! depth at the partial step level 568 ! 569 zn = rn_a0 * ( 1._wp + rn_lambda1*zt + rn_mu1*zh ) + rn_nu*zs 570 pab(ji,jj,jp_tem) = zn * r1_rau0 ! alpha 571 ! 572 zn = rn_b0 * ( 1._wp - rn_lambda2*zs - rn_mu2*zh ) - rn_nu*zt 573 pab(ji,jj,jp_sal) = zn * r1_rau0 ! beta 574 ! 575 END DO 576 END DO 577 ! 578 CALL crs_lbc_lnk( pab(:,:,jp_tem), 'T', 1. ) ! Lateral boundary conditions 579 CALL crs_lbc_lnk( pab(:,:,jp_sal), 'T', 1. ) 580 ! 581 CASE DEFAULT 582 IF(lwp) WRITE(numout,cform_err) 583 IF(lwp) WRITE(numout,*) ' bad flag value for nn_eos = ', nn_eos 584 nstop = nstop + 1 585 ! 586 END SELECT 587 ! 588 IF(ln_ctl) CALL prt_ctl( tab2d_1=pab(:,:,jp_tem), clinfo1=' rab_2d_t: ', & 589 & tab2d_2=pab(:,:,jp_sal), clinfo2=' rab_2d_s : ' ) 590 ! 591 IF( nn_timing == 1 ) CALL timing_stop('rab_2d') 592 ! 593 END SUBROUTINE rab_crs_2d 594 595 596 SUBROUTINE rab_crs_0d( pts, pdep, pab ) 597 !!---------------------------------------------------------------------- 598 !! *** ROUTINE rab_0d *** 599 !! 600 !! ** Purpose : Calculates thermal/haline expansion ratio for a 2d field (unmasked) 601 !! 602 !! ** Action : - pab : thermal/haline expansion ratio at T-points 603 !!---------------------------------------------------------------------- 604 REAL(wp), DIMENSION(jpts) , INTENT(in ) :: pts ! pot. temperature & salinity 605 REAL(wp), INTENT(in ) :: pdep ! depth [m] 606 REAL(wp), DIMENSION(jpts) , INTENT( out) :: pab ! thermal/haline expansion ratio 607 ! 608 REAL(wp) :: zt , zh , zs ! local scalars 609 REAL(wp) :: zn , zn0, zn1, zn2, zn3 ! - - 610 !!---------------------------------------------------------------------- 611 ! 612 IF( nn_timing == 1 ) CALL timing_start('rab_2d') 613 ! 614 pab(:) = 0._wp 615 ! 616 SELECT CASE ( nn_eos ) 617 ! 618 CASE( -1, 0 ) !== polynomial TEOS-10 / EOS-80 ==! 619 ! 620 ! 621 zh = pdep * r1_Z0 ! depth 622 zt = pts (jp_tem) * r1_T0 ! temperature 623 zs = SQRT( ABS( pts(jp_sal) + rdeltaS ) * r1_S0 ) ! square root salinity 624 ! 625 ! alpha 626 zn3 = ALP003 627 ! 628 zn2 = ALP012*zt + ALP102*zs+ALP002 629 ! 630 zn1 = ((ALP031*zt & 631 & + ALP121*zs+ALP021)*zt & 632 & + (ALP211*zs+ALP111)*zs+ALP011)*zt & 633 & + ((ALP301*zs+ALP201)*zs+ALP101)*zs+ALP001 634 ! 635 zn0 = ((((ALP050*zt & 636 & + ALP140*zs+ALP040)*zt & 637 & + (ALP230*zs+ALP130)*zs+ALP030)*zt & 638 & + ((ALP320*zs+ALP220)*zs+ALP120)*zs+ALP020)*zt & 639 & + (((ALP410*zs+ALP310)*zs+ALP210)*zs+ALP110)*zs+ALP010)*zt & 640 & + ((((ALP500*zs+ALP400)*zs+ALP300)*zs+ALP200)*zs+ALP100)*zs+ALP000 641 ! 642 zn = ( ( zn3 * zh + zn2 ) * zh + zn1 ) * zh + zn0 643 ! 644 pab(jp_tem) = zn * r1_rau0 645 ! 646 ! beta 647 zn3 = BET003 648 ! 649 zn2 = BET012*zt + BET102*zs+BET002 650 ! 651 zn1 = ((BET031*zt & 652 & + BET121*zs+BET021)*zt & 653 & + (BET211*zs+BET111)*zs+BET011)*zt & 654 & + ((BET301*zs+BET201)*zs+BET101)*zs+BET001 655 ! 656 zn0 = ((((BET050*zt & 657 & + BET140*zs+BET040)*zt & 658 & + (BET230*zs+BET130)*zs+BET030)*zt & 659 & + ((BET320*zs+BET220)*zs+BET120)*zs+BET020)*zt & 660 & + (((BET410*zs+BET310)*zs+BET210)*zs+BET110)*zs+BET010)*zt & 661 & + ((((BET500*zs+BET400)*zs+BET300)*zs+BET200)*zs+BET100)*zs+BET000 662 ! 663 zn = ( ( zn3 * zh + zn2 ) * zh + zn1 ) * zh + zn0 664 ! 665 pab(jp_sal) = zn / zs * r1_rau0 666 ! 667 ! 668 ! 669 CASE( 1 ) !== simplified EOS ==! 670 ! 671 zt = pts(jp_tem) - 10._wp ! pot. temperature anomaly (t-T0) 672 zs = pts(jp_sal) - 35._wp ! abs. salinity anomaly (s-S0) 673 zh = pdep ! depth at the partial step level 674 ! 675 zn = rn_a0 * ( 1._wp + rn_lambda1*zt + rn_mu1*zh ) + rn_nu*zs 676 pab(jp_tem) = zn * r1_rau0 ! alpha 677 ! 678 zn = rn_b0 * ( 1._wp - rn_lambda2*zs - rn_mu2*zh ) - rn_nu*zt 679 pab(jp_sal) = zn * r1_rau0 ! beta 680 ! 681 CASE DEFAULT 682 IF(lwp) WRITE(numout,cform_err) 683 IF(lwp) WRITE(numout,*) ' bad flag value for nn_eos = ', nn_eos 684 nstop = nstop + 1 685 ! 686 END SELECT 687 ! 688 IF( nn_timing == 1 ) CALL timing_stop('rab_2d') 689 ! 690 END SUBROUTINE rab_crs_0d 691 692 693 SUBROUTINE bn2_crs( pts, pab, pn2 ) 694 !!---------------------------------------------------------------------- 695 !! *** ROUTINE bn2 *** 696 !! 697 !! ** Purpose : Compute the local Brunt-Vaisala frequency at the 698 !! time-step of the input arguments 699 !! 700 !! ** Method : pn2 = grav * (alpha dk[T] + beta dk[S] ) / e3w 701 !! where alpha and beta are given in pab, and computed on T-points. 702 !! N.B. N^2 is set one for all to zero at jk=1 in istate module. 703 !! 704 !! ** Action : pn2 : square of the brunt-vaisala frequency at w-point 705 !! 706 !!---------------------------------------------------------------------- 707 REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk,jpts), INTENT(in ) :: pts ! pot. temperature and salinity [Celcius,psu] 708 REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk,jpts), INTENT(in ) :: pab ! thermal/haline expansion coef. [Celcius-1,psu-1] 709 REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk ), INTENT( out) :: pn2 ! Brunt-Vaisala frequency squared [1/s^2] 710 ! 711 INTEGER :: ji, jj, jk ! dummy loop indices 712 REAL(wp) :: zaw, zbw, zrw ! local scalars 713 !!---------------------------------------------------------------------- 714 ! 715 pn2(:,:,:)=0._wp 716 717 IF( nn_timing == 1 ) CALL timing_start('bn2') 718 ! 719 DO jk = 2, jpkm1 ! interior points only (2=< jk =< jpkm1 ) 720 DO jj = 1, jpj_crs ! surface and bottom value set to zero one for all in istate.F90 721 DO ji = 1, jpi_crs 722 !zrw = ( gdepw_crs(ji,jj,jk ) - gdept_crs(ji,jj,jk) ) & 723 ! & / ( gdept_crs(ji,jj,jk-1) - gdept_crs(ji,jj,jk) ) 724 zrw = gdepw_crs(ji,jj,jk ) - gdept_crs(ji,jj,jk) 725 !?IF( gdept_crs(ji,jj,jk-1) - gdept_crs(ji,jj,jk) .NE. 0._wp )THEN 726 IF( gdept_crs(ji,jj,jk-1) - gdept_crs(ji,jj,jk) .LT. 0._wp )THEN 727 zrw = zrw / ( gdept_crs(ji,jj,jk-1) - gdept_crs(ji,jj,jk) ) 728 ELSE 729 zrw = 0._wp 730 ENDIF 731 ! 732 zaw = pab(ji,jj,jk,jp_tem) * (1._wp - zrw) + pab(ji,jj,jk-1,jp_tem) * zrw 733 zbw = pab(ji,jj,jk,jp_sal) * (1._wp - zrw) + pab(ji,jj,jk-1,jp_sal) * zrw 734 ! 735 IF( e3w_max_crs(ji,jj,jk) .NE. 0._wp ) THEN 736 pn2(ji,jj,jk) = grav * ( zaw * ( pts(ji,jj,jk-1,jp_tem) - pts(ji,jj,jk,jp_tem) ) & 737 & - zbw * ( pts(ji,jj,jk-1,jp_sal) - pts(ji,jj,jk,jp_sal) ) ) & 738 & * tmask_crs(ji,jj,jk) / e3w_max_crs(ji,jj,jk) 739 ENDIF 740 END DO 741 END DO 742 END DO 743 ! 744 IF( nn_timing == 1 ) CALL timing_stop('bn2') 745 ! 746 END SUBROUTINE bn2_crs 747 748 SUBROUTINE eos_init_crs 707 749 !!---------------------------------------------------------------------- 708 750 !! *** ROUTINE eos_init *** 709 751 !! 710 !! ** Purpose : Compute the sea surface freezing temperature [Celcius]711 !!712 !! ** Method : UNESCO freezing point at the surface (pressure = 0???)713 !! freezing point [Celcius]=(-.0575+1.710523e-3*sqrt(abs(s))-2.154996e-4*s)*s-7.53e-4*p714 !! checkvalue: tf= -2.588567 Celsius for s=40.0psu, p=500. decibars715 !!716 !! Reference : UNESCO tech. papers in the marine science no. 28. 1978717 !!----------------------------------------------------------------------718 REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: psal ! salinity [psu]719 ! Leave result array automatic rather than making explicitly allocated720 REAL(wp), DIMENSION(jpi,jpj) :: ptf ! freezing temperature [Celcius]721 !!----------------------------------------------------------------------722 !723 ptf(:,:) = ( - 0.0575_wp + 1.710523e-3_wp * SQRT( psal(:,:) ) &724 & - 2.154996e-4_wp * psal(:,:) ) * psal(:,:)725 !726 END FUNCTION tfreez_crs727 728 729 SUBROUTINE eos_init_crs730 !!----------------------------------------------------------------------731 !! *** ROUTINE eos_init ***732 !!733 752 !! ** Purpose : initializations for the equation of state 734 753 !! 735 754 !! ** Method : Read the namelist nameos and control the parameters 736 755 !!---------------------------------------------------------------------- 737 INTEGER :: ios ! Local integer output status for namelist read 738 !! 739 NAMELIST/nameos/ nn_eos, rn_alpha, rn_beta 740 !!---------------------------------------------------------------------- 741 ! 742 REWIND( numnam_ref ) 743 READ ( numnam_ref, nameos, IOSTAT = ios, ERR = 901) 756 INTEGER :: ios ! local integer 757 !! 758 NAMELIST/nameos/ nn_eos, ln_useCT, rn_a0, rn_b0, rn_lambda1, rn_mu1, & 759 & rn_lambda2, rn_mu2, rn_nu 760 !!---------------------------------------------------------------------- 761 ! 762 REWIND( numnam_ref ) ! Namelist nameos in reference namelist : equation of state 763 READ ( numnam_ref, nameos, IOSTAT = ios, ERR = 901 ) 744 764 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nameos in reference namelist', lwp ) 745 746 REWIND( numnam_cfg ) 765 ! 766 REWIND( numnam_cfg ) ! Namelist nameos in configuration namelist : equation of state 747 767 READ ( numnam_cfg, nameos, IOSTAT = ios, ERR = 902 ) 748 768 902 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nameos in configuration namelist', lwp ) 749 IF(lwm) WRITE ( numond, nameos ) 750 769 IF(lwm) WRITE( numond, nameos ) 770 ! 771 rau0 = 1026._wp !: volumic mass of reference [kg/m3] 772 rcp = 3991.86795711963_wp !: heat capacity [J/K] 751 773 ! 752 774 IF(lwp) THEN ! Control print … … 756 778 WRITE(numout,*) ' Namelist nameos : set eos parameters' 757 779 WRITE(numout,*) ' flag for eq. of state and N^2 nn_eos = ', nn_eos 758 WRITE(numout,*) ' thermal exp. coef. (linear) rn_alpha = ', rn_alpha 759 WRITE(numout,*) ' saline exp. coef. (linear) rn_beta = ', rn_beta 780 IF( ln_useCT ) THEN 781 WRITE(numout,*) ' model uses Conservative Temperature' 782 WRITE(numout,*) ' Important: model must be initialized with CT and SA fields' 783 ENDIF 760 784 ENDIF 761 785 ! 762 786 SELECT CASE( nn_eos ) ! check option 763 787 ! 764 CASE( 0 ) !== Jackett and McDougall (1994) formulation==!788 CASE( -1 ) !== polynomial TEOS-10 ==! 765 789 IF(lwp) WRITE(numout,*) 766 IF(lwp) WRITE(numout,*) ' use of Jackett & McDougall (1994) equation of state and' 767 IF(lwp) WRITE(numout,*) ' McDougall (1987) Brunt-Vaisala frequency' 768 ! 769 CASE( 1 ) !== Linear formulation = F( temperature ) ==! 790 IF(lwp) WRITE(numout,*) ' use of TEOS-10 equation of state (cons. temp. and abs. salinity)' 791 ! 792 rdeltaS = 32._wp 793 r1_S0 = 0.875_wp/35.16504_wp 794 r1_T0 = 1._wp/40._wp 795 r1_Z0 = 1.e-4_wp 796 ! 797 EOS000 = 8.0189615746e+02_wp 798 EOS100 = 8.6672408165e+02_wp 799 EOS200 = -1.7864682637e+03_wp 800 EOS300 = 2.0375295546e+03_wp 801 EOS400 = -1.2849161071e+03_wp 802 EOS500 = 4.3227585684e+02_wp 803 EOS600 = -6.0579916612e+01_wp 804 EOS010 = 2.6010145068e+01_wp 805 EOS110 = -6.5281885265e+01_wp 806 EOS210 = 8.1770425108e+01_wp 807 EOS310 = -5.6888046321e+01_wp 808 EOS410 = 1.7681814114e+01_wp 809 EOS510 = -1.9193502195_wp 810 EOS020 = -3.7074170417e+01_wp 811 EOS120 = 6.1548258127e+01_wp 812 EOS220 = -6.0362551501e+01_wp 813 EOS320 = 2.9130021253e+01_wp 814 EOS420 = -5.4723692739_wp 815 EOS030 = 2.1661789529e+01_wp 816 EOS130 = -3.3449108469e+01_wp 817 EOS230 = 1.9717078466e+01_wp 818 EOS330 = -3.1742946532_wp 819 EOS040 = -8.3627885467_wp 820 EOS140 = 1.1311538584e+01_wp 821 EOS240 = -5.3563304045_wp 822 EOS050 = 5.4048723791e-01_wp 823 EOS150 = 4.8169980163e-01_wp 824 EOS060 = -1.9083568888e-01_wp 825 EOS001 = 1.9681925209e+01_wp 826 EOS101 = -4.2549998214e+01_wp 827 EOS201 = 5.0774768218e+01_wp 828 EOS301 = -3.0938076334e+01_wp 829 EOS401 = 6.6051753097_wp 830 EOS011 = -1.3336301113e+01_wp 831 EOS111 = -4.4870114575_wp 832 EOS211 = 5.0042598061_wp 833 EOS311 = -6.5399043664e-01_wp 834 EOS021 = 6.7080479603_wp 835 EOS121 = 3.5063081279_wp 836 EOS221 = -1.8795372996_wp 837 EOS031 = -2.4649669534_wp 838 EOS131 = -5.5077101279e-01_wp 839 EOS041 = 5.5927935970e-01_wp 840 EOS002 = 2.0660924175_wp 841 EOS102 = -4.9527603989_wp 842 EOS202 = 2.5019633244_wp 843 EOS012 = 2.0564311499_wp 844 EOS112 = -2.1311365518e-01_wp 845 EOS022 = -1.2419983026_wp 846 EOS003 = -2.3342758797e-02_wp 847 EOS103 = -1.8507636718e-02_wp 848 EOS013 = 3.7969820455e-01_wp 849 ! 850 ALP000 = -6.5025362670e-01_wp 851 ALP100 = 1.6320471316_wp 852 ALP200 = -2.0442606277_wp 853 ALP300 = 1.4222011580_wp 854 ALP400 = -4.4204535284e-01_wp 855 ALP500 = 4.7983755487e-02_wp 856 ALP010 = 1.8537085209_wp 857 ALP110 = -3.0774129064_wp 858 ALP210 = 3.0181275751_wp 859 ALP310 = -1.4565010626_wp 860 ALP410 = 2.7361846370e-01_wp 861 ALP020 = -1.6246342147_wp 862 ALP120 = 2.5086831352_wp 863 ALP220 = -1.4787808849_wp 864 ALP320 = 2.3807209899e-01_wp 865 ALP030 = 8.3627885467e-01_wp 866 ALP130 = -1.1311538584_wp 867 ALP230 = 5.3563304045e-01_wp 868 ALP040 = -6.7560904739e-02_wp 869 ALP140 = -6.0212475204e-02_wp 870 ALP050 = 2.8625353333e-02_wp 871 ALP001 = 3.3340752782e-01_wp 872 ALP101 = 1.1217528644e-01_wp 873 ALP201 = -1.2510649515e-01_wp 874 ALP301 = 1.6349760916e-02_wp 875 ALP011 = -3.3540239802e-01_wp 876 ALP111 = -1.7531540640e-01_wp 877 ALP211 = 9.3976864981e-02_wp 878 ALP021 = 1.8487252150e-01_wp 879 ALP121 = 4.1307825959e-02_wp 880 ALP031 = -5.5927935970e-02_wp 881 ALP002 = -5.1410778748e-02_wp 882 ALP102 = 5.3278413794e-03_wp 883 ALP012 = 6.2099915132e-02_wp 884 ALP003 = -9.4924551138e-03_wp 885 ! 886 BET000 = 1.0783203594e+01_wp 887 BET100 = -4.4452095908e+01_wp 888 BET200 = 7.6048755820e+01_wp 889 BET300 = -6.3944280668e+01_wp 890 BET400 = 2.6890441098e+01_wp 891 BET500 = -4.5221697773_wp 892 BET010 = -8.1219372432e-01_wp 893 BET110 = 2.0346663041_wp 894 BET210 = -2.1232895170_wp 895 BET310 = 8.7994140485e-01_wp 896 BET410 = -1.1939638360e-01_wp 897 BET020 = 7.6574242289e-01_wp 898 BET120 = -1.5019813020_wp 899 BET220 = 1.0872489522_wp 900 BET320 = -2.7233429080e-01_wp 901 BET030 = -4.1615152308e-01_wp 902 BET130 = 4.9061350869e-01_wp 903 BET230 = -1.1847737788e-01_wp 904 BET040 = 1.4073062708e-01_wp 905 BET140 = -1.3327978879e-01_wp 906 BET050 = 5.9929880134e-03_wp 907 BET001 = -5.2937873009e-01_wp 908 BET101 = 1.2634116779_wp 909 BET201 = -1.1547328025_wp 910 BET301 = 3.2870876279e-01_wp 911 BET011 = -5.5824407214e-02_wp 912 BET111 = 1.2451933313e-01_wp 913 BET211 = -2.4409539932e-02_wp 914 BET021 = 4.3623149752e-02_wp 915 BET121 = -4.6767901790e-02_wp 916 BET031 = -6.8523260060e-03_wp 917 BET002 = -6.1618945251e-02_wp 918 BET102 = 6.2255521644e-02_wp 919 BET012 = -2.6514181169e-03_wp 920 BET003 = -2.3025968587e-04_wp 921 ! 922 PEN000 = -9.8409626043_wp 923 PEN100 = 2.1274999107e+01_wp 924 PEN200 = -2.5387384109e+01_wp 925 PEN300 = 1.5469038167e+01_wp 926 PEN400 = -3.3025876549_wp 927 PEN010 = 6.6681505563_wp 928 PEN110 = 2.2435057288_wp 929 PEN210 = -2.5021299030_wp 930 PEN310 = 3.2699521832e-01_wp 931 PEN020 = -3.3540239802_wp 932 PEN120 = -1.7531540640_wp 933 PEN220 = 9.3976864981e-01_wp 934 PEN030 = 1.2324834767_wp 935 PEN130 = 2.7538550639e-01_wp 936 PEN040 = -2.7963967985e-01_wp 937 PEN001 = -1.3773949450_wp 938 PEN101 = 3.3018402659_wp 939 PEN201 = -1.6679755496_wp 940 PEN011 = -1.3709540999_wp 941 PEN111 = 1.4207577012e-01_wp 942 PEN021 = 8.2799886843e-01_wp 943 PEN002 = 1.7507069098e-02_wp 944 PEN102 = 1.3880727538e-02_wp 945 PEN012 = -2.8477365341e-01_wp 946 ! 947 APE000 = -1.6670376391e-01_wp 948 APE100 = -5.6087643219e-02_wp 949 APE200 = 6.2553247576e-02_wp 950 APE300 = -8.1748804580e-03_wp 951 APE010 = 1.6770119901e-01_wp 952 APE110 = 8.7657703198e-02_wp 953 APE210 = -4.6988432490e-02_wp 954 APE020 = -9.2436260751e-02_wp 955 APE120 = -2.0653912979e-02_wp 956 APE030 = 2.7963967985e-02_wp 957 APE001 = 3.4273852498e-02_wp 958 APE101 = -3.5518942529e-03_wp 959 APE011 = -4.1399943421e-02_wp 960 APE002 = 7.1193413354e-03_wp 961 ! 962 BPE000 = 2.6468936504e-01_wp 963 BPE100 = -6.3170583896e-01_wp 964 BPE200 = 5.7736640125e-01_wp 965 BPE300 = -1.6435438140e-01_wp 966 BPE010 = 2.7912203607e-02_wp 967 BPE110 = -6.2259666565e-02_wp 968 BPE210 = 1.2204769966e-02_wp 969 BPE020 = -2.1811574876e-02_wp 970 BPE120 = 2.3383950895e-02_wp 971 BPE030 = 3.4261630030e-03_wp 972 BPE001 = 4.1079296834e-02_wp 973 BPE101 = -4.1503681096e-02_wp 974 BPE011 = 1.7676120780e-03_wp 975 BPE002 = 1.7269476440e-04_wp 976 ! 977 CASE( 0 ) !== polynomial EOS-80 formulation ==! 978 ! 770 979 IF(lwp) WRITE(numout,*) 771 IF(lwp) WRITE(numout,*) ' use of linear eos rho(T) = rau0 * ( 1.0285 - rn_alpha * T )' 772 IF( lk_zdfddm ) CALL ctl_stop( ' double diffusive mixing parameterization requires', & 773 & ' that T and S are used as state variables' ) 774 ! 775 CASE( 2 ) !== Linear formulation = F( temperature , salinity ) ==! 776 ralpbet_crs = rn_alpha / rn_beta 777 IF(lwp) WRITE(numout,*) 778 IF(lwp) WRITE(numout,*) ' use of linear eos rho(T,S) = rau0 * ( rn_beta * S - rn_alpha * T )' 980 IF(lwp) WRITE(numout,*) ' use of EOS-80 equation of state (pot. temp. and pract. salinity)' 981 ! 982 rdeltaS = 20._wp 983 r1_S0 = 1._wp/40._wp 984 r1_T0 = 1._wp/40._wp 985 r1_Z0 = 1.e-4_wp 986 ! 987 EOS000 = 9.5356891948e+02_wp 988 EOS100 = 1.7136499189e+02_wp 989 EOS200 = -3.7501039454e+02_wp 990 EOS300 = 5.1856810420e+02_wp 991 EOS400 = -3.7264470465e+02_wp 992 EOS500 = 1.4302533998e+02_wp 993 EOS600 = -2.2856621162e+01_wp 994 EOS010 = 1.0087518651e+01_wp 995 EOS110 = -1.3647741861e+01_wp 996 EOS210 = 8.8478359933_wp 997 EOS310 = -7.2329388377_wp 998 EOS410 = 1.4774410611_wp 999 EOS510 = 2.0036720553e-01_wp 1000 EOS020 = -2.5579830599e+01_wp 1001 EOS120 = 2.4043512327e+01_wp 1002 EOS220 = -1.6807503990e+01_wp 1003 EOS320 = 8.3811577084_wp 1004 EOS420 = -1.9771060192_wp 1005 EOS030 = 1.6846451198e+01_wp 1006 EOS130 = -2.1482926901e+01_wp 1007 EOS230 = 1.0108954054e+01_wp 1008 EOS330 = -6.2675951440e-01_wp 1009 EOS040 = -8.0812310102_wp 1010 EOS140 = 1.0102374985e+01_wp 1011 EOS240 = -4.8340368631_wp 1012 EOS050 = 1.2079167803_wp 1013 EOS150 = 1.1515380987e-01_wp 1014 EOS060 = -2.4520288837e-01_wp 1015 EOS001 = 1.0748601068e+01_wp 1016 EOS101 = -1.7817043500e+01_wp 1017 EOS201 = 2.2181366768e+01_wp 1018 EOS301 = -1.6750916338e+01_wp 1019 EOS401 = 4.1202230403_wp 1020 EOS011 = -1.5852644587e+01_wp 1021 EOS111 = -7.6639383522e-01_wp 1022 EOS211 = 4.1144627302_wp 1023 EOS311 = -6.6955877448e-01_wp 1024 EOS021 = 9.9994861860_wp 1025 EOS121 = -1.9467067787e-01_wp 1026 EOS221 = -1.2177554330_wp 1027 EOS031 = -3.4866102017_wp 1028 EOS131 = 2.2229155620e-01_wp 1029 EOS041 = 5.9503008642e-01_wp 1030 EOS002 = 1.0375676547_wp 1031 EOS102 = -3.4249470629_wp 1032 EOS202 = 2.0542026429_wp 1033 EOS012 = 2.1836324814_wp 1034 EOS112 = -3.4453674320e-01_wp 1035 EOS022 = -1.2548163097_wp 1036 EOS003 = 1.8729078427e-02_wp 1037 EOS103 = -5.7238495240e-02_wp 1038 EOS013 = 3.8306136687e-01_wp 1039 ! 1040 ALP000 = -2.5218796628e-01_wp 1041 ALP100 = 3.4119354654e-01_wp 1042 ALP200 = -2.2119589983e-01_wp 1043 ALP300 = 1.8082347094e-01_wp 1044 ALP400 = -3.6936026529e-02_wp 1045 ALP500 = -5.0091801383e-03_wp 1046 ALP010 = 1.2789915300_wp 1047 ALP110 = -1.2021756164_wp 1048 ALP210 = 8.4037519952e-01_wp 1049 ALP310 = -4.1905788542e-01_wp 1050 ALP410 = 9.8855300959e-02_wp 1051 ALP020 = -1.2634838399_wp 1052 ALP120 = 1.6112195176_wp 1053 ALP220 = -7.5817155402e-01_wp 1054 ALP320 = 4.7006963580e-02_wp 1055 ALP030 = 8.0812310102e-01_wp 1056 ALP130 = -1.0102374985_wp 1057 ALP230 = 4.8340368631e-01_wp 1058 ALP040 = -1.5098959754e-01_wp 1059 ALP140 = -1.4394226233e-02_wp 1060 ALP050 = 3.6780433255e-02_wp 1061 ALP001 = 3.9631611467e-01_wp 1062 ALP101 = 1.9159845880e-02_wp 1063 ALP201 = -1.0286156825e-01_wp 1064 ALP301 = 1.6738969362e-02_wp 1065 ALP011 = -4.9997430930e-01_wp 1066 ALP111 = 9.7335338937e-03_wp 1067 ALP211 = 6.0887771651e-02_wp 1068 ALP021 = 2.6149576513e-01_wp 1069 ALP121 = -1.6671866715e-02_wp 1070 ALP031 = -5.9503008642e-02_wp 1071 ALP002 = -5.4590812035e-02_wp 1072 ALP102 = 8.6134185799e-03_wp 1073 ALP012 = 6.2740815484e-02_wp 1074 ALP003 = -9.5765341718e-03_wp 1075 ! 1076 BET000 = 2.1420623987_wp 1077 BET100 = -9.3752598635_wp 1078 BET200 = 1.9446303907e+01_wp 1079 BET300 = -1.8632235232e+01_wp 1080 BET400 = 8.9390837485_wp 1081 BET500 = -1.7142465871_wp 1082 BET010 = -1.7059677327e-01_wp 1083 BET110 = 2.2119589983e-01_wp 1084 BET210 = -2.7123520642e-01_wp 1085 BET310 = 7.3872053057e-02_wp 1086 BET410 = 1.2522950346e-02_wp 1087 BET020 = 3.0054390409e-01_wp 1088 BET120 = -4.2018759976e-01_wp 1089 BET220 = 3.1429341406e-01_wp 1090 BET320 = -9.8855300959e-02_wp 1091 BET030 = -2.6853658626e-01_wp 1092 BET130 = 2.5272385134e-01_wp 1093 BET230 = -2.3503481790e-02_wp 1094 BET040 = 1.2627968731e-01_wp 1095 BET140 = -1.2085092158e-01_wp 1096 BET050 = 1.4394226233e-03_wp 1097 BET001 = -2.2271304375e-01_wp 1098 BET101 = 5.5453416919e-01_wp 1099 BET201 = -6.2815936268e-01_wp 1100 BET301 = 2.0601115202e-01_wp 1101 BET011 = -9.5799229402e-03_wp 1102 BET111 = 1.0286156825e-01_wp 1103 BET211 = -2.5108454043e-02_wp 1104 BET021 = -2.4333834734e-03_wp 1105 BET121 = -3.0443885826e-02_wp 1106 BET031 = 2.7786444526e-03_wp 1107 BET002 = -4.2811838287e-02_wp 1108 BET102 = 5.1355066072e-02_wp 1109 BET012 = -4.3067092900e-03_wp 1110 BET003 = -7.1548119050e-04_wp 1111 ! 1112 PEN000 = -5.3743005340_wp 1113 PEN100 = 8.9085217499_wp 1114 PEN200 = -1.1090683384e+01_wp 1115 PEN300 = 8.3754581690_wp 1116 PEN400 = -2.0601115202_wp 1117 PEN010 = 7.9263222935_wp 1118 PEN110 = 3.8319691761e-01_wp 1119 PEN210 = -2.0572313651_wp 1120 PEN310 = 3.3477938724e-01_wp 1121 PEN020 = -4.9997430930_wp 1122 PEN120 = 9.7335338937e-02_wp 1123 PEN220 = 6.0887771651e-01_wp 1124 PEN030 = 1.7433051009_wp 1125 PEN130 = -1.1114577810e-01_wp 1126 PEN040 = -2.9751504321e-01_wp 1127 PEN001 = -6.9171176978e-01_wp 1128 PEN101 = 2.2832980419_wp 1129 PEN201 = -1.3694684286_wp 1130 PEN011 = -1.4557549876_wp 1131 PEN111 = 2.2969116213e-01_wp 1132 PEN021 = 8.3654420645e-01_wp 1133 PEN002 = -1.4046808820e-02_wp 1134 PEN102 = 4.2928871430e-02_wp 1135 PEN012 = -2.8729602515e-01_wp 1136 ! 1137 APE000 = -1.9815805734e-01_wp 1138 APE100 = -9.5799229402e-03_wp 1139 APE200 = 5.1430784127e-02_wp 1140 APE300 = -8.3694846809e-03_wp 1141 APE010 = 2.4998715465e-01_wp 1142 APE110 = -4.8667669469e-03_wp 1143 APE210 = -3.0443885826e-02_wp 1144 APE020 = -1.3074788257e-01_wp 1145 APE120 = 8.3359333577e-03_wp 1146 APE030 = 2.9751504321e-02_wp 1147 APE001 = 3.6393874690e-02_wp 1148 APE101 = -5.7422790533e-03_wp 1149 APE011 = -4.1827210323e-02_wp 1150 APE002 = 7.1824006288e-03_wp 1151 ! 1152 BPE000 = 1.1135652187e-01_wp 1153 BPE100 = -2.7726708459e-01_wp 1154 BPE200 = 3.1407968134e-01_wp 1155 BPE300 = -1.0300557601e-01_wp 1156 BPE010 = 4.7899614701e-03_wp 1157 BPE110 = -5.1430784127e-02_wp 1158 BPE210 = 1.2554227021e-02_wp 1159 BPE020 = 1.2166917367e-03_wp 1160 BPE120 = 1.5221942913e-02_wp 1161 BPE030 = -1.3893222263e-03_wp 1162 BPE001 = 2.8541225524e-02_wp 1163 BPE101 = -3.4236710714e-02_wp 1164 BPE011 = 2.8711395266e-03_wp 1165 BPE002 = 5.3661089288e-04_wp 1166 ! 1167 CASE( 1 ) !== Simplified EOS ==! 1168 IF(lwp) THEN 1169 WRITE(numout,*) 1170 WRITE(numout,*) ' use of simplified eos: rhd(dT=T-10,dS=S-35,Z) = ' 1171 WRITE(numout,*) ' [-a0*(1+lambda1/2*dT+mu1*Z)*dT + b0*(1+lambda2/2*dT+mu2*Z)*dS - nu*dT*dS]/rau0' 1172 WRITE(numout,*) 1173 WRITE(numout,*) ' thermal exp. coef. rn_a0 = ', rn_a0 1174 WRITE(numout,*) ' saline cont. coef. rn_b0 = ', rn_b0 1175 WRITE(numout,*) ' cabbeling coef. rn_lambda1 = ', rn_lambda1 1176 WRITE(numout,*) ' cabbeling coef. rn_lambda2 = ', rn_lambda2 1177 WRITE(numout,*) ' thermobar. coef. rn_mu1 = ', rn_mu1 1178 WRITE(numout,*) ' thermobar. coef. rn_mu2 = ', rn_mu2 1179 WRITE(numout,*) ' 2nd cabbel. coef. rn_nu = ', rn_nu 1180 WRITE(numout,*) ' Caution: rn_beta0=0 incompatible with ddm parameterization ' 1181 ENDIF 779 1182 ! 780 1183 CASE DEFAULT !== ERROR in nn_eos ==! … … 784 1187 END SELECT 785 1188 ! 1189 r1_rau0 = 1._wp / rau0 1190 r1_rcp = 1._wp / rcp 1191 r1_rau0_rcp = 1._wp / ( rau0 * rcp ) 1192 ! 1193 IF(lwp) WRITE(numout,*) 1194 IF(lwp) WRITE(numout,*) ' volumic mass of reference rau0 = ', rau0 , ' kg/m^3' 1195 IF(lwp) WRITE(numout,*) ' 1. / rau0 r1_rau0 = ', r1_rau0, ' m^3/kg' 1196 IF(lwp) WRITE(numout,*) ' ocean specific heat rcp = ', rcp , ' J/Kelvin' 1197 IF(lwp) WRITE(numout,*) ' 1. / ( rau0 * rcp ) r1_rau0_rcp = ', r1_rau0_rcp 1198 ! 786 1199 END SUBROUTINE eos_init_crs 787 1200 -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/TRA/traadv_tvd_crs.F90
r5105 r5601 24 24 USE oce ! ocean dynamics and active tracers 25 25 USE dom_oce , ONLY : lk_vvl 26 USE trd mod_oce! tracers trends26 USE trd_oce ! tracers trends 27 27 USE trdtra ! tracers trends 28 28 USE in_out_manager ! I/O manager … … 123 123 ! 2. upstream advection with initial mass fluxes & intermediate update 124 124 ! -------------------------------------------------------------------- 125 !DO jk = 2, jpkm1 ! Interior value126 ! DO jj = 1, jpj127 ! DO ji = 1, jpi128 ! IF( ptb(ji,jj,jk,jn) .NE. ptb(ji,jj,jk,jn) )WRITE(narea+200,*)"ADVtb",ptb(ji,jj,jk,jn) ; call flush(narea+200)129 ! IF( ptn(ji,jj,jk,jn) .NE. ptn(ji,jj,jk,jn) )WRITE(narea+200,*)"ADVtn",ptb(ji,jj,jk,jn) ; call flush(narea+200)130 ! IF( pun(ji,jj,jk) .NE. pun(ji,jj,jk) )WRITE(narea+200,*)"ADVun",pun(ji,jj,jk) ; call flush(narea+200)131 ! IF( pvn(ji,jj,jk) .NE. pvn(ji,jj,jk) )WRITE(narea+200,*)"ADVvn",pvn(ji,jj,jk) ; call flush(narea+200)132 ! IF( pwn(ji,jj,jk) .NE. pwn(ji,jj,jk) )WRITE(narea+200,*)"ADVwn",pwn(ji,jj,jk) ; call flush(narea+200)133 ! END DO134 ! END DO135 ! END DO136 ! ji=117 ; jj=211 ; jk=74137 ! ji=ji-nimpp_crs+1 ; jj=jj-njmpp_crs+1138 ! IF( ji .GE. 2 .AND. ji .LE. jpi_crs-1 .AND. jj .GE. 2 .AND. jj .LE. jpj_crs-1 )THEN139 ! WRITE(narea+5000,*)"tvd =======> kt ",kt140 ! WRITE(narea+5000,*)ptb(ji,jj,jk,jn),ptn(ji,jj,jk,jn)141 ! WRITE(narea+5000,*)pun(ji-1,jj,jk),pun(ji,jj,jk)142 ! WRITE(narea+5000,*)pvn(ji,jj-1,jk),pun(ji,jj,jk)143 ! WRITE(narea+5000,*)pwn(ji,jj,jk),pwn(ji,jj,jk+1)144 ! ENDIF145 125 146 126 ! upstream tracer flux in the i and j direction … … 173 153 END DO 174 154 END DO 175 !WRITE(numout,*) 'test_tra', maxval(pta(:,:,:,1)) , kt176 !WRITE(numout,*) 'test_tra', minval(pta(:,:,:,1)) , kt177 155 ! total advective trend 178 156 DO jk = 1, jpkm1 … … 188 166 pta(ji,jj,jk,jn) = pta(ji,jj,jk,jn) + ztra 189 167 zwi(ji,jj,jk) = ( ptb(ji,jj,jk,jn) + z2dtt * ztra ) * tmask_crs(ji,jj,jk) 190 !iji=117 ; ijj=211 ; ijk=74 191 !iji=iji-nimpp+1 ; ijj=ijj-njmpp+1 192 !IF( ji==iji .AND. jj==ijj )THEN 193 !WRITE(narea+5000,*)"test ",jk,zwx(ji,jj,jk) , zwx(ji-1,jj ,jk ), & 194 ! zwy(ji,jj,jk) , zwy(ji ,jj-1,jk ),zwz(ji,jj,jk),zwz(ji ,jj ,jk+1) 195 !ENDIF 196 !IF( ztra .NE. 0._wp )WRITE(narea+6000,*)"buga ",kt,ji,jj,jk,mbathy_crs(ji,jj), & 197 ! zwx(ji,jj,jk) , zwx(ji-1,jj ,jk ),zwy(ji,jj,jk) , zwy(ji ,jj-1,jk ),zwz(ji,jj,jk),zwz(ji ,jj ,jk+1) 198 END DO 199 END DO 200 END DO 201 !IF(narea==267)WRITE(narea+5000,*)"1 pta(17,6,74,1) = ",pta(17,6,74,1) 202 !zmin=MINVAL( pta(2:jpi-1,2:jpj-1,2:jpk,1),mask=(tmask(2:jpi-1,2:jpj-1,2:jpk)==1)) ; CALL mpp_min(zmin) 203 !zmax=MAXVAL( pta(2:jpi-1,2:jpj-1,2:jpk,1),mask=(tmask(2:jpi-1,2:jpj-1,2:jpk)==1)) ; CALL mpp_max(zmax) 204 !IF(lwp)WRITE(numout,*)"trcadvtvdcrs a ",kt,zmin,zmax 205 206 !WRITE(numout,*) 'test_tra', maxval(pta(:,:,:,jk)) , kt 207 !WRITE(numout,*) 'test_tra', minval(pta(:,:,:,jk)) , kt 168 END DO 169 END DO 170 END DO 208 171 ! ! Lateral boundary conditions on zwi (unchanged sign) 209 172 CALL crs_lbc_lnk( zwi, 'T', 1. ) … … 226 189 DO jj = 1, jpjm1 227 190 DO ji = 1, fs_jpim1 ! vector opt. 228 !iji=117 ; ijj=211 ; ijk=74229 !iji=iji-nimpp+1 ; ijj=ijj-njmpp+1230 !IF( ji==iji .AND. jj==ijj )THEN231 !WRITE(narea+5000,*)"antidiffxy ",jk,pun(ji,jj,jk),ptn(ji,jj,jk,jn),ptn(ji+1,jj,jk,jn),zwx(ji,jj,jk)232 !WRITE(narea+5000,*)"antidiffxy ",jk,pvn(ji,jj,jk),ptn(ji,jj,jk,jn),ptn(ji,jj+1,jk,jn),zwy(ji,jj,jk)233 !ENDIF234 191 zwx(ji,jj,jk) = 0.5 * pun(ji,jj,jk) * ( ptn(ji,jj,jk,jn) + ptn(ji+1,jj,jk,jn) ) - zwx(ji,jj,jk) 235 192 zwy(ji,jj,jk) = 0.5 * pvn(ji,jj,jk) * ( ptn(ji,jj,jk,jn) + ptn(ji,jj+1,jk,jn) ) - zwy(ji,jj,jk) 236 !iji=117 ; ijj=211 ; ijk=74 237 !iji=iji-nimpp+1 ; ijj=ijj-njmpp+1 238 !IF( ji==iji .AND. jj==ijj )THEN 239 !WRITE(narea+5000,*)"antidiffxy ",jk,zwx(ji,jj,jk),zwy(ji,jj,jk) 240 !ENDIF 241 END DO 242 END DO 243 END DO 244 ! WRITE(numout,*) 'test6456_trb_sbc', pta(10,10,1,1), kt 193 END DO 194 END DO 195 END DO 245 196 ! antidiffusive flux on k 246 197 zwz(:,:,1) = 0.e0 ! Surface value … … 250 201 DO ji = 1, jpi 251 202 zwz(ji,jj,jk) = 0.5 * pwn(ji,jj,jk) * ( ptn(ji,jj,jk,jn) + ptn(ji,jj,jk-1,jn) ) - zwz(ji,jj,jk) 252 !iji=117 ; ijj=211 ; ijk=74253 !iji=iji-nimpp+1 ; ijj=ijj-njmpp+1254 !IF( ji==iji .AND. jj==ijj )THEN255 !WRITE(narea+5000,*)"antidiffz ",jk,zwz(ji,jj,jk)256 !ENDIF257 203 END DO 258 204 END DO … … 263 209 ! 4. monotonicity algorithm 264 210 ! ------------------------- 265 !DO jk = 2, jpkm1 ! Interior value266 ! DO jj = 1, jpj267 ! DO ji = 1, jpi268 ! IF( ptb(ji,jj,jk,jn) .NE. ptb(ji,jj,jk,jn) )WRITE(narea+200,*)"ADV1",ptb(ji,jj,jk,jn) ; call flush(narea+200)269 ! IF( zwx(ji,jj,jk) .NE. zwx(ji,jj,jk) )WRITE(narea+200,*)"ADV2",zwx(ji,jj,jk) ; call flush(narea+200)270 ! IF( zwy(ji,jj,jk) .NE. zwy(ji,jj,jk) )WRITE(narea+200,*)"ADV3",zwy(ji,jj,jk) ; call flush(narea+200)271 ! IF( zwz(ji,jj,jk) .NE. zwz(ji,jj,jk) )WRITE(narea+200,*)"ADV4",zwz(ji,jj,jk) ; call flush(narea+200)272 ! IF( zwi(ji,jj,jk) .NE. zwi(ji,jj,jk) )WRITE(narea+200,*)"ADV5",zwi(ji,jj,jk) ; call flush(narea+200)273 ! IF( tmask_crs(ji,jj,jk) .NE. tmask_crs(ji,jj,jk) )WRITE(narea+200,*)"ADV6",tmask_crs(ji,jj,jk) ; call flush(narea+200)274 ! END DO275 ! END DO276 !END DO277 278 211 CALL nonosc_crs( ptb(:,:,:,jn), zwx, zwy, zwz, zwi, p2dt ) 279 280 !IF( narea==267 )THEN281 !DO jk=1,jpk-1282 !WRITE(narea+5000,*)"toto",jk,zwx(16,6,jk),zwx(17,6,jk),zwy(17,5,jk),zwy(17,6,jk),zwz(17,6,jk),zwz(17,6,jk+1)283 !ENDDO284 !ENDIF285 212 286 213 ! 5. final trend with corrected fluxes … … 298 225 299 226 300 !IF( narea==267 .AND. ji==17 .AND. jj==6 )THEN 301 !WRITE(narea+5000,*)"correc ",jk,ptb(ji,jj,jk,1),pta(ji,jj,jk,1),zwx(ji,jj,jk) , zwx(ji-1,jj ,jk ), & 302 ! zwy(ji,jj,jk) , zwy(ji ,jj-1,jk ),zwz(ji,jj,jk),zwz(ji ,jj ,jk+1) 303 !ENDIF 304 305 306 !IF( ztra .NE. 0._wp )WRITE(narea+6000,*)"bugb ",kt,ji,jj,jk,mbathy_crs(ji,jj), & 307 ! zwx(ji,jj,jk) , zwx(ji-1,jj ,jk ),zwy(ji,jj,jk) , zwy(ji ,jj-1,jk ),zwz(ji,jj,jk),zwz(ji ,jj ,jk+1) 308 END DO 309 END DO 310 END DO 311 !IF(narea==267)WRITE(narea+5000,*)"2 pta(17,6,74,1) = ",pta(17,6,74,1) 312 !zmin=MINVAL( pta(2:jpi-1,2:jpj-1,2:jpk,1),mask=(tmask(2:jpi-1,2:jpj-1,2:jpk)==1)) ; CALL mpp_min(zmin) 313 !zmax=MAXVAL( pta(2:jpi-1,2:jpj-1,2:jpk,1),mask=(tmask(2:jpi-1,2:jpj-1,2:jpk)==1)) ; CALL mpp_max(zmax) 314 !IF(lwp)WRITE(numout,*)"trcadvtvdcrs b ",kt,zmin,zmax 315 316 !WRITE(numout,*) 'test_tra', maxval(pta(:,:,:,jk)) , kt 317 !WRITE(numout,*) 'test_tra', minval(pta(:,:,:,jk)) , kt 318 !WRITE(numout,*) 'test6456_trb_sbc', pta(10,10,1,1), kt 227 END DO 228 END DO 229 END DO 230 319 231 ! ! trend diagnostics (contribution of upstream fluxes) 320 232 IF( l_trd ) THEN … … 323 235 ztrdz(:,:,:) = ztrdz(:,:,:) + zwz(:,:,:) ! <<< Add to previously computed 324 236 325 CALL trd_tra( kt, cdtype, jn, jptra_ trd_xad, ztrdx, pun, ptn(:,:,:,jn) )326 CALL trd_tra( kt, cdtype, jn, jptra_ trd_yad, ztrdy, pvn, ptn(:,:,:,jn) )327 CALL trd_tra( kt, cdtype, jn, jptra_ trd_zad, ztrdz, pwn, ptn(:,:,:,jn) )237 CALL trd_tra( kt, cdtype, jn, jptra_xad, ztrdx, pun, ptn(:,:,:,jn) ) 238 CALL trd_tra( kt, cdtype, jn, jptra_yad, ztrdy, pvn, ptn(:,:,:,jn) ) 239 CALL trd_tra( kt, cdtype, jn, jptra_zad, ztrdz, pwn, ptn(:,:,:,jn) ) 328 240 END IF 329 241 ! ! "Poleward" heat and salt transports (contribution of upstream fluxes) … … 339 251 ! 340 252 IF( nn_timing == 1 ) CALL timing_stop('tra_adv_tvd') 341 ! IF(lwp) WRITE(numout,*) 'TEST2', pta342 !WRITE(numout,*) 'test6456_trb_sbc', pta(10,10,1,1), kt343 253 ! 344 254 END SUBROUTINE tra_adv_tvd_crs … … 434 344 zbu = MIN( 1.e0, zbetup(ji,jj,jk), zbetdo(ji+1,jj,jk) ) 435 345 zcu = ( 0.5 + SIGN( 0.5 , paa(ji,jj,jk) ) ) 436 !IF( narea==267 .AND. ji==17 .AND. jj==6 )THEN437 ! WRITE(narea+5000,*)"nonosc ",jk438 ! WRITE(narea+5000,*)"paa",zbetdo(ji,jj,jk),zbetup(ji+1,jj,jk),zbetup(ji,jj,jk),zbetdo(ji+1,jj,jk)439 ! WRITE(narea+5000,*)"paa",zau,zbu,zcu, paa(ji,jj,jk)440 !ENDIF441 346 paa(ji,jj,jk) = paa(ji,jj,jk) * ( zcu * zau + ( 1.e0 - zcu) * zbu ) 442 !IF( narea==267 .AND. ji==17 .AND. jj==6 )WRITE(narea+5000,*)"paa",paa(ji,jj,jk)443 347 444 348 zav = MIN( 1.e0, zbetdo(ji,jj,jk), zbetup(ji,jj+1,jk) ) 445 349 zbv = MIN( 1.e0, zbetup(ji,jj,jk), zbetdo(ji,jj+1,jk) ) 446 350 zcv = ( 0.5 + SIGN( 0.5 , pbb(ji,jj,jk) ) ) 447 !IF( narea==267 .AND. ji==17 .AND. jj==6 )THEN448 ! WRITE(narea+5000,*)"pbb",zbetdo(ji,jj,jk),zbetup(ji,jj+1,jk),zbetup(ji,jj,jk),zbetdo(ji,jj+1,jk)449 ! WRITE(narea+5000,*)"pbb",zav,zbv,zcv, pbb(ji,jj,jk)450 !ENDIF451 351 pbb(ji,jj,jk) = pbb(ji,jj,jk) * ( zcv * zav + ( 1.e0 - zcv) * zbv ) 452 !IF( narea==267 .AND. ji==17 .AND. jj==6 )WRITE(narea+5000,*)"pbb",pbb(ji,jj,jk)453 352 454 353 ! monotonic flux in the k direction, i.e. pcc … … 457 356 zb = MIN( 1., zbetup(ji,jj,jk+1), zbetdo(ji,jj,jk) ) 458 357 zc = ( 0.5 + SIGN( 0.5 , pcc(ji,jj,jk+1) ) ) 459 !IF( narea==267 .AND. ji==17 .AND. jj==6 )THEN460 ! WRITE(narea+5000,*)"pcc",zbetdo(ji,jj,jk+1),zbetup(ji,jj,jk),zbetup(ji,jj,jk+1),zbetdo(ji,jj,jk)461 ! WRITE(narea+5000,*)"pcc",za,zb,zc, pcc(ji,jj,jk+1)462 !ENDIF463 358 pcc(ji,jj,jk+1) = pcc(ji,jj,jk+1) * ( zc * za + ( 1.e0 - zc) * zb ) 464 !IF( narea==267 .AND. ji==17 .AND. jj==6 )WRITE(narea+5000,*)"pcc",pcc(ji,jj,jk+1)465 359 END DO 466 360 END DO 467 361 END DO 468 362 469 !IF( narea==267 )THEN470 !DO jk=1,jpk-1471 !WRITE(narea+5000,*)"nono",jk,paa(16,6,jk),paa(17,6,jk),pbb(17,5,jk),pbb(17,6,jk),pcc(17,6,jk),pcc(17,6,jk+1)472 !ENDDO473 !ENDIF474 475 363 CALL crs_lbc_lnk( paa, 'U', -1. ) ; CALL crs_lbc_lnk( pbb, 'V', -1. ) ! lateral boundary condition (changed sign) 476 !IF( narea==267 )THEN477 !DO jk=1,jpk-1478 !WRITE(narea+5000,*)"nono1",jk,paa(16,6,jk),paa(17,6,jk),pbb(17,5,jk),pbb(17,6,jk),pcc(17,6,jk),pcc(17,6,jk+1)479 !!ENDDO480 !ENDIF481 364 ! 482 365 CALL wrk_dealloc( jpi, jpj, jpk, zbetup, zbetdo, zbup, zbdo ) -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/TRA/trabbl_crs.F90
r5105 r5601 28 28 USE phycst ! physical constant 29 29 USE eosbn2_crs ! equation of state 30 USE trd mod_oce! trends: ocean variables30 USE trd_oce ! trends: ocean variables 31 31 USE trdtra ! trends: active tracers 32 32 USE iom ! IOM server … … 38 38 USE crs 39 39 USE crslbclnk 40 USE crs iom40 USE crsfld 41 41 42 42 … … 154 154 ztrdt(:,:,:) = tsa_crs(:,:,:,jp_tem) - ztrdt(:,:,:) 155 155 ztrds(:,:,:) = tsa_crs(:,:,:,jp_sal) - ztrds(:,:,:) 156 CALL trd_tra( kt, 'TRA', jp_tem, jptra_ trd_bbl, ztrdt )157 CALL trd_tra( kt, 'TRA', jp_sal, jptra_ trd_bbl, ztrds )156 CALL trd_tra( kt, 'TRA', jp_tem, jptra_bbl, ztrdt ) 157 CALL trd_tra( kt, 'TRA', jp_sal, jptra_bbl, ztrds ) 158 158 CALL wrk_dealloc( jpi, jpj, jpk, ztrdt, ztrds ) 159 159 ENDIF -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/TRA/traldf_iso_crs.F90
r5105 r5601 19 19 !! the isopycnal or geopotential s-coord. operator 20 20 !!---------------------------------------------------------------------- 21 USE oce ! ocean dynamics and active tracers22 USE dom_oce ! ocean space and time domain23 USE trc_oce ! share passive tracers/Ocean variables24 USE zdf_oce ! ocean vertical physics25 USE ldftra_oce ! ocean active tracers: lateral physics26 !USE ldfslp ! iso-neutral slopes21 ! USE oce ! ocean dynamics and active tracers 22 ! USE dom_oce ! ocean space and time domain 23 ! USE trc_oce ! share passive tracers/Ocean variables 24 ! USE zdf_oce ! ocean vertical physics 25 ! USE ldftra_oce ! ocean active tracers: lateral physics 26 ! USE ldfslp ! iso-neutral slopes 27 27 USE ldfslp_crs ! iso-neutral slopes 28 28 USE diaptr ! poleward transport diagnostics … … 35 35 USE wrk_nemo ! Memory Allocation 36 36 USE timing ! Timing 37 USE crs 37 ! USE crs 38 USE oce_trc 39 USE iom, ONLY : iom_put,iom_swap 38 40 39 41 IMPLICIT NONE … … 94 96 !! ** Action : Update pta arrays with the before rotated diffusion 95 97 !!---------------------------------------------------------------------- 96 USE oce , ONLY: zftu => ua , zftv => va ! (ua,va) used as workspace97 98 ! 98 99 INTEGER , INTENT(in ) :: kt ! ocean time-step index … … 113 114 #endif 114 115 REAL(wp), POINTER, DIMENSION(:,: ) :: zdkt, zdk1t, z2d 115 REAL(wp), POINTER, DIMENSION(:,:,:) :: zdit, zdjt, ztfw 116 REAL(wp), POINTER, DIMENSION(:,:,:) :: zdit, zdjt, ztfw , zftu, zftv 116 117 !!---------------------------------------------------------------------- 117 118 ! … … 119 120 ! 120 121 CALL wrk_alloc( jpi, jpj, zdkt, zdk1t, z2d ) 121 CALL wrk_alloc( jpi, jpj, jpk, zdit, zdjt, ztfw )122 CALL wrk_alloc( jpi, jpj, jpk, zdit, zdjt, ztfw , zftu, zftv ) 122 123 ! 123 124 … … 149 150 END DO 150 151 END DO 151 ! WRITE(numout,*) ' test1 ', zdit152 !cc commenté pour le test concluant de TMP16 --> pgu mauvais, correction dans153 !zpshde_crs ( probleme de signe lorsque ze3wu negatif, de mem pour pgv)154 152 IF( ln_zps ) THEN ! partial steps correction at the last ocean level 155 153 DO jj = 1, jpjm1 … … 160 158 END DO 161 159 ENDIF 162 !cc163 ! WRITE(numout,*) ' test2 ', zdit164 160 165 161 !!---------------------------------------------------------------------- … … 183 179 DO jj = 1 , jpjm1 184 180 DO ji = 1, fs_jpim1 ! vector opt. 185 ! zabe1 = ( fsahtu(ji,jj,jk) + pahtb0 ) * e2e3u_msk(ji,jj,jk) / e1u_crs(ji,jj) 186 zabe1 = ( fsahtu(ji,jj,jk) + pahtb0 ) * e2e3u_msk(ji,jj,jk) / e1u_crs(ji,jj) 187 ! zabe2 = ( fsahtv(ji,jj,jk) + pahtb0 ) * e1e3v_msk(ji,jj,jk) / e2v_crs(ji,jj) 188 zabe2 = ( fsahtv(ji,jj,jk) + pahtb0 ) * e1e3v_msk(ji,jj,jk) / e2v_crs(ji,jj) 181 zabe1 = ( fsahtu(ji,jj,jk) + pahtb0 ) * e2e3u_msk(ji,jj,jk) / e1u_crs(ji,jj) 182 zabe2 = ( fsahtv(ji,jj,jk) + pahtb0 ) * e1e3v_msk(ji,jj,jk) / e2v_crs(ji,jj) 189 183 190 184 zmsku = 1. / MAX( tmask_crs(ji+1,jj,jk ) + tmask_crs(ji,jj,jk+1) & … … 194 188 & + tmask_crs(ji,jj+1,jk+1) + tmask_crs(ji,jj,jk ), 1. ) 195 189 ! 196 ! zcof1 = - fsahtu(ji,jj,jk) * e2e3u_msk(ji,jj,jk) * uslp_crs(ji,jj,jk) * zmsku / MAX( 1._wp , e3u_max_crs(ji,jj,jk)) vue avec Gurvan OK 197 zcof1 = - fsahtu(ji,jj,jk) * e2e3u_msk(ji,jj,jk) * uslp_crs(ji,jj,jk) * zmsku / MAX( 1._wp , e3u_max_crs(ji,jj,jk)) 198 ! zcof2 = - fsahtv(ji,jj,jk) * e1e3v_msk(ji,jj,jk) * vslp_crs(ji,jj,jk) * zmskv / MAX( 1._wp , e3v_max_crs(ji,jj,jk)) vue avec Gurvan OK 199 zcof2 = - fsahtv(ji,jj,jk) * e1e3v_msk(ji,jj,jk) * vslp_crs(ji,jj,jk) * zmskv / MAX( 1._wp , e3v_max_crs(ji,jj,jk)) 200 ! zcof1 = - fsahtu(ji,jj,jk) * e2u_crs(ji,jj) * uslp(ji,jj,jk) * zmsku 201 ! zcof2 = - fsahtv(ji,jj,jk) * e1v_crs(ji,jj) * vslp(ji,jj,jk) * zmskv 190 zcof1 = - fsahtu(ji,jj,jk) * e2e3u_msk(ji,jj,jk) * uslp_crs(ji,jj,jk) * zmsku / MAX( 1._wp , e3u_max_crs(ji,jj,jk)) 191 zcof2 = - fsahtv(ji,jj,jk) * e1e3v_msk(ji,jj,jk) * vslp_crs(ji,jj,jk) * zmskv / MAX( 1._wp , e3v_max_crs(ji,jj,jk)) 202 192 ! 203 193 zftu(ji,jj,jk ) = ( zabe1 * zdit(ji,jj,jk) & … … 209 199 END DO 210 200 END DO 201 CALL iom_swap( "nemo_crs" ) 202 CALL iom_put( "zftu" , zftu ) 203 CALL iom_put( "zftv" , zftv ) 204 CALL iom_swap( "nemo" ) 211 205 212 206 ! II.4 Second derivative (divergence) and add to the general trend … … 285 279 zcoef3 = zcoef0 * e1e2w_crs(ji,jj,jk) * zmsku * wslpi_crs(ji,jj,jk) / e1t_crs(ji,jj) 286 280 zcoef4 = zcoef0 * e1e2w_crs(ji,jj,jk) * zmskv * wslpj_crs(ji,jj,jk) / e2t_crs(ji,jj) 287 ! zcoef3 = zcoef0 * e2t_crs(ji,jj) * zmsku * wslpi (ji,jj,jk)288 ! zcoef4 = zcoef0 * e1t_crs(ji,jj) * zmskv * wslpj (ji,jj,jk)289 281 ztfw(ji,jj,jk) = zcoef3 * ( zdit(ji ,jj ,jk-1) + zdit(ji-1,jj ,jk) & 290 282 & + zdit(ji-1,jj ,jk-1) + zdit(ji ,jj ,jk) ) & … … 312 304 ! 313 305 CALL wrk_dealloc( jpi, jpj, zdkt, zdk1t, z2d ) 314 CALL wrk_dealloc( jpi, jpj, jpk, zdit, zdjt, ztfw )306 CALL wrk_dealloc( jpi, jpj, jpk, zdit, zdjt, ztfw , zftu, zftv ) 315 307 ! 316 308 IF( nn_timing == 1 ) CALL timing_stop('tra_ldf_iso') -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/TRA/tranxt.F90
r4990 r5601 290 290 ll_traqsr = ln_traqsr ! active tracers case and solar penetration 291 291 ELSE 292 ll_tra = .FALSE. ! passive tracers case292 ll_tra = .FALSE. ! passive tracers case 293 293 ll_tra_hpg = .FALSE. ! passive tracers case or NO semi-implicit hpg 294 294 ll_traqsr = .FALSE. ! active tracers case and NO solar penetration -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/TRA/trazdf_imp_crs.F90
r5105 r5601 78 78 !! ** Action : - pta becomes the after tracer 79 79 !!--------------------------------------------------------------------- 80 USE oce , ONLY: zwd => ua , zws => va ! (ua,va) used as 3D workspace81 80 ! 82 81 INTEGER , INTENT(in ) :: kt ! ocean time-step index … … 90 89 INTEGER :: ji, jj, jk, jn ! dummy loop indices 91 90 REAL(wp) :: zrhs, ze3tb, ze3tn, ze3ta ! local scalars 92 REAL(wp), POINTER, DIMENSION(:,:,:) :: zwi, zwt 91 REAL(wp), POINTER, DIMENSION(:,:,:) :: zwi, zwt,zwd,zws 93 92 !!--------------------------------------------------------------------- 94 93 ! 95 !WRITE(numout,*) 'test6456_trb_sbc1', pta(:,:,:,1), kt 96 IF( nn_timing == 1 ) CALL timing_start('tra_zdf_imp') 97 ! 98 CALL wrk_alloc( jpi, jpj, jpk, zwi, zwt ) 94 IF( nn_timing == 1 ) CALL timing_start('tra_zdf_imp_crs') 95 ! 96 CALL wrk_alloc( jpi, jpj, jpk, zwi, zwt, zwd, zws ) 99 97 ! 100 98 IF( kt == kit000 ) THEN … … 121 119 ! vertical mixing coef.: avt for temperature, avs for salinity and passive tracers 122 120 IF( cdtype == 'TRA' .AND. jn == jp_tem ) THEN ; zwt(:,:,2:jpk) = avt (:,:,2:jpk) 123 #if defined key_zdfddm 124 ELSE ; zwt(:,:,2:jpk) = avs_crs(:,:,2:jpk) 125 #endif 121 ELSE ; zwt(:,:,2:jpk) = avt_crs(:,:,2:jpk) 126 122 ENDIF 127 123 zwt(:,:,1) = 0._wp … … 135 131 DO ji = fs_2, fs_jpim1 ! vector opt. 136 132 zwt(ji,jj,jk) = zwt(ji,jj,jk) + ah_wslp2(ji,jj,jk) 137 ! WRITE(numout,*) 'ah_wslp2', ah_wslp2(ji,jj,jk)138 133 END DO 139 134 END DO … … 152 147 153 148 #endif 154 !WRITE(numout,*) 'test6456_trb_sbc2', pta(:,:,:,1), kt155 ! Diagonal, lower (i), upper (s) (including the bottom boundary condition since avt is masked)156 ! WRITE(numout,*) 'wslpi_crs', wslpi_crs(:,:,:)157 ! WRITE(numout,*) 'wslpj_crs(ji,jj,jk-1)',wslpj_crs(:,:,:)158 ! WRITE(numout,*) ' fsahtw', fsahtw(:,:,:)159 !WRITE(numout,*) 'ah_wslp2', ah_wslp2(:,:,:)160 ! WRITE(numout,*) 'zwt2(ji,jj,jk-1)', zwt(:,:,:)161 162 149 DO jk = 1, jpkm1 163 150 DO jj = 2, jpjm1 164 151 DO ji = fs_2, fs_jpim1 ! vector opt. 165 ! ze3ta = ( 1. - r_vvl ) + r_vvl * ocean_volume_crs_t(ji,jj,jk) ! after scale factor at T-point166 ! ze3tn = r_vvl + ( 1. - r_vvl ) * ocean_volume_crs_t(ji,jj,jk) ! now scale factor at T-point167 152 ze3ta = ( 1. - r_vvl ) + r_vvl * e3t_crs(ji,jj,jk) ! after scale factor at T-point 168 153 ze3tn = r_vvl + ( 1. - r_vvl ) * e3t_crs(ji,jj,jk) ! now scale factor at T-point 169 zwi(ji,jj,jk) = - p2dt(jk) * zwt(ji,jj,jk ) / ( ze3tn * e3w_1d(jk ) ) !cc 170 zws(ji,jj,jk) = - p2dt(jk) * zwt(ji,jj,jk+1) / ( ze3tn * e3w_1d(jk+1) ) !cc 154 !cbr zwi(ji,jj,jk) = - p2dt(jk) * zwt(ji,jj,jk ) / ( ze3tn * e3w_1d(jk ) ) !cc 155 !cbr zws(ji,jj,jk) = - p2dt(jk) * zwt(ji,jj,jk+1) / ( ze3tn * e3w_1d(jk+1) ) !cc 156 zwi(ji,jj,jk) = - p2dt(jk) * zwt(ji,jj,jk ) / ( ze3tn * e3w_max_crs(ji,jj,jk) ) 157 zws(ji,jj,jk) = - p2dt(jk) * zwt(ji,jj,jk+1) / ( ze3tn * e3w_max_crs(ji,jj,jk+1) ) 171 158 zwd(ji,jj,jk) = ze3ta - zwi(ji,jj,jk) - zws(ji,jj,jk) 172 ! WRITE(numout,*) 'ze3tn', ze3tn173 ! WRITE(numout,*) 'e3w_0', e3w_0(jk)174 ! WRITE(numout,*) 'ze3ta', ze3ta175 ! WRITE(numout,*) 'zwt3(ji,jj,jk-1)', zwt(ji,jj,jk)176 159 END DO 177 160 END DO 178 161 END DO 179 ! WRITE(numout,*) 'zwi(ji,jj,jk-1)', zwi(:,:,:)180 ! WRITE(numout,*) 'zws(ji,jj,jk-1)', zws(:,:,:)181 ! WRITE(numout,*) 'zwd(ji,jj,jk-1)', zwd(:,:,:)182 162 ! 183 163 !! Matrix inversion from the first level … … 216 196 ! 217 197 END IF 218 ! WRITE(numout,*) 'zwt4(ji,jj,jk-1)', zwt(:,:,:)219 198 ! 220 !WRITE(numout,*) 'test6456_trb_sbc4', pta(:,:,:,1), kt221 199 ! second recurrence: Zk = Yk - Ik / Tk-1 Zk-1 222 200 DO jj = 2, jpjm1 223 201 DO ji = fs_2, fs_jpim1 224 ! ze3tb = ( 1. - r_vvl ) + r_vvl * ocean_volume_crs_t(ji,jj,1)225 ! ze3tn = ( 1. - r_vvl ) + r_vvl * ocean_volume_crs_t(ji,jj,1)226 202 ze3tb = ( 1. - r_vvl ) + r_vvl * e3t_crs(ji,jj,1) 227 203 ze3tn = ( 1. - r_vvl ) + r_vvl * e3t_crs(ji,jj,1) 228 204 pta(ji,jj,1,jn) = ze3tb * ptb(ji,jj,1,jn) + p2dt(1) * ze3tn * pta(ji,jj,1,jn) 229 !WRITE(numout,*) 'test6456_trb_sbc4', pta(:,:,:,1), kt 230 END DO 231 END DO 232 233 !WRITE(numout,*) 'kt', kt 205 END DO 206 END DO 207 234 208 DO jk = 2, jpkm1 235 209 DO jj = 2, jpjm1 236 210 DO ji = fs_2, fs_jpim1 237 ! ze3tb = ( 1. - r_vvl ) + r_vvl * ocean_volume_crs_t(ji,jj,jk)238 ! ze3tn = ( 1. - r_vvl ) + r_vvl * ocean_volume_crs_t(ji,jj,jk)239 211 ze3tb = ( 1. - r_vvl ) + r_vvl * e3t_crs(ji,jj,jk) 240 212 ze3tn = ( 1. - r_vvl ) + r_vvl * e3t_crs(ji,jj,jk) … … 246 218 END DO 247 219 248 !WRITE(numout,*) 'test6456_trb_sbc5', pta(:,:,:,1), kt249 220 ! third recurrence: Xk = (Zk - Sk Xk+1 ) / Tk (result is the after tracer) 250 221 DO jj = 2, jpjm1 … … 267 238 ! ! ================= ! 268 239 ! 269 !WRITE(numout,*) 'test6456_trb_sbc6', pta(:,:,:,1), kt 270 CALL wrk_dealloc( jpi, jpj, jpk, zwi, zwt ) 240 CALL wrk_dealloc( jpi, jpj, jpk, zwi, zwt, zwd, zws ) 271 241 ! 272 242 IF( nn_timing == 1 ) CALL timing_stop('tra_zdf_imp_crs') -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/TRA/zpshde_crs.F90
r5105 r5601 103 103 !!---------------------------------------------------------------------- 104 104 ! 105 IF( nn_timing == 1 ) CALL timing_start( 'zps_hde ')105 IF( nn_timing == 1 ) CALL timing_start( 'zps_hde_crs') 106 106 ! 107 107 !! CALL wrk_alloc( jpi, jpj, zri, zrj, zhi, zhj ) … … 128 128 ! i- direction 129 129 IF( ze3wu >= 0._wp ) THEN ! case 1 130 !cbr zmaxu = ze3wu / e3w_max_crs(ji+1,jj,iku) 131 zmaxu = ze3wu 132 IF( e3w_max_crs(ji+1,jj,iku) .NE. 0._wp ) zmaxu = zmaxu / e3w_max_crs(ji+1,jj,iku) 130 zmaxu = ze3wu / e3w_max_crs(ji+1,jj,iku) 133 131 ! zmaxu = ze3wu / e3w_crs(ji+1,jj,iku) 134 132 ! interpolated values of tracers … … 137 135 pgtu(ji,jj,jn) = umask_crs(ji,jj,1) * ( zti(ji,jj,jn) - pta(ji,jj,iku,jn) ) 138 136 ELSE ! case 2 139 !cbr zmaxu = -ze3wu / e3w_max_crs(ji,jj,iku) 140 zmaxu = -ze3wu 141 IF( e3w_max_crs(ji,jj,iku) .NE. 0._wp ) zmaxu = zmaxu / e3w_max_crs(ji,jj,iku) 137 zmaxu = -ze3wu / e3w_max_crs(ji,jj,iku) 142 138 ! zmaxu = -ze3wu / e3w_crs(ji,jj,iku) 143 139 ! interpolated values of tracers … … 149 145 ! j- direction 150 146 IF( ze3wv >= 0._wp ) THEN ! case 1 151 !cbr zmaxv = ze3wv / e3w_max_crs(ji,jj+1,ikv) 152 zmaxv = ze3wv 153 IF( e3w_max_crs(ji,jj+1,ikv) .NE. 0._wp ) zmaxv = zmaxv / e3w_max_crs(ji,jj+1,ikv) 147 zmaxv = ze3wv / e3w_max_crs(ji,jj+1,ikv) 154 148 ! zmaxv = ze3wv / e3w_crs(ji,jj+1,ikv) 155 149 ! interpolated values of tracers … … 158 152 pgtv(ji,jj,jn) = vmask_crs(ji,jj,1) * ( zte(ji,jj,jn) - pta(ji,jj,ikv,jn) ) 159 153 ELSE ! case 2 160 !cbr zmaxv = -ze3wv / e3w_max_crs(ji,jj,ikv) 161 zmaxv = -ze3wv 162 IF( e3w_max_crs(ji,jj,ikv) .NE. 0._wp )zmaxv = zmaxv / e3w_max_crs(ji,jj,ikv) 154 zmaxv = -ze3wv / e3w_max_crs(ji,jj,ikv) 163 155 ! zmaxv = -ze3wv / e3w_crs(ji,jj,ikv) 164 156 ! interpolated values of tracers … … 237 229 DEALLOCATE( zri , zrj, zte, zhi, zhj, zti) 238 230 ! 239 IF( nn_timing == 1 ) CALL timing_stop( 'zps_hde ')231 IF( nn_timing == 1 ) CALL timing_stop( 'zps_hde_crs') 240 232 ! 241 233 END SUBROUTINE zps_hde_crs -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/ZDF/zdfmxl.F90
r4990 r5601 83 83 REAL(wp) :: zN2_c ! local scalar 84 84 INTEGER, POINTER, DIMENSION(:,:) :: imld ! 2D workspace 85 REAL(wp), POINTER, DIMENSION(:,:) :: z2d ! 2D workspace 85 86 !!---------------------------------------------------------------------- 86 87 ! … … 88 89 ! 89 90 CALL wrk_alloc( jpi,jpj, imld ) 91 CALL wrk_alloc( jpi,jpj, z2d ) 90 92 91 93 IF( kt == nit000 ) THEN … … 135 137 CALL iom_put( "mldr10_1", hmlp ) ! mixed layer depth 136 138 CALL iom_put( "mldkz5" , hmld ) ! turbocline depth 139 z2d(:,:)=REAL(nmln,wp) 140 CALL iom_put( "nmln" , z2d ) ! turbocline depth 137 141 ENDIF 138 142 … … 140 144 ! 141 145 CALL wrk_dealloc( jpi,jpj, imld ) 146 CALL wrk_dealloc( jpi,jpj, z2d ) 142 147 ! 143 148 IF( nn_timing == 1 ) CALL timing_stop('zdf_mxl') -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/ZDF/zdfmxl_crs.F90
r5105 r5601 6 6 !! History : 1.0 ! 2003-08 (G. Madec) original code 7 7 !! 3.2 ! 2009-07 (S. Masson, G. Madec) IOM + merge of DO-loop 8 !! 3.7 ! 2012-03 (G. Madec) make public the density criteria for trdmxl 9 !! - ! 2014-02 (F. Roquet) mixed layer depth calculated using N2 instead of rhop 8 10 !!---------------------------------------------------------------------- 9 11 !! zdf_mxl : Compute the turbocline and mixed layer depths. 10 12 !!---------------------------------------------------------------------- 11 USE oce ! ocean dynamics and tracers variables 12 USE dom_oce ! ocean space and time domain variables 13 !USE oce ! ocean dynamics and tracers variables 14 !USE dom_oce ! ocean space and time domain variables 15 !USE oce_trc 13 16 USE zdf_oce ! ocean vertical physics 14 17 USE in_out_manager ! I/O manager 15 18 USE prtctl ! Print control 19 USE phycst ! physical constants 16 20 USE iom ! I/O library 17 21 USE lib_mpp ! MPP library … … 26 30 PUBLIC zdf_mxl_crs ! called by step.F90 27 31 28 INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: nmln !: number of level in the mixed layer (used by TOP) 29 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hmld !: mixing layer depth (turbocline) [m] 30 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hmlp !: mixed layer depth (rho=rho0+zdcrit) [m] 31 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hmlpt !: mixed layer depth at t-points [m] 32 REAL(wp) :: avt_c = 5.e-4_wp ! Kz criterion for the turbocline depth 32 33 33 34 !! * Substitutions … … 35 36 !!---------------------------------------------------------------------- 36 37 !! NEMO/OPA 4.0 , NEMO Consortium (2011) 37 !! $Id: zdfmxl.F90 3294 2012-01-28 16:44:18Z rblod$38 !! $Id: zdfmxl.F90 4990 2014-12-15 16:42:49Z timgraham $ 38 39 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 39 40 !!---------------------------------------------------------------------- 40 41 CONTAINS 41 42 INTEGER FUNCTION zdf_mxl_alloc_crs()43 !!----------------------------------------------------------------------44 !! *** FUNCTION zdf_mxl_alloc ***45 !!----------------------------------------------------------------------46 zdf_mxl_alloc_crs = 0 ! set to zero if no array to be allocated47 IF( .NOT. ALLOCATED( nmln_crs ) ) THEN48 ALLOCATE( nmln_crs(jpi_crs,jpj_crs), hmld_crs(jpi_crs,jpj_crs), hmlp_crs(jpi_crs,jpj_crs) & !! declaration in crs.F9049 & , hmlpt_crs(jpi_crs,jpj_crs), STAT= zdf_mxl_alloc_crs )50 !51 IF( lk_mpp ) CALL mpp_sum ( zdf_mxl_alloc_crs )52 IF( zdf_mxl_alloc_crs /= 0 ) CALL ctl_warn('zdf_mxl_alloc: failed to allocate arrays.')53 !54 ENDIF55 END FUNCTION zdf_mxl_alloc_crs56 57 42 58 43 SUBROUTINE zdf_mxl_crs( kt ) … … 65 50 !! ** Method : The mixed layer depth is the shallowest W depth with 66 51 !! the density of the corresponding T point (just bellow) bellow a 67 !! given value defined locally as rho(10m) + zrho_c52 !! given value defined locally as rho(10m) + rho_c 68 53 !! The turbocline depth is the depth at which the vertical 69 54 !! eddy diffusivity coefficient (resulting from the vertical physics 70 55 !! alone, not the isopycnal part, see trazdf.F) fall below a given 71 !! value defined locally (avt_c here taken equal to 5 cm/s2 )56 !! value defined locally (avt_c here taken equal to 5 cm/s2 by default) 72 57 !! 73 58 !! ** Action : nmln, hmld, hmlp, hmlpt 74 59 !!---------------------------------------------------------------------- 75 60 INTEGER, INTENT(in) :: kt ! ocean time-step index 76 !! 77 INTEGER :: ji, jj, jk ! dummy loop indices 78 INTEGER :: iikn, iiki ! temporary integer within a do loop 79 INTEGER, POINTER, DIMENSION(:,:) :: imld ! temporary workspace 80 REAL(wp) :: zrho_c = 0.01_wp ! density criterion for mixed layer depth 81 REAL(wp) :: zavt_c = 5.e-4_wp ! Kz criterion for the turbocline depth 61 ! 62 INTEGER :: ji, jj, jk ! dummy loop indices 63 INTEGER :: iiki,iikn ! local integer 64 REAL(wp) :: zN2_c ! local scalar 65 INTEGER, POINTER, DIMENSION(:,:) :: imld ! 2D workspace 82 66 !!---------------------------------------------------------------------- 83 67 ! 84 IF( nn_timing == 1 ) CALL timing_start('zdf_mxl ')68 IF( nn_timing == 1 ) CALL timing_start('zdf_mxl_crs') 85 69 ! 86 70 CALL wrk_alloc( jpi_crs,jpj_crs, imld ) … … 88 72 IF( kt == nit000 ) THEN 89 73 IF(lwp) WRITE(numout,*) 90 IF(lwp) WRITE(numout,*) 'zdf_mxl : mixed layer depth'74 IF(lwp) WRITE(numout,*) 'zdf_mxl_crs : mixed layer depth' 91 75 IF(lwp) WRITE(numout,*) '~~~~~~~ ' 92 ! ! allocate zdfmxl arrays93 IF( zdf_mxl_alloc_crs() /= 0 ) CALL ctl_stop( 'STOP', 'zdf_mxl : unable to allocate arrays' )94 76 ENDIF 95 77 96 ! w-level of the mixing and mixed layers 97 nmln_crs(:,:) = mbkt_crs(:,:) + 1 ! Initialization to the number of w ocean point 98 imld(:,:) = mbkt_crs(:,:) + 1 99 DO jk = jpkm1, nlb10, -1 ! from the bottom to nlb10 78 ! w-level of the turbocline 79 imld(:,:)=0 80 DO jk = jpkm1, nlb10, -1 ! from the bottom to nlb10 100 81 DO jj = 1, jpj_crs 101 82 DO ji = 1, jpi_crs 102 IF( rhop_crs(ji,jj,jk) > rhop_crs(ji,jj,nla10) + zrho_c ) nmln_crs(ji,jj) = jk ! Mixed layer 103 ! IF( avt (ji,jj,jk) < zavt_c ) imld(ji,jj) = jk ! Turbocline 83 IF( avt_crs (ji,jj,jk) < avt_c ) imld(ji,jj) = MAX( jk, 1 ) ! Turbocline 104 84 END DO 105 85 END DO 106 86 END DO 87 107 88 ! depth of the mixing and mixed layers 108 !write(narea+2000,*)"nlb10 ",nlb10,SHAPE(hmlpt_crs),SHAPE(gdepw_crs) ; call flush(narea+2000) 89 hmld_crs(:,:) = 0._wp 90 hmlpt_crs(:,:) = 0._wp 109 91 DO jj = 1, jpj_crs 110 92 DO ji = 1, jpi_crs 111 !iiki = imld(ji,jj)93 iiki = imld(ji,jj) 112 94 iikn = nmln_crs(ji,jj) 113 ! write(narea+2000,*)ji,jj,iikn,gdept_crs(ji,jj,iikn-1) ; call flush(narea+2000) 114 ! hmld (ji,jj) = gdepw_crs(ji,jj,iiki ) * tmask_crs(ji,jj,1) ! Turbocline depth 115 !IF( iikn .LT. 2 .OR. iikn .GT. jpk )write(narea+2000,*)"iikn ",ji,jj,iikn ; call flush(narea+2000) 116 hmlp_crs (ji,jj) = gdepw_crs(ji,jj,iikn ) * tmask_crs(ji,jj,1) ! Mixed layer depth 117 hmlpt_crs(ji,jj) = gdept_crs(ji,jj,iikn-1) ! depth of the last T-point inside the mixed layer 95 IF( iiki .NE. 0 ) hmld_crs (ji,jj) = ( gdepw_crs(ji,jj,iiki ) - gdepw_crs(ji,jj,1 ) ) * tmask_crs(ji,jj,1) ! Turbocline depth 96 IF( iiki .NE. 0 ) hmlpt_crs(ji,jj) = ( gdept_crs(ji,jj,iikn-1) - gdepw_crs(ji,jj,1 ) ) * tmask_crs(ji,jj,1) ! depth of the last T-point inside the mixed layer 118 97 END DO 119 98 END DO 120 IF( .NOT.lk_offline ) THEN ! no need to output in offline mode121 ! CALL iom_put( "mldr10_1", hmlp ) ! mixed layer depth122 ! CALL iom_put( "mldkz5" , hmld ) ! turbocline depth123 ENDIF124 125 ! IF(ln_ctl) CALL prt_ctl( tab2d_1=REAL(nmln,wp), clinfo1=' nmln : ', tab2d_2=hmlp, clinfo2=' hmlp : ', ovlap=1 )126 99 ! 127 100 CALL wrk_dealloc( jpi_crs,jpj_crs, imld ) 128 101 ! 129 IF( nn_timing == 1 ) CALL timing_stop('zdf_mxl ')102 IF( nn_timing == 1 ) CALL timing_stop('zdf_mxl_crs') 130 103 ! 131 104 END SUBROUTINE zdf_mxl_crs -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/nemogcm.F90
r5105 r5601 82 82 USE crsini ! initialise grid coarsening utility 83 83 USE lbcnfd, ONLY: isendto, nsndto, nfsloop, nfeloop ! Setup of north fold exchanges 84 USE trabbl_crs 84 85 85 86 IMPLICIT NONE … … 114 115 !!---------------------------------------------------------------------- 115 116 INTEGER :: istp ! time step index 117 CHARACTER(len=20) :: cmd 116 118 !!---------------------------------------------------------------------- 117 119 ! … … 410 412 IF( lk_ldfslp ) CALL ldf_slp_init ! slope of lateral mixing 411 413 ! 412 IF( ln_crs .AND. lk_ldfslp ) THEN414 IF( ln_crs_top .AND. lk_ldfslp ) THEN 413 415 CALL dom_grid_crs 414 416 CALL ldf_slp_init_crs … … 420 422 IF( lk_trabbl ) CALL tra_bbl_init ! advective (and/or diffusive) bottom boundary layer scheme 421 423 ! 422 IF( ln_crs .AND. lk_trabbl ) THEN424 IF( ln_crs_top .AND. lk_trabbl ) THEN 423 425 CALL dom_grid_crs 424 426 CALL tra_bbl_init_crs ! advective (and/or diffusive) bottom boundary layer scheme -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/step.F90
r5105 r5601 110 110 !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 111 111 ! THERMODYNAMICS 112 CALL eos_rab( tsb, rab_b ) ! before local thermal/haline expension ratio at T-points113 CALL eos_rab( tsn, rab_n ) ! now local thermal/haline expension ratio at T-points112 !cbr not used CALL eos_rab( tsb, rab_b ) ! before local thermal/haline expension ratio at T-points 113 !cbr not used CALL eos_rab( tsn, rab_n ) ! now local thermal/haline expension ratio at T-points 114 114 CALL bn2 ( tsb, rab_b, rn2b ) ! before Brunt-Vaisala frequency 115 115 CALL bn2 ( tsn, rab_n, rn2 ) ! now Brunt-Vaisala frequency … … 139 139 CALL zdf_mxl( kstp ) ! mixed layer depth 140 140 141 IF(ln_crs) CALL zdf_mxl_crs(kstp)142 141 ! write TKE or GLS information in the restart file 143 142 IF( lrst_oce .AND. lk_zdftke ) CALL tke_rst( kstp, 'WRITE' ) … … 154 153 CALL ldf_slp_grif( kstp ) 155 154 ELSE 155 CALL iom_put("rabt",rab_n(:,:,:,jp_tem)) 156 CALL iom_put("rabs",rab_n(:,:,:,jp_sal)) 157 CALL iom_put("rhd",rhd) 158 CALL iom_put("rn2b",rn2b) 156 159 CALL ldf_slp( kstp, rhd, rn2b ) ! before slope for Madec operator 157 160 ENDIF … … 228 231 IF( ln_crs ) THEN 229 232 CALL dom_grid_crs 230 CALL eos_crs(tsb_crs , rhd_crs, rhop_crs) 231 CALL bn2_crs(tsb_crs , rb2_crs) 232 IF( ln_zps ) CALL zps_hde_crs( kstp, 2, tsb_crs, gtsu_crs, gtsv_crs, rhd_crs, gru_crs, grv_crs ) 233 CALL zdf_mxl_crs(kstp) 233 234 CALL eos_rab_crs( tsn_crs, rab_crs_n ) ! now local thermal/haline expension ratio at T-points 235 CALL bn2_crs ( tsn_crs, rab_crs_n, rb2_crs ) ! now Brunt-Vaisala frequency 236 CALL eos_crs ( tsn_crs, rhd_crs, rhop_crs, gdept_crs(:,:,:) ) ! now in situ density for hpg computation 237 238 IF( ln_zps ) CALL zps_hde_crs( kstp, jpts, tsb_crs, gtsu_crs, gtsv_crs, rhd_crs, gru_crs, grv_crs ) 239 234 240 IF( lk_ldfslp .AND. .NOT. ln_traldf_grif ) & 235 241 CALL ldf_slp_crs( kstp, rhd_crs, rb2_crs ) 236 242 CALL dom_grid_glo 237 ENDIF 243 244 ENDIF 245 CALL zdf_mxl_crs(kstp) 238 246 239 247 IF( ln_crs_top ) CALL dom_grid_crs -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/TOP_SRC/MY_TRC/trcini_my_trc.F90
r2787 r5601 16 16 USE trc 17 17 USE trcsms_my_trc 18 USE dom_oce, ONLY : gdepw_1d,e3t_1d,nyear_len 18 19 19 20 IMPLICIT NONE … … 44 45 IF(lwp) WRITE(numout,*) ' trc_ini_my_trc: initialisation of MY_TRC model' 45 46 IF(lwp) WRITE(numout,*) ' ~~~~~~~~~~~~~~' 47 48 nlb_age = MINLOC( gdepw_1d, mask = gdepw_1d > age_depth, dim = 1 ) 49 nl_age = nlb_age - 1 50 nla_age = nl_age - 1 51 frac_kill_age = (age_depth - gdepw_1d(nl_age))/e3t_1d(nl_age) 52 frac_add_age = 1._wp - frac_kill_age 53 rryear = 1._wp / ( nyear_len(1) * rday ) 54 46 55 56 IF( .NOT. ln_rsttr ) trb(:,:,:,jp_myt0:jp_myt1) = 0. 47 57 IF( .NOT. ln_rsttr ) trn(:,:,:,jp_myt0:jp_myt1) = 0. 48 58 ! -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/TOP_SRC/MY_TRC/trcsms_my_trc.F90
r4990 r5601 25 25 PUBLIC trc_sms_my_trc_alloc ! called by trcini_my_trc.F90 module 26 26 27 INTEGER , PUBLIC :: nl_age ! T level surrounding age_depth 28 INTEGER , PUBLIC :: nla_age ! T level wholly above age_depth 29 INTEGER , PUBLIC :: nlb_age ! T level wholly below age_depth 30 31 REAL(wp), PUBLIC :: rryear !: recip number of seconds in one year 32 REAL(wp), PUBLIC :: age_depth = 10. !: depth over which age tracer reset to zero 33 REAL(wp), PUBLIC :: age_kill_rate = -1./7200. !: recip of relaxation timescale (s) for age tracer shallower than age_depth 34 REAL(wp), PUBLIC :: frac_kill_age !: fraction of level nl_age above age_depth where it is relaxed towards zero 35 REAL(wp), PUBLIC :: frac_add_age !: fraction of level nl_age below age_depth where it is incremented 36 37 27 38 ! Defined HERE the arrays specific to MY_TRC sms and ALLOCATE them in trc_sms_my_trc_alloc 28 39 … … 44 55 ! 45 56 INTEGER, INTENT(in) :: kt ! ocean time-step index 46 INTEGER :: jn ! dummy loop index57 INTEGER :: jn, jk ! dummy loop index 47 58 REAL(wp), POINTER, DIMENSION(:,:,:) :: ztrmyt 48 59 !!---------------------------------------------------------------------- … … 56 67 IF( l_trdtrc ) CALL wrk_alloc( jpi, jpj, jpk, ztrmyt ) 57 68 58 WHERE( (glamt <= 170) .AND. (glamt >= 160) .AND. (gphit <= -74) .AND. (gphit >=-75.6) ) 59 trn(:,:,1,jpmyt1) = 1._wp 60 trb(:,:,1,jpmyt1) = 1._wp 61 tra(:,:,1,jpmyt1) = 0._wp 62 END WHERE 63 69 DO jk = 1, nla_age 70 tra(:,:,jk,jpmyt1) = age_kill_rate * trb(:,:,jk,jpmyt1) 71 ENDDO 72 ! 73 tra(:,:,nl_age,jpmyt1) = frac_kill_age * age_kill_rate * trb(:,:,nl_age,jpmyt1) & 74 & + frac_add_age * rryear * tmask(:,:,nl_age) 75 ! 76 DO jk = nlb_age, jpk 77 tra(:,:,jk,jpmyt1) = tmask(:,:,jk) * rryear 78 ENDDO 79 ! 64 80 IF( l_trdtrc ) THEN ! Save the trends in the ixed layer 65 81 DO jn = jp_myt0, jp_myt1 -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/TOP_SRC/MY_TRC/trcwri_my_trc.F90
r5105 r5601 14 14 USE trc ! passive tracers common variables 15 15 USE oce_trc 16 USE crs, ONLY : ln_crs 16 USE crs, ONLY : ln_crs,ln_crs_top,ahtt_crs,ahtu_crs,ahtv_crs,ahtw_crs,jpi_crs,jpj_crs 17 USE iom, ONLY : iom_swap, iom_put 17 18 18 19 IMPLICIT NONE … … 33 34 INTEGER :: jn 34 35 !!--------------------------------------------------------------------- 35 IF( ln_crs ) CALL iom_swap( "nemo_crs" ) 36 IF( ln_crs_top ) CALL iom_swap( "nemo_crs" ) 37 38 CALL iom_put("ahtt_crs",ahtt_crs) 39 CALL iom_put("ahtu_crs",ahtu_crs) 40 CALL iom_put("ahtv_crs",ahtv_crs) 41 CALL iom_put("ahtw_crs",ahtw_crs) 42 36 43 37 44 ! write the tracer concentrations in the file … … 40 47 cltra = TRIM( ctrcnm(jn) ) ! short title for tracer 41 48 IF( lk_vvl ) THEN 42 CALL iom_put( cltra, trn(:,:,:,jn) * fse3t_n(:,:,:) )49 CALL iom_put( TRIM(cltra), trn(:,:,:,jn) * fse3t_n(:,:,:) ) 43 50 ELSE 44 51 CALL iom_put( TRIM(cltra), trn(:,:,:,jn) ) … … 46 53 END DO 47 54 ! 48 IF( ln_crs ) CALL iom_swap( "nemo" )55 IF( ln_crs_top ) CALL iom_swap( "nemo" ) 49 56 ! 50 57 END SUBROUTINE trc_wri_my_trc -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/TOP_SRC/TRP/trcadv.F90
r4610 r5601 16 16 USE oce_trc ! ocean dynamics and active tracers 17 17 USE trc ! ocean passive tracers variables 18 USe domvvl 18 19 USE trcnam_trp ! passive tracers transport namelist variables 19 20 USE traadv_cen2 ! 2nd order centered scheme (tra_adv_cen2 routine) -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/TOP_SRC/TRP/trcbbl_crs.F90
r5105 r5601 25 25 USE trabbl_crs ! 26 26 USE prtctl_trc ! Print control for debbuging 27 USE trd mod_oce27 USE trd_oce 28 28 USE trdtra 29 29 … … 95 95 DO jn = 1, jptra 96 96 ztrtrd(:,:,:,jn) = tra(:,:,:,jn) - ztrtrd(:,:,:,jn) 97 CALL trd_tra( kt, 'TRC', jn, jptra_ trd_ldf, ztrtrd(:,:,:,jn) )97 CALL trd_tra( kt, 'TRC', jn, jptra_ldf, ztrtrd(:,:,:,jn) ) 98 98 END DO 99 99 CALL wrk_dealloc( jpi, jpj, jpk, jptra, ztrtrd ) ! temporary save of trends -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/TOP_SRC/TRP/trcldf_crs.F90
r5105 r5601 25 25 USE traldf_iso_grif ! lateral mixing (tra_ldf_iso_grif routine) 26 26 USE traldf_lap_crs ! lateral mixing (tra_ldf_lap routine) 27 USE trd mod_oce27 USE trd_oce 28 28 USE trdtra 29 29 USE prtctl_trc ! Print control … … 83 83 CALL tra_ldf_iso_crs ( kt, nittrc000, 'TRC', gtru ,gtrv , trb, tra, jptra, rn_ahtb_0 ) 84 84 ENDIF 85 CASE ( 2 ) ; CALL tra_ldf_bilap ( kt, nittrc000, 'TRC', gtru, gtrv, trb, tra, jptra ) ! iso-level bilaplacian85 CASE ( 2 ) ; CALL tra_ldf_bilap ( kt, nittrc000, 'TRC', gtru, gtrv, gtrui, gtrvi, trb, tra, jptra ) ! iso-level bilaplacian 86 86 CASE ( 3 ) ; CALL tra_ldf_bilapg( kt, nittrc000, 'TRC', trb, tra, jptra ) ! s-coord. horizontal bilaplacian 87 87 ! … … 97 97 WRITE(charout, FMT="('ldf1 ')") ; CALL prt_ctl_trc_info(charout) 98 98 CALL prt_ctl_trc( tab4d=tra, mask=tmask, clinfo=ctrcnm, clinfo2='trd' ) 99 CALL tra_ldf_bilap ( kt, nittrc000, 'TRC', gtru, gtrv, trb, tra, jptra )99 CALL tra_ldf_bilap ( kt, nittrc000, 'TRC', gtru, gtrv, gtrui, gtrvi, trb, tra, jptra ) 100 100 WRITE(charout, FMT="('ldf2 ')") ; CALL prt_ctl_trc_info(charout) 101 101 CALL prt_ctl_trc( tab4d=tra, mask=tmask, clinfo=ctrcnm, clinfo2='trd' ) … … 108 108 DO jn = 1, jptra 109 109 ztrtrd(:,:,:,jn) = tra(:,:,:,jn) - ztrtrd(:,:,:,jn) 110 CALL trd_tra( kt, 'TRC', jn, jptra_ trd_ldf, ztrtrd(:,:,:,jn) )110 CALL trd_tra( kt, 'TRC', jn, jptra_ldf, ztrtrd(:,:,:,jn) ) 111 111 END DO 112 112 CALL wrk_dealloc( jpi, jpj, jpk, jptra, ztrtrd ) -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/TOP_SRC/TRP/trcsbc.F90
r4990 r5601 95 95 IF( l_trdtrc ) ztrtrd(:,:,:) = tra(:,:,:,jn) ! save trends 96 96 ! ! add the trend to the general tracer trend 97 DO jj = 2, jpj 98 DO ji = fs_2, fs_jpim1 ! vector opt. 99 zse3t = 1. / fse3t(ji,jj,1) 100 tra(ji,jj,1,jn) = tra(ji,jj,1,jn) + zsfx(ji,jj) * zsrau * trn(ji,jj,1,jn) * zse3t 97 IF( lk_vvl ) THEN ! online coupling with vvl 98 99 100 DO jj = 2, jpj 101 DO ji = fs_2, fs_jpim1 ! vector opt. 102 zse3t = 1. / fse3t(ji,jj,1) 103 tra(ji,jj,1,jn) = tra(ji,jj,1,jn) + zsfx(ji,jj) * zsrau * trn(ji,jj,1,jn) * zse3t 104 END DO 101 105 END DO 102 END DO 103 106 ELSE 107 DO jj = 2, jpj 108 DO ji = fs_2, fs_jpim1 ! vector opt. 109 zse3t = 1. / fse3t(ji,jj,1) 110 tra(ji,jj,1,jn) = tra(ji,jj,1,jn) + zsfx(ji,jj) * zsrau * trn(ji,jj,1,jn) * zse3t 111 END DO 112 END DO 113 ENDIF 114 104 115 IF( l_trdtrc ) THEN 105 116 ztrtrd(:,:,:) = tra(:,:,:,jn) - ztrtrd(:,:,:) -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/TOP_SRC/TRP/trcsbc_crs.F90
r5105 r5601 19 19 USE trc ! ocean passive tracers variables 20 20 USE prtctl_trc ! Print control for debbuging 21 USE trd mod_oce21 USE trd_oce 22 22 USE trdtra 23 23 !cbr USE crs … … 101 101 IF( l_trdtrc ) THEN 102 102 ztrtrd(:,:,:) = tra(:,:,:,jn) - ztrtrd(:,:,:) 103 CALL trd_tra( kt, 'TRC', jn, jptra_ trd_nsr, ztrtrd )103 CALL trd_tra( kt, 'TRC', jn, jptra_nsr, ztrtrd ) 104 104 END IF 105 105 ! ! =========== -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/TOP_SRC/TRP/trctrp.F90
r5105 r5601 35 35 USE zpshde_crs ! partial step: hor. derivative (zps_hde routine) 36 36 USE dom_oce , ONLY : ln_crs 37 USe crs, ONLY : jpi_crs,jpj_crs,wn_crs !cbr 37 USE crs , ONLY : jpi_crs,jpj_crs,wn_crs,ln_crs_top !cbr 38 USE ldfslp_crs 38 39 39 40 #if defined key_agrif … … 75 76 IF( .NOT. lk_c1d ) THEN 76 77 ! 77 ! CALL test(kstp,1) 78 ! IF( ln_crs ) THEN ; CALL trc_sbc_crs( kstp ) 79 ! ELSE ; CALL trc_sbc( kstp ) 80 ! ENDIF 81 ! CALL test(kstp,2) 82 IF( ln_crs ) THEN ; CALL trc_bbl_crs( kstp ) 78 IF( ln_crs_top ) THEN ; CALL trc_sbc_crs( kstp ) 79 ELSE ; CALL trc_sbc( kstp ) 80 ENDIF 81 IF( ln_crs_top ) THEN ; CALL trc_bbl_crs( kstp ) 83 82 ELSE ; CALL trc_bbl( kstp ) 84 83 ENDIF 85 84 IF( ln_trcdmp ) CALL trc_dmp( kstp ) ! internal damping trends 86 ! CALL test(kstp,3)87 85 88 IF( ln_crs ) THEN ; CALL trc_adv_crs( kstp )86 IF( ln_crs_top ) THEN ; CALL trc_adv_crs( kstp ) 89 87 ELSE ; CALL trc_adv( kstp ) 90 88 ENDIF 91 ! CALL test(kstp,4)92 89 93 90 IF( ln_trcdmp_clo ) CALL trc_dmp_clo( kstp ) ! internal damping trends on closed seas only 94 IF( ln_crs ) THEN ; CALL trc_ldf_crs( kstp )91 IF( ln_crs_top ) THEN ; CALL trc_ldf_crs( kstp ) 95 92 ELSE ; CALL trc_ldf( kstp ) 96 93 ENDIF 97 ! CALL test(kstp,5)98 94 IF( .NOT. lk_offline .AND. lk_zdfkpp ) & 99 95 & CALL trc_kpp( kstp ) ! KPP non-local tracer fluxes … … 101 97 IF(.NOT. Agrif_Root()) CALL Agrif_Sponge_trc ! tracers sponge 102 98 #endif 103 IF( ln_crs ) THEN ; CALL trc_zdf_crs( kstp )99 IF( ln_crs_top ) THEN ; CALL trc_zdf_crs( kstp ) 104 100 ELSE ; CALL trc_zdf( kstp ) 105 101 ENDIF 106 ! CALL test(kstp,6)107 102 CALL trc_nxt( kstp ) ! tracer fields at next time step 108 ! CALL test(kstp,7)109 103 IF( ln_trcrad ) CALL trc_rad( kstp ) ! Correct artificial negative concentrations 110 104 … … 112 106 IF( .NOT. Agrif_Root()) CALL Agrif_Update_Trc( kstp ) ! Update tracer at AGRIF zoom boundaries : children only 113 107 #endif 114 IF( ln_zps ) CALL zps_hde( kstp, jptra, trn, gtru, gtrv )! Partial steps: now horizontal gradient of passive108 ! Partial steps: now horizontal gradient of passive 115 109 IF( ln_zps )THEN 116 IF( ln_crs ) THEN ; CALL zps_hde_crs( kstp, jptra, trn, gtru, gtrv )117 ELSE ; CALL zps_hde( kstp, jptra, trn, gtru, gtrv)110 IF( ln_crs_top ) THEN ; CALL zps_hde_crs( kstp, jptra, trn, gtru, gtrv ) 111 ELSE ; CALL zps_hde( kstp, jptra, trn, pgtu=gtru, pgtv=gtrv, sgtu=gtrui, sgtv=gtrvi ) 118 112 ENDIF 119 113 ENDIF … … 136 130 INTEGER,INTENT(IN) :: kt,i 137 131 REAL(wp)::zmin,zmax 138 INTEGER :: ji,jj,jk132 INTEGER :: ii,jj,kk 139 133 zmin=MINVAL( trb(2:jpi-1,2:jpj-1,:,1),mask=(tmask(2:jpi-1,2:jpj-1,:)==1)) ; CALL mpp_min(zmin) 140 134 zmax=MAXVAL( trb(2:jpi-1,2:jpj-1,:,1),mask=(tmask(2:jpi-1,2:jpj-1,:)==1)) ; CALL mpp_max(zmax) … … 146 140 zmax=MAXVAL( tra(2:jpi-1,2:jpj-1,:,1),mask=(tmask(2:jpi-1,2:jpj-1,:)==1)) ; CALL mpp_max(zmax) 147 141 IF(lwp)WRITE(numout,*)"trctrp a ",kt,i,zmin,zmax 148 zmin=MINVAL( trn(2:jpi-1,2:jpj-1,1:jpk-1,1),mask=(tmask(2:jpi-1,2:jpj-1,1:jpk-1)==1)) ; CALL mpp_min(zmin) 149 zmax=MAXVAL( trn(2:jpi-1,2:jpj-1,1:jpk-1,1),mask=(tmask(2:jpi-1,2:jpj-1,1:jpk-1)==1)) ; CALL mpp_max(zmax) 150 IF(lwp)WRITE(numout,*)"trctrp n ",kt,i,zmin,zmax 151 zmin=MINVAL( tra(2:jpi-1,2:jpj-1,1:jpk-1,1),mask=(tmask(2:jpi-1,2:jpj-1,1:jpk-1)==1)) ; CALL mpp_min(zmin) 152 zmax=MAXVAL( tra(2:jpi-1,2:jpj-1,1:jpk-1,1),mask=(tmask(2:jpi-1,2:jpj-1,1:jpk-1)==1)) ; CALL mpp_max(zmax) 153 IF(lwp)WRITE(numout,*)"trctrp a ",kt,i,zmin,zmax 142 zmin=MINVAL( tra(2:jpi-1,2:jpj-1,30,1),mask=(tmask(2:jpi-1,2:jpj-1,30)==1)) ; CALL mpp_min(zmin) 143 zmax=MAXVAL( tra(2:jpi-1,2:jpj-1,30,1),mask=(tmask(2:jpi-1,2:jpj-1,30)==1)) ; CALL mpp_max(zmax) 154 144 155 IF(narea==267)WRITE(narea+5000,*)"tra(17,5,74,1) = ",kt,i,tra(17,5,74,1)156 157 DO ji=1,jpi158 DO jj=1,jpj159 DO jk=1,jpk160 IF( tra(ji,jj,jk,1) .NE. tra(ji,jj,jk,1) )WRITE(narea+200,*)"BUG7 ",ji,jj,jk, tra(ji,jj,jk,1); CALL FLUSH(narea+200)161 ENDDO162 ENDDO163 ENDDO164 165 145 END SUBROUTINE test 166 146 #else -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/TOP_SRC/TRP/trczdf_crs.F90
r5105 r5601 19 19 USE trazdf_exp ! vertical diffusion: explicit (tra_zdf_exp routine) 20 20 USE trazdf_imp_crs ! vertical diffusion: implicit (tra_zdf_imp routine) 21 USE trd mod_oce21 USE trd_oce 22 22 USE trdtra 23 23 USE prtctl_trc ! Print control 24 USE timing 24 25 25 26 IMPLICIT NONE … … 72 73 ! 73 74 IF( kt == nittrc000 ) CALL zdf_ctl ! initialisation & control of options 74 75 #if ! defined key_pisces 76 IF( neuler == 0 .AND. kt == nittrc000 ) THEN ! at nittrc000 77 r2dt(:) = rdttrc(:) ! = rdttrc (restarting with Euler time stepping) 78 ELSEIF( kt <= nittrc000 + 1 ) THEN ! at nittrc000 or nittrc000+1 79 r2dt(:) = 2. * rdttrc(:) ! = 2 rdttrc (leapfrog) 75 !cbr bug 76 !#if ! defined key_pisces 77 ! IF( neuler == 0 .AND. kt == nittrc000 ) THEN ! at nittrc000 78 ! r2dt(:) = rdttrc(:) ! = rdttrc (restarting with Euler time stepping) 79 ! ELSEIF( kt <= nittrc000 + 1 ) THEN ! at nittrc000 or nittrc000+1 80 ! r2dt(:) = 2. * rdttrc(:) ! = 2 rdttrc (leapfrog) 81 ! ENDIF 82 !#else 83 ! r2dt(:) = rdttrc(:) ! = rdttrc (for PISCES use Euler time stepping) 84 !#endif 85 IF( ln_top_euler) THEN 86 r2dt(:) = rdttrc(:) ! = rdttrc (use Euler time stepping) 87 ELSE 88 IF( neuler == 0 .AND. kt == nittrc000 ) THEN ! at nittrc000 89 r2dt(:) = rdttrc(:) ! = rdttrc (restarting with Euler time stepping) 90 ELSEIF( kt <= nittrc000 + 1 ) THEN ! at nittrc000 or nittrc000+1 91 r2dt(:) = 2. * rdttrc(:) ! = 2 rdttrc (leapfrog) 92 ENDIF 80 93 ENDIF 81 #else82 r2dt(:) = rdttrc(:) ! = rdttrc (for PISCES use Euler time stepping)83 #endif84 94 85 95 IF( l_trdtrc ) THEN … … 98 108 CASE ( 0 ) ; CALL tra_zdf_exp( kt, nittrc000, 'TRC', r2dt, nn_trczdf_exp, trb, tra, jptra ) ! explicit scheme 99 109 CASE ( 1 ) ; CALL tra_zdf_imp_crs( kt, nittrc000, 'TRC', r2dt, trb, tra, jptra ) ! implicit scheme 100 101 110 END SELECT 102 111 … … 106 115 ztrtrd(:,:,jk,jn) = ( ( tra(:,:,jk,jn) - trb(:,:,jk,jn) ) / r2dt(jk) ) - ztrtrd(:,:,jk,jn) 107 116 END DO 108 CALL trd_tra( kt, 'TRC', jn, jptra_ trd_zdf, ztrtrd(:,:,:,jn) )117 CALL trd_tra( kt, 'TRC', jn, jptra_zdf, ztrtrd(:,:,:,jn) ) 109 118 END DO 110 119 CALL wrk_dealloc( jpi, jpj, jpk, jptra, ztrtrd ) -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/TOP_SRC/oce_trc.F90
r5105 r5601 142 142 USE oce , ONLY : tsa => tsa !: 4D array contaning ( ta, sa ) 143 143 USE oce , ONLY : rhop => rhop !: potential volumic mass (kg m-3) 144 USE oce , ONLY : rhd => rhd !: in situ density anomalie rhd=(rho-rau0)/rau0 (no units) 144 USE crs , ONLY : rhd => rhd_crs !: in situ density anomalie rhd=(rho-rau0)/rau0 (no units) 145 USE crs , ONLY : rn2b => rb2_crs !: in situ density anomalie rhd=(rho-rau0)/rau0 (no units) 146 USE crs , ONLY : rab_n => rab_crs_n !: in situ density anomalie rhd=(rho-rau0)/rau0 (no units) 145 147 USE crs , ONLY : hdivn => hdivn_crs !: horizontal divergence (1/s) 146 148 USE crs , ONLY : hdivb => hdivb_crs !: horizontal divergence (1/s) … … 160 162 USE crs , ONLY : rnf => rnf_crs !: river runoff [Kg/m2/s] 161 163 USE crs , ONLY : fr_i => fr_i_crs !: ice fraction (between 0 to 1) 164 USE trcnam_trp , ONLY : aht0 => rn_ahtrc_0 !: horizontal eddy diffusivity for tracers (m2/s) 165 USE crs , ONLY : ahtu => ahtu_crs !: lateral diffusivity coef. at u-points 166 USE crs , ONLY : ahtv => ahtv_crs !: lateral diffusivity coef. at v-points 167 USE crs , ONLY : ahtw => ahtw_crs !: lateral diffusivity coef. at w-points 168 USE crs , ONLY : ahtt => ahtt_crs !: lateral diffusivity coef. at t-points 169 USE ldftra_oce , ONLY : rldf => rldf 162 170 163 171 USE crs , ONLY : avt => avt_crs !: vert. diffusivity coef. at w-point for temp … … 177 185 !* direction of lateral diffusion * 178 186 #if defined key_ldfslp 179 USE ldfslp_crs , ONLY : uslp => uslp_crs !: i-direction slope at u-, w-points180 USE ldfslp_crs , ONLY : vslp => vslp_crs !: j-direction slope at v-, w-points181 USE ldfslp_crs , ONLY : wslpi => wslpi_crs !: i-direction slope at u-, w-points182 USE ldfslp_crs , ONLY : wslpj => wslpj_crs !: j-direction slope at v-, w-points187 USE crs , ONLY : uslp => uslp_crs !: i-direction slope at u-, w-points 188 USE crs , ONLY : vslp => vslp_crs !: j-direction slope at v-, w-points 189 USE crs , ONLY : wslpi => wslpi_crs !: i-direction slope at u-, w-points 190 USE crs , ONLY : wslpj => wslpj_crs !: j-direction slope at v-, w-points 183 191 #endif 184 192 … … 318 326 USE oce , ONLY : rhop => rhop !: potential volumic mass (kg m-3) 319 327 USE oce , ONLY : rhd => rhd !: in situ density anomalie rhd=(rho-rau0)/rau0 (no units) 328 USE oce , ONLY : rab_n => rab_n !: in situ density anomalie rhd=(rho-rau0)/rau0 (no units) 329 USE oce , ONLY : rn2b => rn2b !: in situ density anomalie rhd=(rho-rau0)/rau0 (no units) 320 330 USE oce , ONLY : hdivn => hdivn !: horizontal divergence (1/s) 321 331 USE oce , ONLY : rotn => rotn !: relative vorticity [s-1] -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/TOP_SRC/trcini.F90
r5105 r5601 94 94 cvol(:,:,jk) = e1e2t(:,:) * fse3t(:,:,jk) * tmask(:,:,jk) 95 95 END DO 96 IF( lk_degrad ) cvol(:,:,:) = cvol(:,:,:) * facvol(:,:,:) ! degrad option: reduction by facvol96 !cbr IF( lk_degrad ) cvol(:,:,:) = cvol(:,:,:) * facvol(:,:,:) ! degrad option: reduction by facvol 97 97 ! ! total volume of the ocean 98 98 areatot = glob_sum( cvol(:,:,:) ) -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/TOP_SRC/trcstp.F90
r5105 r5601 66 66 cvol(:,:,jk) = e1e2t(:,:) * fse3t(:,:,jk) * tmask(:,:,jk) 67 67 END DO 68 IF( lk_degrad ) cvol(:,:,:) = cvol(:,:,:) * facvol(:,:,:) ! degrad option: reduction by facvol68 !cbr IF( lk_degrad ) cvol(:,:,:) = cvol(:,:,:) * facvol(:,:,:) ! degrad option: reduction by facvol 69 69 areatot = glob_sum( cvol(:,:,:) ) 70 70 ENDIF -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/TOP_SRC/trcsub.F90
r5105 r5601 14 14 USE prtctl_trc ! Print control for debbuging 15 15 USE iom, ONLY : jpnf90 16 USE i n_out_manager, ONLY : jprstlib16 USE iom_def, ONLY : jprstlib 17 17 USE lbclnk 18 18 !#if defined key_zdftke … … 112 112 sshn_tm (:,:) = sshn_tm (:,:) + sshn (:,:) 113 113 rnf_tm (:,:) = rnf_tm (:,:) + rnf (:,:) 114 h_rnf_tm (:,:) = h_rnf_tm (:,:) + h_rnf (:,:)114 !cbr h_rnf_tm (:,:) = h_rnf_tm (:,:) + h_rnf (:,:) 115 115 hmld_tm (:,:) = hmld_tm (:,:) + hmld (:,:) 116 116 fr_i_tm (:,:) = fr_i_tm (:,:) + fr_i (:,:) … … 151 151 ssha_temp (:,:) = ssha (:,:) 152 152 rnf_temp (:,:) = rnf (:,:) 153 h_rnf_temp (:,:) = h_rnf (:,:)153 !cbr h_rnf_temp (:,:) = h_rnf (:,:) 154 154 hmld_temp (:,:) = hmld (:,:) 155 155 fr_i_temp (:,:) = fr_i (:,:) … … 197 197 sshn_tm (:,:) = sshn_tm (:,:) + sshn (:,:) 198 198 rnf_tm (:,:) = rnf_tm (:,:) + rnf (:,:) 199 h_rnf_tm (:,:) = h_rnf_tm (:,:) + h_rnf (:,:)199 !cbr h_rnf_tm (:,:) = h_rnf_tm (:,:) + h_rnf (:,:) 200 200 hmld_tm (:,:) = hmld_tm (:,:) + hmld (:,:) 201 201 fr_i_tm (:,:) = fr_i_tm (:,:) + fr_i (:,:) … … 208 208 sshb (:,:) = sshb_hold (:,:) 209 209 rnf (:,:) = rnf_tm (:,:) * r1_ndttrcp1 210 h_rnf (:,:) = h_rnf_tm (:,:) * r1_ndttrcp1210 !cbr h_rnf (:,:) = h_rnf_tm (:,:) * r1_ndttrcp1 211 211 hmld (:,:) = hmld_tm (:,:) * r1_ndttrcp1 212 212 ! variables that are initialized after averages … … 320 320 sshn_tm (:,:) = sshn (:,:) 321 321 rnf_tm (:,:) = rnf (:,:) 322 h_rnf_tm (:,:) = h_rnf (:,:)322 !cbr h_rnf_tm (:,:) = h_rnf (:,:) 323 323 hmld_tm (:,:) = hmld (:,:) 324 324 … … 379 379 ssha (:,:) = ssha_temp (:,:) 380 380 rnf (:,:) = rnf_temp (:,:) 381 h_rnf (:,:) = h_rnf_temp (:,:)381 !cbr h_rnf (:,:) = h_rnf_temp (:,:) 382 382 ! 383 383 hmld (:,:) = hmld_temp (:,:) … … 428 428 sshn_tm (:,:) = sshn (:,:) 429 429 rnf_tm (:,:) = rnf (:,:) 430 h_rnf_tm (:,:) = h_rnf (:,:)430 !cbr h_rnf_tm (:,:) = h_rnf (:,:) 431 431 hmld_tm (:,:) = hmld (:,:) 432 432 fr_i_tm (:,:) = fr_i (:,:)
Note: See TracChangeset
for help on using the changeset viewer.