Changeset 7083
- Timestamp:
- 2016-10-25T12:12:41+02:00 (8 years ago)
- Location:
- branches/UKMO/dev_r5518_GO6_package_MEDUSA_extra_CMIP6_diags/NEMOGCM/NEMO
- Files:
-
- 26 edited
-
LIM_SRC_3/limistate.F90 (modified) (4 diffs)
-
NST_SRC/agrif_lim2_interp.F90 (modified) (8 diffs)
-
OPA_SRC/DIA/diaar5.F90 (modified) (4 diffs)
-
OPA_SRC/DYN/dynzdf_imp.F90 (modified) (1 diff)
-
OPA_SRC/ICB/icbini.F90 (modified) (5 diffs)
-
OPA_SRC/LDF/ldfeiv.F90 (modified) (1 diff)
-
OPA_SRC/SBC/sbcblk_core.F90 (modified) (1 diff)
-
OPA_SRC/SBC/sbccpl.F90 (modified) (17 diffs)
-
OPA_SRC/TRA/eosbn2.F90 (modified) (2 diffs)
-
OPA_SRC/TRA/traadv.F90 (modified) (4 diffs)
-
OPA_SRC/TRA/traadv_eiv.F90 (modified) (5 diffs)
-
OPA_SRC/TRA/traadv_tvd.F90 (modified) (5 diffs)
-
OPA_SRC/TRA/traldf_iso.F90 (modified) (7 diffs)
-
OPA_SRC/TRA/tranxt.F90 (modified) (2 diffs)
-
OPA_SRC/TRA/trasbc.F90 (modified) (1 diff)
-
OPA_SRC/TRD/trd_oce.F90 (modified) (2 diffs)
-
OPA_SRC/TRD/trdini.F90 (modified) (1 diff)
-
OPA_SRC/TRD/trdtra.F90 (modified) (7 diffs)
-
OPA_SRC/ZDF/zdfevd.F90 (modified) (2 diffs)
-
OPA_SRC/oce.F90 (modified) (1 diff)
-
TOP_SRC/PISCES/P4Z/p4zopt.F90 (modified) (6 diffs)
-
TOP_SRC/PISCES/P4Z/p4zprod.F90 (modified) (1 diff)
-
TOP_SRC/TRP/trcadv.F90 (modified) (4 diffs)
-
TOP_SRC/TRP/trcdmp.F90 (modified) (7 diffs)
-
TOP_SRC/trcdta.F90 (modified) (12 diffs)
-
TOP_SRC/trcini.F90 (modified) (1 diff)
Legend:
- Unmodified
- Added
- Removed
-
branches/UKMO/dev_r5518_GO6_package_MEDUSA_extra_CMIP6_diags/NEMOGCM/NEMO/LIM_SRC_3/limistate.F90
r6498 r7083 246 246 ztest_1 = 1 247 247 ELSE 248 ! this write is useful249 IF(lwp) WRITE(numout,*) ' * TEST1 AREA NOT CONSERVED *** zA_cons = ', zA_cons,' zat_i_ini = ',zat_i_ini(i_hemis)250 248 ztest_1 = 0 251 249 ENDIF … … 258 256 ztest_2 = 1 259 257 ELSE 260 ! this write is useful261 IF(lwp) WRITE(numout,*) ' * TEST2 VOLUME NOT CONSERVED *** zV_cons = ', zV_cons, &262 ' zvt_i_ini = ', zvt_i_ini(i_hemis)263 258 ztest_2 = 0 264 259 ENDIF … … 268 263 ztest_3 = 1 269 264 ELSE 270 ! this write is useful271 IF(lwp) WRITE(numout,*) ' * TEST 3 THICKNESS OF THE LAST CATEGORY OUT OF BOUNDS *** zh_i_ini(i_fill,i_hemis) = ', &272 zh_i_ini(i_fill,i_hemis), ' hi_max(jpl-1) = ', hi_max(i_fill-1)273 265 ztest_3 = 0 274 266 ENDIF … … 278 270 DO jl = 1, jpl 279 271 IF ( za_i_ini(jl,i_hemis) .LT. 0._wp ) THEN 280 ! this write is useful281 IF(lwp) WRITE(numout,*) ' * TEST 4 POSITIVITY NOT OK FOR CAT ', jl, ' WITH A = ', za_i_ini(jl,i_hemis)282 272 ztest_4 = 0 283 273 ENDIF -
branches/UKMO/dev_r5518_GO6_package_MEDUSA_extra_CMIP6_diags/NEMOGCM/NEMO/NST_SRC/agrif_lim2_interp.F90
r6487 r7083 392 392 INTEGER :: ji,jj,jn 393 393 REAL(wp) :: zalpha 394 REAL(wp), DIMENSION(jpi,jpj,7) :: tabice_agr395 394 !!----------------------------------------------------------------------- 396 395 ! … … 529 528 END DO 530 529 END DO 530 ELSE 531 DO jj=MAX(j1,2),j2 532 DO ji=MAX(i1,2),i2 533 uice_agr(ji,jj) = tabres(ji,jj) 534 END DO 535 END DO 531 536 ENDIF 532 537 #else … … 541 546 END DO 542 547 END DO 548 ELSE 549 DO jj= j1, j2 550 DO ji= i1, i2 551 uice_agr(ji,jj) = tabres(ji,jj) 552 END DO 553 END DO 543 554 ENDIF 544 555 #endif … … 566 577 tabres(ji,jj) = e1f(ji-1,jj-1) * v_ice(ji,jj) 567 578 ENDIF 579 END DO 580 END DO 581 ELSE 582 DO jj=MAX(j1,2),j2 583 DO ji=MAX(i1,2),i2 584 vice_agr(ji,jj) = tabres(ji,jj) 568 585 END DO 569 586 END DO … … 580 597 END DO 581 598 END DO 599 ELSE 600 DO jj= j1 ,j2 601 DO ji = i1, i2 602 vice_agr(ji,jj) = tabres(ji,jj) 603 END DO 604 END DO 582 605 ENDIF 583 606 #endif … … 585 608 586 609 587 SUBROUTINE interp_adv_ice( tabres, i1, i2, j1, j2, before )610 SUBROUTINE interp_adv_ice( tabres, i1, i2, j1, j2, k1, k2, before ) 588 611 !!----------------------------------------------------------------------- 589 612 !! *** ROUTINE interp_adv_ice *** … … 593 616 !! put -9999 where no ice for correct extrapolation 594 617 !!----------------------------------------------------------------------- 595 INTEGER, INTENT(in) :: i1, i2, j1, j2 596 REAL(wp), DIMENSION(i1:i2,j1:j2, 7), INTENT(inout) :: tabres618 INTEGER, INTENT(in) :: i1, i2, j1, j2, k1, k2 619 REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: tabres 597 620 LOGICAL, INTENT(in) :: before 598 621 !! … … 601 624 ! 602 625 IF( before ) THEN 603 DO jj=j1,j2 604 DO ji=i1,i2 605 IF( tms(ji,jj) == 0. ) THEN 606 tabres(ji,jj,:) = -9999. 607 ELSE 608 tabres(ji,jj, 1) = frld (ji,jj) 609 tabres(ji,jj, 2) = hicif (ji,jj) 610 tabres(ji,jj, 3) = hsnif (ji,jj) 611 tabres(ji,jj, 4) = tbif (ji,jj,1) 612 tabres(ji,jj, 5) = tbif (ji,jj,2) 613 tabres(ji,jj, 6) = tbif (ji,jj,3) 614 tabres(ji,jj, 7) = qstoif(ji,jj) 615 ENDIF 616 END DO 617 END DO 626 DO jj=j1,j2 627 DO ji=i1,i2 628 IF( tms(ji,jj) == 0. ) THEN 629 tabres(ji,jj,:) = -9999 630 ELSE 631 tabres(ji,jj, 1) = frld (ji,jj) 632 tabres(ji,jj, 2) = hicif (ji,jj) 633 tabres(ji,jj, 3) = hsnif (ji,jj) 634 tabres(ji,jj, 4) = tbif (ji,jj,1) 635 tabres(ji,jj, 5) = tbif (ji,jj,2) 636 tabres(ji,jj, 6) = tbif (ji,jj,3) 637 tabres(ji,jj, 7) = qstoif(ji,jj) 638 ENDIF 639 END DO 640 END DO 641 ELSE 642 DO jj=j1,j2 643 DO ji=i1,i2 644 DO jk=k1, k2 645 tabice_agr(ji,jj,jk) = tabres(ji,jj,jk) 646 END DO 647 END DO 648 END DO 618 649 ENDIF 619 650 ! -
branches/UKMO/dev_r5518_GO6_package_MEDUSA_extra_CMIP6_diags/NEMOGCM/NEMO/OPA_SRC/DIA/diaar5.F90
r6731 r7083 212 212 REAL(wp) :: zztmp 213 213 REAL(wp), POINTER, DIMENSION(:,:,:,:) :: zsaldta ! Jan/Dec levitus salinity 214 ! reading initial file215 LOGICAL :: ln_tsd_init !: T & S data flag216 LOGICAL :: ln_tsd_tradmp !: internal damping toward input data flag217 CHARACTER(len=100) :: cn_dir218 TYPE(FLD_N) :: sn_tem,sn_sal219 INTEGER :: ios=0220 221 NAMELIST/namtsd/ ln_tsd_init,ln_tsd_tradmp,cn_dir,sn_tem,sn_sal222 !223 224 REWIND( numnam_ref ) ! Namelist namtsd in reference namelist :225 READ ( numnam_ref, namtsd, IOSTAT = ios, ERR = 901)226 901 IF( ios /= 0 ) CALL ctl_nam ( ios , ' namtsd in reference namelist for dia_ar5', lwp )227 REWIND( numnam_cfg ) ! Namelist namtsd in configuration namelist : Parameters of the run228 READ ( numnam_cfg, namtsd, IOSTAT = ios, ERR = 902 )229 902 IF( ios /= 0 ) CALL ctl_nam ( ios , ' namtsd in configuration namelist for dia_ar5', lwp )230 IF(lwm) WRITE ( numond, namtsd )231 214 ! 232 215 !!---------------------------------------------------------------------- … … 234 217 IF( nn_timing == 1 ) CALL timing_start('dia_ar5_init') 235 218 ! 236 CALL wrk_alloc( jpi , jpj , jpk, jpts, zsaldta )219 CALL wrk_alloc( jpi, jpj, jpk, 2, zsaldta ) 237 220 ! ! allocate dia_ar5 arrays 238 221 IF( dia_ar5_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'dia_ar5_init : unable to allocate arrays' ) … … 250 233 IF( lk_mpp ) CALL mpp_sum( vol0 ) 251 234 252 CALL iom_open ( TRIM( cn_dir )//TRIM(sn_sal%clname), inum )253 CALL iom_get ( inum, jpdom_data, TRIM(sn_sal%clvar), zsaldta(:,:,:,1), 1 )254 CALL iom_get ( inum, jpdom_data, TRIM(sn_sal%clvar), zsaldta(:,:,:,2), 12 )235 CALL iom_open ( 'sali_ref_clim_monthly', inum ) 236 CALL iom_get ( inum, jpdom_data, 'vosaline' , zsaldta(:,:,:,1), 1 ) 237 CALL iom_get ( inum, jpdom_data, 'vosaline' , zsaldta(:,:,:,2), 12 ) 255 238 CALL iom_close( inum ) 239 256 240 sn0(:,:,:) = 0.5_wp * ( zsaldta(:,:,:,1) + zsaldta(:,:,:,2) ) 257 241 sn0(:,:,:) = sn0(:,:,:) * tmask(:,:,:) … … 268 252 ENDIF 269 253 ! 270 CALL wrk_dealloc( jpi , jpj , jpk, jpts, zsaldta )254 CALL wrk_dealloc( jpi, jpj, jpk, 2, zsaldta ) 271 255 ! 272 256 IF( nn_timing == 1 ) CALL timing_stop('dia_ar5_init') -
branches/UKMO/dev_r5518_GO6_package_MEDUSA_extra_CMIP6_diags/NEMOGCM/NEMO/OPA_SRC/DYN/dynzdf_imp.F90
r6486 r7083 323 323 ze3va = ( 1._wp - r_vvl ) * fse3v_n(ji,jj,1) + r_vvl * fse3v_a(ji,jj,1) 324 324 va(ji,jj,1) = va(ji,jj,1) + p2dt * 0.5_wp * ( vtau_b(ji,jj) + vtau(ji,jj) ) & 325 & / ( ze3va * rau0 ) 325 & / ( ze3va * rau0 ) * vmask(ji,jj,1) 326 326 #else 327 327 va(ji,jj,1) = vb(ji,jj,1) & 328 328 & + p2dt *(va(ji,jj,1) + 0.5_wp * ( vtau_b(ji,jj) + vtau(ji,jj) ) & 329 & / ( fse3v(ji,jj,1) * rau0 ))329 & / ( fse3v(ji,jj,1) * rau0 ) * vmask(ji,jj,1) ) 330 330 #endif 331 331 END DO -
branches/UKMO/dev_r5518_GO6_package_MEDUSA_extra_CMIP6_diags/NEMOGCM/NEMO/OPA_SRC/ICB/icbini.F90
r6486 r7083 120 120 ! first entry with narea for this processor is left hand interior index 121 121 ! last entry is right hand interior index 122 jj = jpj/2122 jj = nlcj/2 123 123 nicbdi = -1 124 124 nicbei = -1 … … 136 136 ! 137 137 ! repeat for j direction 138 ji = jpi/2138 ji = nlci/2 139 139 nicbdj = -1 140 140 nicbej = -1 … … 153 153 ! special for east-west boundary exchange we save the destination index 154 154 i1 = MAX( nicbdi-1, 1) 155 i3 = INT( src_calving(i1, jpj/2) )155 i3 = INT( src_calving(i1,nlcj/2) ) 156 156 jj = INT( i3/nicbpack ) 157 157 ricb_left = REAL( i3 - nicbpack*jj, wp ) 158 158 i1 = MIN( nicbei+1, jpi ) 159 i3 = INT( src_calving(i1, jpj/2) )159 i3 = INT( src_calving(i1,nlcj/2) ) 160 160 jj = INT( i3/nicbpack ) 161 161 ricb_right = REAL( i3 - nicbpack*jj, wp ) … … 196 196 WRITE(numicb,*) 'berg left ', ricb_left 197 197 WRITE(numicb,*) 'berg right ', ricb_right 198 jj = jpj/2198 jj = nlcj/2 199 199 WRITE(numicb,*) "central j line:" 200 200 WRITE(numicb,*) "i processor" … … 202 202 WRITE(numicb,*) "i point" 203 203 WRITE(numicb,*) (INT(src_calving(ji,jj)), ji=1,jpi) 204 ji = jpi/2204 ji = nlci/2 205 205 WRITE(numicb,*) "central i line:" 206 206 WRITE(numicb,*) "j processor" -
branches/UKMO/dev_r5518_GO6_package_MEDUSA_extra_CMIP6_diags/NEMOGCM/NEMO/OPA_SRC/LDF/ldfeiv.F90
r6486 r7083 157 157 END DO 158 158 ENDIF 159 160 ! ORCA R1: Take the minimum between aeiw and aeiv0 161 IF( cp_cfg == "orca" .AND. jp_cfg == 1 ) THEN 162 DO jj = 2, jpjm1 163 DO ji = fs_2, fs_jpim1 ! vector opt. 164 aeiw(ji,jj) = MIN( aeiw(ji,jj), aeiv0 ) 165 END DO 166 END DO 167 ENDIF 168 159 169 CALL lbc_lnk( aeiw, 'W', 1. ) ! lateral boundary condition on aeiw 160 170 -
branches/UKMO/dev_r5518_GO6_package_MEDUSA_extra_CMIP6_diags/NEMOGCM/NEMO/OPA_SRC/SBC/sbcblk_core.F90
r6498 r7083 206 206 IF( MOD( kt - 1, nn_fsbc ) == 0 ) THEN 207 207 qlw_ice(:,:,1) = sf(jp_qlw)%fnow(:,:,1) 208 qsr_ice(:,:,1) = sf(jp_qsr)%fnow(:,:,1) 208 IF( ln_dm2dc ) THEN ; qsr_ice(:,:,1) = sbc_dcy( sf(jp_qsr)%fnow(:,:,1) ) 209 ELSE ; qsr_ice(:,:,1) = sf(jp_qsr)%fnow(:,:,1) 210 ENDIF 209 211 tatm_ice(:,:) = sf(jp_tair)%fnow(:,:,1) 210 212 qatm_ice(:,:) = sf(jp_humi)%fnow(:,:,1) -
branches/UKMO/dev_r5518_GO6_package_MEDUSA_extra_CMIP6_diags/NEMOGCM/NEMO/OPA_SRC/SBC/sbccpl.F90
r7033 r7083 1618 1618 !! *** ROUTINE sbc_cpl_ice_flx *** 1619 1619 !! 1620 !! ** Purpose : provide the heat and freshwater fluxes of the 1621 !! ocean-ice system. 1620 !! ** Purpose : provide the heat and freshwater fluxes of the ocean-ice system 1622 1621 !! 1623 1622 !! ** Method : transform the fields received from the atmosphere into 1624 1623 !! surface heat and fresh water boundary condition for the 1625 1624 !! ice-ocean system. The following fields are provided: 1626 !! * total non solar, solar and freshwater fluxes (qns_tot,1625 !! * total non solar, solar and freshwater fluxes (qns_tot, 1627 1626 !! qsr_tot and emp_tot) (total means weighted ice-ocean flux) 1628 1627 !! NB: emp_tot include runoffs and calving. 1629 !! * fluxes over ice (qns_ice, qsr_ice, emp_ice) where1628 !! * fluxes over ice (qns_ice, qsr_ice, emp_ice) where 1630 1629 !! emp_ice = sublimation - solid precipitation as liquid 1631 1630 !! precipitation are re-routed directly to the ocean and 1632 !! runoffs and calving directly enter the ocean.1633 !! * solid precipitation (sprecip), used to add to qns_tot1631 !! calving directly enter the ocean (runoffs are read but included in trasbc.F90) 1632 !! * solid precipitation (sprecip), used to add to qns_tot 1634 1633 !! the heat lost associated to melting solid precipitation 1635 1634 !! over the ocean fraction. 1636 !! ===>> CAUTION here this changes the net heat flux received from 1637 !! the atmosphere 1638 !! 1639 !! - the fluxes have been separated from the stress as 1640 !! (a) they are updated at each ice time step compare to 1641 !! an update at each coupled time step for the stress, and 1642 !! (b) the conservative computation of the fluxes over the 1643 !! sea-ice area requires the knowledge of the ice fraction 1644 !! after the ice advection and before the ice thermodynamics, 1645 !! so that the stress is updated before the ice dynamics 1646 !! while the fluxes are updated after it. 1635 !! * heat content of rain, snow and evap can also be provided, 1636 !! otherwise heat flux associated with these mass flux are 1637 !! guessed (qemp_oce, qemp_ice) 1638 !! 1639 !! - the fluxes have been separated from the stress as 1640 !! (a) they are updated at each ice time step compare to 1641 !! an update at each coupled time step for the stress, and 1642 !! (b) the conservative computation of the fluxes over the 1643 !! sea-ice area requires the knowledge of the ice fraction 1644 !! after the ice advection and before the ice thermodynamics, 1645 !! so that the stress is updated before the ice dynamics 1646 !! while the fluxes are updated after it. 1647 !! 1648 !! ** Details 1649 !! qns_tot = pfrld * qns_oce + ( 1 - pfrld ) * qns_ice => provided 1650 !! + qemp_oce + qemp_ice => recalculated and added up to qns 1651 !! 1652 !! qsr_tot = pfrld * qsr_oce + ( 1 - pfrld ) * qsr_ice => provided 1653 !! 1654 !! emp_tot = emp_oce + emp_ice => calving is provided and added to emp_tot (and emp_oce) 1655 !! river runoff (rnf) is provided but not included here 1647 1656 !! 1648 1657 !! ** Action : update at each nf_ice time step: 1649 1658 !! qns_tot, qsr_tot non-solar and solar total heat fluxes 1650 1659 !! qns_ice, qsr_ice non-solar and solar heat fluxes over the ice 1651 !! emp_tot total evaporation - precipitation(liquid and solid) (-runoff)(-calving)1652 !! emp_ice 1653 !! dqns_ice 1654 !! sprecip 1660 !! emp_tot total evaporation - precipitation(liquid and solid) (-calving) 1661 !! emp_ice ice sublimation - solid precipitation over the ice 1662 !! dqns_ice d(non-solar heat flux)/d(Temperature) over the ice 1663 !! sprecip solid precipitation over the ocean 1655 1664 !!---------------------------------------------------------------------- 1656 1665 REAL(wp), INTENT(in ), DIMENSION(:,:) :: p_frld ! lead fraction [0 to 1] … … 1662 1671 INTEGER :: jl ! dummy loop index 1663 1672 REAL(wp), POINTER, DIMENSION(:,: ) :: zcptn, ztmp, zicefr, zmsk, zsnw 1664 REAL(wp), POINTER, DIMENSION(:,: ) :: zemp_tot, zemp_ice, zemp_oce, ztprecip, zsprecip, zevap , zevap_ice, zdevap_ice1673 REAL(wp), POINTER, DIMENSION(:,: ) :: zemp_tot, zemp_ice, zemp_oce, ztprecip, zsprecip, zevap_oce, zevap_ice, zdevap_ice 1665 1674 REAL(wp), POINTER, DIMENSION(:,: ) :: zqns_tot, zqns_oce, zqsr_tot, zqsr_oce, zqprec_ice, zqemp_oce, zqemp_ice 1666 1675 REAL(wp), POINTER, DIMENSION(:,:,:) :: zqns_ice, zqsr_ice, zdqns_ice, zqevap_ice … … 1670 1679 ! 1671 1680 CALL wrk_alloc( jpi,jpj, zcptn, ztmp, zicefr, zmsk, zsnw ) 1672 CALL wrk_alloc( jpi,jpj, zemp_tot, zemp_ice, zemp_oce, ztprecip, zsprecip, zevap , zevap_ice, zdevap_ice )1681 CALL wrk_alloc( jpi,jpj, zemp_tot, zemp_ice, zemp_oce, ztprecip, zsprecip, zevap_oce, zevap_ice, zdevap_ice ) 1673 1682 CALL wrk_alloc( jpi,jpj, zqns_tot, zqns_oce, zqsr_tot, zqsr_oce, zqprec_ice, zqemp_oce, zqemp_ice ) 1674 1683 CALL wrk_alloc( jpi,jpj,jpl, zqns_ice, zqsr_ice, zdqns_ice, zqevap_ice ) … … 1679 1688 ! 1680 1689 ! ! ========================= ! 1681 ! ! freshwater budget ! (emp )1690 ! ! freshwater budget ! (emp_tot) 1682 1691 ! ! ========================= ! 1683 1692 ! 1684 ! ! total Precipitation - total Evaporation (emp_tot)1685 ! ! solid precipitation - sublimation (emp_ice)1686 ! ! solid Precipitation (sprecip)1687 ! ! liquid + solid Precipitation (tprecip)1693 ! ! solid Precipitation (sprecip) 1694 ! ! liquid + solid Precipitation (tprecip) 1695 ! ! total Evaporation - total Precipitation (emp_tot) 1696 ! ! sublimation - solid precipitation (cell average) (emp_ice) 1688 1697 SELECT CASE( TRIM( sn_rcv_emp%cldes ) ) 1689 1698 CASE( 'conservative' ) ! received fields: jpr_rain, jpr_snow, jpr_ievp, jpr_tevp … … 1717 1726 ENDIF 1718 1727 #else 1719 zemp_ice(:,:) = frcv(jpr_ievp)%z3(:,:,1) - frcv(jpr_snow)%z3(:,:,1)1728 zemp_ice(:,:) = ( frcv(jpr_ievp)%z3(:,:,1) - frcv(jpr_snow)%z3(:,:,1) ) * zicefr(:,:) 1720 1729 #endif 1721 1730 CALL iom_put( 'rain' , frcv(jpr_rain)%z3(:,:,1) * tmask(:,:,1) ) ! liquid precipitation … … 1733 1742 CASE( 'oce and ice' ) ! received fields: jpr_sbpr, jpr_semp, jpr_oemp, jpr_ievp 1734 1743 zemp_tot(:,:) = p_frld(:,:) * frcv(jpr_oemp)%z3(:,:,1) + zicefr(:,:) * frcv(jpr_sbpr)%z3(:,:,1) 1735 zemp_ice(:,:) = frcv(jpr_semp)%z3(:,:,1) 1744 zemp_ice(:,:) = frcv(jpr_semp)%z3(:,:,1) * zicefr(:,:) 1736 1745 zsprecip(:,:) = frcv(jpr_ievp)%z3(:,:,1) - frcv(jpr_semp)%z3(:,:,1) 1737 1746 ztprecip(:,:) = frcv(jpr_semp)%z3(:,:,1) - frcv(jpr_sbpr)%z3(:,:,1) + zsprecip(:,:) … … 1739 1748 1740 1749 #if defined key_lim3 1741 ! zsnw = snow percentage over ice after wind blowing 1742 zsnw(:,:) = 0._wp 1743 CALL lim_thd_snwblow( p_frld, zsnw ) 1750 ! zsnw = snow fraction over ice after wind blowing 1751 zsnw(:,:) = 0._wp ; CALL lim_thd_snwblow( p_frld, zsnw ) 1744 1752 1745 ! --- evaporation (kg/m2/s) --- ! 1753 ! --- evaporation minus precipitation corrected (because of wind blowing on snow) --- ! 1754 zemp_ice(:,:) = zemp_ice(:,:) + zsprecip(:,:) * ( zicefr(:,:) - zsnw(:,:) ) ! emp_ice = A * sublimation - zsnw * sprecip 1755 zemp_oce(:,:) = zemp_tot(:,:) - zemp_ice(:,:) ! emp_oce = emp_tot - emp_ice 1756 1757 ! --- evaporation over ocean (used later for qemp) --- ! 1758 zevap_oce(:,:) = frcv(jpr_tevp)%z3(:,:,1) - frcv(jpr_ievp)%z3(:,:,1) * zicefr(:,:) 1759 1760 ! --- evaporation over ice (kg/m2/s) --- ! 1746 1761 zevap_ice(:,:) = frcv(jpr_ievp)%z3(:,:,1) 1747 1762 ! since the sensitivity of evap to temperature (devap/dT) is not prescribed by the atmosphere, we set it to 0 … … 1749 1764 zdevap_ice(:,:) = 0._wp 1750 1765 1751 ! --- evaporation minus precipitation corrected for the effect of wind blowing on snow --- ! 1752 zemp_oce(:,:) = zemp_tot(:,:) - zemp_ice(:,:) - zsprecip * (1._wp - zsnw) 1753 zemp_ice(:,:) = zemp_ice(:,:) + zsprecip * (1._wp - zsnw) 1754 1755 ! Sublimation over sea-ice (cell average) 1756 IF( iom_use('subl_ai_cea') ) CALL iom_put( 'subl_ai_cea', zevap_ice(:,:) * zicefr(:,:) ) 1757 ! runoffs and calving (put in emp_tot) 1766 ! --- runoffs (included in emp later on) --- ! 1758 1767 IF( srcv(jpr_rnf)%laction ) rnf(:,:) = frcv(jpr_rnf)%z3(:,:,1) 1768 1769 ! --- calving (put in emp_tot and emp_oce) --- ! 1759 1770 IF( srcv(jpr_cal)%laction ) THEN 1760 1771 zemp_tot(:,:) = zemp_tot(:,:) - frcv(jpr_cal)%z3(:,:,1) 1772 zemp_oce(:,:) = zemp_oce(:,:) - frcv(jpr_cal)%z3(:,:,1) 1761 1773 CALL iom_put( 'calving_cea', frcv(jpr_cal)%z3(:,:,1) ) 1762 1774 ENDIF … … 1784 1796 ENDIF 1785 1797 1786 CALL iom_put( 'snowpre' , sprecip ) ! Snow 1787 IF( iom_use('snow_ao_cea') ) CALL iom_put( 'snow_ao_cea', sprecip(:,:) * ( 1._wp - zsnw ) ) ! Snow over ice-free ocean (cell average) 1788 IF( iom_use('snow_ai_cea') ) CALL iom_put( 'snow_ai_cea', sprecip(:,:) * zsnw ) ! Snow over sea-ice (cell average) 1798 IF( iom_use('subl_ai_cea') ) CALL iom_put( 'subl_ai_cea', zevap_ice(:,:) * zicefr(:,:) ) ! Sublimation over sea-ice (cell average) 1799 CALL iom_put( 'snowpre' , sprecip(:,:) ) ! Snow 1800 IF( iom_use('snow_ao_cea') ) CALL iom_put( 'snow_ao_cea', sprecip(:,:) * ( 1._wp - zsnw(:,:) ) ) ! Snow over ice-free ocean (cell average) 1801 IF( iom_use('snow_ai_cea') ) CALL iom_put( 'snow_ai_cea', sprecip(:,:) * zsnw(:,:) ) ! Snow over sea-ice (cell average) 1789 1802 #else 1790 ! Sublimation over sea-ice (cell average)1791 IF( iom_use('subl_ai_cea') ) CALL iom_put( 'subl_ai_cea', frcv(jpr_ievp)%z3(:,:,1) * zicefr(:,:) )1792 1803 ! runoffs and calving (put in emp_tot) 1793 1804 IF( srcv(jpr_rnf)%laction ) rnf(:,:) = frcv(jpr_rnf)%z3(:,:,1) … … 1821 1832 SELECT CASE( TRIM( sn_rcv_qns%cldes ) ) ! non solar heat fluxes ! (qns) 1822 1833 ! ! ========================= ! 1823 CASE( 'oce only' ) 1824 zqns_tot(:,: 1825 CASE( 'conservative' ) 1826 zqns_tot(:,: 1834 CASE( 'oce only' ) ! the required field is directly provided 1835 zqns_tot(:,:) = frcv(jpr_qnsoce)%z3(:,:,1) 1836 CASE( 'conservative' ) ! the required fields are directly provided 1837 zqns_tot(:,:) = frcv(jpr_qnsmix)%z3(:,:,1) 1827 1838 IF ( TRIM(sn_rcv_qns%clcat) == 'yes' ) THEN 1828 1839 zqns_ice(:,:,1:jpl) = frcv(jpr_qnsice)%z3(:,:,1:jpl) 1829 1840 ELSE 1830 ! Set all category values equal for the moment1831 1841 DO jl=1,jpl 1832 zqns_ice(:,:,jl) = frcv(jpr_qnsice)%z3(:,:,1) 1842 zqns_ice(:,:,jl) = frcv(jpr_qnsice)%z3(:,:,1) ! Set all category values equal 1833 1843 ENDDO 1834 1844 ENDIF 1835 CASE( 'oce and ice' ) 1836 zqns_tot(:,: 1845 CASE( 'oce and ice' ) ! the total flux is computed from ocean and ice fluxes 1846 zqns_tot(:,:) = p_frld(:,:) * frcv(jpr_qnsoce)%z3(:,:,1) 1837 1847 IF ( TRIM(sn_rcv_qns%clcat) == 'yes' ) THEN 1838 1848 DO jl=1,jpl … … 1841 1851 ENDDO 1842 1852 ELSE 1843 qns_tot(:,: 1853 qns_tot(:,:) = qns_tot(:,:) + zicefr(:,:) * frcv(jpr_qnsice)%z3(:,:,1) 1844 1854 DO jl=1,jpl 1845 1855 zqns_tot(:,: ) = zqns_tot(:,:) + zicefr(:,:) * frcv(jpr_qnsice)%z3(:,:,1) … … 1847 1857 ENDDO 1848 1858 ENDIF 1849 CASE( 'mixed oce-ice' ) 1859 CASE( 'mixed oce-ice' ) ! the ice flux is cumputed from the total flux, the SST and ice informations 1850 1860 ! ** NEED TO SORT OUT HOW THIS SHOULD WORK IN THE MULTI-CATEGORY CASE - CURRENTLY NOT ALLOWED WHEN INTERFACE INITIALISED ** 1851 1861 zqns_tot(:,: ) = frcv(jpr_qnsmix)%z3(:,:,1) 1852 1862 zqns_ice(:,:,1) = frcv(jpr_qnsmix)%z3(:,:,1) & 1853 1863 & + frcv(jpr_dqnsdt)%z3(:,:,1) * ( pist(:,:,1) - ( (rt0 + psst(:,: ) ) * p_frld(:,:) & 1854 & + pist(:,:,1)* zicefr(:,:) ) )1864 & + pist(:,:,1) * zicefr(:,:) ) ) 1855 1865 END SELECT 1856 1866 !!gm … … 1862 1872 !! similar job should be done for snow and precipitation temperature 1863 1873 ! 1864 IF( srcv(jpr_cal)%laction ) THEN ! Iceberg melting 1865 ztmp(:,:) = frcv(jpr_cal)%z3(:,:,1) * lfus ! add the latent heat of iceberg melting 1866 zqns_tot(:,:) = zqns_tot(:,:) - ztmp(:,:) 1867 IF( iom_use('hflx_cal_cea') ) & 1868 CALL iom_put( 'hflx_cal_cea', ztmp + frcv(jpr_cal)%z3(:,:,1) * zcptn(:,:) ) ! heat flux from calving 1869 ENDIF 1870 1871 ztmp(:,:) = p_frld(:,:) * zsprecip(:,:) * lfus 1872 IF( iom_use('hflx_snow_cea') ) CALL iom_put( 'hflx_snow_cea', ztmp + sprecip(:,:) * zcptn(:,:) ) ! heat flux from snow (cell average) 1874 IF( srcv(jpr_cal)%laction ) THEN ! Iceberg melting 1875 zqns_tot(:,:) = zqns_tot(:,:) - frcv(jpr_cal)%z3(:,:,1) * lfus ! add the latent heat of iceberg melting 1876 ! we suppose it melts at 0deg, though it should be temp. of surrounding ocean 1877 IF( iom_use('hflx_cal_cea') ) CALL iom_put( 'hflx_cal_cea', - frcv(jpr_cal)%z3(:,:,1) * lfus ) ! heat flux from calving 1878 ENDIF 1873 1879 1874 1880 #if defined key_lim3 1875 ! --- evaporation --- !1876 zevap(:,:) = zemp_tot(:,:) + ztprecip(:,:) ! evaporation over ocean1877 1878 1881 ! --- non solar flux over ocean --- ! 1879 1882 ! note: p_frld cannot be = 0 since we limit the ice concentration to amax … … 1882 1885 1883 1886 ! --- heat flux associated with emp (W/m2) --- ! 1884 zqemp_oce(:,:) = - zevap(:,:) * p_frld(:,:) * zcptn(:,:) &! evap1885 & + ( ztprecip(:,:) - zsprecip(:,:) ) * zcptn(:,:) & ! liquid precip1886 & + zsprecip(:,:) * ( 1._wp - zsnw ) * ( zcptn(:,:) - lfus ) ! solid precip over ocean1887 zqemp_oce(:,:) = - zevap_oce(:,:) * zcptn(:,:) & ! evap 1888 & + ( ztprecip(:,:) - zsprecip(:,:) ) * zcptn(:,:) & ! liquid precip 1889 & + zsprecip(:,:) * ( 1._wp - zsnw ) * ( zcptn(:,:) - lfus ) ! solid precip over ocean + snow melting 1887 1890 ! zqemp_ice(:,:) = - frcv(jpr_ievp)%z3(:,:,1) * zicefr(:,:) * zcptn(:,:) & ! ice evap 1888 1891 ! & + zsprecip(:,:) * zsnw * ( zcptn(:,:) - lfus ) ! solid precip over ice 1889 1892 zqemp_ice(:,:) = zsprecip(:,:) * zsnw * ( zcptn(:,:) - lfus ) ! solid precip over ice (only) 1890 ! qevap_ice=0 since we consider Tice=0 °C1893 ! qevap_ice=0 since we consider Tice=0degC 1891 1894 1892 ! --- heat content ofprecip over ice in J/m3 (to be used in 1D-thermo) --- !1895 ! --- enthalpy of snow precip over ice in J/m3 (to be used in 1D-thermo) --- ! 1893 1896 zqprec_ice(:,:) = rhosn * ( zcptn(:,:) - lfus ) 1894 1897 1895 1898 ! --- heat content of evap over ice in W/m2 (to be used in 1D-thermo) --- ! 1896 1899 DO jl = 1, jpl 1897 zqevap_ice(:,:,jl) = 0._wp ! should be -evap * ( ( Tice - rt0 ) * cpic ) but we do not have Tice, so we consider Tice=0 °C1900 zqevap_ice(:,:,jl) = 0._wp ! should be -evap * ( ( Tice - rt0 ) * cpic ) but we do not have Tice, so we consider Tice=0degC 1898 1901 END DO 1899 1902 … … 1921 1924 qemp_ice (:,: ) = zqemp_ice (:,: ) 1922 1925 ENDIF 1926 1927 !! clem: we should output qemp_oce and qemp_ice (at least) 1928 IF( iom_use('hflx_snow_cea') ) CALL iom_put( 'hflx_snow_cea', sprecip(:,:) * ( zcptn(:,:) - Lfus ) ) ! heat flux from snow (cell average) 1929 !! these diags are not outputed yet 1930 !! IF( iom_use('hflx_rain_cea') ) CALL iom_put( 'hflx_rain_cea', ( tprecip(:,:) - sprecip(:,:) ) * zcptn(:,:) ) ! heat flux from rain (cell average) 1931 !! IF( iom_use('hflx_snow_ao_cea') ) CALL iom_put( 'hflx_snow_ao_cea', sprecip(:,:) * ( zcptn(:,:) - Lfus ) * (1._wp - zsnw(:,:)) ) ! heat flux from snow (cell average) 1932 !! IF( iom_use('hflx_snow_ai_cea') ) CALL iom_put( 'hflx_snow_ai_cea', sprecip(:,:) * ( zcptn(:,:) - Lfus ) * zsnw(:,:) ) ! heat flux from snow (cell average) 1933 1923 1934 #else 1924 1935 ! clem: this formulation is certainly wrong... but better than it was... … … 1927 1938 & - (p_frld(:,:) * zsprecip(:,:) * lfus) & ! remove the latent heat flux of solid precip. melting 1928 1939 & - ( zemp_tot(:,:) & ! remove the heat content of mass flux (assumed to be at SST) 1929 & - zemp_ice(:,:) * zicefr(:,:)) * zcptn(:,:)1940 & - zemp_ice(:,:) ) * zcptn(:,:) 1930 1941 1931 1942 IF( ln_mixcpl ) THEN … … 2047 2058 2048 2059 CALL wrk_dealloc( jpi,jpj, zcptn, ztmp, zicefr, zmsk, zsnw ) 2049 CALL wrk_dealloc( jpi,jpj, zemp_tot, zemp_ice, zemp_oce, ztprecip, zsprecip, zevap , zevap_ice, zdevap_ice )2060 CALL wrk_dealloc( jpi,jpj, zemp_tot, zemp_ice, zemp_oce, ztprecip, zsprecip, zevap_oce, zevap_ice, zdevap_ice ) 2050 2061 CALL wrk_dealloc( jpi,jpj, zqns_tot, zqns_oce, zqsr_tot, zqsr_oce, zqprec_ice, zqemp_oce, zqemp_ice ) 2051 2062 CALL wrk_dealloc( jpi,jpj,jpl, zqns_ice, zqsr_ice, zdqns_ice, zqevap_ice ) -
branches/UKMO/dev_r5518_GO6_package_MEDUSA_extra_CMIP6_diags/NEMOGCM/NEMO/OPA_SRC/TRA/eosbn2.F90
r6498 r7083 1018 1018 DO jj = 1, jpj 1019 1019 DO ji = 1, jpi 1020 zs= SQRT( ABS( psal(ji,jj) ) * r1_S0) ! square root salinity1020 zs= SQRT( ABS( psal(ji,jj) ) / 35.16504_wp ) ! square root salinity 1021 1021 ptf(ji,jj) = ((((1.46873e-03_wp*zs-9.64972e-03_wp)*zs+2.28348e-02_wp)*zs & 1022 1022 & - 3.12775e-02_wp)*zs+2.07679e-02_wp)*zs-5.87701e-02_wp … … 1066 1066 CASE ( -1, 1 ) !== CT,SA (TEOS-10 formulation) ==! 1067 1067 ! 1068 zs = SQRT( ABS( psal ) * r1_S0) ! square root salinity1068 zs = SQRT( ABS( psal ) / 35.16504_wp ) ! square root salinity 1069 1069 ptf = ((((1.46873e-03_wp*zs-9.64972e-03_wp)*zs+2.28348e-02_wp)*zs & 1070 1070 & - 3.12775e-02_wp)*zs+2.07679e-02_wp)*zs-5.87701e-02_wp -
branches/UKMO/dev_r5518_GO6_package_MEDUSA_extra_CMIP6_diags/NEMOGCM/NEMO/OPA_SRC/TRA/traadv.F90
r6486 r7083 26 26 USE cla ! cross land advection (cla_traadv routine) 27 27 USE ldftra_oce ! lateral diffusion coefficient on tracers 28 USE trd_oce ! trends: ocean variables 29 USE trdtra ! trends manager: tracers 28 30 ! 29 31 USE in_out_manager ! I/O manager … … 79 81 INTEGER :: jk ! dummy loop index 80 82 REAL(wp), POINTER, DIMENSION(:,:,:) :: zun, zvn, zwn 83 REAL(wp), POINTER, DIMENSION(:,:,:) :: ztrdt, ztrds ! 3D workspace 81 84 !!---------------------------------------------------------------------- 82 85 ! … … 120 123 IF( ln_diaptr ) CALL dia_ptr( zvn ) ! diagnose the effective MSF 121 124 ! 122 125 IF( l_trdtra ) THEN !* Save ta and sa trends 126 CALL wrk_alloc( jpi, jpj, jpk, ztrdt, ztrds ) 127 ztrdt(:,:,:) = tsa(:,:,:,jp_tem) 128 ztrds(:,:,:) = tsa(:,:,:,jp_sal) 129 ENDIF 130 ! 123 131 SELECT CASE ( nadv ) !== compute advection trend and add it to general trend ==! 124 132 CASE ( 1 ) ; CALL tra_adv_cen2 ( kt, nit000, 'TRA', zun, zvn, zwn, tsb, tsn, tsa, jpts ) ! 2nd order centered … … 151 159 END SELECT 152 160 ! 161 IF( l_trdtra ) THEN ! save the advective trends for further diagnostics 162 DO jk = 1, jpkm1 163 ztrdt(:,:,jk) = tsa(:,:,jk,jp_tem) - ztrdt(:,:,jk) 164 ztrds(:,:,jk) = tsa(:,:,jk,jp_sal) - ztrds(:,:,jk) 165 END DO 166 CALL trd_tra( kt, 'TRA', jp_tem, jptra_totad, ztrdt ) 167 CALL trd_tra( kt, 'TRA', jp_sal, jptra_totad, ztrds ) 168 CALL wrk_dealloc( jpi, jpj, jpk, ztrdt, ztrds ) 169 ENDIF 153 170 ! ! print mean trends (used for debugging) 154 171 IF(ln_ctl) CALL prt_ctl( tab3d_1=tsa(:,:,:,jp_tem), clinfo1=' adv - Ta: ', mask1=tmask, & -
branches/UKMO/dev_r5518_GO6_package_MEDUSA_extra_CMIP6_diags/NEMOGCM/NEMO/OPA_SRC/TRA/traadv_eiv.F90
r6919 r7083 79 79 # endif 80 80 REAL(wp), POINTER, DIMENSION(:,:) :: zu_eiv, zv_eiv, zw_eiv, z2d 81 REAL(wp), POINTER, DIMENSION(:,:,:) :: z3d 81 REAL(wp), POINTER, DIMENSION(:,:,:) :: z3d, z3d_T 82 82 !!---------------------------------------------------------------------- 83 83 ! … … 86 86 # if defined key_diaeiv 87 87 CALL wrk_alloc( jpi, jpj, zu_eiv, zv_eiv, zw_eiv, z2d ) 88 IF( ln_diaptr ) CALL wrk_alloc( jpi, jpj, jpk, z3d)88 CALL wrk_alloc( jpi, jpj, jpk, z3d, z3d_T ) 89 89 # else 90 90 CALL wrk_alloc( jpi, jpj, zu_eiv, zv_eiv, zw_eiv ) … … 170 170 CALL iom_put( "weiv_masstr" , z3d ) 171 171 ENDIF 172 IF( iom_use("ueiv_masstr") .OR. iom_use("ueiv_heattr") ) THEN 172 IF( iom_use("ueiv_masstr") .OR. iom_use("ueiv_heattr") .OR. iom_use('ueiv_heattr3d') & 173 .OR. iom_use("ueiv_salttr") .OR. iom_use('ueiv_salttr3d') ) THEN 173 174 z3d(:,:,jpk) = 0.e0 174 z2d(:,:) = 0.e0175 175 DO jk = 1, jpkm1 176 176 z3d(:,:,jk) = rau0 * u_eiv(:,:,jk) * e2u(:,:) * fse3u(:,:,jk) * umask(:,:,jk) 177 z2d(:,:) = z2d(:,:) + z3d(:,:,jk)178 177 END DO 179 178 CALL iom_put( "ueiv_masstr", z3d ) ! mass transport in i-direction 180 179 ENDIF 181 180 182 IF( iom_use('ueiv_heattr') ) THEN181 IF( iom_use('ueiv_heattr') .OR. iom_use('ueiv_heattr3d') ) THEN 183 182 zztmp = 0.5 * rcp 184 183 z2d(:,:) = 0.e0 185 DO jk = 1, jpkm1 186 DO jj = 2, jpjm1 187 DO ji = fs_2, fs_jpim1 ! vector opt. 188 z2d(ji,jj) = z2d(ji,jj) + z3d(ji,jj,jk) * ( tsn(ji,jj,jk,jp_tem) + tsn(ji+1,jj,jk,jp_tem) ) 189 END DO 190 END DO 191 END DO 192 CALL lbc_lnk( z2d, 'U', -1. ) 193 CALL iom_put( "ueiv_heattr", zztmp * z2d ) ! heat transport in i-direction 194 ENDIF 195 196 IF( iom_use("veiv_masstr") .OR. iom_use("veiv_heattr") ) THEN 184 z3d_T(:,:,:) = 0.e0 185 DO jk = 1, jpkm1 186 DO jj = 2, jpjm1 187 DO ji = fs_2, fs_jpim1 ! vector opt. 188 z3d_T(ji,jj,jk) = z3d(ji,jj,jk) * ( tsn(ji,jj,jk,jp_tem) + tsn(ji+1,jj,jk,jp_tem) ) 189 z2d(ji,jj) = z2d(ji,jj) + z3d_T(ji,jj,jk) 190 END DO 191 END DO 192 END DO 193 IF (iom_use('ueiv_heattr') ) THEN 194 CALL lbc_lnk( z2d, 'U', -1. ) 195 CALL iom_put( "ueiv_heattr", zztmp * z2d ) ! 2D heat transport in i-direction 196 ENDIF 197 IF (iom_use('ueiv_heattr3d') ) THEN 198 CALL lbc_lnk( z3d_T, 'U', -1. ) 199 CALL iom_put( "ueiv_heattr3d", zztmp * z3d_T ) ! 3D heat transport in i-direction 200 ENDIF 201 ENDIF 202 203 IF( iom_use('ueiv_salttr') .OR. iom_use('ueiv_salttr3d') ) THEN 204 zztmp = 0.5 * 0.001 205 z2d(:,:) = 0.e0 206 z3d_T(:,:,:) = 0.e0 207 DO jk = 1, jpkm1 208 DO jj = 2, jpjm1 209 DO ji = fs_2, fs_jpim1 ! vector opt. 210 z3d_T(ji,jj,jk) = z3d(ji,jj,jk) * ( tsn(ji,jj,jk,jp_sal) + tsn(ji+1,jj,jk,jp_sal) ) 211 z2d(ji,jj) = z2d(ji,jj) + z3d_T(ji,jj,jk) 212 END DO 213 END DO 214 END DO 215 IF (iom_use('ueiv_salttr') ) THEN 216 CALL lbc_lnk( z2d, 'U', -1. ) 217 CALL iom_put( "ueiv_salttr", zztmp * z2d ) ! 2D salt transport in i-direction 218 ENDIF 219 IF (iom_use('ueiv_salttr3d') ) THEN 220 CALL lbc_lnk( z3d_T, 'U', -1. ) 221 CALL iom_put( "ueiv_salttr3d", zztmp * z3d_T ) ! 3D salt transport in i-direction 222 ENDIF 223 ENDIF 224 225 IF( iom_use("veiv_masstr") .OR. iom_use("veiv_heattr") .OR. iom_use('veiv_heattr3d') & 226 .OR. iom_use("veiv_salttr") .OR. iom_use('veiv_salttr3d') ) THEN 197 227 z3d(:,:,jpk) = 0.e0 198 z2d(:,:) = 0.e0199 228 DO jk = 1, jpkm1 200 229 z3d(:,:,jk) = rau0 * v_eiv(:,:,jk) * e1v(:,:) * fse3v(:,:,jk) * vmask(:,:,jk) … … 202 231 CALL iom_put( "veiv_masstr", z3d ) ! mass transport in j-direction 203 232 ENDIF 204 205 IF( iom_use('veiv_heattr') ) THEN 233 IF( iom_use('veiv_heattr') .OR. iom_use('veiv_heattr3d') ) THEN 206 234 zztmp = 0.5 * rcp 207 235 z2d(:,:) = 0.e0 208 DO jk = 1, jpkm1 209 DO jj = 2, jpjm1 210 DO ji = fs_2, fs_jpim1 ! vector opt. 211 z2d(ji,jj) = z2d(ji,jj) + z3d(ji,jj,jk) * ( tsn(ji,jj,jk,jp_tem) + tsn(ji,jj+1,jk,jp_tem) ) 212 END DO 213 END DO 214 END DO 215 CALL lbc_lnk( z2d, 'V', -1. ) 216 CALL iom_put( "veiv_heattr", zztmp * z2d ) ! heat transport in j-direction 217 ENDIF 236 z3d_T(:,:,:) = 0.e0 237 DO jk = 1, jpkm1 238 DO jj = 2, jpjm1 239 DO ji = fs_2, fs_jpim1 ! vector opt. 240 z3d_T(ji,jj,jk) = z3d(ji,jj,jk) * ( tsn(ji,jj,jk,jp_tem) + tsn(ji,jj+1,jk,jp_tem) ) 241 z2d(ji,jj) = z2d(ji,jj) + z3d_T(ji,jj,jk) 242 END DO 243 END DO 244 END DO 245 IF (iom_use('veiv_heattr') ) THEN 246 CALL lbc_lnk( z2d, 'V', -1. ) 247 CALL iom_put( "veiv_heattr", zztmp * z2d ) ! 2D heat transport in j-direction 248 ENDIF 249 IF (iom_use('veiv_heattr3d') ) THEN 250 CALL lbc_lnk( z3d_T, 'V', -1. ) 251 CALL iom_put( "veiv_heattr3d", zztmp * z3d_T ) ! 3D heat transport in j-direction 252 ENDIF 253 ENDIF 254 255 IF( iom_use('veiv_salttr') .OR. iom_use('veiv_salttr3d') ) THEN 256 zztmp = 0.5 * 0.001 257 z2d(:,:) = 0.e0 258 z3d_T(:,:,:) = 0.e0 259 DO jk = 1, jpkm1 260 DO jj = 2, jpjm1 261 DO ji = fs_2, fs_jpim1 ! vector opt. 262 z3d_T(ji,jj,jk) = z3d(ji,jj,jk) * ( tsn(ji,jj,jk,jp_sal) + tsn(ji,jj+1,jk,jp_sal) ) 263 z2d(ji,jj) = z2d(ji,jj) + z3d_T(ji,jj,jk) 264 END DO 265 END DO 266 END DO 267 IF (iom_use('veiv_salttr') ) THEN 268 CALL lbc_lnk( z2d, 'V', -1. ) 269 CALL iom_put( "veiv_salttr", zztmp * z2d ) ! 2D salt transport in i-direction 270 ENDIF 271 IF (iom_use('veiv_salttr3d') ) THEN 272 CALL lbc_lnk( z3d_T, 'V', -1. ) 273 CALL iom_put( "veiv_salttr3d", zztmp * z3d_T ) ! 3D salt transport in i-direction 274 ENDIF 275 ENDIF 276 277 IF( iom_use('weiv_masstr') .OR. iom_use('weiv_heattr3d') .OR. iom_use('weiv_salttr3d')) THEN ! vertical mass transport & its square value 278 z2d(:,:) = rau0 * e12t(:,:) 279 DO jk = 1, jpk 280 z3d(:,:,jk) = w_eiv(:,:,jk) * z2d(:,:) 281 END DO 282 CALL iom_put( "weiv_masstr" , z3d ) ! mass transport in k-direction 283 ENDIF 284 285 IF( iom_use('weiv_heattr3d') ) THEN 286 zztmp = 0.5 * rcp 287 DO jk = 1, jpkm1 288 DO jj = 2, jpjm1 289 DO ji = fs_2, fs_jpim1 ! vector opt. 290 z3d_T(ji,jj,jk) = z3d(ji,jj,jk) * ( tsn(ji,jj,jk,jp_tem) + tsn(ji,jj,jk+1,jp_tem) ) 291 END DO 292 END DO 293 END DO 294 CALL lbc_lnk( z3d_T, 'T', 1. ) 295 CALL iom_put( "weiv_heattr3d", zztmp * z3d_T ) ! 3D heat transport in k-direction 296 ENDIF 297 298 IF( iom_use('weiv_salttr3d') ) THEN 299 zztmp = 0.5 * 0.001 300 DO jk = 1, jpkm1 301 DO jj = 2, jpjm1 302 DO ji = fs_2, fs_jpim1 ! vector opt. 303 z3d_T(ji,jj,jk) = z3d(ji,jj,jk) * ( tsn(ji,jj,jk,jp_sal) + tsn(ji,jj,jk+1,jp_sal) ) 304 END DO 305 END DO 306 END DO 307 CALL lbc_lnk( z3d_T, 'T', 1. ) 308 CALL iom_put( "weiv_salttr3d", zztmp * z3d_T ) ! 3D salt transport in k-direction 309 ENDIF 310 218 311 END IF 219 312 ! … … 244 337 # if defined key_diaeiv 245 338 CALL wrk_dealloc( jpi, jpj, zu_eiv, zv_eiv, zw_eiv, z2d ) 246 IF( ln_diaptr ) CALL wrk_dealloc( jpi, jpj, jpk, z3d)339 CALL wrk_dealloc( jpi, jpj, jpk, z3d, z3d_T ) 247 340 # else 248 341 CALL wrk_dealloc( jpi, jpj, zu_eiv, zv_eiv, zw_eiv ) -
branches/UKMO/dev_r5518_GO6_package_MEDUSA_extra_CMIP6_diags/NEMOGCM/NEMO/OPA_SRC/TRA/traadv_tvd.F90
r6731 r7083 184 184 DO jj = 2, jpjm1 185 185 DO ji = fs_2, fs_jpim1 ! vector opt. 186 zbtr = 1. / ( e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) )187 186 ! total intermediate advective trends 188 ztra = - zbtr *( zwx(ji,jj,jk) - zwx(ji-1,jj ,jk ) &189 & 190 & + zwz(ji,jj,jk) - zwz(ji ,jj ,jk+1))187 ztra = - ( zwx(ji,jj,jk) - zwx(ji-1,jj ,jk ) & 188 & + zwy(ji,jj,jk) - zwy(ji ,jj-1,jk ) & 189 & + zwz(ji,jj,jk) - zwz(ji ,jj ,jk+1) ) / e1e2t(ji,jj) 191 190 ! update and guess with monotonic sheme 192 pta(ji,jj,jk,jn) = pta(ji,jj,jk,jn) + ztra* tmask(ji,jj,jk)193 zwi(ji,jj,jk) = ( ptb(ji,jj,jk,jn) + z2dtt * ztra) * tmask(ji,jj,jk)191 pta(ji,jj,jk,jn) = pta(ji,jj,jk,jn) + ztra / fse3t_n(ji,jj,jk) * tmask(ji,jj,jk) 192 zwi(ji,jj,jk) = ( fse3t_b(ji,jj,jk) * ptb(ji,jj,jk,jn) + z2dtt * ztra ) / fse3t_a(ji,jj,jk) * tmask(ji,jj,jk) 194 193 END DO 195 194 END DO … … 454 453 DO jj = 2, jpjm1 455 454 DO ji = fs_2, fs_jpim1 ! vector opt. 456 zbtr = 1._wp / ( e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) )457 455 ! total intermediate advective trends 458 ztra = - zbtr *( zwx(ji,jj,jk) - zwx(ji-1,jj ,jk ) &459 & 460 & + zwz(ji,jj,jk) - zwz(ji ,jj ,jk+1))456 ztra = - ( zwx(ji,jj,jk) - zwx(ji-1,jj ,jk ) & 457 & + zwy(ji,jj,jk) - zwy(ji ,jj-1,jk ) & 458 & + zwz(ji,jj,jk) - zwz(ji ,jj ,jk+1) ) / e1e2t(ji,jj) 461 459 ! update and guess with monotonic sheme 462 pta(ji,jj,jk,jn) = pta(ji,jj,jk,jn) + ztra463 zwi(ji,jj,jk) = ( ptb(ji,jj,jk,jn) + z2dtt * ztra) * tmask(ji,jj,jk)460 pta(ji,jj,jk,jn) = pta(ji,jj,jk,jn) + ztra / fse3t_n(ji,jj,jk) * tmask(ji,jj,jk) 461 zwi(ji,jj,jk) = ( fse3t_b(ji,jj,jk) * ptb(ji,jj,jk,jn) + z2dtt * ztra ) / fse3t_a(ji,jj,jk) * tmask(ji,jj,jk) 464 462 END DO 465 463 END DO … … 479 477 ! -------------------------------------------------- 480 478 ! antidiffusive flux on i and j 481 482 479 ! 483 480 DO jk = 1, jpkm1 484 481 ! 485 482 DO jj = 1, jpjm1 486 483 DO ji = 1, fs_jpim1 ! vector opt. … … 513 510 ! 514 511 ztrs(:,:,:,1) = ptb(:,:,:,jn) 512 ztrs(:,:,1,2) = ptb(:,:,1,jn) 513 ztrs(:,:,1,3) = ptb(:,:,1,jn) 515 514 zwzts(:,:,:) = 0._wp 516 515 … … 614 613 END SUBROUTINE tra_adv_tvd_zts 615 614 615 616 616 SUBROUTINE nonosc( pbef, paa, pbb, pcc, paft, p2dt ) 617 617 !!--------------------------------------------------------------------- -
branches/UKMO/dev_r5518_GO6_package_MEDUSA_extra_CMIP6_diags/NEMOGCM/NEMO/OPA_SRC/TRA/traldf_iso.F90
r6731 r7083 26 26 USE ldfslp ! iso-neutral slopes 27 27 USE diaptr ! poleward transport diagnostics 28 USE trd_oce ! trends: ocean variables 29 USE trdtra ! trends manager: tracers 28 30 USE in_out_manager ! I/O manager 29 31 USE iom ! I/O library … … 105 107 INTEGER :: ji, jj, jk, jn ! dummy loop indices 106 108 INTEGER :: ikt 107 REAL(wp) :: zmsku, zabe1, zcof1, zcoef3 ! local scalars108 REAL(wp) :: zmskv, zabe2, zcof2, zcoef4 ! - -109 REAL(wp) :: zcoef0, zbtr , ztra! - -109 REAL(wp) :: zmsku, zabe1, zcof1, zcoef3 ! local scalars 110 REAL(wp) :: zmskv, zabe2, zcof2, zcoef4 ! - - 111 REAL(wp) :: zcoef0, zbtr ! - - 110 112 REAL(wp), POINTER, DIMENSION(:,: ) :: z2d 111 113 REAL(wp), POINTER, DIMENSION(:,:,:) :: zdkt, zdk1t, zdit, zdjt, ztfw 114 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:), TARGET :: ztrax, ztray, ztraz 115 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:), TARGET :: ztrax_T, ztray_T, ztraz_T 112 116 !!---------------------------------------------------------------------- 113 117 ! … … 115 119 ! 116 120 CALL wrk_alloc( jpi, jpj, z2d ) 117 CALL wrk_alloc( jpi, jpj, jpk, zdit, zdjt, ztfw, zdkt, zdk1t ) 121 CALL wrk_alloc( jpi, jpj, jpk, zdit, zdjt, ztfw, zdkt, zdk1t) 122 ALLOCATE( ztrax(jpi,jpj,jpk), ztray(jpi,jpj,jpk), ztraz(jpi,jpj,jpk) ) 123 IF( l_trdtra .and. cdtype == 'TRA' ) ALLOCATE( ztrax_T(jpi,jpj,jpk), ztray_T(jpi,jpj,jpk), ztraz_T(jpi,jpj,jpk) ) 118 124 ! 119 125 … … 127 133 DO jn = 1, kjpt ! tracer loop 128 134 ! ! =========== 135 ztrax(:,:,:) = 0._wp ; ztray(:,:,:) = 0._wp ; ztraz(:,:,:) = 0._wp ; 129 136 ! 130 137 !!---------------------------------------------------------------------- … … 226 233 DO ji = fs_2, fs_jpim1 ! vector opt. 227 234 zbtr = 1.0 / ( e12t(ji,jj) * fse3t_n(ji,jj,jk) ) 228 ztra = zbtr * ( zftu(ji,jj,jk) - zftu(ji-1,jj,jk) + zftv(ji,jj,jk) - zftv(ji,jj-1,jk))229 pta(ji,jj,jk,jn) = pta(ji,jj,jk,jn) + ztra235 ztrax(ji,jj,jk) = zbtr * ( zftu(ji,jj,jk) - zftu(ji-1,jj,jk) ) 236 ztray(ji,jj,jk) = zbtr * ( zftv(ji,jj,jk) - zftv(ji,jj-1,jk) ) 230 237 END DO 231 238 END DO … … 233 240 END DO ! End of slab 234 241 ! ! =============== 242 ! 243 pta(:,:,:,jn) = pta(:,:,:,jn) + ztrax(:,:,:) + ztray(:,:,:) 235 244 ! 236 245 ! "Poleward" diffusive heat or salt transports (T-S case only) … … 311 320 DO ji = fs_2, fs_jpim1 ! vector opt. 312 321 zbtr = 1.0 / ( e12t(ji,jj) * fse3t_n(ji,jj,jk) ) 313 ztra = ( ztfw(ji,jj,jk) - ztfw(ji,jj,jk+1) ) * zbtr 314 pta(ji,jj,jk,jn) = pta(ji,jj,jk,jn) + ztra 322 ztraz(ji,jj,jk) = ( ztfw(ji,jj,jk) - ztfw(ji,jj,jk+1) ) * zbtr 315 323 END DO 316 324 END DO 317 325 END DO 326 pta(:,:,:,jn) = pta(:,:,:,jn) + ztraz(:,:,:) 318 327 ! 328 IF( l_trdtra .AND. cdtype == "TRA" .AND. jn .eq. 1 ) THEN ! save the temperature trends 329 ztrax_T(:,:,:) = ztrax(:,:,:) 330 ztray_T(:,:,:) = ztray(:,:,:) 331 ztraz_T(:,:,:) = ztraz(:,:,:) 332 ENDIF 333 IF( l_trdtra .AND. cdtype == "TRC" ) THEN ! save the horizontal component of diffusive trends for further diagnostics 334 CALL trd_tra( kt, cdtype, jn, jptra_iso_x, ztrax ) 335 CALL trd_tra( kt, cdtype, jn, jptra_iso_y, ztray ) 336 CALL trd_tra( kt, cdtype, jn, jptra_iso_z1, ztraz ) ! This is the first part of the vertical component. 337 ENDIF 319 338 END DO 339 ! 340 IF( l_trdtra .AND. cdtype == "TRA" ) THEN ! save the horizontal component of diffusive trends for further diagnostics 341 CALL trd_tra( kt, cdtype, jp_tem, jptra_iso_x, ztrax_T ) 342 CALL trd_tra( kt, cdtype, jp_sal, jptra_iso_x, ztrax ) 343 CALL trd_tra( kt, cdtype, jp_tem, jptra_iso_y, ztray_T ) 344 CALL trd_tra( kt, cdtype, jp_sal, jptra_iso_y, ztray ) 345 CALL trd_tra( kt, cdtype, jp_tem, jptra_iso_z1, ztraz_T ) ! This is the first part of the vertical component 346 CALL trd_tra( kt, cdtype, jp_sal, jptra_iso_z1, ztraz ) ! 347 ENDIF 320 348 ! 321 349 CALL wrk_dealloc( jpi, jpj, z2d ) 322 350 CALL wrk_dealloc( jpi, jpj, jpk, zdit, zdjt, ztfw, zdkt, zdk1t ) 351 DEALLOCATE( ztrax, ztray, ztraz ) 352 IF( l_trdtra ) DEALLOCATE( ztrax_T, ztray_T, ztraz_T ) 323 353 ! 324 354 IF( nn_timing == 1 ) CALL timing_stop('tra_ldf_iso') -
branches/UKMO/dev_r5518_GO6_package_MEDUSA_extra_CMIP6_diags/NEMOGCM/NEMO/OPA_SRC/TRA/tranxt.F90
r6487 r7083 129 129 IF( l_trdtra ) THEN ! store now fields before applying the Asselin filter 130 130 CALL wrk_alloc( jpi, jpj, jpk, ztrdt, ztrds ) 131 ! Asselin filter trend 131 132 ztrdt(:,:,:) = tsn(:,:,:,jp_tem) 132 133 ztrds(:,:,:) = tsn(:,:,:,jp_sal) … … 135 136 CALL trd_tra( kt, 'TRA', jp_sal, jptra_zdfp, ztrds ) 136 137 ENDIF 138 ! total trend (note slightly inaccurate because tsb is time-filtered and tsa isn't) 139 ztrdt(:,:,:) = 0._wp 140 ztrds(:,:,:) = 0._wp 141 DO jk = 1, jpkm1 142 ztrdt(:,:,jk) = ( tsa(:,:,jk,jp_tem) - tsb(:,:,jk,jp_tem) ) / r2dtra(jk) 143 ztrds(:,:,jk) = ( tsa(:,:,jk,jp_sal) - tsb(:,:,jk,jp_sal) ) / r2dtra(jk) 144 END DO 145 CALL trd_tra( kt, 'TRA', jp_tem, jptra_tot, ztrdt ) 146 CALL trd_tra( kt, 'TRA', jp_sal, jptra_tot, ztrds ) 137 147 ENDIF 138 148 -
branches/UKMO/dev_r5518_GO6_package_MEDUSA_extra_CMIP6_diags/NEMOGCM/NEMO/OPA_SRC/TRA/trasbc.F90
r6487 r7083 158 158 ELSE ! No restart or restart not found: Euler forward time stepping 159 159 zfact = 1._wp 160 sbc_tsc(:,:,:) = 0._wp 160 161 sbc_tsc_b(:,:,:) = 0._wp 161 162 ENDIF -
branches/UKMO/dev_r5518_GO6_package_MEDUSA_extra_CMIP6_diags/NEMOGCM/NEMO/OPA_SRC/TRD/trd_oce.F90
r6486 r7083 33 33 # endif 34 34 ! !!!* Active tracers trends indexes 35 INTEGER, PUBLIC, PARAMETER :: jptot_tra = 14!: Total trend nb: change it when adding/removing one indice below35 INTEGER, PUBLIC, PARAMETER :: jptot_tra = 20 !: Total trend nb: change it when adding/removing one indice below 36 36 ! =============== ! 37 37 INTEGER, PUBLIC, PARAMETER :: jptra_xad = 1 !: x- horizontal advection … … 39 39 INTEGER, PUBLIC, PARAMETER :: jptra_zad = 3 !: z- vertical advection 40 40 INTEGER, PUBLIC, PARAMETER :: jptra_sad = 4 !: z- vertical advection 41 INTEGER, PUBLIC, PARAMETER :: jptra_ldf = 5 !: lateral diffusion 42 INTEGER, PUBLIC, PARAMETER :: jptra_zdf = 6 !: vertical diffusion 43 INTEGER, PUBLIC, PARAMETER :: jptra_zdfp = 7 !: "PURE" vert. diffusion (ln_traldf_iso=T) 44 INTEGER, PUBLIC, PARAMETER :: jptra_bbc = 8 !: Bottom Boundary Condition (geoth. heating) 45 INTEGER, PUBLIC, PARAMETER :: jptra_bbl = 9 !: Bottom Boundary Layer (diffusive and/or advective) 46 INTEGER, PUBLIC, PARAMETER :: jptra_npc = 10 !: non-penetrative convection treatment 47 INTEGER, PUBLIC, PARAMETER :: jptra_dmp = 11 !: internal restoring (damping) 48 INTEGER, PUBLIC, PARAMETER :: jptra_qsr = 12 !: penetrative solar radiation 49 INTEGER, PUBLIC, PARAMETER :: jptra_nsr = 13 !: non solar radiation / C/D on salinity (+runoff if ln_rnf=T) 50 INTEGER, PUBLIC, PARAMETER :: jptra_atf = 14 !: Asselin time filter 41 INTEGER, PUBLIC, PARAMETER :: jptra_totad = 5 !: total advection 42 INTEGER, PUBLIC, PARAMETER :: jptra_ldf = 6 !: lateral diffusion 43 INTEGER, PUBLIC, PARAMETER :: jptra_iso_x = 7 !: x-component of isopycnal diffusion 44 INTEGER, PUBLIC, PARAMETER :: jptra_iso_y = 8 !: y-component of isopycnal diffusion 45 INTEGER, PUBLIC, PARAMETER :: jptra_iso_z1 = 9 !: z-component of isopycnal diffusion 46 INTEGER, PUBLIC, PARAMETER :: jptra_zdf = 10 !: vertical diffusion 47 INTEGER, PUBLIC, PARAMETER :: jptra_zdfp = 11 !: "PURE" vert. diffusion (ln_traldf_iso=T) 48 INTEGER, PUBLIC, PARAMETER :: jptra_evd = 12 !: EVD term (convection) 49 INTEGER, PUBLIC, PARAMETER :: jptra_bbc = 13 !: Bottom Boundary Condition (geoth. heating) 50 INTEGER, PUBLIC, PARAMETER :: jptra_bbl = 14 !: Bottom Boundary Layer (diffusive and/or advective) 51 INTEGER, PUBLIC, PARAMETER :: jptra_npc = 15 !: non-penetrative convection treatment 52 INTEGER, PUBLIC, PARAMETER :: jptra_dmp = 16 !: internal restoring (damping) 53 INTEGER, PUBLIC, PARAMETER :: jptra_qsr = 17 !: penetrative solar radiation 54 INTEGER, PUBLIC, PARAMETER :: jptra_nsr = 18 !: non solar radiation / C/D on salinity (+runoff if ln_rnf=T) 55 INTEGER, PUBLIC, PARAMETER :: jptra_atf = 19 !: Asselin time filter 56 INTEGER, PUBLIC, PARAMETER :: jptra_tot = 20 !: Model total trend 51 57 ! 52 58 ! !!!* Passive tracers trends indices (use if "key_top" defined) 53 INTEGER, PUBLIC, PARAMETER :: jptra_sms = 1 5!: sources m. sinks54 INTEGER, PUBLIC, PARAMETER :: jptra_radn = 16!: corr. trn<0 in trcrad55 INTEGER, PUBLIC, PARAMETER :: jptra_radb = 17!: corr. trb<0 in trcrad (like atf)59 INTEGER, PUBLIC, PARAMETER :: jptra_sms = 19 !: sources m. sinks 60 INTEGER, PUBLIC, PARAMETER :: jptra_radn = 20 !: corr. trn<0 in trcrad 61 INTEGER, PUBLIC, PARAMETER :: jptra_radb = 21 !: corr. trb<0 in trcrad (like atf) 56 62 ! 57 63 ! !!!* Momentum trends indices -
branches/UKMO/dev_r5518_GO6_package_MEDUSA_extra_CMIP6_diags/NEMOGCM/NEMO/OPA_SRC/TRD/trdini.F90
r6486 r7083 91 91 !!gm end 92 92 ! 93 IF( lk_vvl .AND. ( l_trdtra .OR. l_trddyn ) ) CALL ctl_stop( 'trend diagnostics with variable volume not validated' )94 93 95 94 !!gm : Potential BUG : 3D output only for vector invariant form! add a ctl_stop or code the flux form case -
branches/UKMO/dev_r5518_GO6_package_MEDUSA_extra_CMIP6_diags/NEMOGCM/NEMO/OPA_SRC/TRD/trdtra.F90
r6486 r7083 38 38 REAL(wp) :: r2dt ! time-step, = 2 rdttra except at nit000 (=rdttra) if neuler=0 39 39 40 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: trdtx, trdty, trdt ! use to store the temperature trends 40 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: trdtx, trdty, trdt ! use to store the temperature trends 41 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: avt_evd ! store avt_evd to calculate EVD trend 41 42 42 43 !! * Substitutions … … 55 56 !! *** FUNCTION trd_tra_alloc *** 56 57 !!--------------------------------------------------------------------- 57 ALLOCATE( trdtx(jpi,jpj,jpk) , trdty(jpi,jpj,jpk) , trdt(jpi,jpj,jpk) , STAT= trd_tra_alloc )58 ALLOCATE( trdtx(jpi,jpj,jpk) , trdty(jpi,jpj,jpk) , trdt(jpi,jpj,jpk) , avt_evd(jpi,jpj,jpk), STAT= trd_tra_alloc ) 58 59 ! 59 60 IF( lk_mpp ) CALL mpp_sum ( trd_tra_alloc ) … … 104 105 ztrds(:,:,:) = 0._wp 105 106 CALL trd_tra_mng( trdt, ztrds, ktrd, kt ) 107 CASE( jptra_evd ) ; avt_evd(:,:,:) = ptrd(:,:,:) * tmask(:,:,:) 106 108 CASE DEFAULT ! other trends: masked trends 107 109 trdt(:,:,:) = ptrd(:,:,:) * tmask(:,:,:) ! mask & store … … 138 140 END DO 139 141 CALL trd_tra_mng( ztrdt, ztrds, jptra_zdfp, kt ) 142 ! 143 ! ! Also calculate EVD trend at this point. 144 zwt(:,:,:) = 0._wp ; zws(:,:,:) = 0._wp ! vertical diffusive fluxes 145 DO jk = 2, jpk 146 zwt(:,:,jk) = avt_evd(:,:,jk) * ( tsa(:,:,jk-1,jp_tem) - tsa(:,:,jk,jp_tem) ) / fse3w(:,:,jk) * tmask(:,:,jk) 147 zws(:,:,jk) = avt_evd(:,:,jk) * ( tsa(:,:,jk-1,jp_sal) - tsa(:,:,jk,jp_sal) ) / fse3w(:,:,jk) * tmask(:,:,jk) 148 END DO 149 ! 150 ztrdt(:,:,jpk) = 0._wp ; ztrds(:,:,jpk) = 0._wp 151 DO jk = 1, jpkm1 152 ztrdt(:,:,jk) = ( zwt(:,:,jk) - zwt(:,:,jk+1) ) / fse3t(:,:,jk) 153 ztrds(:,:,jk) = ( zws(:,:,jk) - zws(:,:,jk+1) ) / fse3t(:,:,jk) 154 END DO 155 CALL trd_tra_mng( ztrdt, ztrds, jptra_evd, kt ) 140 156 ! 141 157 CALL wrk_dealloc( jpi, jpj, jpk, zwt, zws, ztrdt ) … … 312 328 CALL wrk_dealloc( jpi, jpj, z2dx, z2dy ) 313 329 ENDIF 330 CASE( jptra_totad ) ; CALL iom_put( "ttrd_totad" , ptrdx ) ! total advection 331 CALL iom_put( "strd_totad" , ptrdy ) 314 332 CASE( jptra_ldf ) ; CALL iom_put( "ttrd_ldf" , ptrdx ) ! lateral diffusion 315 333 CALL iom_put( "strd_ldf" , ptrdy ) … … 318 336 CASE( jptra_zdfp ) ; CALL iom_put( "ttrd_zdfp", ptrdx ) ! PURE vertical diffusion (no isoneutral contribution) 319 337 CALL iom_put( "strd_zdfp", ptrdy ) 338 CASE( jptra_evd ) ; CALL iom_put( "ttrd_evd", ptrdx ) ! EVD trend (convection) 339 CALL iom_put( "strd_evd", ptrdy ) 340 CASE( jptra_iso_x ) ; CALL iom_put( "ttrd_iso_x", ptrdx ) ! x-component of isopycnal mixing 341 CALL iom_put( "strd_iso_x", ptrdy ) 342 CASE( jptra_iso_y ) ; CALL iom_put( "ttrd_iso_y", ptrdx ) ! y-component of isopycnal mixing 343 CALL iom_put( "strd_iso_y", ptrdy ) 344 CASE( jptra_iso_z1 ) ; CALL iom_put( "ttrd_iso_z1", ptrdx ) ! first part of z-component of isopycnal mixing 345 CALL iom_put( "strd_iso_z1", ptrdy ) 320 346 CASE( jptra_dmp ) ; CALL iom_put( "ttrd_dmp" , ptrdx ) ! internal restoring (damping) 321 347 CALL iom_put( "strd_dmp" , ptrdy ) … … 330 356 CASE( jptra_atf ) ; CALL iom_put( "ttrd_atf" , ptrdx ) ! asselin time Filter 331 357 CALL iom_put( "strd_atf" , ptrdy ) 358 CASE( jptra_tot ) ; CALL iom_put( "ttrd_tot" , ptrdx ) ! model total trend 359 CALL iom_put( "strd_tot" , ptrdy ) 332 360 END SELECT 333 361 ! -
branches/UKMO/dev_r5518_GO6_package_MEDUSA_extra_CMIP6_diags/NEMOGCM/NEMO/OPA_SRC/ZDF/zdfevd.F90
r6486 r7083 19 19 USE zdf_oce ! ocean vertical physics variables 20 20 USE zdfkpp ! KPP vertical mixing 21 USE trd_oce ! trends: ocean variables 22 USE trdtra ! trends manager: tracers 21 23 USE in_out_manager ! I/O manager 22 24 USE iom ! for iom_put … … 122 124 zavt_evd(:,:,:) = avt(:,:,:) - zavt_evd(:,:,:) ! change in avt due to evd 123 125 CALL iom_put( "avt_evd", zavt_evd ) ! output this change 126 IF( l_trdtra ) CALL trd_tra( kt, 'TRA', jp_tem, jptra_evd, zavt_evd ) 124 127 ! 125 128 IF( nn_timing == 1 ) CALL timing_stop('zdf_evd') -
branches/UKMO/dev_r5518_GO6_package_MEDUSA_extra_CMIP6_diags/NEMOGCM/NEMO/OPA_SRC/oce.F90
r6698 r7083 140 140 PCO2a_in_cpl(jpi,jpj), Dust_in_cpl(jpi,jpj), STAT=ierr(5) ) 141 141 142 ! RSRH Temporarily initialise output coupling fields while we await clarification143 ! of exactly how these will be initialised at model startup!144 DMS_out_cpl(:,:) = 0.0145 CO2Flux_out_cpl(:,:) = 0.0146 142 ENDIF 147 143 #endif -
branches/UKMO/dev_r5518_GO6_package_MEDUSA_extra_CMIP6_diags/NEMOGCM/NEMO/TOP_SRC/PISCES/P4Z/p4zopt.F90
r6618 r7083 76 76 REAL(wp) :: zchl 77 77 REAL(wp) :: zc0 , zc1 , zc2, zc3, z1_dep 78 REAL(wp), POINTER, DIMENSION(:,: ) :: zdepmoy, zetmp1, zetmp2, zetmp3, zetmp4, zqsr100 78 REAL(wp), POINTER, DIMENSION(:,: ) :: zdepmoy, zetmp1, zetmp2, zetmp3, zetmp4 79 REAL(wp), POINTER, DIMENSION(:,: ) :: zqsr100, zqsr_corr 79 80 REAL(wp), POINTER, DIMENSION(:,:,:) :: zpar, ze0, ze1, ze2, ze3 80 81 !!--------------------------------------------------------------------- … … 83 84 ! 84 85 ! Allocate temporary workspace 85 CALL wrk_alloc( jpi, jpj, zqsr100, zdepmoy, zetmp1, zetmp2, zetmp3, zetmp4 ) 86 CALL wrk_alloc( jpi, jpj, zdepmoy, zetmp1, zetmp2, zetmp3, zetmp4 ) 87 CALL wrk_alloc( jpi, jpj, zqsr100, zqsr_corr ) 86 88 CALL wrk_alloc( jpi, jpj, jpk, zpar, ze0, ze1, ze2, ze3 ) 87 89 … … 112 114 ! ! -------------------------------------- 113 115 IF( l_trcdm2dc ) THEN ! diurnal cycle 114 ! 1% of qsr to compute euphotic layer116 ! ! 1% of qsr to compute euphotic layer 115 117 zqsr100(:,:) = 0.01 * qsr_mean(:,:) ! daily mean qsr 116 118 ! 117 CALL p4z_opt_par( kt, qsr_mean, ze1, ze2, ze3 ) 119 zqsr_corr(:,:) = qsr_mean(:,:) / ( 1. - fr_i(:,:) + rtrn ) 120 ! 121 CALL p4z_opt_par( kt, zqsr_corr, ze1, ze2, ze3 ) 118 122 ! 119 123 DO jk = 1, nksrp … … 123 127 END DO 124 128 ! 125 CALL p4z_opt_par( kt, qsr, ze1, ze2, ze3 ) 129 zqsr_corr(:,:) = qsr(:,:) / ( 1. - fr_i(:,:) + rtrn ) 130 ! 131 CALL p4z_opt_par( kt, zqsr_corr, ze1, ze2, ze3 ) 126 132 ! 127 133 DO jk = 1, nksrp … … 133 139 zqsr100(:,:) = 0.01 * qsr(:,:) 134 140 ! 135 CALL p4z_opt_par( kt, qsr, ze1, ze2, ze3 ) 141 zqsr_corr(:,:) = qsr(:,:) / ( 1. - fr_i(:,:) + rtrn ) 142 ! 143 CALL p4z_opt_par( kt, zqsr_corr, ze1, ze2, ze3 ) 136 144 ! 137 145 DO jk = 1, nksrp … … 226 234 ENDIF 227 235 ! 228 CALL wrk_dealloc( jpi, jpj, zqsr100, zdepmoy, zetmp1, zetmp2, zetmp3, zetmp4 ) 236 CALL wrk_dealloc( jpi, jpj, zdepmoy, zetmp1, zetmp2, zetmp3, zetmp4 ) 237 CALL wrk_dealloc( jpi, jpj, zqsr100, zqsr_corr ) 229 238 CALL wrk_dealloc( jpi, jpj, jpk, zpar, ze0, ze1, ze2, ze3 ) 230 239 ! -
branches/UKMO/dev_r5518_GO6_package_MEDUSA_extra_CMIP6_diags/NEMOGCM/NEMO/TOP_SRC/PISCES/P4Z/p4zprod.F90
r6618 r7083 136 136 zval = MAX( 1., zstrn(ji,jj) ) 137 137 zval = 1.5 * zval / ( 12. + zval ) 138 zprbio(ji,jj,jk) = prmax(ji,jj,jk) * zval 138 zprbio(ji,jj,jk) = prmax(ji,jj,jk) * zval * ( 1. - fr_i(ji,jj) ) 139 139 zprdia(ji,jj,jk) = zprbio(ji,jj,jk) 140 140 ENDIF -
branches/UKMO/dev_r5518_GO6_package_MEDUSA_extra_CMIP6_diags/NEMOGCM/NEMO/TOP_SRC/TRP/trcadv.F90
r6486 r7083 26 26 USE traadv_mle ! ML eddy induced velocity (tra_adv_mle routine) 27 27 USE ldftra_oce ! lateral diffusion coefficient on tracers 28 USE trd_oce 29 USE trdtra 28 30 USE prtctl_trc ! Print control 29 31 … … 74 76 CHARACTER (len=22) :: charout 75 77 REAL(wp), POINTER, DIMENSION(:,:,:) :: zun, zvn, zwn ! effective velocity 78 REAL(wp), POINTER, DIMENSION(:,:,:,:) :: ztrtrd 76 79 !!---------------------------------------------------------------------- 77 80 ! … … 111 114 IF( ln_mle ) CALL tra_adv_mle( kt, nittrc000, zun, zvn, zwn, 'TRC' ) ! add the mle transport (if necessary) 112 115 ! 116 IF( l_trdtrc ) THEN 117 CALL wrk_alloc( jpi, jpj, jpk, jptra, ztrtrd ) 118 ztrtrd(:,:,:,:) = tra(:,:,:,:) 119 ENDIF 120 ! 113 121 SELECT CASE ( nadv ) !== compute advection trend and add it to general trend ==! 114 122 CASE ( 1 ) ; CALL tra_adv_cen2 ( kt, nittrc000, 'TRC', zun, zvn, zwn, trb, trn, tra, jptra ) ! 2nd order centered … … 140 148 ! 141 149 END SELECT 150 ! 151 IF( l_trdtrc ) THEN ! save the advective trends for further diagnostics 152 DO jn = 1, jptra 153 ztrtrd(:,:,:,jn) = tra(:,:,:,jn) - ztrtrd(:,:,:,jn) 154 CALL trd_tra( kt, 'TRC', jn, jptra_totad, ztrtrd(:,:,:,jn) ) 155 END DO 156 CALL wrk_dealloc( jpi, jpj, jpk, jptra, ztrtrd ) 157 ENDIF 142 158 143 159 ! ! print mean trends (used for debugging) -
branches/UKMO/dev_r5518_GO6_package_MEDUSA_extra_CMIP6_diags/NEMOGCM/NEMO/TOP_SRC/TRP/trcdmp.F90
r6498 r7083 35 35 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: restotr ! restoring coeff. on tracers (s-1) 36 36 37 INTEGER, PARAMETER :: npncts = 5! number of closed sea37 INTEGER, PARAMETER :: npncts = 8 ! number of closed sea 38 38 INTEGER, DIMENSION(npncts) :: nctsi1, nctsj1 ! south-west closed sea limits (i,j) 39 39 INTEGER, DIMENSION(npncts) :: nctsi2, nctsj2 ! north-east closed sea limits (i,j) … … 107 107 108 108 jl = n_trc_index(jn) 109 CALL trc_dta( kt, sf_trcdta(jl) ) ! read tracer data at nit000 110 ztrcdta(:,:,:) = sf_trcdta(jl)%fnow(:,:,:) * tmask(:,:,:) * rf_trfac(jl) 109 CALL trc_dta( kt, sf_trcdta(jl), rf_trfac(jl), ztrcdta ) ! read tracer data at nit000 111 110 112 111 SELECT CASE ( nn_zdmp_tr ) … … 187 186 INTEGER :: ji , jj, jk, jn, jl, jc ! dummy loop indicesa 188 187 INTEGER :: isrow ! local index 188 REAL(wp), POINTER, DIMENSION(:,:,:) :: ztrcdta ! 3D workspace 189 189 190 190 !!---------------------------------------------------------------------- … … 207 207 ! 208 208 ! Caspian Sea 209 nctsi1(1) = 332 ; nctsj1(1) = 243 - isrow 210 nctsi2(1) = 344 ; nctsj2(1) = 275 - isrow 209 nctsi1(1) = 333 ; nctsj1(1) = 243 - isrow 210 nctsi2(1) = 342 ; nctsj2(1) = 274 - isrow 211 ! ! Lake Superior 212 nctsi1(2) = 198 ; nctsj1(2) = 258 - isrow 213 nctsi2(2) = 204 ; nctsj2(2) = 262 - isrow 214 ! ! Lake Michigan 215 nctsi1(3) = 201 ; nctsj1(3) = 250 - isrow 216 nctsi2(3) = 203 ; nctsj2(3) = 256 - isrow 217 ! ! Lake Huron 218 nctsi1(4) = 204 ; nctsj1(4) = 252 - isrow 219 nctsi2(4) = 209 ; nctsj2(4) = 256 - isrow 220 ! ! Lake Erie 221 nctsi1(5) = 206 ; nctsj1(5) = 249 - isrow 222 nctsi2(5) = 209 ; nctsj2(5) = 251 - isrow 223 ! ! Lake Ontario 224 nctsi1(6) = 210 ; nctsj1(6) = 252 - isrow 225 nctsi2(6) = 212 ; nctsj2(6) = 252 - isrow 226 ! ! Victoria Lake 227 nctsi1(7) = 321 ; nctsj1(7) = 180 - isrow 228 nctsi2(7) = 322 ; nctsj2(7) = 189 - isrow 229 ! ! Baltic Sea 230 nctsi1(8) = 297 ; nctsj1(8) = 270 - isrow 231 nctsi2(8) = 308 ; nctsj2(8) = 293 - isrow 211 232 ! 212 233 ! ! ======================= … … 277 298 IF(lwp) WRITE(numout,*) 278 299 ! 300 CALL wrk_alloc( jpi, jpj, jpk, ztrcdta ) ! Memory allocation 301 ! 279 302 DO jn = 1, jptra 280 303 IF( ln_trc_ini(jn) ) THEN ! update passive tracers arrays with input data read from file 281 304 jl = n_trc_index(jn) 282 CALL trc_dta( kt, sf_trcdta(jl) ) ! read tracer data at nit000305 CALL trc_dta( kt, sf_trcdta(jl), rf_trfac(jl), ztrcdta ) ! read tracer data at nit000 283 306 DO jc = 1, npncts 284 307 DO jk = 1, jpkm1 285 308 DO jj = nctsj1(jc), nctsj2(jc) 286 309 DO ji = nctsi1(jc), nctsi2(jc) 287 trn(ji,jj,jk,jn) = sf_trcdta(jl)%fnow(ji,jj,jk) * tmask(ji,jj,jk) * rf_trfac(jl)310 trn(ji,jj,jk,jn) = ztrcdta(ji,jj,jk) 288 311 trb(ji,jj,jk,jn) = trn(ji,jj,jk,jn) 289 312 ENDDO … … 293 316 ENDIF 294 317 ENDDO 295 !318 CALL wrk_dealloc( jpi, jpj, jpk, ztrcdta ) 296 319 ENDIF 297 320 ! … … 313 336 IF( nn_timing == 1 ) CALL timing_start('trc_dmp_init') 314 337 ! 338 !Allocate arrays 339 IF( trc_dmp_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'trc_dmp_init: unable to allocate arrays' ) 315 340 316 341 IF( lzoom ) nn_zdmp_tr = 0 ! restoring to climatology at closed north or south boundaries -
branches/UKMO/dev_r5518_GO6_package_MEDUSA_extra_CMIP6_diags/NEMOGCM/NEMO/TOP_SRC/trcdta.F90
r6498 r7083 77 77 ALLOCATE( n_trc_index(ntrc), slf_i(ntrc), STAT=ierr0 ) 78 78 IF( ierr0 > 0 ) THEN 79 CALL ctl_stop( 'trc_ nam: unable to allocate n_trc_index' ) ; RETURN79 CALL ctl_stop( 'trc_dta_init: unable to allocate n_trc_index' ) ; RETURN 80 80 ENDIF 81 81 nb_trcdta = 0 … … 91 91 IF(lwp) THEN 92 92 WRITE(numout,*) ' ' 93 WRITE(numout,*) 'trc_dta_init : Passive tracers Initial Conditions ' 94 WRITE(numout,*) '~~~~~~~~~~~~~~ ' 93 95 WRITE(numout,*) ' number of passive tracers to be initialize by data :', ntra 94 96 WRITE(numout,*) ' ' … … 107 109 DO jn = 1, ntrc 108 110 IF( ln_trc_ini(jn) ) THEN ! open input file only if ln_trc_ini(jn) is true 109 clndta = TRIM( sn_trcdta(jn)%clvar ) 110 clntrc = TRIM( ctrcnm (jn) ) 111 clndta = TRIM( sn_trcdta(jn)%clvar ) 112 if (jn > jptra) then 113 clntrc='Dummy' ! By pass weird formats in ocean.output if ntrc > jptra 114 else 115 clntrc = TRIM( ctrcnm (jn) ) 116 endif 111 117 zfact = rn_trfac(jn) 112 IF( clndta /= clntrc ) THEN 113 CALL ctl_warn( 'trc_dta_init: passive tracer data initialisation :', &114 & ' the variable name in the data file : '//clndta// &115 & ' must be the same than the name of the passive tracer : '//clntrc//' ')118 IF( clndta /= clntrc ) THEN 119 CALL ctl_warn( 'trc_dta_init: passive tracer data initialisation ', & 120 & 'Input name of data file : '//TRIM(clndta)// & 121 & ' differs from that of tracer : '//TRIM(clntrc)//' ') 116 122 ENDIF 117 WRITE(numout, *) ' read an initial file for passive tracer number :', jn, ' name : ', clndta, &118 & ' multiplicativefactor : ', zfact123 WRITE(numout,'(a, i4,3a,e11.3)') ' Read IC file for tracer number :', & 124 & jn, ', name : ', TRIM(clndta), ', Multiplicative Scaling factor : ', zfact 119 125 ENDIF 120 126 END DO … … 124 130 ALLOCATE( sf_trcdta(nb_trcdta), rf_trfac(nb_trcdta), STAT=ierr1 ) 125 131 IF( ierr1 > 0 ) THEN 126 CALL ctl_stop( 'trc_dta_ini : unable to allocate sf_trcdta structure' ) ; RETURN132 CALL ctl_stop( 'trc_dta_init: unable to allocate sf_trcdta structure' ) ; RETURN 127 133 ENDIF 128 134 ! … … 135 141 IF( sn_trcdta(jn)%ln_tint ) ALLOCATE( sf_trcdta(jl)%fdta(jpi,jpj,jpk,2) , STAT=ierr3 ) 136 142 IF( ierr2 + ierr3 > 0 ) THEN 137 CALL ctl_stop( 'trc_dta : unable to allocate passive tracer data arrays' ) ; RETURN143 CALL ctl_stop( 'trc_dta_init : unable to allocate passive tracer data arrays' ) ; RETURN 138 144 ENDIF 139 145 ENDIF … … 141 147 ENDDO 142 148 ! ! fill sf_trcdta with slf_i and control print 143 CALL fld_fill( sf_trcdta, slf_i, cn_dir, 'trc_dta ', 'Passive tracer data', 'namtrc' )149 CALL fld_fill( sf_trcdta, slf_i, cn_dir, 'trc_dta_init', 'Passive tracer data', 'namtrc' ) 144 150 ! 145 151 ENDIF … … 151 157 152 158 153 SUBROUTINE trc_dta( kt, sf_dta 159 SUBROUTINE trc_dta( kt, sf_dta, ptrfac, ptrc) 154 160 !!---------------------------------------------------------------------- 155 161 !! *** ROUTINE trc_dta *** … … 164 170 !!---------------------------------------------------------------------- 165 171 INTEGER , INTENT(in ) :: kt ! ocean time-step 166 TYPE(FLD), DIMENSION(1) , INTENT(inout) :: sf_dta ! array of information on the field to read 172 TYPE(FLD), DIMENSION(1) , INTENT(inout) :: sf_dta ! array of information on the field to read 173 REAL(wp) , INTENT(in ) :: ptrfac ! multiplication factor 174 REAL(wp), DIMENSION(jpi,jpj,jpk), OPTIONAL , INTENT(out ) :: ptrc 167 175 ! 168 176 INTEGER :: ji, jj, jk, jl, jkk, ik ! dummy loop indices 169 177 REAL(wp):: zl, zi 170 178 REAL(wp), DIMENSION(jpk) :: ztp ! 1D workspace 179 REAL(wp), POINTER, DIMENSION(:,:,:) :: ztrcdta ! 3D workspace 171 180 CHARACTER(len=100) :: clndta 172 181 !!---------------------------------------------------------------------- … … 176 185 IF( nb_trcdta > 0 ) THEN 177 186 ! 187 CALL wrk_alloc( jpi, jpj, jpk, ztrcdta ) ! Memory allocation 188 ! 178 189 CALL fld_read( kt, 1, sf_dta ) !== read data at kt time step ==! 190 ztrcdta(:,:,:) = sf_dta(1)%fnow(:,:,:) * tmask(:,:,:) ! Mask 179 191 ! 180 192 IF( ln_sco ) THEN !== s- or mixed s-zps-coordinate ==! … … 185 197 ENDIF 186 198 ! 187 DO jj = 1, jpj ! vertical interpolation of T & S 199 DO jj = 1, jpj ! vertical interpolation of T & S 200 DO ji = 1, jpi 201 DO jk = 1, jpk ! determines the intepolated T-S profiles at each (i,j) points 202 zl = fsdept_n(ji,jj,jk) 203 IF( zl < gdept_1d(1 ) ) THEN ! above the first level of data 204 ztp(jk) = ztrcdta(ji,jj,1) 205 ELSEIF( zl > gdept_1d(jpk) ) THEN ! below the last level of data 206 ztp(jk) = ztrcdta(ji,jj,jpkm1) 207 ELSE ! inbetween : vertical interpolation between jkk & jkk+1 208 DO jkk = 1, jpkm1 ! when gdept(jkk) < zl < gdept(jkk+1) 209 IF( (zl-gdept_1d(jkk)) * (zl-gdept_1d(jkk+1)) <= 0._wp ) THEN 210 zi = ( zl - gdept_1d(jkk) ) / (gdept_1d(jkk+1)-gdept_1d(jkk)) 211 ztp(jk) = ztrcdta(ji,jj,jkk) + ( ztrcdta(ji,jj,jkk+1) - & 212 ztrcdta(ji,jj,jkk) ) * zi 213 ENDIF 214 END DO 215 ENDIF 216 END DO 217 DO jk = 1, jpkm1 218 ztrcdta(ji,jj,jk) = ztp(jk) * tmask(ji,jj,jk) ! mask required for mixed zps-s-coord 219 END DO 220 ztrcdta(ji,jj,jpk) = 0._wp 221 END DO 222 END DO 223 ! 224 ELSE !== z- or zps- coordinate ==! 225 ! 226 IF( ln_zps ) THEN ! zps-coordinate (partial steps) interpolation at the last ocean level 227 DO jj = 1, jpj 188 228 DO ji = 1, jpi 189 DO jk = 1, jpk ! determines the intepolated T-S profiles at each (i,j) points 190 zl = fsdept_n(ji,jj,jk) 191 IF( zl < gdept_1d(1 ) ) THEN ! above the first level of data 192 ztp(jk) = sf_dta(1)%fnow(ji,jj,1) 193 ELSEIF( zl > gdept_1d(jpk) ) THEN ! below the last level of data 194 ztp(jk) = sf_dta(1)%fnow(ji,jj,jpkm1) 195 ELSE ! inbetween : vertical interpolation between jkk & jkk+1 196 DO jkk = 1, jpkm1 ! when gdept(jkk) < zl < gdept(jkk+1) 197 IF( (zl-gdept_1d(jkk)) * (zl-gdept_1d(jkk+1)) <= 0._wp ) THEN 198 zi = ( zl - gdept_1d(jkk) ) / (gdept_1d(jkk+1)-gdept_1d(jkk)) 199 ztp(jk) = sf_dta(1)%fnow(ji,jj,jkk) + ( sf_dta(1)%fnow(ji,jj,jkk+1) - & 200 sf_dta(1)%fnow(ji,jj,jkk) ) * zi 201 ENDIF 202 END DO 203 ENDIF 204 END DO 205 DO jk = 1, jpkm1 206 sf_dta(1)%fnow(ji,jj,jk) = ztp(jk) * tmask(ji,jj,jk) ! mask required for mixed zps-s-coord 207 END DO 208 sf_dta(1)%fnow(ji,jj,jpk) = 0._wp 229 ik = mbkt(ji,jj) 230 IF( ik > 1 ) THEN 231 zl = ( gdept_1d(ik) - fsdept_n(ji,jj,ik) ) / ( gdept_1d(ik) - gdept_1d(ik-1) ) 232 ztrcdta(ji,jj,ik) = (1.-zl) * ztrcdta(ji,jj,ik) + zl * ztrcdta(ji,jj,ik-1) 233 ENDIF 234 ik = mikt(ji,jj) 235 IF( ik > 1 ) THEN 236 zl = ( fsdept_n(ji,jj,ik) - gdept_1d(ik) ) / ( gdept_1d(ik+1) - gdept_1d(ik) ) 237 ztrcdta(ji,jj,ik) = (1.-zl) * ztrcdta(ji,jj,ik) + zl * ztrcdta(ji,jj,ik+1) 238 ENDIF 209 239 END DO 210 240 END DO 211 ! 212 ELSE !== z- or zps- coordinate ==! 213 ! 214 sf_dta(1)%fnow(:,:,:) = sf_dta(1)%fnow(:,:,:) * tmask(:,:,:) ! Mask 215 ! 216 IF( ln_zps ) THEN ! zps-coordinate (partial steps) interpolation at the last ocean level 217 DO jj = 1, jpj 218 DO ji = 1, jpi 219 ik = mbkt(ji,jj) 220 IF( ik > 1 ) THEN 221 zl = ( gdept_1d(ik) - fsdept_n(ji,jj,ik) ) / ( gdept_1d(ik) - gdept_1d(ik-1) ) 222 sf_dta(1)%fnow(ji,jj,ik) = (1.-zl) * sf_dta(1)%fnow(ji,jj,ik) + zl * sf_dta(1)%fnow(ji,jj,ik-1) 223 ENDIF 224 ik = mikt(ji,jj) 225 IF( ik > 1 ) THEN 226 zl = ( gdept_0(ji,jj,ik) - gdept_1d(ik) ) / ( gdept_1d(ik+1) - gdept_1d(ik) ) 227 sf_dta(1)%fnow(ji,jj,ik) = (1.-zl) * sf_dta(1)%fnow(ji,jj,ik) + zl * sf_dta(1)%fnow(ji,jj,ik+1) 228 ENDIF 229 END DO 230 END DO 231 ENDIF 232 ! 233 ENDIF 241 ENDIF 242 ! 243 ENDIF 244 ! 245 ! Add multiplicative factor 246 ztrcdta(:,:,:) = ztrcdta(:,:,:) * ptrfac 247 ! 248 ! Data structure for trc_ini (and BFMv5.1 coupling) 249 IF( .NOT. PRESENT(ptrc) ) sf_dta(1)%fnow(:,:,:) = ztrcdta(:,:,:) 250 ! 251 ! Data structure for trc_dmp 252 IF( PRESENT(ptrc) ) ptrc(:,:,:) = ztrcdta(:,:,:) 234 253 ! 235 254 IF( lwp .AND. kt == nit000 ) THEN … … 238 257 WRITE(numout,*) 239 258 WRITE(numout,*)' level = 1' 240 CALL prihre( sf_dta(1)%fnow(:,:,1), jpi, jpj, 1, jpi, 20, 1, jpj, 20, 1., numout )259 CALL prihre( ztrcdta(:,:,1), jpi, jpj, 1, jpi, 20, 1, jpj, 20, 1., numout ) 241 260 WRITE(numout,*)' level = ', jpk/2 242 CALL prihre( sf_dta(1)%fnow(:,:,jpk/2), jpi, jpj, 1, jpi, 20, 1, jpj, 20, 1., numout )261 CALL prihre( ztrcdta(:,:,jpk/2), jpi, jpj, 1, jpi, 20, 1, jpj, 20, 1., numout ) 243 262 WRITE(numout,*)' level = ', jpkm1 244 CALL prihre( sf_dta(1)%fnow(:,:,jpkm1), jpi, jpj, 1, jpi, 20, 1, jpj, 20, 1., numout )263 CALL prihre( ztrcdta(:,:,jpkm1), jpi, jpj, 1, jpi, 20, 1, jpj, 20, 1., numout ) 245 264 WRITE(numout,*) 246 265 ENDIF 266 ! 267 CALL wrk_dealloc( jpi, jpj, jpk, ztrcdta ) 268 ! 247 269 ENDIF 248 270 ! … … 255 277 !!---------------------------------------------------------------------- 256 278 CONTAINS 257 SUBROUTINE trc_dta( kt, sf_dta, zrf_trfac) ! Empty routine279 SUBROUTINE trc_dta( kt, sf_dta, ptrfac, ptrc) ! Empty routine 258 280 WRITE(*,*) 'trc_dta: You should not have seen this print! error?', kt 259 281 END SUBROUTINE trc_dta -
branches/UKMO/dev_r5518_GO6_package_MEDUSA_extra_CMIP6_diags/NEMOGCM/NEMO/TOP_SRC/trcini.F90
r6731 r7083 125 125 IF( ln_trc_ini(jn) ) THEN ! update passive tracers arrays with input data read from file 126 126 jl = n_trc_index(jn) 127 CALL trc_dta( nit000, sf_trcdta(jl) ) ! read tracer data at nit000 128 trn(:,:,:,jn) = sf_trcdta(jl)%fnow(:,:,:) * tmask(:,:,:) * rf_trfac(jl) 129 ! 127 CALL trc_dta( nit000, sf_trcdta(jl), rf_trfac(jl) ) ! read tracer data at nit000 128 trn(:,:,:,jn) = sf_trcdta(jl)%fnow(:,:,:) 130 129 IF( .NOT.ln_trcdmp .AND. .NOT.ln_trcdmp_clo ) THEN !== deallocate data structure ==! 131 130 ! (data used only for initialisation)
Note: See TracChangeset
for help on using the changeset viewer.
