New URL for NEMO forge!   http://forge.nemo-ocean.eu

Since March 2022 along with NEMO 4.2 release, the code development moved to a self-hosted GitLab.
This present forge is now archived and remained online for history.
Changeset 13463 for NEMO/branches/2019/dev_r11351_fldread_with_XIOS/src/TOP/PISCES/P2Z/p2zexp.F90 – NEMO

Ignore:
Timestamp:
2020-09-14T17:40:34+02:00 (4 years ago)
Author:
andmirek
Message:

Ticket #2195:update to trunk 13461

Location:
NEMO/branches/2019/dev_r11351_fldread_with_XIOS
Files:
2 edited

Legend:

Unmodified
Added
Removed

  • NEMO/branches/2019/dev_r11351_fldread_with_XIOS

    • Property svn:externals

      •  

        old new  
        33^/utils/build/mk@HEAD         mk 
        44^/utils/tools@HEAD            tools 
        5 ^/vendors/AGRIF/dev@HEAD      ext/AGRIF 
         5^/vendors/AGRIF/dev_r12970_AGRIF_CMEMS      ext/AGRIF 
        66^/vendors/FCM@HEAD            ext/FCM 
        77^/vendors/IOIPSL@HEAD         ext/IOIPSL 
         8 
         9# SETTE 
         10^/utils/CI/sette@13382        sette 

  • NEMO/branches/2019/dev_r11351_fldread_with_XIOS/src/TOP/PISCES/P2Z/p2zexp.F90

    r10425 r13463  
    1717   USE p2zsed 
    1818   USE lbclnk 
    19    USE prtctl_trc      ! Print control for debbuging 
     19   USE prtctl          ! Print control for debbuging 
    2020   USE trd_oce 
    2121   USE trdtrc 
    … …  
    3838 
    3939   !! * Substitutions 
    40 #  include "vectopt_loop_substitute.h90" 
     40#  include "do_loop_substitute.h90" 
     41#  include "domzgr_substitute.h90" 
    4142   !!---------------------------------------------------------------------- 
    4243   !! NEMO/TOP 4.0 , NEMO Consortium (2018) 
    … …  
    4647CONTAINS 
    4748 
    48    SUBROUTINE p2z_exp( kt ) 
     49   SUBROUTINE p2z_exp( kt, Kmm, Krhs ) 
    4950      !!--------------------------------------------------------------------- 
    5051      !!                     ***  ROUTINE p2z_exp  *** 
    … …  
    6061      !!--------------------------------------------------------------------- 
    6162      !! 
    62       INTEGER, INTENT( in ) ::   kt      ! ocean time-step index       
     63      INTEGER, INTENT( in ) ::   kt             ! ocean time-step index       
     64      INTEGER, INTENT( in ) ::   Kmm, Krhs      ! time level indices 
    6365      !! 
    6466      INTEGER  ::   ji, jj, jk, jl, ikt 
    … …  
    7072      IF( ln_timing )   CALL timing_start('p2z_exp') 
    7173      ! 
    72       IF( kt == nittrc000 )   CALL p2z_exp_init 
     74      IF( kt == nittrc000 )   CALL p2z_exp_init( Kmm ) 
    7375 
    7476      zsedpoca(:,:) = 0. 
    … …  
    8082      ! LAYERS IS DETERMINED BY DMIN3 DEFINED IN sms_p2z.F90 
    8183      ! ---------------------------------------------------------------------- 
    82       DO jk = 1, jpkm1 
    83          DO jj = 2, jpjm1 
    84             DO ji = fs_2, fs_jpim1 
    85                ze3t = 1. / e3t_n(ji,jj,jk) 
    86                tra(ji,jj,jk,jpno3) = tra(ji,jj,jk,jpno3) + ze3t * dmin3(ji,jj,jk) * xksi(ji,jj) 
    87             END DO 
    88          END DO 
    89       END DO 
     84      DO_3D( 0, 0, 0, 0, 1, jpkm1 ) 
     85         ze3t = 1. / e3t(ji,jj,jk,Kmm) 
     86         tr(ji,jj,jk,jpno3,Krhs) = tr(ji,jj,jk,jpno3,Krhs) + ze3t * dmin3(ji,jj,jk) * xksi(ji,jj) 
     87      END_3D 
    9088 
    9189      ! Find the last level of the water column 
    … …  
    9593      zgeolpoc = 0.e0         !     Initialization 
    9694      ! Release of nutrients from the "simple" sediment 
    97       DO jj = 2, jpjm1 
    98          DO ji = fs_2, fs_jpim1 
    99             ikt = mbkt(ji,jj)  
    100             tra(ji,jj,ikt,jpno3) = tra(ji,jj,ikt,jpno3) + sedlam * sedpocn(ji,jj) / e3t_n(ji,jj,ikt)  
    101             ! Deposition of organic matter in the sediment 
    102             zwork = vsed * trn(ji,jj,ikt,jpdet) 
    103             zsedpoca(ji,jj) = ( zwork + dminl(ji,jj) * xksi(ji,jj)   & 
    104                &           - sedlam * sedpocn(ji,jj) - sedlostpoc * sedpocn(ji,jj) ) * rdt 
    105             zgeolpoc = zgeolpoc + sedlostpoc * sedpocn(ji,jj) * e1e2t(ji,jj) 
    106          END DO 
    107       END DO 
    108  
    109       DO jj = 2, jpjm1 
    110          DO ji = fs_2, fs_jpim1 
    111             tra(ji,jj,1,jpno3) = tra(ji,jj,1,jpno3) + zgeolpoc * cmask(ji,jj) / areacot / e3t_n(ji,jj,1) 
    112          END DO 
    113       END DO 
    114  
    115       CALL lbc_lnk( 'p2zexp', sedpocn, 'T', 1. ) 
     95      DO_2D( 0, 0, 0, 0 ) 
     96         ikt = mbkt(ji,jj)  
     97         tr(ji,jj,ikt,jpno3,Krhs) = tr(ji,jj,ikt,jpno3,Krhs) + sedlam * sedpocn(ji,jj) / e3t(ji,jj,ikt,Kmm)  
     98         ! Deposition of organic matter in the sediment 
     99         zwork = vsed * tr(ji,jj,ikt,jpdet,Kmm) 
     100         zsedpoca(ji,jj) = ( zwork + dminl(ji,jj) * xksi(ji,jj)   & 
     101            &           - sedlam * sedpocn(ji,jj) - sedlostpoc * sedpocn(ji,jj) ) * rn_Dt 
     102         zgeolpoc = zgeolpoc + sedlostpoc * sedpocn(ji,jj) * e1e2t(ji,jj) 
     103      END_2D 
     104 
     105      DO_2D( 0, 0, 0, 0 ) 
     106         tr(ji,jj,1,jpno3,Krhs) = tr(ji,jj,1,jpno3,Krhs) + zgeolpoc * cmask(ji,jj) / areacot / e3t(ji,jj,1,Kmm) 
     107      END_2D 
     108 
     109      CALL lbc_lnk( 'p2zexp', sedpocn, 'T', 1.0_wp ) 
    116110  
    117111      ! Oa & Ek: diagnostics depending on jpdia2d !          left as example 
    … …  
    121115      ! Time filter and swap of arrays 
    122116      ! ------------------------------ 
    123       IF( neuler == 0 .AND. kt == nittrc000 ) THEN        ! Euler time-stepping at first time-step 
    124         !                                             ! (only swap) 
     117      IF( l_1st_euler ) THEN        ! Euler time-stepping at first time-step 
     118        !                           ! (only swap) 
    125119        sedpocn(:,:) = zsedpoca(:,:) 
    126120        !                                               
    127121      ELSE 
    128122        ! 
    129         DO jj = 1, jpj 
    130            DO ji = 1, jpi 
    131               zsedpocd = zsedpoca(ji,jj) - 2. * sedpocn(ji,jj) + sedpocb(ji,jj)      ! time laplacian on tracers 
    132               sedpocb(ji,jj) = sedpocn(ji,jj) + atfp * zsedpocd                     ! sedpocb <-- filtered sedpocn 
    133               sedpocn(ji,jj) = zsedpoca(ji,jj)                                       ! sedpocn <-- sedpoca 
    134            END DO 
    135         END DO 
     123        DO_2D( 1, 1, 1, 1 ) 
     124           zsedpocd = zsedpoca(ji,jj) - 2. * sedpocn(ji,jj) + sedpocb(ji,jj)      ! time laplacian on tracers 
     125           sedpocb(ji,jj) = sedpocn(ji,jj) + rn_atfp * zsedpocd                     ! sedpocb <-- filtered sedpocn 
     126           sedpocn(ji,jj) = zsedpoca(ji,jj)                                       ! sedpocn <-- sedpoca 
     127        END_2D 
    136128        !  
    137129      ENDIF 
    … …  
    146138      ENDIF 
    147139      ! 
    148       IF(ln_ctl)   THEN  ! print mean trends (used for debugging) 
     140      IF(sn_cfctl%l_prttrc)   THEN  ! print mean trends (used for debugging) 
    149141         WRITE(charout, FMT="('exp')") 
    150          CALL prt_ctl_trc_info(charout) 
    151          CALL prt_ctl_trc(tab4d=tra, mask=tmask, clinfo=ctrcnm) 
     142         CALL prt_ctl_info( charout, cdcomp = 'top' ) 
     143         CALL prt_ctl(tab4d_1=tr(:,:,:,:,Krhs), mask1=tmask, clinfo=ctrcnm) 
    152144      ENDIF 
    153145      ! 
    … …  
    157149 
    158150 
    159    SUBROUTINE p2z_exp_init 
     151   SUBROUTINE p2z_exp_init( Kmm ) 
    160152      !!---------------------------------------------------------------------- 
    161153      !!                    ***  ROUTINE p4z_exp_init  *** 
    162154      !! ** purpose :   specific initialisation for export 
    163155      !!---------------------------------------------------------------------- 
     156      INTEGER, INTENT(in)  ::  Kmm      ! time level index 
    164157      INTEGER  ::   ji, jj, jk 
    165158      REAL(wp) ::   zmaskt, zfluo, zfluu 
    … …  
    181174      zdm0 = 0._wp 
    182175      zrro = 1._wp 
    183       DO jk = jpkb, jpkm1 
    184          DO jj = 1, jpj 
    185             DO ji = 1, jpi 
    186                zfluo = ( gdepw_n(ji,jj,jk  ) / gdepw_n(ji,jj,jpkb) )**xhr 
    187                zfluu = ( gdepw_n(ji,jj,jk+1) / gdepw_n(ji,jj,jpkb) )**xhr 
    188                IF( zfluo.GT.1. )   zfluo = 1._wp 
    189                zdm0(ji,jj,jk) = zfluo - zfluu 
    190                IF( jk <= jpkb-1 )   zdm0(ji,jj,jk) = 0._wp 
    191                zrro(ji,jj) = zrro(ji,jj) - zdm0(ji,jj,jk) 
    192             END DO 
    193          END DO 
    194       END DO 
     176      DO_3D( 1, 1, 1, 1, jpkb, jpkm1 ) 
     177         zfluo = ( gdepw(ji,jj,jk  ,Kmm) / gdepw(ji,jj,jpkb,Kmm) )**xhr 
     178         zfluu = ( gdepw(ji,jj,jk+1,Kmm) / gdepw(ji,jj,jpkb,Kmm) )**xhr 
     179         IF( zfluo.GT.1. )   zfluo = 1._wp 
     180         zdm0(ji,jj,jk) = zfluo - zfluu 
     181         IF( jk <= jpkb-1 )   zdm0(ji,jj,jk) = 0._wp 
     182         zrro(ji,jj) = zrro(ji,jj) - zdm0(ji,jj,jk) 
     183      END_3D 
    195184      ! 
    196185      zdm0(:,:,jpk) = zrro(:,:) 
    … …  
    202191      dminl(:,:)   = 0._wp 
    203192      dmin3(:,:,:) = zdm0 
    204       DO jk = 1, jpk 
    205          DO jj = 1, jpj 
    206             DO ji = 1, jpi 
    207                IF( tmask(ji,jj,jk) == 0._wp ) THEN 
    208                   dminl(ji,jj) = dminl(ji,jj) + dmin3(ji,jj,jk) 
    209                   dmin3(ji,jj,jk) = 0._wp 
    210                ENDIF 
    211             END DO 
    212          END DO 
    213       END DO 
    214  
    215       DO jj = 1, jpj 
    216          DO ji = 1, jpi 
    217             IF( tmask(ji,jj,1) == 0 )   dmin3(ji,jj,1) = 0._wp 
    218          END DO 
    219       END DO 
     193      DO_3D( 1, 1, 1, 1, 1, jpk ) 
     194         IF( tmask(ji,jj,jk) == 0._wp ) THEN 
     195            dminl(ji,jj) = dminl(ji,jj) + dmin3(ji,jj,jk) 
     196            dmin3(ji,jj,jk) = 0._wp 
     197         ENDIF 
     198      END_3D 
     199 
     200      DO_2D( 1, 1, 1, 1 ) 
     201         IF( tmask(ji,jj,1) == 0 )   dmin3(ji,jj,1) = 0._wp 
     202      END_2D 
    220203 
    221204      ! Coastal mask  
    222205      cmask(:,:) = 0._wp 
    223       DO jj = 2, jpjm1 
    224          DO ji = fs_2, fs_jpim1 
    225             IF( tmask(ji,jj,1) /= 0. ) THEN 
    226                zmaskt = tmask(ji+1,jj,1) * tmask(ji-1,jj,1) * tmask(ji,jj+1,1) * tmask(ji,jj-1,1)  
    227                IF( zmaskt == 0. )   cmask(ji,jj) = 1._wp 
    228             END IF 
    229          END DO 
    230       END DO 
    231       CALL lbc_lnk( 'p2zexp', cmask , 'T', 1. )      ! lateral boundary conditions on cmask   (sign unchanged) 
     206      DO_2D( 0, 0, 0, 0 ) 
     207         IF( tmask(ji,jj,1) /= 0. ) THEN 
     208            zmaskt = tmask(ji+1,jj,1) * tmask(ji-1,jj,1) * tmask(ji,jj+1,1) * tmask(ji,jj-1,1)  
     209            IF( zmaskt == 0. )   cmask(ji,jj) = 1._wp 
     210         END IF 
     211      END_2D 
     212      CALL lbc_lnk( 'p2zexp', cmask , 'T', 1.0_wp )      ! lateral boundary conditions on cmask   (sign unchanged) 
    232213      areacot = glob_sum( 'p2zexp', e1e2t(:,:) * cmask(:,:) ) 
    233214      ! 
    234215      IF( ln_rsttr ) THEN 
    235          CALL iom_get( numrtr, jpdom_autoglo, 'SEDB'//ctrcnm(jpdet), sedpocb(:,:) ) 
    236          CALL iom_get( numrtr, jpdom_autoglo, 'SEDN'//ctrcnm(jpdet), sedpocn(:,:) ) 
     216         CALL iom_get( numrtr, jpdom_auto, 'SEDB'//ctrcnm(jpdet), sedpocb(:,:) ) 
     217         CALL iom_get( numrtr, jpdom_auto, 'SEDN'//ctrcnm(jpdet), sedpocn(:,:) ) 
    237218      ELSE 
    238219         sedpocb(:,:) = 0._wp 
Note: See TracChangeset for help on using the changeset viewer.