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 3211 for branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/TRA – NEMO

Ignore:
Timestamp:
2011-12-11T16:00:26+01:00 (12 years ago)
Author:
spickles2
Message:

Stephen Pickles, 11 Dec 2011

Commit to bring the rest of the DCSE NEMO development branch
in line with the latest development version. This includes
array index re-ordering of all OPA_SRC/.

Location:
branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/TRA
Files:
2 added
27 edited

Legend:

Unmodified
Added
Removed

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/TRA/eosbn2.F90

    r2715 r3211  
    6161 
    6262   REAL(wp), PUBLIC ::   ralpbet              !: alpha / beta ratio 
     63 
     64   !! * Control permutation of array indices 
     65#  include "dom_oce_ftrans.h90" 
     66#  include "zdfddm_ftrans.h90" 
    6367    
    6468   !! * Substitutions 
    … …  
    111115      USE wrk_nemo, ONLY:   zws => wrk_3d_1   ! 3D workspace 
    112116      !! 
     117 
     118!FTRANS zws :I :I :z 
     119!FTRANS pts :I :I :z :I 
     120!FTRANS prd :I :I :z 
     121 
    113122      REAL(wp), DIMENSION(:,:,:,:), INTENT(in   ) ::   pts   ! 1 : potential temperature  [Celcius] 
    114123      !                                                      ! 2 : salinity               [psu] 
    … …  
    135144         zws(:,:,:) = SQRT( ABS( pts(:,:,:,jp_sal) ) ) 
    136145         !   
     146#if defined key_z_first 
     147         DO jj = 1, jpj 
     148            DO ji = 1, jpi 
     149               DO jk = 1, jpkm1 
     150#else 
    137151         DO jk = 1, jpkm1 
    138152            DO jj = 1, jpj 
    139153               DO ji = 1, jpi 
     154#endif 
    140155                  zt = pts   (ji,jj,jk,jp_tem) 
    141156                  zs = pts   (ji,jj,jk,jp_sal) 
    … …  
    178193         ! 
    179194      CASE( 1 )                !==  Linear formulation function of temperature only  ==! 
     195#if defined key_z_first 
     196         DO jj = 1, jpj 
     197            DO ji = 1, jpi 
     198               DO jk = 1, jpkm1 
     199                  prd(ji,jj,jk) = ( 0.0285_wp - rn_alpha * pts(ji,jj,jk,jp_tem) ) * tmask(ji,jj,jk) 
     200               END DO 
     201            END DO 
     202         END DO 
     203#else 
    180204         DO jk = 1, jpkm1 
    181205            prd(:,:,jk) = ( 0.0285_wp - rn_alpha * pts(:,:,jk,jp_tem) ) * tmask(:,:,jk) 
    182206         END DO 
     207#endif 
    183208         ! 
    184209      CASE( 2 )                !==  Linear formulation function of temperature and salinity  ==! 
     210#if defined key_z_first 
     211         DO jj = 1, jpj 
     212            DO ji = 1, jpi 
     213               DO jk = 1, jpkm1 
     214                  prd(ji,jj,jk) = ( rn_beta  * pts(ji,jj,jk,jp_sal) - rn_alpha * pts(ji,jj,jk,jp_tem) ) * tmask(ji,jj,jk) 
     215               END DO 
     216            END DO 
     217         END DO 
     218#else 
    185219         DO jk = 1, jpkm1 
    186220            prd(:,:,jk) = ( rn_beta  * pts(:,:,jk,jp_sal) - rn_alpha * pts(:,:,jk,jp_tem) ) * tmask(:,:,jk) 
    187221         END DO 
     222#endif 
    188223         ! 
    189224      END SELECT 
    … …  
    193228      IF( wrk_not_released(3, 1) )   CALL ctl_stop('eos_insitu: failed to release workspace array') 
    194229      ! 
     230 
     231!! * Reset control of array index permutation 
     232!FTRANS CLEAR 
     233#  include "dom_oce_ftrans.h90" 
     234#  include "zdfddm_ftrans.h90" 
     235 
    195236   END SUBROUTINE eos_insitu 
    196237 
    … …  
    245286      USE wrk_nemo, ONLY:   zws => wrk_3d_1 ! 3D workspace 
    246287      !! 
    247       REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(in   ) ::   pts    ! 1 : potential temperature  [Celcius] 
    248       !                                                                ! 2 : salinity               [psu] 
    249       REAL(wp), DIMENSION(jpi,jpj,jpk     ), INTENT(  out) ::   prd    ! in situ density            [-] 
    250       REAL(wp), DIMENSION(jpi,jpj,jpk     ), INTENT(  out) ::   prhop  ! potential density (surface referenced) 
     288 
     289!FTRANS zws :I :I :z 
     290!FTRANS pts :I :I :z :I 
     291!FTRANS prd :I :I :z 
     292!FTRANS prhop :I :I :z 
     293 
     294!!DCSE NEMO: This style defeats ftrans 
     295!     REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(in   ) ::   pts    ! 1 : potential temperature  [Celcius] 
     296!     !                                                                ! 2 : salinity               [psu] 
     297!     REAL(wp), DIMENSION(jpi,jpj,jpk     ), INTENT(  out) ::   prd    ! in situ density            [-] 
     298!     REAL(wp), DIMENSION(jpi,jpj,jpk     ), INTENT(  out) ::   prhop  ! potential density (surface referenced) 
     299      REAL(wp), INTENT(in   ) ::   pts(jpi,jpj,jpk,jpts)   ! 1 : potential temperature  [Celcius] 
     300      !                                                    ! 2 : salinity               [psu] 
     301      REAL(wp), INTENT(  out) ::   prd(jpi,jpj,jpk)        ! in situ density            [-] 
     302      REAL(wp), INTENT(  out) ::   prhop(jpi,jpj,jpk)      ! potential density (surface referenced) 
    251303      ! 
    252304      INTEGER  ::   ji, jj, jk   ! dummy loop indices 
    … …  
    266318         zws(:,:,:) = SQRT( ABS( pts(:,:,:,jp_sal) ) ) 
    267319         !   
     320#if defined key_z_first 
     321         DO jj = 1, jpj 
     322            DO ji = 1, jpi 
     323               DO jk = 1, jpkm1 
     324#else 
    268325         DO jk = 1, jpkm1 
    269326            DO jj = 1, jpj 
    270327               DO ji = 1, jpi 
     328#endif 
    271329                  zt = pts   (ji,jj,jk,jp_tem) 
    272330                  zs = pts   (ji,jj,jk,jp_sal) 
    … …  
    312370         ! 
    313371      CASE( 1 )                !==  Linear formulation = F( temperature )  ==! 
     372#if defined key_z_first 
     373         DO jj = 1, jpj 
     374            DO ji = 1, jpi 
     375               DO jk = 1, jpkm1 
     376                  prd  (ji,jj,jk) = ( 0.0285_wp - rn_alpha * pts(ji,jj,jk,jp_tem) )        * tmask(ji,jj,jk) 
     377                  prhop(ji,jj,jk) = ( 1.e0_wp   +            prd(ji,jj,jk)        ) * rau0 * tmask(ji,jj,jk) 
     378               END DO 
     379            END DO 
     380         END DO 
     381#else 
    314382         DO jk = 1, jpkm1 
    315383            prd  (:,:,jk) = ( 0.0285_wp - rn_alpha * pts(:,:,jk,jp_tem) )        * tmask(:,:,jk) 
    316384            prhop(:,:,jk) = ( 1.e0_wp   +            prd (:,:,jk)       ) * rau0 * tmask(:,:,jk) 
    317385         END DO 
     386#endif 
    318387         ! 
    319388      CASE( 2 )                !==  Linear formulation = F( temperature , salinity )  ==! 
     389#if defined key_z_first 
     390         DO jj = 1, jpj 
     391            DO ji = 1, jpi 
     392               DO jk = 1, jpkm1 
     393                  prd  (ji,jj,jk) = ( rn_beta  * pts(ji,jj,jk,jp_sal) - rn_alpha * pts(ji,jj,jk,jp_tem) )        * tmask(ji,jj,jk) 
     394                  prhop(ji,jj,jk) = ( 1.e0_wp  + prd(ji,jj,jk)                                          ) * rau0 * tmask(ji,jj,jk) 
     395               END DO 
     396            END DO 
     397         END DO 
     398#else 
    320399         DO jk = 1, jpkm1 
    321400            prd  (:,:,jk) = ( rn_beta  * pts(:,:,jk,jp_sal) - rn_alpha * pts(:,:,jk,jp_tem) )        * tmask(:,:,jk) 
    322401            prhop(:,:,jk) = ( 1.e0_wp  + prd (:,:,jk) )                                       * rau0 * tmask(:,:,jk) 
    323402         END DO 
     403#endif 
    324404         ! 
    325405      END SELECT 
    … …  
    329409      IF( wrk_not_released(3, 1) )   CALL ctl_stop('eos_insitu_pot: failed to release workspace array') 
    330410      ! 
     411 
     412!! * Reset control of array index permutation 
     413!FTRANS CLEAR 
     414#  include "dom_oce_ftrans.h90" 
     415#  include "zdfddm_ftrans.h90" 
     416 
    331417   END SUBROUTINE eos_insitu_pot 
    332418 
    … …  
    400486         DO jj = 1, jpjm1 
    401487            DO ji = 1, fs_jpim1   ! vector opt. 
     488#if defined key_z_first 
     489               zmask = tmask_1(ji,jj)          ! land/sea bottom mask = surf. mask 
     490#else 
    402491               zmask = tmask(ji,jj,1)          ! land/sea bottom mask = surf. mask 
     492#endif 
    403493               zt    = pts  (ji,jj,jp_tem)            ! interpolated T 
    404494               zs    = pts  (ji,jj,jp_sal)            ! interpolated S 
    … …  
    442532         DO jj = 1, jpjm1 
    443533            DO ji = 1, fs_jpim1   ! vector opt. 
     534#if defined key_z_first 
     535               prd(ji,jj) = ( 0.0285_wp - rn_alpha * pts(ji,jj,jp_tem) ) * tmask_1(ji,jj) 
     536#else 
    444537               prd(ji,jj) = ( 0.0285_wp - rn_alpha * pts(ji,jj,jp_tem) ) * tmask(ji,jj,1) 
     538#endif 
    445539            END DO 
    446540         END DO 
    … …  
    449543         DO jj = 1, jpjm1 
    450544            DO ji = 1, fs_jpim1   ! vector opt. 
     545#if defined key_z_first 
     546               prd(ji,jj) = ( rn_beta * pts(ji,jj,jp_sal) - rn_alpha * pts(ji,jj,jp_tem) ) * tmask_1(ji,jj)  
     547#else 
    451548               prd(ji,jj) = ( rn_beta * pts(ji,jj,jp_sal) - rn_alpha * pts(ji,jj,jp_tem) ) * tmask(ji,jj,1)  
     549#endif 
    452550            END DO 
    453551         END DO 
    … …  
    492590      !! References :   McDougall, J. Phys. Oceanogr., 17, 1950-1964, 1987. 
    493591      !!---------------------------------------------------------------------- 
    494       REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(in   ) ::   pts   ! 1 : potential temperature  [Celcius] 
    495       !                                                               ! 2 : salinity               [psu] 
    496       REAL(wp), DIMENSION(jpi,jpj,jpk)     , INTENT(  out) ::   pn2   ! Brunt-Vaisala frequency    [s-1] 
     592 
     593!FTRANS pts :I :I :z :I 
     594!FTRANS pn2 :I :I :z 
     595 
     596!!DCSE_NEMO: This style defeats ftrans 
     597!     REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(in   ) ::   pts   ! 1 : potential temperature  [Celcius] 
     598!     !                                                               ! 2 : salinity               [psu] 
     599!     REAL(wp), DIMENSION(jpi,jpj,jpk)     , INTENT(  out) ::   pn2   ! Brunt-Vaisala frequency    [s-1] 
     600 
     601      REAL(wp), INTENT(in   ) ::   pts(jpi,jpj,jpk,jpts)   ! 1 : potential temperature  [Celcius] 
     602      !                                                    ! 2 : salinity               [psu] 
     603      REAL(wp), INTENT(  out) ::   pn2(jpi,jpj,jpk)        ! Brunt-Vaisala frequency    [s-1] 
    497604      !! 
    498605      INTEGER  ::   ji, jj, jk   ! dummy loop indices 
    … …  
    509616      ! 
    510617      CASE( 0 )                !==  Jackett and McDougall (1994) formulation  ==! 
     618#if defined key_z_first 
     619         DO jj = 1, jpj 
     620            DO ji = 1, jpi 
     621               DO jk = 2, jpkm1 
     622#else 
    511623         DO jk = 2, jpkm1 
    512624            DO jj = 1, jpj 
    513625               DO ji = 1, jpi 
     626#endif 
    514627                  zgde3w = grav / fse3w(ji,jj,jk) 
    515628                  zt = 0.5 * ( pts(ji,jj,jk,jp_tem) + pts(ji,jj,jk-1,jp_tem) )         ! potential temperature at w-pt 
    … …  
    556669         ! 
    557670      CASE( 1 )                !==  Linear formulation = F( temperature )  ==! 
     671#if defined key_z_first 
     672         DO jj = 1, jpj 
     673            DO ji = 1, jpi 
     674               DO jk = 2, jpkm1 
     675                  pn2(ji,jj,jk) = grav * rn_alpha * ( pts(ji,jj,jk-1,jp_tem) - pts(ji,jj,jk,jp_tem) ) & 
     676                     &                 / fse3w(ji,jj,jk) * tmask(ji,jj,jk) 
     677               END DO 
     678            END DO 
     679         END DO 
     680#else 
    558681         DO jk = 2, jpkm1 
    559682            pn2(:,:,jk) = grav * rn_alpha * ( pts(:,:,jk-1,jp_tem) - pts(:,:,jk,jp_tem) ) / fse3w(:,:,jk) * tmask(:,:,jk) 
    560683         END DO 
     684#endif 
    561685         ! 
    562686      CASE( 2 )                !==  Linear formulation = F( temperature , salinity )  ==! 
     687#if defined key_z_first 
     688         DO jj = 1, jpj 
     689            DO ji = 1, jpi 
     690               DO jk = 2, jpkm1 
     691                  pn2(ji,jj,jk) = grav * (  rn_alpha * ( pts(ji,jj,jk-1,jp_tem) - pts(ji,jj,jk,jp_tem) )      & 
     692                     &                    - rn_beta  * ( pts(ji,jj,jk-1,jp_sal) - pts(ji,jj,jk,jp_sal) )  )   & 
     693                     &                 / fse3w(ji,jj,jk) * tmask(ji,jj,jk) 
     694               END DO 
     695            END DO 
     696         END DO  
     697#else 
    563698         DO jk = 2, jpkm1 
    564699            pn2(:,:,jk) = grav * (  rn_alpha * ( pts(:,:,jk-1,jp_tem) - pts(:,:,jk,jp_tem) )      & 
    … …  
    566701               &               / fse3w(:,:,jk) * tmask(:,:,jk) 
    567702         END DO  
     703#endif 
    568704#if defined key_zdfddm 
     705#if defined key_z_first 
     706         DO jj = 1, jpj                                   ! Rrau = (alpha / beta) (dk[t] / dk[s]) 
     707            DO ji = 1, jpi 
     708               DO jk = 2, jpkm1 
     709#else 
    569710         DO jk = 2, jpkm1                                 ! Rrau = (alpha / beta) (dk[t] / dk[s]) 
    570711            DO jj = 1, jpj 
    571712               DO ji = 1, jpi 
     713#endif 
    572714                  zds = ( pts(ji,jj,jk-1,jp_sal) - pts(ji,jj,jk,jp_sal) )   
    573715                  IF ( ABS( zds ) <= 1.e-20_wp ) zds = 1.e-20_wp 
    … …  
    584726#endif 
    585727      ! 
     728 
     729!! * Reset control of array index permutation 
     730!FTRANS CLEAR 
     731#  include "dom_oce_ftrans.h90" 
     732#  include "zdfddm_ftrans.h90" 
     733 
    586734   END SUBROUTINE eos_bn2 
    587735 
    … …  
    609757      !! ** Action  : - palph, pbeta : thermal and haline expansion coeff. at T-point 
    610758      !!---------------------------------------------------------------------- 
    611       REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(in   ) ::   pts            ! pot. temperature & salinity 
    612       REAL(wp), DIMENSION(jpi,jpj,jpk)     , INTENT(  out) ::   palph, pbeta   ! thermal & haline expansion coeff. 
     759 
     760!FTRANS pts :I :I :z :I 
     761!FTRANS palph :I :I :z 
     762!FTRANS pbeta :I :I :z 
     763!!DCSE_NEMO: This style defeats ftrans 
     764!     REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(in   ) ::   pts            ! pot. temperature & salinity 
     765!     REAL(wp), DIMENSION(jpi,jpj,jpk)     , INTENT(  out) ::   palph, pbeta   ! thermal & haline expansion coeff. 
     766      REAL(wp), INTENT(in   ) ::   pts(jpi,jpj,jpk,jpts)            ! pot. temperature & salinity 
     767      REAL(wp), INTENT(  out) ::   palph(jpi,jpj,jpk)               ! thermal expansion coeff. 
     768      REAL(wp), INTENT(  out) ::   pbeta(jpi,jpj,jpk)               ! haline  expansion coeff. 
    613769      ! 
    614770      INTEGER  ::   ji, jj, jk   ! dummy loop indices 
    … …  
    619775      ! 
    620776      CASE ( 0 )               ! Jackett and McDougall (1994) formulation 
     777#if defined key_z_first 
     778         DO jj = 1, jpj 
     779            DO ji = 1, jpi 
     780               DO jk = 1, jpk 
     781#else 
    621782         DO jk = 1, jpk 
    622783            DO jj = 1, jpj 
    623784               DO ji = 1, jpi 
     785#endif 
    624786                  zt = pts(ji,jj,jk,jp_tem)           ! potential temperature 
    625787                  zs = pts(ji,jj,jk,jp_sal) - 35._wp  ! salinity anomaly (s-35) 
    … …  
    670832      END SELECT 
    671833      ! 
     834 
     835!! * Reset control of array index permutation 
     836!FTRANS CLEAR 
     837#  include "dom_oce_ftrans.h90" 
     838#  include "zdfddm_ftrans.h90" 
     839 
    672840   END SUBROUTINE eos_alpbet 
    673841 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/TRA/traadv.F90

    r2715 r3211  
    4444   INTEGER ::   nadv   ! choice of the type of advection scheme 
    4545 
     46   !! * Control permutation of array indices 
     47#  include "oce_ftrans.h90" 
     48#  include "dom_oce_ftrans.h90" 
     49#  include "ldftra_oce_ftrans.h90" 
     50 
    4651   !! * Substitutions 
    4752#  include "domzgr_substitute.h90" 
    … …  
    6469      USE wrk_nemo, ONLY:   wrk_in_use, wrk_not_released 
    6570      USE wrk_nemo, ONLY:   zun => wrk_3d_1 , zvn => wrk_3d_2 , zwn => wrk_3d_3   ! 3D workspace 
     71 
     72      !! DCSE_NEMO: need additional directives for renamed module variables 
     73!FTRANS zun zvn zwn :I :I :z 
     74 
    6675      ! 
    6776      INTEGER, INTENT( in ) ::   kt   ! ocean time-step index 
    6877      ! 
    69       INTEGER ::   jk   ! dummy loop index 
     78      INTEGER ::   ji, jj, jk   ! dummy loop index 
    7079      !!---------------------------------------------------------------------- 
    7180      ! 
    … …  
    8392      ! 
    8493      !                                               !==  effective transport  ==! 
     94#if defined key_z_first 
     95      DO jj = 1, jpj 
     96         DO ji = 1, jpi 
     97            DO jk = 1, jpkm1 
     98               zun(ji,jj,jk) = e2u(ji,jj) * fse3u(ji,jj,jk) * un(ji,jj,jk)     ! eulerian transport only 
     99               zvn(ji,jj,jk) = e1v(ji,jj) * fse3v(ji,jj,jk) * vn(ji,jj,jk) 
     100               zwn(ji,jj,jk) = e1t(ji,jj) * e2t(ji,jj)      * wn(ji,jj,jk) 
     101            END DO 
     102            zun(ji,jj,jpk) = 0._wp                                             ! no transport trough the bottom 
     103            zvn(ji,jj,jpk) = 0._wp                                             ! no transport trough the bottom 
     104            zwn(ji,jj,jpk) = 0._wp                                             ! no transport trough the bottom 
     105         END DO 
     106      END DO 
     107#else 
    85108      DO jk = 1, jpkm1 
    86109         zun(:,:,jk) = e2u(:,:) * fse3u(:,:,jk) * un(:,:,jk)                  ! eulerian transport only 
    … …  
    91114      zvn(:,:,jpk) = 0._wp                                                     ! no transport trough the bottom 
    92115      zwn(:,:,jpk) = 0._wp                                                     ! no transport trough the bottom 
     116#endif 
    93117      ! 
    94118      IF( lk_traldf_eiv .AND. .NOT. ln_traldf_grif )   & 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/TRA/traadv_cen2.F90

    r2715 r3211  
    4343   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: upsmsk !: mixed upstream/centered scheme near some straits  
    4444   !                                                             !  and in closed seas (orca 2 and 4 configurations) 
     45 
     46   !! * Control permutation of array indices 
     47#  include "oce_ftrans.h90" 
     48#  include "dom_oce_ftrans.h90" 
     49#  include "trc_oce_ftrans.h90" 
     50#  include "zdf_oce_ftrans.h90" 
     51 
    4552   !! * Substitutions 
    4653#  include "domzgr_substitute.h90" 
    … …  
    114121      USE wrk_nemo, ONLY:   zwz => wrk_3d_1 , zind => wrk_3d_2   ! 3D workspace 
    115122      USE wrk_nemo, ONLY:   ztfreez => wrk_2d_1                  ! 2D     - 
     123      !! DCSE_NEMO: need additional directives for renamed module variables 
     124!FTRANS zwx zwy zwz zind :I :I :z 
    116125      ! 
    117126      INTEGER                              , INTENT(in   ) ::   kt              ! ocean time-step index 
    118127      CHARACTER(len=3)                     , INTENT(in   ) ::   cdtype          ! =TRA or TRC (tracer indicator) 
    119128      INTEGER                              , INTENT(in   ) ::   kjpt            ! number of tracers 
    120       REAL(wp), DIMENSION(jpi,jpj,jpk     ), INTENT(in   ) ::   pun, pvn, pwn   ! 3 ocean velocity components 
    121       REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in   ) ::   ptb, ptn        ! before and now tracer fields 
    122       REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) ::   pta             ! tracer trend  
     129 
     130      !! DCSE_NEMO: This style defeats ftrans 
     131!     REAL(wp), DIMENSION(jpi,jpj,jpk     ), INTENT(in   ) ::   pun, pvn, pwn   ! 3 ocean velocity components 
     132!     REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in   ) ::   ptb, ptn        ! before and now tracer fields 
     133!     REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) ::   pta             ! tracer trend  
     134 
     135!FTRANS pun pvn pwn :I :I :z 
     136      REAL(wp), INTENT(in   ) ::   pun(jpi,jpj,jpk)         ! ocean velocity component 
     137      REAL(wp), INTENT(in   ) ::   pvn(jpi,jpj,jpk)         ! ocean velocity component 
     138      REAL(wp), INTENT(in   ) ::   pwn(jpi,jpj,jpk)         ! ocean velocity component 
     139!FTRANS ptb ptn pta :I :I :z : 
     140      REAL(wp), INTENT(in   ) ::   ptb(jpi,jpj,jpk,kjpt)    ! tracer field (before) 
     141      REAL(wp), INTENT(in   ) ::   ptn(jpi,jpj,jpk,kjpt)    ! tracer field (now) 
     142      REAL(wp), INTENT(inout) ::   pta(jpi,jpj,jpk,kjpt)    ! tracer trend  
    123143      ! 
    124144      INTEGER  ::   ji, jj, jk, jn   ! dummy loop indices 
    … …  
    164184!!gm  not a big deal since cen2 is no more used in global ice-ocean simulations 
    165185      ztfreez(:,:) = tfreez( tsn(:,:,1,jp_sal) ) 
     186#if defined key_z_first 
     187      DO jj = 1, jpj 
     188         DO ji = 1, jpi 
     189            DO jk = 1, jpk 
     190#else 
    166191      DO jk = 1, jpk 
    167192         DO jj = 1, jpj 
    168193            DO ji = 1, jpi 
     194#endif 
    169195               !                                        ! below ice covered area (if tn < "freezing"+0.1 ) 
    170196               IF( tsn(ji,jj,jk,jp_tem) <= ztfreez(ji,jj) + 0.1 ) THEN   ;   zice = 1.e0 
    … …  
    185211         !    ==================== 
    186212         ! 
     213#if defined key_z_first 
     214         DO jj = 1, jpjm1 
     215            DO ji = 1, fs_jpim1 
     216               DO jk = 1, jpkm1 
     217#else 
    187218         DO jk = 1, jpkm1 
    188219            !                        ! Second order centered tracer flux at u- and v-points 
    … …  
    190221               ! 
    191222               DO ji = 1, fs_jpim1   ! vector opt. 
     223#endif 
    192224                  ! upstream indicator 
    193225                  zcofi = MAX( zind(ji+1,jj,jk), zind(ji,jj,jk) ) 
    … …  
    221253         ENDIF 
    222254         ! 
     255#if defined key_z_first 
     256         DO jj = 2, jpjm1 
     257            DO ji = fs_2, fs_jpim1   ! vector opt. 
     258               DO jk = 2, jpk 
     259#else 
    223260         DO jk = 2, jpk              ! Second order centered tracer flux at w-point 
    224261            DO jj = 2, jpjm1 
    225262               DO ji = fs_2, fs_jpim1   ! vector opt. 
     263#endif 
    226264                  ! upstream indicator 
    227265                  zcofk = MAX( zind(ji,jj,jk-1), zind(ji,jj,jk) )  
    … …  
    240278         ! II. Divergence of advective fluxes 
    241279         ! ---------------------------------- 
     280#if defined key_z_first 
     281         DO jj = 2, jpjm1 
     282            DO ji = fs_2, fs_jpim1   ! vector opt. 
     283               DO jk = 1, jpkm1 
     284#else 
    242285         DO jk = 1, jpkm1 
    243286            DO jj = 2, jpjm1 
    244287               DO ji = fs_2, fs_jpim1   ! vector opt. 
     288#endif 
    245289                  zbtr = 1. / ( e1t(ji,jj) * e2t(ji,jj) *  fse3t(ji,jj,jk) ) 
    246290                  ! advective trends 
    … …  
    278322          wrk_not_released(3, 1,2) )   CALL ctl_stop('tra_adv_cen2: failed to release workspace arrays') 
    279323      ! 
     324 
     325!! * Reset control of array index permutation 
     326!FTRANS CLEAR 
     327#  include "oce_ftrans.h90" 
     328#  include "dom_oce_ftrans.h90" 
     329#  include "trc_oce_ftrans.h90" 
     330#  include "zdf_oce_ftrans.h90" 
     331 
    280332   END SUBROUTINE tra_adv_cen2 
    281333    

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/TRA/traadv_eiv.F90

    r2715 r3211  
    3232 
    3333   PUBLIC   tra_adv_eiv   ! routine called by step.F90 
     34 
     35   !! * Control permutation of array indices 
     36#  include "oce_ftrans.h90" 
     37#  include "dom_oce_ftrans.h90" 
     38#  include "trc_oce_ftrans.h90" 
     39#  include "ldftra_oce_ftrans.h90" 
     40#  include "ldfslp_ftrans.h90" 
    3441 
    3542   !! * Substitutions 
    … …  
    7077      INTEGER                         , INTENT(in   ) ::   kt       ! ocean time-step index 
    7178      CHARACTER(len=3)                , INTENT(in   ) ::   cdtype   ! =TRA or TRC (tracer indicator) 
    72       REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   pun      ! in : 3 ocean velocity components  
    73       REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   pvn      ! out: 3 ocean velocity components 
    74       REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   pwn      ! increased by the eiv 
     79 
     80      !! DCSE_NEMO: This style defeats ftrans 
     81!     REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   pun      ! in : 3 ocean velocity components  
     82!     REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   pvn      ! out: 3 ocean velocity components 
     83!     REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   pwn      ! increased by the eiv 
     84 
     85!FTRANS pun pvn pwn :I :I :z 
     86      REAL(wp), INTENT(inout) ::   pun(jpi,jpj,jpk)      ! in : 3 ocean velocity components  
     87      REAL(wp), INTENT(inout) ::   pvn(jpi,jpj,jpk)      ! out: 3 ocean velocity components 
     88      REAL(wp), INTENT(inout) ::   pwn(jpi,jpj,jpk)      ! increased by the eiv 
    7589      !! 
    7690      INTEGER  ::   ji, jj, jk                 ! dummy loop indices 
    … …  
    105119      zu_eiv(:,:) = 0.e0   ;   zv_eiv(:,:) = 0.e0   ;    zw_eiv(:,:) = 0.e0   
    106120       
     121!!DCSE_NEMO: TODO - restucture loop(s) so that loop over levels is innermost 
    107122                                                    ! ================= 
    108123      DO jk = 1, jpkm1                              !  Horizontal slab 
    … …  
    165180            zztmp = 0.5 * rau0 * rcp  
    166181            z2d(:,:) = 0.e0  
     182#if defined key_z_first 
     183            DO jj = 2, jpjm1 
     184               DO ji = fs_2, fs_jpim1   ! vector opt. 
     185                  DO jk = 1, jpkm1 
     186#else 
    167187            DO jk = 1, jpkm1 
    168188               DO jj = 2, jpjm1 
    169189                  DO ji = fs_2, fs_jpim1   ! vector opt. 
     190#endif 
    170191                     z2d(ji,jj) = z2d(ji,jj) + zztmp * u_eiv(ji,jj,jk) & 
    171192                       &         * (tsn(ji,jj,jk,jp_tem)+tsn(ji+1,jj,jk,jp_tem)) * e1u(ji,jj) * fse3u(ji,jj,jk)  
    … …  
    176197            CALL iom_put( "ueiv_heattr", z2d )                  ! heat transport in i-direction 
    177198            z2d(:,:) = 0.e0  
     199#if defined key_z_first 
     200            DO jj = 2, jpjm1 
     201               DO ji = fs_2, fs_jpim1   ! vector opt. 
     202                  DO jk = 1, jpkm1 
     203#else 
    178204            DO jk = 1, jpkm1 
    179205               DO jj = 2, jpjm1 
    180206                  DO ji = fs_2, fs_jpim1   ! vector opt. 
     207#endif 
    181208                     z2d(ji,jj) = z2d(ji,jj) + zztmp * v_eiv(ji,jj,jk) & 
    182209                     &           * (tsn(ji,jj,jk,jp_tem)+tsn(ji,jj+1,jk,jp_tem)) * e2v(ji,jj) * fse3v(ji,jj,jk)  

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/TRA/traadv_muscl.F90

    r2715 r3211  
    3333 
    3434   LOGICAL  :: l_trd       ! flag to compute trends 
     35 
     36   !! * Control permutation of array indices 
     37#  include "oce_ftrans.h90" 
     38#  include "dom_oce_ftrans.h90" 
     39#  include "trc_oce_ftrans.h90" 
    3540 
    3641   !! * Substitutions 
    … …  
    6469      USE oce     , ONLY:   zwx   => ua       , zwy   => va          ! (ua,va) used as workspace 
    6570      USE wrk_nemo, ONLY:   zslpx => wrk_3d_1 , zslpy => wrk_3d_2    ! 3D workspace 
     71 
     72      !! DCSE_NEMO: need additional directives for renamed module variables 
     73!FTRANS zwx zwy zslpx zslpy :I :I :z 
     74 
    6675      ! 
    6776      INTEGER                              , INTENT(in   ) ::   kt              ! ocean time-step index 
    … …  
    6978      INTEGER                              , INTENT(in   ) ::   kjpt            ! number of tracers 
    7079      REAL(wp), DIMENSION(        jpk     ), INTENT(in   ) ::   p2dt            ! vertical profile of tracer time-step 
    71       REAL(wp), DIMENSION(jpi,jpj,jpk     ), INTENT(in   ) ::   pun, pvn, pwn   ! 3 ocean velocity components 
    72       REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in   ) ::   ptb             ! before tracer field 
    73       REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) ::   pta             ! tracer trend  
     80 
     81      !! DCSE_NEMO: This style defeats ftrans 
     82!     REAL(wp), DIMENSION(jpi,jpj,jpk     ), INTENT(in   ) ::   pun, pvn, pwn   ! 3 ocean velocity components 
     83!     REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in   ) ::   ptb             ! before tracer field 
     84!     REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) ::   pta             ! tracer trend  
     85 
     86!FTRANS pun pvn pwn :I :I :z 
     87!FTRANS ptb :I :I :z : 
     88!FTRANS pta :I :I :z : 
     89      REAL(wp), INTENT(in   ) ::   pun(jpi,jpj,jpk)        ! ocean velocity component (u) 
     90      REAL(wp), INTENT(in   ) ::   pvn(jpi,jpj,jpk)        ! ocean velocity component (v) 
     91      REAL(wp), INTENT(in   ) ::   pwn(jpi,jpj,jpk)        ! ocean velocity component (w) 
     92      REAL(wp), INTENT(in   ) ::   ptb(jpi,jpj,jpk,kjpt)   ! tracer fields (before) 
     93      REAL(wp), INTENT(inout) ::   pta(jpi,jpj,jpk,kjpt)   ! tracer trend  
     94 
    7495      ! 
    7596      INTEGER  ::   ji, jj, jk, jn   ! dummy loop indices 
    … …  
    100121         zwx(:,:,jpk) = 0.e0   ;   zwy(:,:,jpk) = 0.e0        ! bottom values 
    101122         ! interior values 
     123#if defined key_z_first 
     124         DO jj = 1, jpjm1       
     125            DO ji = 1, jpim1 
     126               DO jk = 1, jpkm1 
     127#else 
    102128         DO jk = 1, jpkm1 
    103129            DO jj = 1, jpjm1       
    104130               DO ji = 1, fs_jpim1   ! vector opt. 
     131#endif 
    105132                  zwx(ji,jj,jk) = umask(ji,jj,jk) * ( ptb(ji+1,jj,jk,jn) - ptb(ji,jj,jk,jn) ) 
    106133                  zwy(ji,jj,jk) = vmask(ji,jj,jk) * ( ptb(ji,jj+1,jk,jn) - ptb(ji,jj,jk,jn) ) 
    … …  
    113140         !                                             !-- Slopes of tracer 
    114141         zslpx(:,:,jpk) = 0.e0   ;   zslpy(:,:,jpk) = 0.e0    ! bottom values 
     142#if defined key_z_first 
     143         DO jj = 2, jpj                                       ! interior values 
     144            DO ji = 2, jpi 
     145               DO jk = 1, jpkm1 
     146#else 
    115147         DO jk = 1, jpkm1                                     ! interior values 
    116148            DO jj = 2, jpj 
    117149               DO ji = fs_2, jpi   ! vector opt. 
     150#endif 
    118151                  zslpx(ji,jj,jk) =                    ( zwx(ji,jj,jk) + zwx(ji-1,jj  ,jk) )   & 
    119152                     &            * ( 0.25 + SIGN( 0.25, zwx(ji,jj,jk) * zwx(ji-1,jj  ,jk) ) ) 
    … …  
    124157         END DO 
    125158         ! 
     159#if defined key_z_first 
     160         DO jj = 2, jpj                                       ! Slopes limitation 
     161            DO ji = 2, jpi 
     162               DO jk = 1, jpkm1 
     163#else 
    126164         DO jk = 1, jpkm1                                     ! Slopes limitation 
    127165            DO jj = 2, jpj 
    128166               DO ji = fs_2, jpi   ! vector opt. 
     167#endif 
    129168                  zslpx(ji,jj,jk) = SIGN( 1., zslpx(ji,jj,jk) ) * MIN(    ABS( zslpx(ji  ,jj,jk) ),   & 
    130169                     &                                                 2.*ABS( zwx  (ji-1,jj,jk) ),   & 
    … …  
    138177 
    139178         !                                             !-- MUSCL horizontal advective fluxes 
     179#if defined key_z_first 
     180         DO jj = 2, jpjm1                                     ! interior values 
     181            DO ji = 2, jpim1 
     182               DO jk = 1, jpkm1 
     183                  zdt  = p2dt(jk) 
     184#else 
    140185         DO jk = 1, jpkm1                                     ! interior values 
    141186            zdt  = p2dt(jk) 
    142187            DO jj = 2, jpjm1 
    143188               DO ji = fs_2, fs_jpim1   ! vector opt. 
     189#endif 
    144190                  ! MUSCL fluxes 
    145191                  z0u = SIGN( 0.5, pun(ji,jj,jk) ) 
    … …  
    163209         ! 
    164210         ! Tracer flux divergence at t-point added to the general trend 
     211#if defined key_z_first 
     212         DO jj = 2, jpjm1       
     213            DO ji = 2, jpim1 
     214               DO jk = 1, jpkm1 
     215#else 
    165216         DO jk = 1, jpkm1 
    166217            DO jj = 2, jpjm1       
    167218               DO ji = fs_2, fs_jpim1   ! vector opt. 
     219#endif 
    168220                  zbtr = 1. / ( e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) ) 
    169221                  ! horizontal advective trends 
    … …  
    189241         ! ----------------------------- 
    190242         !                                             !-- first guess of the slopes 
     243#if defined key_z_first 
     244         DO jj = 1, jpj 
     245            DO ji = 1, jpi 
     246               zwx(ji,jj,1) = 0.e0                             ! surface boundary conditions 
     247               DO jk = 2, jpkm1                                ! interior values 
     248                  zwx(ji,jj,jk) = tmask(ji,jj,jk) * ( ptb(ji,jj,jk-1,jn) - ptb(ji,jj,jk,jn) ) 
     249               END DO 
     250               zwx(ji,jj,jpk) = 0.e0                           ! bottom boundary conditions 
     251            END DO 
     252         END DO 
     253#else 
    191254         zwx (:,:, 1 ) = 0.e0    ;    zwx (:,:,jpk) = 0.e0    ! surface & bottom boundary conditions 
    192255         DO jk = 2, jpkm1                                     ! interior values 
    193256            zwx(:,:,jk) = tmask(:,:,jk) * ( ptb(:,:,jk-1,jn) - ptb(:,:,jk,jn) ) 
    194257         END DO 
     258#endif 
    195259 
    196260         !                                             !-- Slopes of tracer 
     261#if defined key_z_first 
     262         DO jj = 1, jpj 
     263            DO ji = 1, jpi 
     264               zslpx(ji,jj,1) = 0.e0                          ! surface values 
     265               DO jk = 2, jpkm1                               ! interior value 
     266#else 
    197267         zslpx(:,:,1) = 0.e0                                  ! surface values 
    198268         DO jk = 2, jpkm1                                     ! interior value 
    199269            DO jj = 1, jpj 
    200270               DO ji = 1, jpi 
     271#endif 
    201272                  zslpx(ji,jj,jk) =                    ( zwx(ji,jj,jk) + zwx(ji,jj,jk+1) )   & 
    202273                     &            * ( 0.25 + SIGN( 0.25, zwx(ji,jj,jk) * zwx(ji,jj,jk+1) ) ) 
    … …  
    205276         END DO 
    206277         !                                             !-- Slopes limitation 
     278#if defined key_z_first 
     279         DO jj = 1, jpj    
     280            DO ji = 1, jpi 
     281               DO jk = 2, jpkm1                               ! interior values 
     282#else 
    207283         DO jk = 2, jpkm1                                     ! interior values 
    208284            DO jj = 1, jpj 
    209285               DO ji = 1, jpi 
     286#endif 
    210287                  zslpx(ji,jj,jk) = SIGN( 1., zslpx(ji,jj,jk) ) * MIN(    ABS( zslpx(ji,jj,jk  ) ),   & 
    211288                     &                                                 2.*ABS( zwx  (ji,jj,jk+1) ),   & 
    … …  
    220297         ENDIF  
    221298         ! 
     299#if defined key_z_first 
     300         DO jj = 2, jpjm1                                     ! interior values 
     301            DO ji = 2, jpim1 
     302               DO jk = 1, jpkm1 
     303                  zdt  = p2dt(jk) 
     304#else 
    222305         DO jk = 1, jpkm1                                     ! interior values 
    223306            zdt  = p2dt(jk) 
    224307            DO jj = 2, jpjm1       
    225308               DO ji = fs_2, fs_jpim1   ! vector opt. 
     309#endif 
    226310                  zbtr = 1. / ( e1t(ji,jj) * e2t(ji,jj) * fse3w(ji,jj,jk+1) ) 
    227311                  z0w = SIGN( 0.5, pwn(ji,jj,jk+1) ) 
    … …  
    236320 
    237321         ! Compute & add the vertical advective trend 
     322#if defined key_z_first 
     323         DO jj = 2, jpjm1       
     324            DO ji = 2, jpim1 
     325               DO jk = 1, jpkm1 
     326#else 
    238327         DO jk = 1, jpkm1 
    239328            DO jj = 2, jpjm1       
    240329               DO ji = fs_2, fs_jpim1   ! vector opt. 
     330#endif 
    241331                  zbtr = 1. / ( e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) ) 
    242332                  ! vertical advective trends  

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/TRA/traadv_muscl2.F90

    r2715 r3211  
    3232   LOGICAL  :: l_trd       ! flag to compute trends 
    3333 
     34   !! * Control permutation of array indices 
     35#  include "oce_ftrans.h90" 
     36#  include "dom_oce_ftrans.h90" 
     37#  include "trc_oce_ftrans.h90" 
     38 
    3439   !! * Substitutions 
    3540#  include "domzgr_substitute.h90" 
    … …  
    6267      USE oce     , ONLY:   zwx   => ua       , zwy   => va         ! (ua,va) used as 3D workspace 
    6368      USE wrk_nemo, ONLY:   zslpx => wrk_3d_1 , zslpy => wrk_3d_2   ! 3D workspace 
     69      !! DCSE_NEMO: need additional directives for renamed module variables 
     70!FTRANS zwx zwy zslpx zslpy :I :I :z 
     71 
    6472      !! 
    6573      INTEGER                              , INTENT(in   ) ::   kt              ! ocean time-step index 
    … …  
    6775      INTEGER                              , INTENT(in   ) ::   kjpt            ! number of tracers 
    6876      REAL(wp), DIMENSION(        jpk     ), INTENT(in   ) ::   p2dt            ! vertical profile of tracer time-step 
    69       REAL(wp), DIMENSION(jpi,jpj,jpk     ), INTENT(in   ) ::   pun, pvn, pwn   ! 3 ocean velocity components 
    70       REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in   ) ::   ptb, ptn        ! before & now tracer fields 
    71       REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) ::   pta             ! tracer trend  
     77 
     78      !! DCSE_NEMO: This style defeats ftrans 
     79!     REAL(wp), DIMENSION(jpi,jpj,jpk     ), INTENT(in   ) ::   pun, pvn, pwn   ! 3 ocean velocity components 
     80!     REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in   ) ::   ptb, ptn        ! before & now tracer fields 
     81!     REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) ::   pta             ! tracer trend  
     82 
     83!FTRANS pun pvn pwn :I :I :z 
     84!FTRANS ptb ptn :I :I :z : 
     85!FTRANS pta :I :I :z : 
     86      REAL(wp), INTENT(in   ) ::   pun(jpi,jpj,jpk)        ! ocean velocity component (u) 
     87      REAL(wp), INTENT(in   ) ::   pvn(jpi,jpj,jpk)        ! ocean velocity component (v) 
     88      REAL(wp), INTENT(in   ) ::   pwn(jpi,jpj,jpk)        ! ocean velocity component (w) 
     89      REAL(wp), INTENT(in   ) ::   ptb(jpi,jpj,jpk,kjpt)   ! tracer fields (before) 
     90      REAL(wp), INTENT(in   ) ::   ptn(jpi,jpj,jpk,kjpt)   ! tracer fields (now) 
     91      REAL(wp), INTENT(inout) ::   pta(jpi,jpj,jpk,kjpt)   ! tracer trend  
     92 
    7293      !! 
    7394      INTEGER  ::   ji, jj, jk, jn   ! dummy loop indices 
    … …  
    98119         zwx(:,:,jpk) = 0.e0   ;   zwy(:,:,jpk) = 0.e0        ! bottom values 
    99120         ! interior values 
     121#if defined key_z_first 
     122         DO jj = 1, jpjm1       
     123            DO ji = 1, jpim1 
     124               DO jk = 1, jpkm1 
     125#else 
    100126         DO jk = 1, jpkm1 
    101127            DO jj = 1, jpjm1       
    102128               DO ji = 1, fs_jpim1   ! vector opt. 
     129#endif 
    103130                  zwx(ji,jj,jk) = umask(ji,jj,jk) * ( ptb(ji+1,jj,jk,jn) - ptb(ji,jj,jk,jn) ) 
    104131                  zwy(ji,jj,jk) = vmask(ji,jj,jk) * ( ptb(ji,jj+1,jk,jn) - ptb(ji,jj,jk,jn) ) 
    … …  
    111138         !                                             !-- Slopes of tracer 
    112139         zslpx(:,:,jpk) = 0.e0   ;   zslpy(:,:,jpk) = 0.e0    ! bottom values 
     140#if defined key_z_first 
     141         DO jj = 2, jpj                                       ! interior values 
     142            DO ji = 2, jpi 
     143               DO jk = 1, jpkm1  
     144#else 
    113145         DO jk = 1, jpkm1                                     ! interior values 
    114146            DO jj = 2, jpj 
    115147               DO ji = fs_2, jpi   ! vector opt. 
     148#endif 
    116149                  zslpx(ji,jj,jk) =                    ( zwx(ji,jj,jk) + zwx(ji-1,jj  ,jk) )   & 
    117150                     &            * ( 0.25 + SIGN( 0.25, zwx(ji,jj,jk) * zwx(ji-1,jj  ,jk) ) ) 
    … …  
    122155         END DO 
    123156         ! 
     157#if defined key_z_first 
     158         DO jj = 2, jpj                                       ! Slopes limitation 
     159            DO ji = 2, jpi 
     160               DO jk = 1, jpkm1 
     161#else 
    124162         DO jk = 1, jpkm1                                     ! Slopes limitation 
    125163            DO jj = 2, jpj 
    126164               DO ji = fs_2, jpi   ! vector opt. 
     165#endif 
    127166                  zslpx(ji,jj,jk) = SIGN( 1., zslpx(ji,jj,jk) ) * MIN(    ABS( zslpx(ji  ,jj,jk) ),   & 
    128167                     &                                                 2.*ABS( zwx  (ji-1,jj,jk) ),   & 
    … …  
    132171                     &                                                 2.*ABS( zwy  (ji,jj  ,jk) ) ) 
    133172               END DO 
    134            END DO 
     173            END DO 
    135174         END DO             ! interior values 
    136175 
    137176        !                                             !-- MUSCL horizontal advective fluxes 
     177#if defined key_z_first 
     178         DO jj = 2, jpjm1 
     179            DO ji = 2, jpim1 
     180               DO jk = 1, jpkm1                               ! interior values 
     181                  zdt  = p2dt(jk) 
     182#else 
    138183         DO jk = 1, jpkm1                                     ! interior values 
    139184            zdt  = p2dt(jk) 
    140185            DO jj = 2, jpjm1 
    141186               DO ji = fs_2, fs_jpim1   ! vector opt. 
     187#endif 
    142188                  ! MUSCL fluxes 
    143189                  z0u = SIGN( 0.5, pun(ji,jj,jk) ) 
    … …  
    159205 
    160206         !!  centered scheme at lateral b.C. if off-shore velocity 
     207#if defined key_z_first 
     208         DO jj = 2, jpjm1 
     209            DO ji = 2, jpim1 
     210               DO jk = 1, jpkm1 
     211#else 
    161212         DO jk = 1, jpkm1 
    162213            DO jj = 2, jpjm1 
    163214               DO ji = fs_2, fs_jpim1   ! vector opt. 
     215#endif 
    164216                  IF( umask(ji,jj,jk) == 0. ) THEN 
    165217                     IF( pun(ji+1,jj,jk) > 0. .AND. ji /= jpi ) THEN 
    … …  
    184236 
    185237         ! Tracer flux divergence at t-point added to the general trend 
     238#if defined key_z_first 
     239         DO jj = 2, jpjm1 
     240            DO ji = 2, jpim1 
     241               DO jk = 1, jpkm1 
     242#else 
    186243         DO jk = 1, jpkm1 
    187244            DO jj = 2, jpjm1 
    188245               DO ji = fs_2, fs_jpim1   ! vector opt. 
     246#endif 
    189247                  zbtr = 1. / ( e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) ) 
    190248                  ! horizontal advective trends  
    … …  
    194252                  pta(ji,jj,jk,jn) = pta(ji,jj,jk,jn) + ztra 
    195253               END DO 
    196            END DO 
     254            END DO 
    197255         END DO 
    198256         !                                 ! trend diagnostics (contribution of upstream fluxes) 
    … …  
    211269         ! ----------------------------- 
    212270         !                                             !-- first guess of the slopes 
     271#if defined key_z_first 
     272         DO jj = 1, jpj 
     273            DO ji = 1, jpi 
     274               zwx(ji,jj,1) = 0.e0                     ! surface boundary conditions 
     275               DO jk = 2, jpkm1                        ! interior values 
     276                  zwx(ji,jj,jk) = tmask(ji,jj,jk) * ( ptb(ji,jj,jk-1,jn) - ptb(ji,jj,jk,jn) ) 
     277               END DO 
     278               zwx(ji,jj,jpk) = 0.e0                   ! bottom boundary conditions 
     279            END DO 
     280         END DO 
     281#else 
    213282         zwx (:,:, 1 ) = 0.e0    ;    zwx (:,:,jpk) = 0.e0    ! surface & bottom boundary conditions 
    214283         DO jk = 2, jpkm1                                     ! interior values 
    215284            zwx(:,:,jk) = tmask(:,:,jk) * ( ptb(:,:,jk-1,jn) - ptb(:,:,jk,jn) ) 
    216285         END DO 
     286#endif 
    217287 
    218288         !                                             !-- Slopes of tracer 
     289#if defined key_z_first 
     290         DO jj = 1, jpj 
     291            DO ji = 1, jpi 
     292               zslpx(ji,jj,1) = 0.e0                          ! surface values 
     293               DO jk = 2, jpkm1                               ! interior value 
     294#else 
    219295         zslpx(:,:,1) = 0.e0                                  ! surface values 
    220296         DO jk = 2, jpkm1                                     ! interior value 
    221297            DO jj = 1, jpj 
    222298               DO ji = 1, jpi 
     299#endif 
    223300                  zslpx(ji,jj,jk) =                    ( zwx(ji,jj,jk) + zwx(ji,jj,jk+1) )   & 
    224301                     &            * ( 0.25 + SIGN( 0.25, zwx(ji,jj,jk) * zwx(ji,jj,jk+1) ) ) 
    … …  
    227304         END DO 
    228305         !                                             !-- Slopes limitation 
     306#if defined key_z_first 
     307         DO jj = 1, jpj 
     308            DO ji = 1, jpi 
     309               DO jk = 2, jpkm1                               ! interior values 
     310#else 
    229311         DO jk = 2, jpkm1                                     ! interior values 
    230312            DO jj = 1, jpj 
    231313               DO ji = 1, jpi 
     314#endif 
    232315                  zslpx(ji,jj,jk) = SIGN( 1., zslpx(ji,jj,jk) ) * MIN(    ABS( zslpx(ji,jj,jk  ) ),   & 
    233316                     &                                                 2.*ABS( zwx  (ji,jj,jk+1) ),   & 
    … …  
    242325         ENDIF 
    243326         ! 
     327#if defined key_z_first 
     328         DO jj = 2, jpjm1                                     ! interior values 
     329            DO ji = 2, jpim1 
     330               DO jk = 1, jpkm1 
     331                  zdt  = p2dt(jk) 
     332#else 
    244333         DO jk = 1, jpkm1                                     ! interior values 
    245334            zdt  = p2dt(jk) 
    246335            DO jj = 2, jpjm1 
    247336               DO ji = fs_2, fs_jpim1   ! vector opt. 
     337#endif 
    248338                  zbtr = 1. / ( e1t(ji,jj) * e2t(ji,jj) * fse3w(ji,jj,jk+1) ) 
    249339                  z0w = SIGN( 0.5, pwn(ji,jj,jk+1) ) 
    … …  
    257347         END DO 
    258348         ! 
    259          DO jk = 2, jpkm1        ! centered near the bottom 
    260             DO jj = 2, jpjm1 
    261                DO ji = fs_2, fs_jpim1   ! vector opt. 
     349#if defined key_z_first 
     350         DO jj = 2, jpjm1 
     351            DO ji = 2, jpim1 
     352               DO jk = 2, jpkm1         ! centered near the bottom 
     353#else 
     354         DO jk = 2, jpkm1               ! centered near the bottom 
     355            DO jj = 2, jpjm1 
     356               DO ji = fs_2, fs_jpim1   ! vector opt. 
     357#endif 
    262358                  IF( tmask(ji,jj,jk+1) == 0. ) THEN 
    263359                     IF( pwn(ji,jj,jk) > 0. ) THEN 
    … …  
    269365         END DO 
    270366         ! 
     367#if defined key_z_first 
     368         DO jj = 2, jpjm1        ! Compute & add the vertical advective trend 
     369            DO ji = 2, jpim1 
     370               DO jk = 1, jpkm1 
     371#else 
    271372         DO jk = 1, jpkm1        ! Compute & add the vertical advective trend 
    272373            DO jj = 2, jpjm1       
    273374               DO ji = fs_2, fs_jpim1   ! vector opt. 
     375#endif 
    274376                  zbtr = 1. / ( e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) ) 
    275377                  ! vertical advective trends  

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/TRA/traadv_qck.F90

    r2715 r3211  
    3535   REAL(wp) :: r1_6 = 1./ 6.   ! 1/6 ratio 
    3636 
     37   !! * Control permutation of array indices 
     38#  include "oce_ftrans.h90" 
     39#  include "dom_oce_ftrans.h90" 
     40#  include "trc_oce_ftrans.h90" 
     41 
    3742   !! * Substitutions 
    3843#  include "domzgr_substitute.h90" 
    … …  
    8590      INTEGER                              , INTENT(in   ) ::   kjpt            ! number of tracers 
    8691      REAL(wp), DIMENSION(        jpk     ), INTENT(in   ) ::   p2dt            ! vertical profile of tracer time-step 
    87       REAL(wp), DIMENSION(jpi,jpj,jpk     ), INTENT(in   ) ::   pun, pvn, pwn   ! 3 ocean velocity components 
    88       REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in   ) ::   ptb, ptn        ! before and now tracer fields 
    89       REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) ::   pta             ! tracer trend  
     92 
     93      !! DCSE_NEMO: This style defeats ftrans 
     94!     REAL(wp), DIMENSION(jpi,jpj,jpk     ), INTENT(in   ) ::   pun, pvn, pwn   ! 3 ocean velocity components 
     95!     REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in   ) ::   ptb, ptn        ! before and now tracer fields 
     96!     REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) ::   pta             ! tracer trend  
     97 
     98!FTRANS pun pvn pwn :I :I :z 
     99!FTRANS ptb ptn :I :I :z : 
     100!FTRANS pta :I :I :z : 
     101      REAL(wp), INTENT(in   ) ::   pun(jpi,jpj,jpk)        ! ocean velocity component (u) 
     102      REAL(wp), INTENT(in   ) ::   pvn(jpi,jpj,jpk)        ! ocean velocity component (v) 
     103      REAL(wp), INTENT(in   ) ::   pwn(jpi,jpj,jpk)        ! ocean velocity component (w) 
     104      REAL(wp), INTENT(in   ) ::   ptb(jpi,jpj,jpk,kjpt)   ! tracer fields (before) 
     105      REAL(wp), INTENT(in   ) ::   ptn(jpi,jpj,jpk,kjpt)   ! tracer fields (now) 
     106      REAL(wp), INTENT(inout) ::   pta(jpi,jpj,jpk,kjpt)   ! tracer trend  
     107 
    90108      !!---------------------------------------------------------------------- 
    91109 
    … …  
    107125      CALL tra_adv_cen2_k( kt, cdtype, pwn,         ptn, pta, kjpt ) 
    108126      ! 
     127 
     128      !! * Reset control of array index permutation 
     129!FTRANS CLEAR 
     130#  include "oce_ftrans.h90" 
     131#  include "dom_oce_ftrans.h90" 
     132#  include "trc_oce_ftrans.h90" 
     133 
    109134   END SUBROUTINE tra_adv_qck 
    110135 
    … …  
    118143      USE oce     , ONLY:   zwx => ua       ! ua used as workspace 
    119144      USE wrk_nemo, ONLY:   zfu => wrk_3d_1 , zfc => wrk_3d_2, zfd => wrk_3d_3   ! 3D workspace 
     145 
     146      !! DCSE_NEMO: need additional directives for renamed module variables 
     147!FTRANS zwx zfu zfc zfd :I :I :z 
     148 
    120149      ! 
    121150      INTEGER                              , INTENT(in   ) ::   kt         ! ocean time-step index 
    … …  
    123152      INTEGER                              , INTENT(in   ) ::   kjpt       ! number of tracers 
    124153      REAL(wp), DIMENSION(        jpk     ), INTENT(in   ) ::   p2dt       ! vertical profile of tracer time-step 
    125       REAL(wp), DIMENSION(jpi,jpj,jpk     ), INTENT(in   ) ::   pun        ! i-velocity components 
    126       REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in   ) ::   ptb, ptn   ! before and now tracer fields 
    127       REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) ::   pta        ! tracer trend  
     154 
     155      !! DCSE_NEMO: This style defeats ftrans 
     156!     REAL(wp), DIMENSION(jpi,jpj,jpk     ), INTENT(in   ) ::   pun        ! i-velocity components 
     157!     REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in   ) ::   ptb, ptn   ! before and now tracer fields 
     158!     REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) ::   pta        ! tracer trend  
     159 
     160!FTRANS pun :I :I :z 
     161!FTRANS ptb ptn pta :I :I :z : 
     162      REAL(wp), INTENT(in   ) ::   pun(jpi,jpj,jpk)         ! i-velocity component 
     163      REAL(wp), INTENT(in   ) ::   ptb(jpi,jpj,jpk,kjpt)    ! tracer field (before) 
     164      REAL(wp), INTENT(in   ) ::   ptn(jpi,jpj,jpk,kjpt)    ! tracer field (now) 
     165      REAL(wp), INTENT(inout) ::   pta(jpi,jpj,jpk,kjpt)    ! tracer trend  
     166 
    128167      !! 
    129168      INTEGER  :: ji, jj, jk, jn   ! dummy loop indices 
    … …  
    140179         zfd(:,:,:) = 0.0     ;   zwx(:,:,:) = 0.0      
    141180         !                                                   
     181#if defined key_z_first 
     182         !--- Computation of the upstream and downstream value of the tracer and the mask 
     183         DO jj = 2, jpjm1 
     184            DO ji = 2, jpim1 
     185               DO jk = 1, jpkm1                                 
     186#else 
    142187         DO jk = 1, jpkm1                                 
    143188            !                                              
    144             !--- Computation of the ustream and downstream value of the tracer and the mask 
     189            !--- Computation of the upstream and downstream value of the tracer and the mask 
    145190            DO jj = 2, jpjm1 
    146191               DO ji = fs_2, fs_jpim1   ! vector opt. 
     192#endif 
    147193                  ! Upstream in the x-direction for the tracer 
    148194                  zfc(ji,jj,jk) = ptb(ji-1,jj,jk,jn) 
    … …  
    158204         ! --------------------------- 
    159205         ! 
     206#if defined key_z_first 
     207         DO jj = 2, jpjm1 
     208            DO ji = 2, jpim1 
     209               DO jk = 1, jpkm1                              
     210#else 
    160211         DO jk = 1, jpkm1                              
    161212            DO jj = 2, jpjm1 
    162213               DO ji = fs_2, fs_jpim1   ! vector opt.          
     214#endif 
    163215                  zdir = 0.5 + SIGN( 0.5, pun(ji,jj,jk) )   ! if pun > 0 : zdir = 1 otherwise zdir = 0  
    164216                  zfu(ji,jj,jk) = zdir * zfc(ji,jj,jk ) + ( 1. - zdir ) * zfd(ji+1,jj,jk)  ! FU in the x-direction for T  
    … …  
    167219         END DO 
    168220         ! 
     221#if defined key_z_first 
     222         DO jj = 2, jpjm1 
     223            DO ji = 2, jpim1 
     224               DO jk = 1, jpkm1   
     225                  zdt =  p2dt(jk) 
     226#else 
    169227         DO jk = 1, jpkm1   
    170228            zdt =  p2dt(jk) 
    171229            DO jj = 2, jpjm1 
    172230               DO ji = fs_2, fs_jpim1   ! vector opt.    
     231#endif 
    173232                  zdir = 0.5 + SIGN( 0.5, pun(ji,jj,jk) )   ! if pun > 0 : zdir = 1 otherwise zdir = 0  
    174233                  zdx  = ( zdir * e1t(ji,jj) + ( 1. - zdir ) * e1t(ji+1,jj) ) * e2u(ji,jj) * fse3u(ji,jj,jk) 
    … …  
    187246         ! 
    188247         ! Mask at the T-points in the x-direction (mask=0 or mask=1) 
     248#if defined key_z_first 
     249         DO jj = 2, jpjm1 
     250            DO ji = 2, jpim1 
     251               DO jk = 1, jpkm1   
     252#else 
    189253         DO jk = 1, jpkm1   
    190254            DO jj = 2, jpjm1 
    191255               DO ji = fs_2, fs_jpim1   ! vector opt.                
     256#endif 
    192257                  zfu(ji,jj,jk) = tmask(ji-1,jj,jk) + tmask(ji,jj,jk) + tmask(ji+1,jj,jk) - 2. 
    193258               END DO 
    … …  
    198263         ! 
    199264         ! Tracer flux on the x-direction 
     265#if defined key_z_first 
     266         DO jj = 2, jpjm1 
     267            DO ji = 2, jpim1 
     268               DO jk = 1, jpkm1   
     269#else 
    200270         DO jk = 1, jpkm1   
    201             ! 
    202271            DO jj = 2, jpjm1 
    203272               DO ji = fs_2, fs_jpim1   ! vector opt.                
     273#endif 
    204274                  zdir = 0.5 + SIGN( 0.5, pun(ji,jj,jk) )   ! if pun > 0 : zdir = 1 otherwise zdir = 0  
    205275                  !--- If the second ustream point is a land point 
    … …  
    210280               END DO 
    211281            END DO 
     282#if defined key_z_first 
     283         END DO 
     284         ! Computation of the trend 
     285         DO jj = 2, jpjm1 
     286            DO ji = 2, jpim1 
     287               DO jk = 1, jpkm1 
     288#else 
    212289            ! 
    213290            ! Computation of the trend 
    214291            DO jj = 2, jpjm1 
    215292               DO ji = fs_2, fs_jpim1   ! vector opt.   
     293#endif 
    216294                  zbtr = 1. / ( e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) ) 
    217295                  ! horizontal advective trends 
    … …  
    230308      IF( wrk_not_released(3, 1,2,3) )   CALL ctl_stop('tra_adv_qck_i: failed to release workspace arrays') 
    231309      ! 
     310 
     311      !! * Reset control of array index permutation 
     312!FTRANS CLEAR 
     313#  include "oce_ftrans.h90" 
     314#  include "dom_oce_ftrans.h90" 
     315#  include "trc_oce_ftrans.h90" 
     316 
    232317   END SUBROUTINE tra_adv_qck_i 
    233318 
    … …  
    241326      USE oce     , ONLY:   zwy => ua       ! ua used as workspace 
    242327      USE wrk_nemo, ONLY:   zfu => wrk_3d_1 , zfc => wrk_3d_2, zfd => wrk_3d_3   ! 3D workspace 
     328 
     329      !! DCSE_NEMO: need additional directives for renamed module variables 
     330!FTRANS zwy zfu zfc zfd :I :I :z 
     331 
    243332      ! 
    244333      INTEGER                              , INTENT(in   ) ::   kt         ! ocean time-step index 
    … …  
    246335      INTEGER                              , INTENT(in   ) ::   kjpt       ! number of tracers 
    247336      REAL(wp), DIMENSION(        jpk     ), INTENT(in   ) ::   p2dt       ! vertical profile of tracer time-step 
    248       REAL(wp), DIMENSION(jpi,jpj,jpk     ), INTENT(in   ) ::   pvn        ! j-velocity components 
    249       REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in   ) ::   ptb, ptn   ! before and now tracer fields 
    250       REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) ::   pta        ! tracer trend  
     337 
     338      !! DCSE_NEMO: This style defeats ftrans 
     339!     REAL(wp), DIMENSION(jpi,jpj,jpk     ), INTENT(in   ) ::   pvn        ! j-velocity components 
     340!     REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in   ) ::   ptb, ptn   ! before and now tracer fields 
     341!     REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) ::   pta        ! tracer trend  
     342 
     343!FTRANS pvn :I :I :z 
     344!FTRANS ptb ptn pta :I :I :z : 
     345      REAL(wp), INTENT(in   ) ::   pvn(jpi,jpj,jpk)         ! j-velocity component 
     346      REAL(wp), INTENT(in   ) ::   ptb(jpi,jpj,jpk,kjpt)    ! tracer field (before) 
     347      REAL(wp), INTENT(in   ) ::   ptn(jpi,jpj,jpk,kjpt)    ! tracer field (now) 
     348      REAL(wp), INTENT(inout) ::   pta(jpi,jpj,jpk,kjpt)    ! tracer trend  
     349 
    251350      !! 
    252351      INTEGER  :: ji, jj, jk, jn   ! dummy loop indices 
    … …  
    264363         zfd(:,:,:) = 0.0     ;   zwy(:,:,:) = 0.0      
    265364         !                                                   
     365#if defined key_z_first 
     366         !--- Computation of the ustream and downstream value of the tracer and the mask 
     367         DO jj = 2, jpjm1 
     368            DO ji = 2, jpim1 
     369               DO jk = 1, jpkm1                                 
     370#else 
    266371         DO jk = 1, jpkm1                                 
    267372            !                                              
    … …  
    269374            DO jj = 2, jpjm1 
    270375               DO ji = fs_2, fs_jpim1   ! vector opt. 
     376#endif 
    271377                  ! Upstream in the x-direction for the tracer 
    272378                  zfc(ji,jj,jk) = ptb(ji,jj-1,jk,jn) 
    … …  
    283389         ! --------------------------- 
    284390         ! 
     391#if defined key_z_first 
     392         DO jj = 2, jpjm1 
     393            DO ji = 2, jpim1 
     394               DO jk = 1, jpkm1                              
     395#else 
    285396         DO jk = 1, jpkm1                              
    286397            DO jj = 2, jpjm1 
    287398               DO ji = fs_2, fs_jpim1   ! vector opt.          
     399#endif 
    288400                  zdir = 0.5 + SIGN( 0.5, pvn(ji,jj,jk) )   ! if pun > 0 : zdir = 1 otherwise zdir = 0  
    289401                  zfu(ji,jj,jk) = zdir * zfc(ji,jj,jk ) + ( 1. - zdir ) * zfd(ji,jj+1,jk)  ! FU in the x-direction for T  
    … …  
    292404         END DO 
    293405         ! 
     406#if defined key_z_first 
     407         DO jj = 2, jpjm1 
     408            DO ji = 2, jpim1 
     409               DO jk = 1, jpkm1   
     410                  zdt =  p2dt(jk) 
     411#else 
    294412         DO jk = 1, jpkm1   
    295413            zdt =  p2dt(jk) 
    296414            DO jj = 2, jpjm1 
    297415               DO ji = fs_2, fs_jpim1   ! vector opt.    
     416#endif 
    298417                  zdir = 0.5 + SIGN( 0.5, pvn(ji,jj,jk) )   ! if pun > 0 : zdir = 1 otherwise zdir = 0  
    299418                  zdx  = ( zdir * e2t(ji,jj) + ( 1. - zdir ) * e2t(ji,jj+1) ) * e1v(ji,jj) * fse3v(ji,jj,jk) 
    … …  
    313432         ! 
    314433         ! Mask at the T-points in the x-direction (mask=0 or mask=1) 
     434#if defined key_z_first 
     435         DO jj = 2, jpjm1 
     436            DO ji = 2, jpim1 
     437               DO jk = 1, jpkm1   
     438#else 
    315439         DO jk = 1, jpkm1   
    316440            DO jj = 2, jpjm1 
    317441               DO ji = fs_2, fs_jpim1   ! vector opt.                
     442#endif 
    318443                  zfu(ji,jj,jk) = tmask(ji,jj-1,jk) + tmask(ji,jj,jk) + tmask(ji,jj+1,jk) - 2. 
    319444               END DO 
    … …  
    324449         ! 
    325450         ! Tracer flux on the x-direction 
     451#if defined key_z_first 
     452         DO jj = 2, jpjm1 
     453            DO ji = 2, jpim1 
     454               DO jk = 1, jpkm1   
     455#else 
    326456         DO jk = 1, jpkm1   
    327457            ! 
    328458            DO jj = 2, jpjm1 
    329459               DO ji = fs_2, fs_jpim1   ! vector opt.                
     460#endif 
    330461                  zdir = 0.5 + SIGN( 0.5, pvn(ji,jj,jk) )   ! if pun > 0 : zdir = 1 otherwise zdir = 0  
    331462                  !--- If the second ustream point is a land point 
    … …  
    336467               END DO 
    337468            END DO 
     469#if defined key_z_first 
     470         END DO 
     471         ! Computation of the trend 
     472         DO jj = 2, jpjm1 
     473            DO ji = 2, jpim1 
     474               DO jk = 1, jpkm1 
     475#else 
    338476            ! 
    339477            ! Computation of the trend 
    340478            DO jj = 2, jpjm1 
    341479               DO ji = fs_2, fs_jpim1   ! vector opt.   
     480#endif 
    342481                  zbtr = 1. / ( e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) ) 
    343482                  ! horizontal advective trends 
    … …  
    361500      IF( wrk_not_released(3, 1,2,3) )   CALL ctl_stop('tra_adv_qck_j: failed to release workspace arrays') 
    362501      ! 
     502 
     503      !! * Reset control of array index permutation 
     504!FTRANS CLEAR 
     505#  include "oce_ftrans.h90" 
     506#  include "dom_oce_ftrans.h90" 
     507#  include "trc_oce_ftrans.h90" 
     508 
    363509   END SUBROUTINE tra_adv_qck_j 
    364510 
    … …  
    370516      !!---------------------------------------------------------------------- 
    371517      USE oce, ONLY:   zwz => ua   ! ua used as workspace 
     518 
     519      !! DCSE_NEMO: need additional directives for renamed module variables 
     520!FTRANS zwz :I :I :z 
     521 
    372522      ! 
    373523      INTEGER                              , INTENT(in   ) ::   kt       ! ocean time-step index 
    374524      CHARACTER(len=3)                     , INTENT(in   ) ::   cdtype   ! =TRA or TRC (tracer indicator) 
    375525      INTEGER                              , INTENT(in   ) ::   kjpt     ! number of tracers 
    376       REAL(wp), DIMENSION(jpi,jpj,jpk     ), INTENT(in   ) ::   pwn      ! vertical velocity  
    377       REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in   ) ::   ptn      ! before and now tracer fields 
    378       REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) ::   pta      ! tracer trend  
     526 
     527      !! DCSE_NEMO: This style defeats ftrans 
     528!     REAL(wp), DIMENSION(jpi,jpj,jpk     ), INTENT(in   ) ::   pwn      ! vertical velocity  
     529!     REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in   ) ::   ptn      ! tracer fields (now) 
     530!     REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) ::   pta      ! tracer trend  
     531 
     532!FTRANS pwn :I :I :z 
     533!FTRANS ptn pta :I :I :z : 
     534      REAL(wp), INTENT(in   ) ::   pwn(jpi,jpj,jpk)         ! vertical velocity 
     535      REAL(wp), INTENT(in   ) ::   ptn(jpi,jpj,jpk,kjpt)    ! tracer fields (now) 
     536      REAL(wp), INTENT(inout) ::   pta(jpi,jpj,jpk,kjpt)    ! tracer trend  
     537 
    379538      ! 
    380539      INTEGER  ::   ji, jj, jk, jn   ! dummy loop indices 
    … …  
    393552         ENDIF 
    394553         ! 
     554#if defined key_z_first 
     555         DO jj = 2, jpjm1 
     556            DO ji = 2, jpim1 
     557               DO jk = 2, jpkm1            ! Interior point: second order centered tracer flux at w-point 
     558#else 
    395559         DO jk = 2, jpkm1                  ! Interior point: second order centered tracer flux at w-point 
    396560            DO jj = 2, jpjm1 
    397561               DO ji = fs_2, fs_jpim1   ! vector opt. 
     562#endif 
    398563                  zwz(ji,jj,jk) = 0.5 * pwn(ji,jj,jk) * ( ptn(ji,jj,jk-1,jn) + ptn(ji,jj,jk,jn) ) 
    399564               END DO 
    … …  
    401566         END DO 
    402567         ! 
     568#if defined key_z_first 
     569         DO jj = 2, jpjm1 
     570            DO ji = 2, jpim1 
     571               DO jk = 1, jpkm1    !==  Tracer flux divergence added to the general trend  ==! 
     572#else 
    403573         DO jk = 1, jpkm1          !==  Tracer flux divergence added to the general trend  ==! 
    404574            DO jj = 2, jpjm1 
    405575               DO ji = fs_2, fs_jpim1   ! vector opt. 
     576#endif 
    406577                  zbtr = 1. / ( e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) ) 
    407578                  ! k- vertical advective trends  
    … …  
    417588      END DO 
    418589      ! 
     590 
     591      !! * Reset control of array index permutation 
     592!FTRANS CLEAR 
     593#  include "oce_ftrans.h90" 
     594#  include "dom_oce_ftrans.h90" 
     595#  include "trc_oce_ftrans.h90" 
     596 
    419597   END SUBROUTINE tra_adv_cen2_k 
    420598 
    … …  
    427605      !! ** Method :    
    428606      !!---------------------------------------------------------------------- 
    429       REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in   ) ::   pfu   ! second upwind point 
    430       REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in   ) ::   pfd   ! first douwning point 
    431       REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in   ) ::   pfc   ! the central point (or the first upwind point) 
    432       REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   puc   ! input as Courant number ; output as flux 
     607 
     608      !! DCSE_NEMO: This style defeats ftrans 
     609 
     610!     REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in   ) ::   pfu   ! second upwind point 
     611!     REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in   ) ::   pfd   ! first douwning point 
     612!     REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in   ) ::   pfc   ! the central point (or the first upwind point) 
     613!     REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   puc   ! input as Courant number ; output as flux 
     614 
     615!FTRANS pfu pfd pfc puc :I :I :z 
     616      REAL(wp), INTENT(in   ) ::   pfu(jpi,jpj,jpk)   ! second upwind point 
     617      REAL(wp), INTENT(in   ) ::   pfd(jpi,jpj,jpk)   ! first douwning point 
     618      REAL(wp), INTENT(in   ) ::   pfc(jpi,jpj,jpk)   ! the central point (or the first upwind point) 
     619      REAL(wp), INTENT(inout) ::   puc(jpi,jpj,jpk)   ! input as Courant number ; output as flux 
     620 
    433621      !! 
    434622      INTEGER  ::  ji, jj, jk               ! dummy loop indices  
    … …  
    437625      !---------------------------------------------------------------------- 
    438626 
     627#if defined key_z_first 
     628      DO jj = 1, jpj 
     629         DO ji = 1, jpi 
     630            DO jk = 1, jpkm1 
     631#else 
    439632      DO jk = 1, jpkm1 
    440633         DO jj = 1, jpj 
    441634            DO ji = 1, jpi 
     635#endif 
    442636               zc     = puc(ji,jj,jk)                         ! Courant number 
    443637               zcurv  = pfd(ji,jj,jk) + pfu(ji,jj,jk) - 2. * pfc(ji,jj,jk) 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/TRA/traadv_tvd.F90

    r2715 r3211  
    4040 
    4141   LOGICAL ::   l_trd   ! flag to compute trends 
     42 
     43   !! * Control permutation of array indices 
     44#  include "oce_ftrans.h90" 
     45#  include "dom_oce_ftrans.h90" 
     46#  include "trc_oce_ftrans.h90" 
    4247 
    4348   !! * Substitutions 
    … …  
    6974      USE oce     , ONLY:   zwx => ua        , zwy => va          ! (ua,va) used as workspace 
    7075      USE wrk_nemo, ONLY:   zwi => wrk_3d_12 , zwz => wrk_3d_13   ! 3D workspace 
     76 
     77      !! DCSE_NEMO: need additional directives for renamed module variables 
     78!FTRANS zwx zwy zwi zwz :I :I :z 
     79 
    7180      ! 
    7281      INTEGER                              , INTENT(in   ) ::   kt              ! ocean time-step index 
    … …  
    7483      INTEGER                              , INTENT(in   ) ::   kjpt            ! number of tracers 
    7584      REAL(wp), DIMENSION(        jpk     ), INTENT(in   ) ::   p2dt            ! vertical profile of tracer time-step 
    76       REAL(wp), DIMENSION(jpi,jpj,jpk     ), INTENT(in   ) ::   pun, pvn, pwn   ! 3 ocean velocity components 
    77       REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in   ) ::   ptb, ptn        ! before and now tracer fields 
    78       REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) ::   pta             ! tracer trend  
     85 
     86      !! DCSE_NEMO: This style defeats ftrans 
     87!     REAL(wp), DIMENSION(jpi,jpj,jpk     ), INTENT(in   ) ::   pun, pvn, pwn   ! 3 ocean velocity components 
     88!     REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in   ) ::   ptb, ptn        ! before and now tracer fields 
     89!     REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) ::   pta             ! tracer trend  
     90 
     91!FTRANS pun pvn pwn :I :I :z 
     92!FTRANS ptb ptn pta :I :I :z : 
     93      REAL(wp), INTENT(in   ) ::   pun(jpi,jpj,jpk)        ! ocean velocity component (u) 
     94      REAL(wp), INTENT(in   ) ::   pvn(jpi,jpj,jpk)        ! ocean velocity component (v) 
     95      REAL(wp), INTENT(in   ) ::   pwn(jpi,jpj,jpk)        ! ocean velocity component (w) 
     96      REAL(wp), INTENT(in   ) ::   ptb(jpi,jpj,jpk,kjpt)   ! tracer fields (before) 
     97      REAL(wp), INTENT(in   ) ::   ptn(jpi,jpj,jpk,kjpt)   ! tracer fields (now) 
     98      REAL(wp), INTENT(inout) ::   pta(jpi,jpj,jpk,kjpt)   ! tracer trend  
     99 
    79100      ! 
    80101      INTEGER  ::   ji, jj, jk, jn           ! dummy loop indices   
    … …  
    83104      REAL(wp) ::   zfm_ui, zfm_vj, zfm_wk   !   -      - 
    84105      REAL(wp), DIMENSION (:,:,:), ALLOCATABLE ::   ztrdx, ztrdy, ztrdz 
     106!FTRANS ztrdx ztrdy ztrdz :I :I :z 
     107 
    85108      !!---------------------------------------------------------------------- 
    86109 
    … …  
    117140         ! -------------------------------------------------------------------- 
    118141         ! upstream tracer flux in the i and j direction 
     142#if defined key_z_first 
     143         DO jj = 1, jpjm1 
     144            DO ji = 1, jpim1 
     145               DO jk = 1, jpkm1 
     146#else 
    119147         DO jk = 1, jpkm1 
    120148            DO jj = 1, jpjm1 
    121149               DO ji = 1, fs_jpim1   ! vector opt. 
     150#endif 
    122151                  ! upstream scheme 
    123152                  zfp_ui = pun(ji,jj,jk) + ABS( pun(ji,jj,jk) ) 
    … …  
    137166         ENDIF 
    138167         ! Interior value 
     168#if defined key_z_first 
     169         DO jj = 1, jpj 
     170            DO ji = 1, jpi 
     171               DO jk = 2, jpkm1 
     172#else 
    139173         DO jk = 2, jpkm1 
    140174            DO jj = 1, jpj 
    141175               DO ji = 1, jpi 
     176#endif 
    142177                  zfp_wk = pwn(ji,jj,jk) + ABS( pwn(ji,jj,jk) ) 
    143178                  zfm_wk = pwn(ji,jj,jk) - ABS( pwn(ji,jj,jk) ) 
    … …  
    148183 
    149184         ! total advective trend 
     185#if defined key_z_first 
     186         DO jj = 2, jpjm1 
     187            DO ji = 2, jpim1 
     188               DO jk = 1, jpkm1 
     189                  z2dtt = p2dt(jk) 
     190#else 
    150191         DO jk = 1, jpkm1 
    151192            z2dtt = p2dt(jk) 
    152193            DO jj = 2, jpjm1 
    153194               DO ji = fs_2, fs_jpim1   ! vector opt. 
     195#endif 
    154196                  zbtr = 1. / ( e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) ) 
    155197                  ! total intermediate advective trends 
    … …  
    180222         ! -------------------------------------------------- 
    181223         ! antidiffusive flux on i and j 
     224#if defined key_z_first 
     225         DO jj = 1, jpjm1 
     226            DO ji = 1, jpim1 
     227               DO jk = 1, jpkm1 
     228#else 
    182229         DO jk = 1, jpkm1 
    183230            DO jj = 1, jpjm1 
    184231               DO ji = 1, fs_jpim1   ! vector opt. 
     232#endif 
    185233                  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) 
    186234                  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) 
    … …  
    190238       
    191239         ! antidiffusive flux on k 
    192          zwz(:,:,1) = 0.e0         ! Surface value 
     240#if defined key_z_first 
     241         DO jj = 1, jpj 
     242            DO ji = 1, jpi 
     243               zwz(ji,jj,1) = 0.e0   ! Surface value 
     244               DO jk = 2, jpkm1 
     245#else 
     246         zwz(:,:,1) = 0.e0           ! Surface value 
    193247         ! 
    194          DO jk = 2, jpkm1          ! Interior value 
     248         DO jk = 2, jpkm1            ! Interior value 
    195249            DO jj = 1, jpj 
    196250               DO ji = 1, jpi 
     251#endif 
    197252                  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) 
    198253               END DO 
    … …  
    209264         ! 5. final trend with corrected fluxes 
    210265         ! ------------------------------------ 
     266#if defined key_z_first 
     267         DO jj = 2, jpjm1 
     268            DO ji = 2, jpim1 
     269               DO jk = 1, jpkm1 
     270#else 
    211271         DO jk = 1, jpkm1 
    212272            DO jj = 2, jpjm1 
    213273               DO ji = fs_2, fs_jpim1   ! vector opt.   
     274#endif 
    214275                  zbtr = 1. / ( e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) ) 
    215276                  ! total advective trends 
    … …  
    247308      IF( wrk_not_released(3, 12,13) )   CALL ctl_stop('tra_adv_tvd: failed to release workspace arrays') 
    248309      ! 
     310 
     311      !! * Reset control of array index permutation 
     312!FTRANS CLEAR 
     313#  include "oce_ftrans.h90" 
     314#  include "dom_oce_ftrans.h90" 
     315#  include "trc_oce_ftrans.h90" 
     316 
    249317   END SUBROUTINE tra_adv_tvd 
    250318 
    … …  
    266334      USE wrk_nemo, ONLY:   zbetup => wrk_3d_8  , zbetdo => wrk_3d_9    ! 3D workspace 
    267335      USE wrk_nemo, ONLY:   zbup   => wrk_3d_10 , zbdo   => wrk_3d_11   !  -     - 
     336 
     337      !! DCSE_NEMO: need additional directives for renamed module variables 
     338!FTRANS zbetup zbetdo zbup zbdo :I :I :z 
     339 
    268340      ! 
    269341      REAL(wp), DIMENSION(jpk)         , INTENT(in   ) ::   p2dt            ! vertical profile of tracer time-step 
    270       REAL(wp), DIMENSION (jpi,jpj,jpk), INTENT(in   ) ::   pbef, paft      ! before & after field 
    271       REAL(wp), DIMENSION (jpi,jpj,jpk), INTENT(inout) ::   paa, pbb, pcc   ! monotonic fluxes in the 3 directions 
     342 
     343      !! DCSE_NEMO: This style defeats ftrans 
     344!     REAL(wp), DIMENSION (jpi,jpj,jpk), INTENT(in   ) ::   pbef, paft      ! before & after field 
     345!     REAL(wp), DIMENSION (jpi,jpj,jpk), INTENT(inout) ::   paa, pbb, pcc   ! monotonic fluxes in the 3 directions 
     346 
     347!FTRANS pbef paft :I :I :z 
     348!FTRANS paa pbb pcc :I :I :z 
     349      REAL(wp), INTENT(in   ) ::   pbef(jpi,jpj,jpk), paft(jpi,jpj,jpk)     ! before & after field 
     350      REAL(wp), INTENT(inout) ::   paa(jpi,jpj,jpk)                         ! monotonic fluxes in the 1st direction 
     351      REAL(wp), INTENT(inout) ::   pbb(jpi,jpj,jpk)                         ! monotonic fluxes in the 2nd direction 
     352      REAL(wp), INTENT(inout) ::   pcc(jpi,jpj,jpk)                         ! monotonic fluxes in the 3rd direction 
    272353      ! 
    273354      INTEGER ::   ji, jj, jk   ! dummy loop indices 
    … …  
    294375         &        paft * tmask + zbig * ( 1.e0 - tmask )  ) 
    295376 
     377#if defined key_z_first 
     378      DO jj = 2, jpjm1 
     379         DO ji = 2, jpim1 
     380            DO jk = 1, jpkm1 
     381               ikm1 = MAX(jk-1,1) 
     382               z2dtt = p2dt(jk) 
     383#else 
    296384      DO jk = 1, jpkm1 
    297385         ikm1 = MAX(jk-1,1) 
    … …  
    299387         DO jj = 2, jpjm1 
    300388            DO ji = fs_2, fs_jpim1   ! vector opt. 
     389#endif 
    301390 
    302391               ! search maximum in neighbourhood 
    … …  
    335424      ! 3. monotonic flux in the i & j direction (paa & pbb) 
    336425      ! ---------------------------------------- 
     426#if defined key_z_first 
     427      DO jj = 2, jpjm1 
     428         DO ji = 2, jpim1 
     429            DO jk = 1, jpkm1 
     430#else 
    337431      DO jk = 1, jpkm1 
    338432         DO jj = 2, jpjm1 
    339433            DO ji = fs_2, fs_jpim1   ! vector opt. 
     434#endif 
    340435               zau = MIN( 1.e0, zbetdo(ji,jj,jk), zbetup(ji+1,jj,jk) ) 
    341436               zbu = MIN( 1.e0, zbetup(ji,jj,jk), zbetdo(ji+1,jj,jk) ) 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/TRA/traadv_ubs.F90

    r2715 r3211  
    2929 
    3030   LOGICAL :: l_trd  ! flag to compute trends or not 
     31 
     32   !! * Control permutation of array indices 
     33#  include "oce_ftrans.h90" 
     34#  include "dom_oce_ftrans.h90" 
     35#  include "trc_oce_ftrans.h90" 
    3136 
    3237   !! * Substitutions 
    … …  
    7883      USE wrk_nemo, ONLY:   zltu => wrk_3d_3 , zltv => wrk_3d_4   !  -      - 
    7984      USE wrk_nemo, ONLY:   zti  => wrk_3d_5 , ztw  => wrk_3d_6   !  -      - 
     85 
     86      !! DCSE_NEMO: need additional directives for renamed module variables 
     87!FTRANS zwx zwy ztu ztv zltu zltv zti ztw :I :I :z 
     88 
    8089      ! 
    8190      INTEGER                              , INTENT(in   ) ::   kt              ! ocean time-step index 
    … …  
    8392      INTEGER                              , INTENT(in   ) ::   kjpt            ! number of tracers 
    8493      REAL(wp), DIMENSION(        jpk     ), INTENT(in   ) ::   p2dt            ! vertical profile of tracer time-step 
    85       REAL(wp), DIMENSION(jpi,jpj,jpk     ), INTENT(in   ) ::   pun, pvn, pwn   ! 3 ocean velocity components 
    86       REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in   ) ::   ptb, ptn        ! before and now tracer fields 
    87       REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) ::   pta             ! tracer trend  
     94 
     95!     REAL(wp), DIMENSION(jpi,jpj,jpk     ), INTENT(in   ) ::   pun, pvn, pwn   ! 3 ocean velocity components 
     96!     REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in   ) ::   ptb, ptn        ! before and now tracer fields 
     97!     REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) ::   pta             ! tracer trend  
     98 
     99!FTRANS pun pvn pwn :I :I :z 
     100!FTRANS ptb ptn pta :I :I :z : 
     101      REAL(wp), INTENT(in   ) ::   pun(jpi,jpj,jpk)        ! ocean velocity component (u) 
     102      REAL(wp), INTENT(in   ) ::   pvn(jpi,jpj,jpk)        ! ocean velocity component (v) 
     103      REAL(wp), INTENT(in   ) ::   pwn(jpi,jpj,jpk)        ! ocean velocity component (w) 
     104!! DCSE_NEMO: Next two arguments made inout to silence the cray compile, 
     105!! which rightly complains about the call to nonosc_v (which also has them 
     106!! as inout)  
     107      REAL(wp), INTENT(inout) ::   ptb(jpi,jpj,jpk,kjpt)   ! tracer fields (before) 
     108      REAL(wp), INTENT(inout) ::   ptn(jpi,jpj,jpk,kjpt)   ! tracer fields (now) 
     109      REAL(wp), INTENT(inout) ::   pta(jpi,jpj,jpk,kjpt)   ! tracer trend  
     110 
    88111      ! 
    89112      INTEGER  ::   ji, jj, jk, jn   ! dummy loop indices 
    … …  
    113136         zltu(:,:,jpk) = 0.e0       ;      zltv(:,:,jpk) = 0.e0 
    114137         !                                               
     138#if defined key_z_first 
     139         DO jj = 1, jpjm1 
     140            DO ji = 1, jpim1 
     141               DO jk = 1, jpkm1 
     142#else 
    115143         DO jk = 1, jpkm1                                 ! Horizontal slab 
    116144            !                                    
    … …  
    118146            DO jj = 1, jpjm1            ! First derivative (gradient) 
    119147               DO ji = 1, fs_jpim1   ! vector opt. 
     148#endif 
    120149                  zeeu = e2u(ji,jj) * fse3u(ji,jj,jk) / e1u(ji,jj) * umask(ji,jj,jk) 
    121150                  zeev = e1v(ji,jj) * fse3v(ji,jj,jk) / e2v(ji,jj) * vmask(ji,jj,jk) 
    … …  
    124153               END DO 
    125154            END DO 
     155#if defined key_z_first 
     156         END DO 
     157         DO jj = 2, jpjm1               ! Second derivative (divergence) 
     158            DO ji = 2, jpim1 
     159               DO jk = 1, jpkm1 
     160#else 
    126161            DO jj = 2, jpjm1            ! Second derivative (divergence) 
    127162               DO ji = fs_2, fs_jpim1   ! vector opt. 
     163#endif 
    128164                  zcoef = 1. / ( 6. * fse3t(ji,jj,jk) ) 
    129165                  zltu(ji,jj,jk) = (  ztu(ji,jj,jk) - ztu(ji-1,jj,jk)  ) * zcoef 
    … …  
    137173         !     
    138174         !  Horizontal advective fluxes                
     175#if defined key_z_first 
     176         DO jj = 1, jpjm1 
     177            DO ji = 1, jpim1 
     178               DO jk = 1, jpkm1 
     179#else 
    139180         DO jk = 1, jpkm1                                 ! Horizontal slab 
    140181            DO jj = 1, jpjm1 
    141182               DO ji = 1, fs_jpim1   ! vector opt. 
     183#endif 
    142184                  ! upstream transport 
    143185                  zfp_ui = pun(ji,jj,jk) + ABS( pun(ji,jj,jk) ) 
    … …  
    158200 
    159201         ! Horizontal advective trends 
     202#if defined key_z_first 
     203         DO jj = 2, jpjm1 
     204            DO ji = 2, jpim1 
     205               DO jk = 1, jpkm1 
     206#else 
    160207         DO jk = 1, jpkm1 
    161208            !  Tracer flux divergence at t-point added to the general trend 
    162209            DO jj = 2, jpjm1 
    163210               DO ji = fs_2, fs_jpim1   ! vector opt. 
     211#endif 
    164212                  zbtr = 1. / ( e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) ) 
    165213                  ! horizontal advective 
    … …  
    203251         ! ------------------------------------------------------------------- 
    204252         ! Interior value 
     253#if defined key_z_first 
     254         DO jj = 1, jpj 
     255            DO ji = 1, jpi 
     256               DO jk = 2, jpkm1 
     257#else 
    205258         DO jk = 2, jpkm1 
    206259            DO jj = 1, jpj 
    207260               DO ji = 1, jpi 
     261#endif 
    208262                   zfp_wk = pwn(ji,jj,jk) + ABS( pwn(ji,jj,jk) ) 
    209263                   zfm_wk = pwn(ji,jj,jk) - ABS( pwn(ji,jj,jk) ) 
    … …  
    213267         END DO  
    214268         ! update and guess with monotonic sheme 
     269#if defined key_z_first 
     270         DO jj = 2, jpjm1 
     271            DO ji = 2, jpim1 
     272               DO jk = 1, jpkm1 
     273                  z2dtt = p2dt(jk) 
     274#else 
    215275         DO jk = 1, jpkm1 
    216276            z2dtt = p2dt(jk) 
    217277            DO jj = 2, jpjm1 
    218278               DO ji = fs_2, fs_jpim1   ! vector opt. 
     279#endif 
    219280                  zbtr = 1. / ( e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) ) 
    220281                  ztak = - ( ztw(ji,jj,jk) - ztw(ji,jj,jk+1) ) * zbtr 
    … …  
    228289 
    229290         !  antidiffusive flux : high order minus low order 
     291#if defined key_z_first 
     292         DO jj = 1, jpj 
     293            DO ji = 1, jpi 
     294               ztw(ji,jj,1) = 0.e0   ! Surface value 
     295               DO jk = 2, jpkm1      ! Interior value 
     296#else 
    230297         ztw(:,:,1) = 0.e0       ! Surface value 
    231298         DO jk = 2, jpkm1        ! Interior value 
    232299            DO jj = 1, jpj 
    233300               DO ji = 1, jpi 
     301#endif 
    234302                  ztw(ji,jj,jk) = 0.5 * pwn(ji,jj,jk) * ( ptn(ji,jj,jk,jn) + ptn(ji,jj,jk-1,jn) ) - ztw(ji,jj,jk) 
    235303               END DO 
    … …  
    240308 
    241309         !  final trend with corrected fluxes 
     310#if defined key_z_first 
     311         DO jj = 2, jpjm1  
     312            DO ji = 2, jpim1 
     313               DO jk = 1, jpkm1 
     314#else 
    242315         DO jk = 1, jpkm1 
    243316            DO jj = 2, jpjm1  
    244317               DO ji = fs_2, fs_jpim1   ! vector opt.    
     318#endif 
    245319                  zbtr = 1. / ( e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) ) 
    246320                  ! k- vertical advective trends   
    … …  
    254328         !  Save the final vertical advective trends 
    255329         IF( l_trd )  THEN                        ! vertical advective trend diagnostics 
    256             DO jk = 1, jpkm1                       ! (compute -w.dk[ptn]= -dk[w.ptn] + ptn.dk[w]) 
     330            ! (compute -w.dk[ptn]= -dk[w.ptn] + ptn.dk[w]) 
     331#if defined key_z_first 
     332            DO jj = 2, jpjm1 
     333               DO ji = 2, jpim1 
     334                  DO jk = 1, jpkm1 
     335#else 
     336            DO jk = 1, jpkm1 
    257337               DO jj = 2, jpjm1 
    258338                  DO ji = fs_2, fs_jpim1   ! vector opt. 
     339#endif 
    259340                     zbtr = 1.e0 / ( e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) ) 
    260341                     z_hdivn = (  pwn(ji,jj,jk) - pwn(ji,jj,jk+1)  ) * zbtr 
    … …  
    270351      IF( wrk_not_released(3, 1,2,3,4,5,6) )   CALL ctl_stop('tra_adv_ubs: failed to release workspace arrays') 
    271352      ! 
     353 
     354      !! * Reset control of array index permutation 
     355!FTRANS CLEAR 
     356#  include "oce_ftrans.h90" 
     357#  include "dom_oce_ftrans.h90" 
     358#  include "trc_oce_ftrans.h90" 
     359 
    272360   END SUBROUTINE tra_adv_ubs 
    273361 
    … …  
    288376      USE wrk_nemo, ONLY:   wrk_in_use, wrk_not_released 
    289377      USE wrk_nemo, ONLY:   zbetup => wrk_3d_1, zbetdo => wrk_3d_2   ! 3D workspace 
     378 
     379      !! DCSE_NEMO: need additional directives for renamed module variables 
     380!FTRANS zbetup zbetdo :I :I :z 
     381 
    290382      ! 
    291383      REAL(wp), INTENT(in   ), DIMENSION(jpk)          ::   p2dt   ! vertical profile of tracer time-step 
    292       REAL(wp),                DIMENSION (jpi,jpj,jpk) ::   pbef   ! before field 
    293       REAL(wp), INTENT(inout), DIMENSION (jpi,jpj,jpk) ::   paft   ! after field 
    294       REAL(wp), INTENT(inout), DIMENSION (jpi,jpj,jpk) ::   pcc    ! monotonic flux in the k direction 
     384 
     385      !! DCSE_NEMO: This style defeats ftrans 
     386!     REAL(wp),                DIMENSION (jpi,jpj,jpk) ::   pbef   ! before field 
     387!     REAL(wp), INTENT(inout), DIMENSION (jpi,jpj,jpk) ::   paft   ! after field 
     388!     REAL(wp), INTENT(inout), DIMENSION (jpi,jpj,jpk) ::   pcc    ! monotonic flux in the k direction 
     389 
     390!FTRANS pbef paft pcc :I :I :z 
     391      REAL(wp), INTENT(inout) ::   pbef(jpi,jpj,jpk)   ! before field 
     392      REAL(wp), INTENT(inout) ::   paft(jpi,jpj,jpk)   ! after field 
     393      REAL(wp), INTENT(inout) ::   pcc(jpi,jpj,jpk)    ! monotonic flux in the k direction 
    295394      ! 
    296395      INTEGER  ::   ji, jj, jk   ! dummy loop indices 
    … …  
    313412      paft(:,:,:) = paft(:,:,:) * tmask(:,:,:) - zbig * ( 1.e0 - tmask(:,:,:) ) 
    314413      ! search maximum in neighbourhood 
     414#if defined key_z_first 
     415      DO jj = 2, jpjm1 
     416         DO ji = 2, jpim1 
     417            DO jk = 1, jpkm1 
     418               ikm1 = MAX(jk-1,1) 
     419#else 
    315420      DO jk = 1, jpkm1 
    316421         ikm1 = MAX(jk-1,1) 
    317422         DO jj = 2, jpjm1 
    318423            DO ji = fs_2, fs_jpim1   ! vector opt. 
     424#endif 
    319425               zbetup(ji,jj,jk) = MAX(  pbef(ji  ,jj  ,jk  ), paft(ji  ,jj  ,jk  ),   & 
    320426                  &                     pbef(ji  ,jj  ,ikm1), pbef(ji  ,jj  ,jk+1),   & 
    … …  
    327433      paft(:,:,:) = paft(:,:,:) * tmask(:,:,:) + zbig * ( 1.e0 - tmask(:,:,:) ) 
    328434      ! search minimum in neighbourhood 
     435#if defined key_z_first 
     436      DO jj = 2, jpjm1 
     437         DO ji = 2, jpim1 
     438            DO jk = 1, jpkm1 
     439               ikm1 = MAX(jk-1,1) 
     440#else 
    329441      DO jk = 1, jpkm1 
    330442         ikm1 = MAX(jk-1,1) 
    331443         DO jj = 2, jpjm1 
    332444            DO ji = fs_2, fs_jpim1   ! vector opt. 
     445#endif 
    333446               zbetdo(ji,jj,jk) = MIN(  pbef(ji  ,jj  ,jk  ), paft(ji  ,jj  ,jk  ),   & 
    334447                  &                     pbef(ji  ,jj  ,ikm1), pbef(ji  ,jj  ,jk+1),   & 
    … …  
    346459      ! ------------------------------------------------------ 
    347460 
     461#if defined key_z_first 
     462      DO jj = 2, jpjm1 
     463         DO ji = 2, jpim1 
     464            DO jk = 1, jpkm1 
     465               z2dtt = p2dt(jk) 
     466#else 
    348467      DO jk = 1, jpkm1 
    349468         z2dtt = p2dt(jk) 
    350469         DO jj = 2, jpjm1 
    351470            DO ji = fs_2, fs_jpim1   ! vector opt. 
     471#endif 
    352472               ! positive & negative part of the flux 
    353473               zpos = MAX( 0., pcc(ji  ,jj  ,jk+1) ) - MIN( 0., pcc(ji  ,jj  ,jk  ) ) 
    … …  
    362482      ! monotonic flux in the k direction, i.e. pcc 
    363483      ! ------------------------------------------- 
     484#if defined key_z_first 
     485      DO jj = 2, jpjm1 
     486         DO ji = 2, jpim1 
     487            DO jk = 2, jpkm1 
     488#else 
    364489      DO jk = 2, jpkm1 
    365490         DO jj = 2, jpjm1 
    366491            DO ji = fs_2, fs_jpim1   ! vector opt. 
     492#endif 
    367493               za = MIN( 1., zbetdo(ji,jj,jk), zbetup(ji,jj,jk-1) ) 
    368494               zb = MIN( 1., zbetup(ji,jj,jk), zbetdo(ji,jj,jk-1) ) 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/TRA/trabbc.F90

    r2715 r3211  
    3535 
    3636   REAL(wp), PUBLIC, DIMENSION(:,:), ALLOCATABLE ::   qgh_trd0   ! geothermal heating trend 
     37 
     38   !! * Control permutation of array indices 
     39#  include "oce_ftrans.h90" 
     40#  include "dom_oce_ftrans.h90" 
    3741  
    3842   !! * Substitutions 
    … …  
    7175      INTEGER  ::   ji, jj, ik    ! dummy loop indices 
    7276      REAL(wp) ::   zqgh_trd      ! geothermal heat flux trend 
     77 
     78!FTRANS ztrdt :I :I :z 
    7379      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::   ztrdt 
    7480      !!---------------------------------------------------------------------- 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/TRA/trabbl.F90

    r2715 r3211  
    6565   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) ::   r1_e1e2t               ! inverse of the cell surface at t-point      [1/m2] 
    6666 
     67   !! * Control permutation of array indices 
     68#  include "oce_ftrans.h90" 
     69#  include "dom_oce_ftrans.h90" 
     70 
    6771   !! * Substitutions 
    6872#  include "domzgr_substitute.h90" 
    … …  
    105109      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::  ztrdt, ztrds 
    106110      !!---------------------------------------------------------------------- 
     111 
     112!FTRANS ztrdt ztrds :I :I :z 
    107113 
    108114      IF( l_trdtra )   THEN                    !* Save ta and sa trends 
    … …  
    146152   END SUBROUTINE tra_bbl 
    147153 
     154      !! * Reset control of array index permutation 
     155!FTRANS CLEAR 
     156#  include "oce_ftrans.h90" 
     157#  include "dom_oce_ftrans.h90" 
    148158 
    149159   SUBROUTINE tra_bbl_dif( ptb, pta, kjpt ) 
    … …  
    173183      ! 
    174184      INTEGER                              , INTENT(in   ) ::   kjpt   ! number of tracers 
    175       REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in   ) ::   ptb    ! before and now tracer fields 
    176       REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) ::   pta    ! tracer trend  
     185 
     186      !! DCSE_NEMO: This style defeats ftrans 
     187!     REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in   ) ::   ptb    ! before and now tracer fields 
     188!     REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) ::   pta    ! tracer trend  
     189!FTRANS ptb pta :I :I :z :I 
     190      REAL(wp), INTENT(in   ) ::   ptb(jpi,jpj,jpk,kjpt)    ! before tracer fields 
     191      REAL(wp), INTENT(inout) ::   pta(jpi,jpj,jpk,kjpt)    ! tracer trend  
    177192      ! 
    178193      INTEGER  ::   ji, jj, jn   ! dummy loop indices 
    … …  
    220235      IF( wrk_not_released(2,1) )   CALL ctl_stop('tra_bbl_dif: failed to release workspace array') 
    221236      ! 
     237 
    222238   END SUBROUTINE tra_bbl_dif 
    223     
     239 
     240      !! * Reset control of array index permutation 
     241!FTRANS CLEAR 
     242#  include "oce_ftrans.h90" 
     243#  include "dom_oce_ftrans.h90" 
    224244 
    225245   SUBROUTINE tra_bbl_adv( ptb, pta, kjpt ) 
    … …  
    239259      !!----------------------------------------------------------------------   
    240260      INTEGER                              , INTENT(in   ) ::   kjpt   ! number of tracers 
    241       REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in   ) ::   ptb    ! before and now tracer fields 
    242       REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) ::   pta    ! tracer trend  
     261 
     262      !! DCSE_NEMO: This style defeats ftrans 
     263!     REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in   ) ::   ptb    ! before and now tracer fields 
     264!     REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) ::   pta    ! tracer trend  
     265!FTRANS ptb pta :I :I :z :I 
     266      REAL(wp), INTENT(in   ) ::   ptb(jpi,jpj,jpk,kjpt)    ! before tracer fields 
     267      REAL(wp), INTENT(inout) ::   pta(jpi,jpj,jpk,kjpt)    ! tracer trend  
    243268      ! 
    244269      INTEGER  ::   ji, jj, jk, jn           ! dummy loop indices 
    … …  
    310335   END SUBROUTINE tra_bbl_adv 
    311336 
     337      !! * Reset control of array index permutation 
     338!FTRANS CLEAR 
     339#  include "oce_ftrans.h90" 
     340#  include "dom_oce_ftrans.h90" 
    312341 
    313342   SUBROUTINE bbl( kt, cdtype ) 
    … …  
    608637 
    609638      !                             !* masked diffusive flux coefficients  
     639#if defined key_z_first 
     640      ahu_bbl_0(:,:) = rn_ahtbbl * e2u(:,:) * e3u_bbl_0(:,:) / e1u(:,:)  * umask_1(:,:) 
     641      ahv_bbl_0(:,:) = rn_ahtbbl * e1v(:,:) * e3v_bbl_0(:,:) / e2v(:,:)  * vmask_1(:,:) 
     642#else 
    610643      ahu_bbl_0(:,:) = rn_ahtbbl * e2u(:,:) * e3u_bbl_0(:,:) / e1u(:,:)  * umask(:,:,1) 
    611644      ahv_bbl_0(:,:) = rn_ahtbbl * e1v(:,:) * e3v_bbl_0(:,:) / e2v(:,:)  * vmask(:,:,1) 
     645#endif 
    612646 
    613647 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/TRA/tradmp.F90

    r2715 r3211  
    6464   INTEGER  ::   nn_file =    2      ! = 1 create a damping.coeff NetCDF file  
    6565 
     66   !! * Control permutation of array indices 
     67#  include "oce_ftrans.h90" 
     68#  include "dom_oce_ftrans.h90" 
     69#  include "zdf_oce_ftrans.h90" 
     70#  include "dtatem_ftrans.h90" 
     71#  include "dtasal_ftrans.h90" 
     72#  include "tradmp_ftrans.h90" 
     73 
    6674   !! * Substitutions 
    6775#  include "domzgr_substitute.h90" 
    … …  
    112120      ! 
    113121      CASE( 0 )                   !==  newtonian damping throughout the water column  ==! 
     122#if defined key_z_first 
     123         DO jj = 2, jpjm1 
     124            DO ji = 2, jpim1 
     125               DO jk = 1, jpkm1 
     126#else 
    114127         DO jk = 1, jpkm1 
    115128            DO jj = 2, jpjm1 
    116129               DO ji = fs_2, fs_jpim1   ! vector opt. 
     130#endif 
    117131                  zta = resto(ji,jj,jk) * ( t_dta(ji,jj,jk) - tsb(ji,jj,jk,jp_tem) ) 
    118132                  zsa = resto(ji,jj,jk) * ( s_dta(ji,jj,jk) - tsb(ji,jj,jk,jp_sal) ) 
    … …  
    126140         ! 
    127141      CASE ( 1 )                  !==  no damping in the turbocline (avt > 5 cm2/s)  ==! 
     142#if defined key_z_first 
     143         DO jj = 2, jpjm1 
     144            DO ji = 2, jpim1 
     145               DO jk = 1, jpkm1 
     146#else 
    128147         DO jk = 1, jpkm1 
    129148            DO jj = 2, jpjm1 
    130149               DO ji = fs_2, fs_jpim1   ! vector opt. 
     150#endif 
    131151                  IF( avt(ji,jj,jk) <= 5.e-4_wp ) THEN 
    132152                     zta = resto(ji,jj,jk) * ( t_dta(ji,jj,jk) - tsb(ji,jj,jk,jp_tem) ) 
    … …  
    145165         ! 
    146166      CASE ( 2 )                  !==  no damping in the mixed layer   ==! 
     167#if defined key_z_first 
     168         DO jj = 2, jpjm1 
     169            DO ji = 2, jpim1 
     170               DO jk = 1, jpkm1 
     171#else 
    147172         DO jk = 1, jpkm1 
    148173            DO jj = 2, jpjm1 
    149174               DO ji = fs_2, fs_jpim1   ! vector opt. 
     175#endif 
    150176                  IF( fsdept(ji,jj,jk) >= hmlp (ji,jj) ) THEN 
    151177                     zta = resto(ji,jj,jk) * ( t_dta(ji,jj,jk) - tsb(ji,jj,jk,jp_tem) ) 
    … …  
    252278      !! ** Action  : - resto, the damping coeff. for T and S 
    253279      !!---------------------------------------------------------------------- 
    254       REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout)  ::   presto   ! restoring coeff. (s-1) 
     280 
     281      !! DCSE_NEMO: This style defeats ftrans 
     282!     REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout)  ::   presto   ! restoring coeff. (s-1) 
     283!FTRANS presto :I :I :z 
     284      REAL(wp), INTENT(inout)  ::   presto(jpi,jpj,jpk)   ! restoring coeff. (s-1) 
    255285      ! 
    256286      INTEGER  ::   ji, jj, jk, jn   ! dummy loop indices 
    … …  
    292322         z1_5d = 1._wp / ( 5._wp * rday )   ! z1_5d : 1 / 5days 
    293323 
     324#if defined key_z_first 
     325         DO jj = 1, jpj             ! Compute arrays resto ; value for internal damping : 5 days 
     326            DO ji = 1, jpi 
     327               DO jk = 2, jpkm1 
     328#else 
    294329         DO jk = 2, jpkm1           ! Compute arrays resto ; value for internal damping : 5 days 
    295330            DO jj = 1, jpj 
    296331               DO ji = 1, jpi 
     332#endif 
    297333                  zlat = ABS( gphit(ji,jj) ) 
    298334                  IF( zlat1 <= zlat .AND. zlat <= zlat2 ) THEN 
    … …  
    311347   END SUBROUTINE dtacof_zoom 
    312348 
     349!! * Reset control of array index permutation 
     350!FTRANS CLEAR 
     351#  include "oce_ftrans.h90" 
     352#  include "dom_oce_ftrans.h90" 
     353#  include "zdf_oce_ftrans.h90" 
     354#  include "dtatem_ftrans.h90" 
     355#  include "dtasal_ftrans.h90" 
     356#  include "tradmp_ftrans.h90" 
    313357 
    314358   SUBROUTINE dtacof( kn_hdmp, pn_surf, pn_bot, pn_dep,  & 
    … …  
    329373      USE wrk_nemo, ONLY:   wrk_in_use, wrk_not_released 
    330374      USE wrk_nemo, ONLY:   zhfac => wrk_1d_1, zmrs => wrk_2d_1 , zdct  => wrk_3d_1   ! 1D, 2D, 3D workspace 
     375 
     376      !! DCSE_NEMO: need additional directives for renamed module variables 
     377!FTRANS zdct :I :I :z 
     378 
    331379      !! 
    332380      INTEGER                         , INTENT(in   )  ::  kn_hdmp    ! damping option 
    … …  
    336384      INTEGER                         , INTENT(in   )  ::  kn_file    ! save the damping coef on a file or not 
    337385      CHARACTER(len=3)                , INTENT(in   )  ::  cdtype     ! =TRA or TRC (tracer indicator) 
    338       REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout)  ::  presto     ! restoring coeff. (s-1) 
     386 
     387      !! DCSE_NEMO: This style defeats ftrans 
     388!     REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout)  ::   presto   ! restoring coeff. (s-1) 
     389!FTRANS presto :I :I :z 
     390      REAL(wp), INTENT(inout)  ::   presto(jpi,jpj,jpk)   ! restoring coeff. (s-1) 
     391 
    339392      ! 
    340393      INTEGER  ::   ji, jj, jk                  ! dummy loop indices 
    … …  
    407460         zsdmp = 1._wp / ( pn_surf * rday ) 
    408461         zbdmp = 1._wp / ( pn_bot  * rday ) 
     462#if defined key_z_first 
     463         DO jj = 1, jpj 
     464            DO ji = 1, jpi 
     465               DO jk = 2, jpkm1 
     466#else 
    409467         DO jk = 2, jpkm1 
    410468            DO jj = 1, jpj 
    411469               DO ji = 1, jpi 
     470#endif 
    412471                  zdct(ji,jj,jk) = MIN( zinfl, zdct(ji,jj,jk) ) 
    413472                  !   ... Decrease the value in the vicinity of the coast 
    … …  
    518577         END SELECT 
    519578 
     579#if defined key_z_first 
     580         DO jj = 1, jpj 
     581            DO ji = 1, jpi 
     582               DO jk = 1, jpkm1 
     583                  presto(ji,jj,jk) = zmrs(ji,jj) * zhfac(jk) + ( 1._wp - zmrs(ji,jj) ) * presto(ji,jj,jk) 
     584               END DO 
     585            END DO 
     586         END DO 
     587#else 
    520588         DO jk = 1, jpkm1 
    521589            presto(:,:,jk) = zmrs(:,:) * zhfac(jk) + ( 1._wp - zmrs(:,:) ) * presto(:,:,jk) 
    522590         END DO 
     591#endif 
    523592 
    524593         ! Mask resto array and set to 0 first and last levels 
    … …  
    550619   END SUBROUTINE dtacof 
    551620 
     621!! * Reset control of array index permutation 
     622!FTRANS CLEAR 
     623#  include "oce_ftrans.h90" 
     624#  include "dom_oce_ftrans.h90" 
     625#  include "zdf_oce_ftrans.h90" 
     626#  include "dtatem_ftrans.h90" 
     627#  include "dtasal_ftrans.h90" 
     628#  include "tradmp_ftrans.h90" 
    552629 
    553630   SUBROUTINE cofdis( pdct ) 
    … …  
    571648      !!              - NetCDF file 'dist.coast.nc'  
    572649      !!---------------------------------------------------------------------- 
    573       USE ioipsl      ! IOipsl librairy 
     650      USE ioipsl      ! IOipsl library 
    574651      USE wrk_nemo, ONLY:   wrk_in_use, wrk_not_released 
    575652      USE wrk_nemo, ONLY:   zxt => wrk_2d_1 , zyt => wrk_2d_2 , zzt => wrk_2d_3, zmask => wrk_2d_4 
    576653      !! 
     654 
     655      !! DCSE_NEMO: This style defeats ftrans 
     656!     REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT( out ) ::   pdct   ! distance to the coastline 
     657!FTRANS pdct :I :I :z 
    577658      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT( out ) ::   pdct   ! distance to the coastline 
     659 
    578660      !! 
    579661      INTEGER ::   ji, jj, jk, jl   ! dummy loop indices 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/TRA/traldf.F90

    r2715 r3211  
    2121   USE traldf_bilap    ! lateral mixing             (tra_ldf_bilap routine) 
    2222   USE traldf_iso      ! lateral mixing               (tra_ldf_iso routine) 
    23    USE traldf_iso_grif ! lateral mixing          (tra_ldf_iso_grif routine) 
     23 
     24!! DCSE_NEMO 
     25!  USE traldf_iso_grif ! lateral mixing          (tra_ldf_iso_grif routine) 
     26   USE traldf_iso_grif, ONLY : tra_ldf_iso_grif ! lateral mixing 
    2427   USE traldf_lap      ! lateral mixing               (tra_ldf_lap routine) 
    2528   USE trdmod_oce      ! ocean space and time domain 
    … …  
    4144   !                                                               !  (key_traldf_ano only) 
    4245 
     46   !! * Control permutation of array indices 
     47#  include "oce_ftrans.h90" 
     48#  include "dom_oce_ftrans.h90" 
     49#  include "ldftra_oce_ftrans.h90" 
     50#  include "ldfslp_ftrans.h90" 
     51#  include "trc_oce_ftrans.h90" 
     52!FTRANS t0_ldf s0_ldf :I :I :z 
     53 
    4354   !! * Substitutions 
    4455#  include "domzgr_substitute.h90" 
    … …  
    5970      INTEGER, INTENT( in ) ::   kt   ! ocean time-step index 
    6071      !! 
     72!FTRANS ztrdt ztrds :I :I :z 
    6173      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::  ztrdt, ztrds 
    6274      !!---------------------------------------------------------------------- 
    … …  
    115127   END SUBROUTINE tra_ldf 
    116128 
     129   !! * Reset control of array index permutation 
     130!FTRANS CLEAR 
     131#  include "oce_ftrans.h90" 
     132#  include "dom_oce_ftrans.h90" 
     133#  include "ldftra_oce_ftrans.h90" 
     134#  include "ldfslp_ftrans.h90" 
     135#  include "trc_oce_ftrans.h90" 
     136!FTRANS t0_ldf s0_ldf :I :I :z 
    117137 
    118138   SUBROUTINE tra_ldf_init 
    … …  
    240260      USE wrk_nemo, ONLY:   zt_ref => wrk_3d_1, ztb => wrk_3d_2, zavt => wrk_3d_3   ! 3D workspaces 
    241261      USE wrk_nemo, ONLY:   zs_ref => wrk_3d_4, zsb => wrk_3d_5                     ! 3D workspaces 
     262 
     263      !! DCSE_NEMO: need additional directives for renamed module variables 
     264!FTRANS zt_ref ztb zavt zs_ref zsb :I :I :z 
    242265      ! 
    243266      USE zdf_oce         ! vertical mixing 
    244267      USE trazdf          ! vertical mixing: double diffusion 
    245268      USE zdfddm          ! vertical mixing: double diffusion 
    246       ! 
     269 
     270#  include "zdf_oce_ftrans.h90" 
     271#  include "zdfddm_ftrans.h90" 
     272 
     273      ! 
     274#if defined key_z_first 
     275      INTEGER  ::   ji, jj, jk      ! Dummy loop indices 
     276#else 
    247277      INTEGER  ::   jk              ! Dummy loop indice 
     278#endif 
    248279      INTEGER  ::   ierr            ! local integer 
    249280      LOGICAL  ::   llsave          ! local logical 
    … …  
    309340         s0_ldf(:,:,:) = tsa(:,:,:,jp_sal) 
    310341      ELSE 
     342#if defined key_z_first 
     343         DO jj = 1, jpj 
     344            DO ji = 1, jpi 
     345               DO jk = 1, jpkm1 
     346                  t0_ldf(ji,jj,jk) = ( tsa(ji,jj,jk,jp_tem) - tsb(ji,jj,jk,jp_tem) ) / ( z12 *rdttra(jk) ) 
     347                  s0_ldf(ji,jj,jk) = ( tsa(ji,jj,jk,jp_sal) - tsb(ji,jj,jk,jp_sal) ) / ( z12 *rdttra(jk) ) 
     348               END DO 
     349            END DO 
     350         END DO 
     351#else 
    311352         DO jk = 1, jpkm1 
    312353            t0_ldf(:,:,jk) = ( tsa(:,:,jk,jp_tem) - tsb(:,:,jk,jp_tem) ) / ( z12 *rdttra(jk) ) 
    313354            s0_ldf(:,:,jk) = ( tsa(:,:,jk,jp_sal) - tsb(:,:,jk,jp_sal) ) / ( z12 *rdttra(jk) ) 
    314355         END DO 
     356#endif 
    315357      ENDIF 
    316358      tsb(:,:,:,jp_tem) = ztb (:,:,:) 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/TRA/traldf_bilap.F90

    r2715 r3211  
    3434 
    3535   PUBLIC   tra_ldf_bilap   ! routine called by step.F90 
     36 
     37   !! * Control permutation of array indices 
     38#  include "oce_ftrans.h90" 
     39#  include "dom_oce_ftrans.h90" 
     40#  include "ldftra_oce_ftrans.h90" 
     41#  include "ldfslp_ftrans.h90" 
     42#  include "trc_oce_ftrans.h90" 
    3643 
    3744   !! * Substitutions 
    … …  
    7784      USE oce     , ONLY:   ztu  => ua       , ztv  => va                           ! (ua,va) used as workspace 
    7885      USE wrk_nemo, ONLY:   zeeu => wrk_2d_1 , zeev => wrk_2d_2 , zlt => wrk_2d_3   ! 2D workspace 
     86 
     87      !! DCSE_NEMO: need additional directives for renamed module variables 
     88!FTRANS ztu ztv :I :I :z 
     89 
    7990      !! 
    8091      INTEGER                              , INTENT(in   ) ::   kt         ! ocean time-step index 
    … …  
    8293      INTEGER                              , INTENT(in   ) ::   kjpt       ! number of tracers 
    8394      REAL(wp), DIMENSION(jpi,jpj,    kjpt), INTENT(in   ) ::   pgu, pgv   ! tracer gradient at pstep levels 
    84       REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in   ) ::   ptb        ! before and now tracer fields 
    85       REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) ::   pta        ! tracer trend  
     95 
     96      !! DCSE_NEMO: This style defeats ftrans 
     97!     REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in   ) ::   ptb        ! before and now tracer fields 
     98!     REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) ::   pta        ! tracer trend  
     99!FTRANS ptb pta :I :I :z : 
     100      REAL(wp), INTENT(in   ) ::   ptb(jpi,jpj,jpk,kjpt)        ! before tracer fields 
     101      REAL(wp), INTENT(inout) ::   pta(jpi,jpj,jpk,kjpt)        ! tracer trend  
     102 
    86103      !! 
    87104      INTEGER  ::  ji, jj, jk, jn   ! dummy loop indices 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/TRA/traldf_bilapg.F90

    r2715 r3211  
    3030 
    3131   PUBLIC   tra_ldf_bilapg   ! routine called by step.F90 
     32 
     33   !! * Control permutation of array indices 
     34#  include "oce_ftrans.h90" 
     35#  include "dom_oce_ftrans.h90" 
     36#  include "ldftra_oce_ftrans.h90" 
     37#  include "ldfslp_ftrans.h90" 
     38#  include "trc_oce_ftrans.h90" 
    3239 
    3340   !! * Substitutions 
    … …  
    6875      USE wrk_nemo, ONLY:   wrk_in_use, wrk_not_released 
    6976      USE wrk_nemo, ONLY:   wk1 => wrk_4d_1 , wk2 => wrk_4d_2     ! 4D workspace 
     77      !! DCSE_NEMO: need additional directives for renamed module variables 
     78!FTRANS wk1 wk2 :I :I :z : 
    7079      ! 
    7180      INTEGER         , INTENT(in   )                      ::   kt       ! ocean time-step index 
    7281      CHARACTER(len=3), INTENT(in   )                      ::   cdtype   ! =TRA or TRC (tracer indicator) 
    7382      INTEGER         , INTENT(in   )                      ::   kjpt     ! number of tracers 
    74       REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in   ) ::   ptb      ! before and now tracer fields 
    75       REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) ::   pta      ! tracer trend  
     83 
     84      !! DCSE_NEMO: This style defeats ftrans 
     85!     REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in   ) ::   ptb      ! before and now tracer fields 
     86!     REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) ::   pta      ! tracer trend  
     87!FTRANS ptb pta :I :I :z : 
     88      REAL(wp), INTENT(in   ) ::   ptb(jpi,jpj,jpk,kjpt)        ! before tracer fields 
     89      REAL(wp), INTENT(inout) ::   pta(jpi,jpj,jpk,kjpt)        ! tracer trend 
     90 
    7691      ! 
    7792      INTEGER ::   ji, jj, jk, jn   ! dummy loop indices 
    … …  
    105120      ! --------------------------- 
    106121      DO jn = 1, kjpt 
     122#if defined key_z_first 
     123         DO jj = 2, jpjm1 
     124            DO ji = 2, jpim1 
     125               DO jk = 1, jpkm1 
     126#else 
    107127         DO jj = 2, jpjm1 
    108128            DO jk = 1, jpkm1 
    109129               DO ji = 2, jpim1 
     130#endif 
    110131                  ! add it to the general tracer trends 
    111132                  pta(ji,jj,jk,jn) = pta(ji,jj,jk,jn) + wk2(ji,jj,jk,jn) 
    … …  
    119140   END SUBROUTINE tra_ldf_bilapg 
    120141 
     142!! * Reset control of array index permutation 
     143#  include "oce_ftrans.h90" 
     144#  include "dom_oce_ftrans.h90" 
     145#  include "ldftra_oce_ftrans.h90" 
     146#  include "ldfslp_ftrans.h90" 
     147#  include "trc_oce_ftrans.h90" 
    121148 
    122149   SUBROUTINE ldfght ( kt, cdtype, pt, plt, kjpt, kaht ) 
    … …  
    163190      USE wrk_nemo, ONLY:   zftw => wrk_xz_1 , zdit  => wrk_xz_2  
    164191      USE wrk_nemo, ONLY:   zdjt => wrk_xz_3 , zdj1t => wrk_xz_4 
    165       ! 
    166       INTEGER         , INTENT(in )                              ::  kt      ! ocean time-step index 
    167       CHARACTER(len=3), INTENT(in )                              ::  cdtype  ! =TRA or TRC (tracer indicator)  
    168       INTEGER         , INTENT(in )                              ::  kjpt    !: dimension of  
    169       REAL(wp)        , INTENT(in ), DIMENSION(jpi,jpj,jpk,kjpt) ::  pt      ! tracer fields ( before for 1st call 
    170       !                                                         ! and laplacian of these fields for 2nd call.  
    171       REAL(wp)        , INTENT(out), DIMENSION(jpi,jpj,jpk,kjpt) ::  plt     !: partial harmonic operator applied to  pt  components except 
    172       !                                                             !: second order vertical derivative term   
    173       INTEGER         , INTENT(in )                              ::  kaht    !: =1 multiply the laplacian by the eddy diffusivity coeff. 
    174       !                                                             !: =2 no multiplication  
     192 
     193      !! DCSE_NEMO: need additional directives for renamed module variables 
     194!FTRANS zftv :I :I :z 
     195 
     196      ! 
     197      INTEGER, INTENT(in )                               ::  kt      ! ocean time-step index 
     198      CHARACTER(len=3), INTENT(in )                      ::  cdtype  ! =TRA or TRC (tracer indicator)  
     199      INTEGER, INTENT(in )                               ::  kjpt    !: dimension of  
     200 
     201      !! DCSE_NEMO: This style defeats ftrans 
     202!     REAL(wp), INTENT(in ), DIMENSION(jpi,jpj,jpk,kjpt) ::  pt      ! tracer fields ( before for 1st call 
     203!     !                                                         ! and laplacian of these fields for 2nd call.  
     204!     REAL(wp), INTENT(out), DIMENSION(jpi,jpj,jpk,kjpt) ::  plt     !: partial harmonic operator applied to  pt components except 
     205!     !                                                              !: second order vertical derivative term   
     206 
     207!FTRANS pt plt :I :I :z : 
     208      REAL(wp), INTENT(in )  ::  pt(jpi,jpj,jpk,kjpt)      ! tracer fields ( before for 1st call 
     209      !                                                    ! and laplacian of these fields for 2nd call.  
     210      REAL(wp), INTENT(out)  ::  plt(jpi,jpj,jpk,kjpt)     !: partial harmonic operator applied to  pt components except 
     211      !                                                    !: second order vertical derivative term   
     212 
     213      INTEGER, INTENT(in )                               ::  kaht    !: =1 multiply the laplacian by the eddy diffusivity coeff. 
     214      !                                                              !: =2 no multiplication  
    175215      !! 
    176216      INTEGER ::   ji, jj, jk,jn          ! dummy loop indices 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/TRA/traldf_iso.F90

    r2715 r3211  
    3838   PUBLIC   tra_ldf_iso   ! routine called by step.F90 
    3939 
     40   !! * Control permutation of array indices 
     41#  include "oce_ftrans.h90" 
     42#  include "dom_oce_ftrans.h90" 
     43#  include "trc_oce_ftrans.h90" 
     44#  include "zdf_oce_ftrans.h90" 
     45#  include "ldftra_oce_ftrans.h90" 
     46#  include "ldfslp_ftrans.h90" 
     47 
    4048   !! * Substitutions 
    4149#  include "domzgr_substitute.h90" 
    … …  
    92100      USE wrk_nemo, ONLY:   wrk_in_use, wrk_not_released 
    93101      USE oce     , ONLY:   zftu => ua       , zftv  => va         ! (ua,va) used as workspace 
    94       USE wrk_nemo, ONLY:   zdkt => wrk_2d_1 , zdk1t => wrk_2d_2 , z2d  => wrk_2d_3   ! 2D workspace 
     102      !! DCSE_NEMO: need additional directives for renamed module variables 
     103!FTRANS zftu zftv :I :I :z 
     104#if defined key_z_first 
     105      USE wrk_nemo, ONLY:   wdkt => wrk_3d_9 , wdk1t => wrk_3d_10  ! 3D workspace 
     106!FTRANS wdkt wdk1t :I :I :z 
     107#else 
     108      USE wrk_nemo, ONLY:   zdkt => wrk_2d_1 , zdk1t => wrk_2d_2 
     109#endif 
     110      USE wrk_nemo, ONLY:   z2d  => wrk_2d_3                       ! 2D workspace 
    95111      USE wrk_nemo, ONLY:   zdit => wrk_3d_6 , zdjt  => wrk_3d_7 , ztfw => wrk_3d_8   ! 3D workspace 
     112!FTRANS zdit zdjt ztfw :I :I :z 
     113 
    96114      ! 
    97115      INTEGER                              , INTENT(in   ) ::   kt         ! ocean time-step index 
    … …  
    99117      INTEGER                              , INTENT(in   ) ::   kjpt       ! number of tracers 
    100118      REAL(wp), DIMENSION(jpi,jpj    ,kjpt), INTENT(in   ) ::   pgu, pgv   ! tracer gradient at pstep levels 
    101       REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in   ) ::   ptb        ! before and now tracer fields 
    102       REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) ::   pta        ! tracer trend  
     119 
     120      !! DCSE_NEMO: This style defeats ftrans 
     121!     REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in   ) ::   ptb        ! before and now tracer fields 
     122!     REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) ::   pta        ! tracer trend  
     123!FTRANS ptb pta :I :I :z : 
     124      REAL(wp), INTENT(in   ) ::   ptb(jpi,jpj,jpk,kjpt)        ! before and now tracer fields 
     125      REAL(wp), INTENT(inout) ::   pta(jpi,jpj,jpk,kjpt)        ! tracer trend  
     126 
    103127      REAL(wp)                             , INTENT(in   ) ::   pahtb0     ! background diffusion coef 
    104128      ! 
    … …  
    112136      !!---------------------------------------------------------------------- 
    113137 
     138#if defined key_z_first 
     139      IF( wrk_in_use(3, 6,7,8,9,10) .OR. wrk_in_use(2, 3) ) THEN 
     140#else 
    114141      IF( wrk_in_use(3, 6,7,8) .OR. wrk_in_use(2, 1,2,3) ) THEN 
     142#endif 
    115143          CALL ctl_stop('tra_ldf_iso : requested workspace array unavailable')   ;   RETURN 
    116144      ENDIF 
    … …  
    135163 
    136164         ! Horizontal tracer gradient  
     165#if defined key_z_first 
     166         DO jj = 1, jpjm1 
     167            DO ji = 1, jpim1 
     168               DO jk = 1, jpkm1 
     169#else 
    137170         DO jk = 1, jpkm1 
    138171            DO jj = 1, jpjm1 
    139172               DO ji = 1, fs_jpim1   ! vector opt. 
     173#endif 
    140174                  zdit(ji,jj,jk) = ( ptb(ji+1,jj  ,jk,jn) - ptb(ji,jj,jk,jn) ) * umask(ji,jj,jk) 
    141175                  zdjt(ji,jj,jk) = ( ptb(ji  ,jj+1,jk,jn) - ptb(ji,jj,jk,jn) ) * vmask(ji,jj,jk) 
    … …  
    155189         !!   II - horizontal trend  (full) 
    156190         !!---------------------------------------------------------------------- 
     191#if defined key_z_first 
     192            ! 1. Vertical tracer gradient at level jk and jk+1 
     193            ! ------------------------------------------------ 
     194            ! surface boundary condition: wdkt(jk=1)=wdkt(jk=2) 
     195 
     196         DO jj = 1, jpj 
     197            DO ji = 1, jpi 
     198               DO jk = 1, jpkm1 
     199                  wdk1t(ji,jj,jk) = ( ptb(ji,jj,jk,jn) - ptb(ji,jj,jk+1,jn) ) * tmask(ji,jj,jk+1) 
     200               END DO 
     201               wdkt(ji,jj,1) = wdk1t(ji,jj,1) 
     202               DO jk = 2, jpkm1 
     203                  wdkt(ji,jj,jk) =  ( ptb(ji,jj,jk-1,jn) - ptb(ji,jj,jk,jn) ) * tmask(ji,jj,jk) 
     204               END DO 
     205            END DO 
     206         END DO 
     207 
     208            ! 2. Horizontal fluxes 
     209            ! --------------------    
     210         DO jj = 1 , jpjm1 
     211            DO ji = 1, jpim1 
     212               DO jk = 1, jpkm1 
     213                  zabe1 = ( fsahtu(ji,jj,jk) + pahtb0 ) * e2u(ji,jj) * fse3u(ji,jj,jk) / e1u(ji,jj) 
     214                  zabe2 = ( fsahtv(ji,jj,jk) + pahtb0 ) * e1v(ji,jj) * fse3v(ji,jj,jk) / e2v(ji,jj) 
     215                  zmsku = 1. / MAX(  tmask(ji+1,jj,jk  ) + tmask(ji,jj,jk+1)   & 
     216                     &             + tmask(ji+1,jj,jk+1) + tmask(ji,jj,jk  ), 1. ) 
     217                  zmskv = 1. / MAX(  tmask(ji,jj+1,jk  ) + tmask(ji,jj,jk+1)   & 
     218                     &             + tmask(ji,jj+1,jk+1) + tmask(ji,jj,jk  ), 1. ) 
     219                  zcof1 = - fsahtu(ji,jj,jk) * e2u(ji,jj) * uslp(ji,jj,jk) * zmsku 
     220                  zcof2 = - fsahtv(ji,jj,jk) * e1v(ji,jj) * vslp(ji,jj,jk) * zmskv 
     221                  zftu(ji,jj,jk ) = ( zabe1 * zdit(ji,jj,jk)   & 
     222                     &              + zcof1 * (  wdkt (ji+1,jj,jk) + wdk1t(ji,jj,jk)      & 
     223                     &                         + wdk1t(ji+1,jj,jk) + wdkt (ji,jj,jk)  )  ) * umask(ji,jj,jk) 
     224                  zftv(ji,jj,jk) = (  zabe2 * zdjt(ji,jj,jk)   & 
     225                     &              + zcof2 * (  wdkt (ji,jj+1,jk) + wdk1t(ji,jj,jk)      & 
     226                     &                         + wdk1t(ji,jj+1,jk) + wdkt (ji,jj,jk)  )  ) * vmask(ji,jj,jk)                   
     227               END DO 
     228            END DO 
     229         END DO 
     230 
     231            ! II.4 Second derivative (divergence) and add to the general trend 
     232            ! ---------------------------------------------------------------- 
     233         DO jj = 2 , jpjm1 
     234            DO ji = 2, jpim1 
     235               DO jk = 1, jpkm1 
     236                  zbtr = 1.0 / ( e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) ) 
     237                  ztra = zbtr * ( zftu(ji,jj,jk) - zftu(ji-1,jj,jk) + zftv(ji,jj,jk) - zftv(ji,jj-1,jk)  ) 
     238                  pta(ji,jj,jk,jn) = pta(ji,jj,jk,jn) + ztra 
     239               END DO 
     240            END DO 
     241         END DO 
     242#else 
    157243!CDIR PARALLEL DO PRIVATE( zdk1t )  
    158244         !                                                ! =============== 
    … …  
    205291         END DO                                        !   End of slab   
    206292         !                                             ! =============== 
     293#endif 
    207294         ! 
    208295         ! "Poleward" diffusive heat or salt transports (T-S case only) 
    … …  
    216303            z2d(:,:) = 0._wp  
    217304            zztmp = rau0 * rcp  
     305#if defined key_z_first 
     306            DO jj = 2, jpjm1 
     307               DO ji = 2, jpim1 
     308                  DO jk = 1, jpkm1 
     309#else 
    218310            DO jk = 1, jpkm1 
    219311               DO jj = 2, jpjm1 
    220312                  DO ji = fs_2, fs_jpim1   ! vector opt. 
     313#endif 
    221314                     z2d(ji,jj) = z2d(ji,jj) + zftu(ji,jj,jk)  
    222315                  END DO 
    … …  
    227320            CALL iom_put( "udiff_heattr", z2d )                  ! heat transport in i-direction 
    228321            z2d(:,:) = 0._wp  
     322#if defined key_z_first 
     323            DO jj = 2, jpjm1 
     324               DO ji = 2, jpim1 
     325                  DO jk = 1, jpkm1 
     326#else 
    229327            DO jk = 1, jpkm1 
    230328               DO jj = 2, jpjm1 
    231329                  DO ji = fs_2, fs_jpim1   ! vector opt. 
     330#endif 
    232331                     z2d(ji,jj) = z2d(ji,jj) + zftv(ji,jj,jk)  
    233332                  END DO 
    … …  
    255354          
    256355         ! interior (2=<jk=<jpk-1) 
     356#if defined key_z_first 
     357         DO jj = 2, jpjm1 
     358            DO ji = 2, jpim1 
     359               DO jk = 2, jpkm1 
     360#else 
    257361         DO jk = 2, jpkm1 
    258362            DO jj = 2, jpjm1 
    259363               DO ji = fs_2, fs_jpim1   ! vector opt. 
     364#endif 
    260365                  zcoef0 = - fsahtw(ji,jj,jk) * tmask(ji,jj,jk) 
    261366                  ! 
    … …  
    279384         ! I.5 Divergence of vertical fluxes added to the general tracer trend 
    280385         ! ------------------------------------------------------------------- 
     386#if defined key_z_first 
     387         DO jj = 2, jpjm1 
     388            DO ji = 2, jpim1 
     389               DO jk = 1, jpkm1 
     390#else 
    281391         DO jk = 1, jpkm1 
    282392            DO jj = 2, jpjm1 
    283393               DO ji = fs_2, fs_jpim1   ! vector opt. 
     394#endif 
    284395                  zbtr = 1.0 / ( e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) ) 
    285396                  ztra = (  ztfw(ji,jj,jk) - ztfw(ji,jj,jk+1)  ) * zbtr 
    … …  
    291402      END DO 
    292403      ! 
     404#if defined key_z_first 
     405      IF( wrk_not_released(3, 6,7,8,9,10) .OR.   & 
     406          wrk_not_released(2, 3) )       CALL ctl_stop('tra_ldf_iso: failed to release workspace arrays') 
     407#else 
    293408      IF( wrk_not_released(3, 6,7,8) .OR.   & 
    294409          wrk_not_released(2, 1,2,3) )   CALL ctl_stop('tra_ldf_iso: failed to release workspace arrays') 
     410#endif 
    295411      ! 
    296412   END SUBROUTINE tra_ldf_iso 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/TRA/traldf_iso_grif.F90

    r2715 r3211  
    3636   REAL(wp),         DIMENSION(:,:,:), ALLOCATABLE, SAVE ::   zdkt                 !  atypic workspace 
    3737 
     38   !! * Control permutation of array indices 
     39#  include "oce_ftrans.h90" 
     40#  include "dom_oce_ftrans.h90" 
     41#  include "trc_oce_ftrans.h90" 
     42#  include "zdf_oce_ftrans.h90" 
     43#  include "ldftra_oce_ftrans.h90" 
     44#  include "ldfslp_ftrans.h90" 
     45#  include "traldf_iso_grif_ftrans.h90" 
     46 
    3847   !! * Substitutions 
    3948#  include "domzgr_substitute.h90" 
    … …  
    93102      USE wrk_nemo, ONLY:   zdit => wrk_3d_6 , zdjt => wrk_3d_7 , ztfw => wrk_3d_8   ! 3D workspace 
    94103      USE wrk_nemo, ONLY:   z2d  => wrk_2d_1                                         ! 2D workspace 
     104 
     105      !! DCSE_NEMO: need additional directives for renamed module variables 
     106!FTRANS zftu zftv :I :I :z 
     107!FTRANS zdit zdjt ztfw :I :I :z 
     108 
    95109      ! 
    96110      INTEGER                              , INTENT(in   ) ::   kt         ! ocean time-step index 
    … …  
    98112      INTEGER                              , INTENT(in   ) ::   kjpt       ! number of tracers 
    99113      REAL(wp), DIMENSION(jpi,jpj    ,kjpt), INTENT(in   ) ::   pgu, pgv   ! tracer gradient at pstep levels 
    100       REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in   ) ::   ptb        ! before and now tracer fields 
    101       REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) ::   pta        ! tracer trend  
     114 
     115      !! DCSE_NEMO: This style defeats ftrans 
     116!     REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in   ) ::   ptb        ! before and now tracer fields 
     117!     REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) ::   pta        ! tracer trend  
     118 
     119!FTRANS ptb pta :I :I :z : 
     120      REAL(wp), INTENT(in   ) ::   ptb(jpi,jpj,jpk,kjpt)        ! before and now tracer fields 
     121      REAL(wp), INTENT(inout) ::   pta(jpi,jpj,jpk,kjpt)        ! tracer trend  
     122 
    102123      REAL(wp)                             , INTENT(in   ) ::   pahtb0     ! background diffusion coef 
    103124      ! 
    … …  
    156177      DO ip = 0, 1 
    157178         DO kp = 0, 1 
     179#if defined key_z_first 
     180            DO jj = 1, jpjm1 
     181               DO ji = 1, jpim1 
     182                  DO jk = 1, jpkm1 
     183#else 
    158184            DO jk = 1, jpkm1 
    159185               DO jj = 1, jpjm1 
    160186                  DO ji = 1, fs_jpim1 
     187#endif 
    161188                     ze3wr = 1._wp / fse3w(ji+ip,jj,jk+kp) 
    162189                     zbu   = 0.25_wp * e1u(ji,jj) * e2u(ji,jj) * fse3u(ji,jj,jk) 
    … …  
    179206      DO jp = 0, 1 
    180207         DO kp = 0, 1 
     208#if defined key_z_first 
     209            DO jj = 1, jpjm1 
     210               DO ji=1, jpim1 
     211                  DO jk = 1, jpkm1 
     212#else 
    181213            DO jk = 1, jpkm1 
    182214               DO jj = 1, jpjm1 
    183215                  DO ji=1,fs_jpim1 
     216#endif 
    184217                     ze3wr = 1.0_wp / fse3w(ji,jj+jp,jk+kp) 
    185218                     zbv   = 0.25_wp * e1v(ji,jj) * e2v(ji,jj) * fse3v(ji,jj,jk) 
    … …  
    208241         zftv(:,:,:) = 0._wp 
    209242         !                                                
     243#if defined key_z_first 
     244         !==  before lateral T & S gradients at T-level jk  ==! 
     245         DO jj = 1, jpjm1 
     246            DO ji = 1, jpim1 
     247               DO jk = 1, jpkm1 
     248#else 
    210249         DO jk = 1, jpkm1                          !==  before lateral T & S gradients at T-level jk  ==! 
    211250            DO jj = 1, jpjm1 
    212251               DO ji = 1, fs_jpim1   ! vector opt. 
     252#endif 
    213253                  zdit(ji,jj,jk) = ( ptb(ji+1,jj  ,jk,jn) - ptb(ji,jj,jk,jn) ) * umask(ji,jj,jk) 
    214254                  zdjt(ji,jj,jk) = ( ptb(ji  ,jj+1,jk,jn) - ptb(ji,jj,jk,jn) ) * vmask(ji,jj,jk) 
    … …  
    303343         END DO 
    304344         ! 
     345#if defined key_z_first 
     346         DO jj = 2, jpjm1            !== Divergence of vertical fluxes added to the general tracer trend 
     347            DO ji = 2, jpim1 
     348               DO jk = 1, jpkm1 
     349#else 
    305350         DO jk = 1, jpkm1            !== Divergence of vertical fluxes added to the general tracer trend 
    306351            DO jj = 2, jpjm1 
    307352               DO ji = fs_2, fs_jpim1   ! vector opt. 
     353#endif 
    308354                  pta(ji,jj,jk,jn) = pta(ji,jj,jk,jn) + (  ztfw(ji,jj,jk+1) - ztfw(ji,jj,jk)  )   & 
    309355                     &                                / ( e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) ) 
    … …  
    322368            z2d(:,:) = 0._wp  
    323369            zztmp = rau0 * rcp  
     370#if defined key_z_first 
     371            DO jj = 2, jpjm1 
     372               DO ji = 2, jpim1 
     373                  DO jk = 1, jpkm1 
     374#else 
    324375            DO jk = 1, jpkm1 
    325376               DO jj = 2, jpjm1 
    326377                  DO ji = fs_2, fs_jpim1   ! vector opt. 
     378#endif 
    327379                     z2d(ji,jj) = z2d(ji,jj) + zftu(ji,jj,jk)  
    328380                  END DO 
    … …  
    333385            CALL iom_put( "udiff_heattr", z2d )                  ! heat transport in i-direction 
    334386            z2d(:,:) = 0._wp  
     387#if defined key_z_first 
     388            DO jj = 2, jpjm1 
     389               DO ji = 2, jpim1 
     390                  DO jk = 1, jpkm1 
     391#else 
    335392            DO jk = 1, jpkm1 
    336393               DO jj = 2, jpjm1 
    337394                  DO ji = fs_2, fs_jpim1   ! vector opt. 
     395#endif 
    338396                     z2d(ji,jj) = z2d(ji,jj) + zftv(ji,jj,jk)  
    339397                  END DO 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/TRA/traldf_lap.F90

    r2715 r3211  
    3333   REAL(wp), SAVE, ALLOCATABLE, DIMENSION(:,:) ::   e1ur, e2vr   ! scale factor coefficients 
    3434 
     35   !! * Control permutation of array indices 
     36#  include "oce_ftrans.h90" 
     37#  include "dom_oce_ftrans.h90" 
     38#  include "ldftra_oce_ftrans.h90" 
     39#  include "trc_oce_ftrans.h90" 
     40 
    3541   !! * Substitutions 
    3642#  include "domzgr_substitute.h90" 
    … …  
    6470      !!---------------------------------------------------------------------- 
    6571      USE oce, ONLY:   ztu => ua , ztv => va  ! (ua,va) used as workspace 
     72 
     73      !! DCSE_NEMO: need additional directives for renamed module variables 
     74!FTRANS ztu ztv :I :I :z 
     75 
    6676      ! 
    6777      INTEGER                              , INTENT(in   ) ::   kt         ! ocean time-step index 
    … …  
    6979      INTEGER                              , INTENT(in   ) ::   kjpt       ! number of tracers 
    7080      REAL(wp), DIMENSION(jpi,jpj    ,kjpt), INTENT(in   ) ::   pgu, pgv   ! tracer gradient at pstep levels 
    71       REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in   ) ::   ptb        ! before and now tracer fields 
    72       REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) ::   pta        ! tracer trend  
     81 
     82      !! DCSE_NEMO: This style defeats ftrans 
     83!     REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in   ) ::   ptb        ! before and now tracer fields 
     84!     REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) ::   pta        ! tracer trend  
     85 
     86!FTRANS ptb pta :I :I :z : 
     87      REAL(wp), INTENT(in   ) ::   ptb(jpi,jpj,jpk,kjpt)        ! before and now tracer fields 
     88      REAL(wp), INTENT(inout) ::   pta(jpi,jpj,jpk,kjpt)        ! tracer trend  
    7389      ! 
    7490      INTEGER  ::   ji, jj, jk, jn       ! dummy loop indices 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/TRA/tranpc.F90

    r2715 r3211  
    2929   PUBLIC   tra_npc       ! routine called by step.F90 
    3030 
     31   !! * Control permutation of array indices 
     32#  include "oce_ftrans.h90" 
     33#  include "dom_oce_ftrans.h90" 
     34#  include "zdf_oce_ftrans.h90" 
     35 
    3136   !! * Substitutions 
    3237#  include "domzgr_substitute.h90" 
    … …  
    5964      USE wrk_nemo, ONLY:   ztrdt => wrk_3d_1 , ztrds => wrk_3d_2 , zrhop => wrk_3d_3 
    6065      USE wrk_nemo, ONLY:   zwx   => wrk_xz_1 , zwy   => wrk_xz_2 , zwz   => wrk_xz_3 
     66 
     67      !! DCSE_NEMO: need additional directives for renamed module variables 
     68!FTRANS ztrdt ztrds zrhop :I :I :z 
     69 
    6170      ! 
    6271      INTEGER, INTENT(in) ::   kt   ! ocean time-step index 
    … …  
    93102            !  Static instability pointer  
    94103            ! ---------------------------- 
     104#if defined key_z_first 
     105            DO ji = 1, jpi 
     106               DO jk = 1, jpkm1 
     107#else 
    95108            DO jk = 1, jpkm1 
    96109               DO ji = 1, jpi 
     110#endif 
    97111                  zwx(ji,jk) = ( zrhop(ji,jj,jk) - zrhop(ji,jj,jk+1) ) * tmask(ji,jj,jk+1) 
    98112               END DO 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/TRA/tranxt.F90

    r2715 r3211  
    5858   REAL(wp) ::   rbcp   ! Brown & Campana parameters for semi-implicit hpg 
    5959 
     60   !! * Control permutation of array indices 
     61#  include "oce_ftrans.h90" 
     62#  include "dom_oce_ftrans.h90" 
     63#  include "sbc_oce_ftrans.h90" 
     64#  include "zdf_oce_ftrans.h90" 
     65#  include "domvvl_ftrans.h90" 
     66#  include "obc_oce_ftrans.h90" 
     67 
    6068   !! * Substitutions 
    6169#  include "domzgr_substitute.h90" 
    … …  
    93101      INTEGER, INTENT(in) ::   kt    ! ocean time-step index 
    94102      !! 
    95       INTEGER  ::   jk, jn    ! dummy loop indices 
    96       REAL(wp) ::   zfact     ! local scalars 
     103      INTEGER  ::   ji, jj, jk, jn   ! dummy loop indices 
     104      REAL(wp) ::   zfact            ! local scalar 
     105 
     106!FTRANS ztrdt ztrds :I :I :z 
    97107      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::  ztrdt, ztrds 
    98108      !!---------------------------------------------------------------------- 
    … …  
    142152      IF( neuler == 0 .AND. kt == nit000 ) THEN       ! Euler time-stepping at first time-step (only swap) 
    143153         DO jn = 1, jpts 
     154#if defined key_z_first 
     155            DO jj = 1, jpj 
     156               DO ji = 1, jpi 
     157                  DO jk = 1, jpkm1 
     158                     tsn(ji,jj,jk,jn) = tsa(ji,jj,jk,jn)     
     159                  END DO 
     160               END DO 
     161            END DO 
     162#else 
    144163            DO jk = 1, jpkm1 
    145164               tsn(:,:,jk,jn) = tsa(:,:,jk,jn)     
    146165            END DO 
     166#endif 
    147167         END DO 
    148168      ELSE                                            ! Leap-Frog + Asselin filter time stepping 
    … …  
    162182      ! trends computation 
    163183      IF( l_trdtra ) THEN      ! trend of the Asselin filter (tb filtered - tb)/dt      
     184#if defined key_z_first 
     185         DO jj = 1, jpj 
     186            DO ji = 1, jpi 
     187               DO jk = 1, jpkm1 
     188                  zfact = 1.e0 / r2dtra(jk)              
     189                  ztrdt(ji,jj,jk) = ( tsb(ji,jj,jk,jp_tem) - ztrdt(ji,jj,jk) ) * zfact 
     190                  ztrds(ji,jj,jk) = ( tsb(ji,jj,jk,jp_sal) - ztrds(ji,jj,jk) ) * zfact 
     191               END DO 
     192            END DO 
     193         END DO 
     194#else 
    164195         DO jk = 1, jpkm1 
    165196            zfact = 1.e0 / r2dtra(jk)              
    … …  
    167198            ztrds(:,:,jk) = ( tsb(:,:,jk,jp_sal) - ztrds(:,:,jk) ) * zfact 
    168199         END DO 
     200#endif 
    169201         CALL trd_tra( kt, 'TRA', jp_tem, jptra_trd_atf, ztrdt ) 
    170202         CALL trd_tra( kt, 'TRA', jp_sal, jptra_trd_atf, ztrds ) 
    … …  
    178210   END SUBROUTINE tra_nxt 
    179211 
     212   !! * Reset control of array index permutation 
     213!FTRANS CLEAR 
     214#  include "oce_ftrans.h90" 
     215#  include "dom_oce_ftrans.h90" 
     216#  include "sbc_oce_ftrans.h90" 
     217#  include "zdf_oce_ftrans.h90" 
     218#  include "domvvl_ftrans.h90" 
     219#  include "obc_oce_ftrans.h90" 
    180220 
    181221   SUBROUTINE tra_nxt_fix( kt, cdtype, ptb, ptn, pta, kjpt ) 
    … …  
    205245      CHARACTER(len=3), INTENT(in   )                               ::   cdtype   ! =TRA or TRC (tracer indicator) 
    206246      INTEGER         , INTENT(in   )                               ::   kjpt     ! number of tracers 
    207       REAL(wp)        , INTENT(inout), DIMENSION(jpi,jpj,jpk,kjpt)  ::   ptb      ! before tracer fields 
    208       REAL(wp)        , INTENT(inout), DIMENSION(jpi,jpj,jpk,kjpt)  ::   ptn      ! now tracer fields 
    209       REAL(wp)        , INTENT(inout), DIMENSION(jpi,jpj,jpk,kjpt)  ::   pta      ! tracer trend 
     247 
     248      !! DCSE_NEMO: This style defeats ftrans 
     249!     REAL(wp)        , INTENT(inout), DIMENSION(jpi,jpj,jpk,kjpt)  ::   ptb      ! before tracer fields 
     250!     REAL(wp)        , INTENT(inout), DIMENSION(jpi,jpj,jpk,kjpt)  ::   ptn      ! now tracer fields 
     251!     REAL(wp)        , INTENT(inout), DIMENSION(jpi,jpj,jpk,kjpt)  ::   pta      ! tracer trend 
     252 
     253!FTRANS ptb ptn pta :I :I :z : 
     254      REAL(wp)        , INTENT(inout)             ::   ptb(jpi,jpj,jpk,kjpt)      ! before tracer fields 
     255      REAL(wp)        , INTENT(inout)             ::   ptn(jpi,jpj,jpk,kjpt)      ! now tracer fields 
     256      REAL(wp)        , INTENT(inout)             ::   pta(jpi,jpj,jpk,kjpt)      ! tracer trend 
    210257      ! 
    211258      INTEGER  ::   ji, jj, jk, jn   ! dummy loop indices 
    … …  
    226273      DO jn = 1, kjpt 
    227274         ! 
     275#if defined key_z_first 
     276         DO jj = 1, jpj 
     277            DO ji = 1, jpi 
     278               DO jk = 1, jpkm1 
     279#else 
    228280         DO jk = 1, jpkm1 
    229281            DO jj = 1, jpj 
    230282               DO ji = 1, jpi 
     283#endif 
    231284                  ztn = ptn(ji,jj,jk,jn)                                     
    232285                  ztd = pta(ji,jj,jk,jn) - 2. * ztn + ptb(ji,jj,jk,jn)      !  time laplacian on tracers 
    … …  
    244297   END SUBROUTINE tra_nxt_fix 
    245298 
     299   !! * Reset control of array index permutation 
     300!FTRANS CLEAR 
     301#  include "oce_ftrans.h90" 
     302#  include "dom_oce_ftrans.h90" 
     303#  include "sbc_oce_ftrans.h90" 
     304#  include "zdf_oce_ftrans.h90" 
     305#  include "domvvl_ftrans.h90" 
     306#  include "obc_oce_ftrans.h90" 
    246307 
    247308   SUBROUTINE tra_nxt_vvl( kt, cdtype, ptb, ptn, pta, kjpt ) 
    … …  
    272333      CHARACTER(len=3), INTENT(in   )                               ::   cdtype   ! =TRA or TRC (tracer indicator) 
    273334      INTEGER         , INTENT(in   )                               ::   kjpt     ! number of tracers 
    274       REAL(wp)        , INTENT(inout), DIMENSION(jpi,jpj,jpk,kjpt)  ::   ptb      ! before tracer fields 
    275       REAL(wp)        , INTENT(inout), DIMENSION(jpi,jpj,jpk,kjpt)  ::   ptn      ! now tracer fields 
    276       REAL(wp)        , INTENT(inout), DIMENSION(jpi,jpj,jpk,kjpt)  ::   pta      ! tracer trend 
     335 
     336      !! DCSE_NEMO: This style defeats ftrans 
     337!     REAL(wp)        , INTENT(inout), DIMENSION(jpi,jpj,jpk,kjpt)  ::   ptb      ! before tracer fields 
     338!     REAL(wp)        , INTENT(inout), DIMENSION(jpi,jpj,jpk,kjpt)  ::   ptn      ! now tracer fields 
     339!     REAL(wp)        , INTENT(inout), DIMENSION(jpi,jpj,jpk,kjpt)  ::   pta      ! tracer trend 
     340 
     341!FTRANS ptb ptn pta :I :I :z : 
     342      REAL(wp)        , INTENT(inout)             ::   ptb(jpi,jpj,jpk,kjpt)      ! before tracer fields 
     343      REAL(wp)        , INTENT(inout)             ::   ptn(jpi,jpj,jpk,kjpt)      ! now tracer fields 
     344      REAL(wp)        , INTENT(inout)             ::   pta(jpi,jpj,jpk,kjpt)      ! tracer trend 
     345 
    277346      !!      
    278347      LOGICAL  ::   ll_tra, ll_tra_hpg, ll_traqsr   ! local logical 
    … …  
    299368      ! 
    300369      DO jn = 1, kjpt       
     370#if defined key_z_first 
     371         DO jj = 1, jpj 
     372            DO ji = 1, jpi 
     373               DO jk = 1, jpkm1 
     374                  !! DCSE_NEMO: could try promoting these scalars to vectors 
     375                  zfact1 = atfp * rdttra(jk) 
     376                  zfact2 = zfact1 / rau0 
     377#else 
    301378         DO jk = 1, jpkm1 
    302379            zfact1 = atfp * rdttra(jk) 
    … …  
    304381            DO jj = 1, jpj 
    305382               DO ji = 1, jpi 
     383#endif 
    306384                  ze3t_b = fse3t_b(ji,jj,jk) 
    307385                  ze3t_n = fse3t_n(ji,jj,jk) 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/TRA/traqsr.F90

    r2715 r3211  
    5353   REAL(wp), DIMENSION(3,61) ::   rkrgb   !: tabulated attenuation coefficients for RGB absorption 
    5454 
     55   !! * Control permutation of array indices 
     56#  include "oce_ftrans.h90" 
     57#  include "dom_oce_ftrans.h90" 
     58#  include "sbc_oce_ftrans.h90" 
     59#  include "trc_oce_ftrans.h90" 
     60 
    5561   !! * Substitutions 
    5662#  include "domzgr_substitute.h90" 
    … …  
    94100      USE wrk_nemo, ONLY:   ze0  => wrk_3d_1 , ze1  => wrk_3d_2 , ze2  => wrk_3d_3 
    95101      USE wrk_nemo, ONLY:   ze3  => wrk_3d_4 , zea  => wrk_3d_5 
     102 
     103      !! DCSE_NEMO: need additional directives for renamed module variables 
     104!FTRANS ze0 ze1 ze2 ze3 zea :I :I :z 
    96105      ! 
    97106      INTEGER, INTENT(in) ::   kt     ! ocean time-step 
    … …  
    102111      REAL(wp) ::   zc0, zc1, zc2, zc3   !    -         - 
    103112      REAL(wp) ::   zz0, zz1, z1_e3t     !    -         - 
     113 
     114!FTRANS ztrdt :I :I :z 
    104115      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::  ztrdt 
    105116      !!---------------------------------------------------------------------- 
    … …  
    144155      IF( lk_qsr_bio .AND. ln_qsr_bio ) THEN      !  bio-model fluxes  : all vertical coordinates  ! 
    145156         !                                        ! ============================================== ! 
     157#if defined key_z_first 
     158         DO jj = 1, jpj 
     159            DO ji = 1, jpi 
     160               DO jk = 1, jpkm1 
     161                  qsr_hc(:,:,jk) = ro0cpr * ( etot3(:,:,jk) - etot3(:,:,jk+1) ) 
     162               END DO 
     163            END DO 
     164         END DO 
     165#else 
    146166         DO jk = 1, jpkm1 
    147167            qsr_hc(:,:,jk) = ro0cpr * ( etot3(:,:,jk) - etot3(:,:,jk+1) ) 
    148168         END DO 
     169#endif 
    149170         !                                        Add to the general trend 
     171#if defined key_z_first 
     172         DO jj = 2, jpjm1  
     173            DO ji = 2, jpim1 
     174               DO jk = 1, jpkm1 
     175#else 
    150176         DO jk = 1, jpkm1 
    151177            DO jj = 2, jpjm1  
    152178               DO ji = fs_2, fs_jpim1   ! vector opt. 
     179#endif 
    153180                  z1_e3t = zfact / fse3t(ji,jj,jk) 
    154181                  tsa(ji,jj,jk,jp_tem) = tsa(ji,jj,jk,jp_tem) + ( qsr_hc_b(ji,jj,jk) + qsr_hc(ji,jj,jk) ) * z1_e3t 
    … …  
    198225               zea(:,:,1) =         qsr(:,:) 
    199226               ! 
     227#if defined key_z_first 
     228               DO jj = 1, jpj 
     229                  DO ji = 1, jpi 
     230                     DO jk = 2, nksr+1 
     231#else 
    200232               DO jk = 2, nksr+1 
    201233!CDIR NOVERRCHK 
    … …  
    203235!CDIR NOVERRCHK    
    204236                     DO ji = 1, jpi 
     237#endif 
    205238                        zc0 = ze0(ji,jj,jk-1) * EXP( - fse3t(ji,jj,jk-1) * xsi0r     ) 
    206239                        zc1 = ze1(ji,jj,jk-1) * EXP( - fse3t(ji,jj,jk-1) * zekb(ji,jj) ) 
    … …  
    216249               END DO 
    217250               ! 
     251#if defined key_z_first 
     252               DO jj = 1, jpj 
     253                  DO ji = 1, jpi 
     254                     DO jk = 1, nksr                                  ! compute and add qsr trend to ta 
     255                        qsr_hc(ji,jj,jk) = ro0cpr * ( zea(ji,jj,jk) - zea(ji,jj,jk+1) ) 
     256                     END DO 
     257                  END DO 
     258               END DO 
     259#else 
    218260               DO jk = 1, nksr                                        ! compute and add qsr trend to ta 
    219261                  qsr_hc(:,:,jk) = ro0cpr * ( zea(:,:,jk) - zea(:,:,jk+1) ) 
    220262               END DO 
     263#endif 
    221264               zea(:,:,nksr+1:jpk) = 0.e0     ! below 400m set to zero 
    222265               CALL iom_put( 'qsr3d', zea )   ! Shortwave Radiation 3D distribution 
    223266               ! 
    224267            ELSE                                                 !*  Constant Chlorophyll 
     268#if defined key_z_first 
     269               DO jj = 1, jpj 
     270                  DO ji = 1, jpi 
     271                     DO jk = 1, nksr 
     272                        qsr_hc(ji,jj,jk) =  etot3(ji,jj,jk) * qsr(ji,jj) 
     273                     END DO 
     274                  END DO 
     275               END DO 
     276#else 
    225277               DO jk = 1, nksr 
    226278                  qsr_hc(:,:,jk) =  etot3(:,:,jk) * qsr(:,:) 
    227279               END DO 
     280#endif 
    228281            ENDIF 
    229282 
    … …  
    236289               zz0   =        rn_abs   * ro0cpr 
    237290               zz1   = ( 1. - rn_abs ) * ro0cpr 
     291#if defined key_z_first 
     292               DO jj = 2, jpjm1 
     293                  DO ji = 2, jpim1 
     294                     DO jk = 1, nksr              ! solar heat absorbed at T-point in the top 400m  
     295#else 
    238296               DO jk = 1, nksr                    ! solar heat absorbed at T-point in the top 400m  
    239297                  DO jj = 2, jpjm1 
    240298                     DO ji = 2, jpim1 
     299#endif 
    241300                        zc0 = zz0 * EXP( -fsdepw(ji,jj,jk  )*xsi0r ) + zz1 * EXP( -fsdepw(ji,jj,jk  )*xsi1r ) 
    242301                        zc1 = zz0 * EXP( -fsdepw(ji,jj,jk+1)*xsi0r ) + zz1 * EXP( -fsdepw(ji,jj,jk+1)*xsi1r ) 
    … …  
    246305               END DO 
    247306            ELSE                                               !* constant volume: coef. computed one for all 
     307#if defined key_z_first 
     308               DO jj = 2, jpjm1 
     309                  DO ji = 2, jpim1 
     310                     DO jk = 1, nksr 
     311#else 
    248312               DO jk = 1, nksr 
    249313                  DO jj = 2, jpjm1 
    250314                     DO ji = fs_2, fs_jpim1   ! vector opt. 
     315#endif 
    251316                        qsr_hc(ji,jj,jk) =  etot3(ji,jj,jk) * qsr(ji,jj) 
    252317                     END DO 
    … …  
    259324         ! 
    260325         !                                        Add to the general trend 
     326#if defined key_z_first 
     327         DO jj = 2, jpjm1  
     328            DO ji = 2, jpim1 
     329               DO jk = 1, nksr 
     330#else 
    261331         DO jk = 1, nksr 
    262332            DO jj = 2, jpjm1  
    263333               DO ji = fs_2, fs_jpim1   ! vector opt. 
     334#endif 
    264335                  z1_e3t = zfact / fse3t(ji,jj,jk) 
    265336                  tsa(ji,jj,jk,jp_tem) = tsa(ji,jj,jk,jp_tem) + ( qsr_hc_b(ji,jj,jk) + qsr_hc(ji,jj,jk) ) * z1_e3t 
    … …  
    293364   END SUBROUTINE tra_qsr 
    294365 
     366   !! * Reset control of array index permutation  
     367!FTRANS CLEAR 
     368#  include "oce_ftrans.h90" 
     369#  include "dom_oce_ftrans.h90" 
     370#  include "sbc_oce_ftrans.h90" 
     371#  include "trc_oce_ftrans.h90" 
    295372 
    296373   SUBROUTINE tra_qsr_init 
    … …  
    315392      USE wrk_nemo, ONLY:   ze0  => wrk_3d_1 , ze1  => wrk_3d_2 , ze2 => wrk_3d_3 
    316393      USE wrk_nemo, ONLY:   ze3  => wrk_3d_4 , zea  => wrk_3d_5 
     394 
     395      !! DCSE_NEMO: Need additional directives for renamed module variables 
     396!FTRANS ze0 ze1 ze2 ze3 zea :I :I :z 
     397 
    317398      ! 
    318399      INTEGER  ::   ji, jj, jk     ! dummy loop indices 
    … …  
    433514                  ! 
    434515                  zcoef = ( 1. - rn_abs ) / 3.e0              ! equi-partition in R-G-B 
     516                
     517#if defined key_z_first 
     518                  DO jj = 1, jpj 
     519                     DO ji = 1, jpi 
     520                        ze0(ji,jj,1) = rn_abs 
     521                        ze1(ji,jj,1) = zcoef 
     522                        ze2(ji,jj,1) = zcoef  
     523                        ze3(ji,jj,1) = zcoef 
     524                        zea(ji,jj,1) = tmask(ji,jj,1)         ! = ( ze0+ze1+z2+ze3 ) * tmask 
     525                        DO jk = 2, nksr+1 
     526#else 
    435527                  ze0(:,:,1) = rn_abs 
    436528                  ze1(:,:,1) = zcoef 
    … …  
    438530                  ze3(:,:,1) = zcoef 
    439531                  zea(:,:,1) = tmask(:,:,1)                   ! = ( ze0+ze1+z2+ze3 ) * tmask 
    440                 
    441532                  DO jk = 2, nksr+1 
    442533!CDIR NOVERRCHK 
    … …  
    444535!CDIR NOVERRCHK    
    445536                        DO ji = 1, jpi 
     537#endif 
    446538                           zc0 = ze0(ji,jj,jk-1) * EXP( - fse3t_0(ji,jj,jk-1) * xsi0r     ) 
    447539                           zc1 = ze1(ji,jj,jk-1) * EXP( - fse3t_0(ji,jj,jk-1) * zekb(ji,jj) ) 
    … …  
    457549                  END DO  
    458550                  ! 
     551#if defined key_z_first 
     552                  DO jj = 1, jpj 
     553                     DO ji = 1, jpi 
     554                        DO jk = 1, nksr 
     555                           etot3(ji,jj,jk) = ro0cpr * ( zea(ji,jj,jk) - zea(ji,jj,jk+1) )  
     556                        END DO 
     557                     END DO 
     558                  END DO 
     559#else 
    459560                  DO jk = 1, nksr 
    460561                     etot3(:,:,jk) = ro0cpr * ( zea(:,:,jk) - zea(:,:,jk+1) )  
    461562                  END DO 
     563#endif 
    462564                  etot3(:,:,nksr+1:jpk) = 0.e0                ! below 400m set to zero 
    463565               ENDIF 
    … …  
    481583               zz0 =        rn_abs   * ro0cpr 
    482584               zz1 = ( 1. - rn_abs ) * ro0cpr 
     585#if defined key_z_first 
     586               DO jj = 1, jpj                     !*  solar heat absorbed at T-point computed once for all 
     587                  DO ji = 1, jpi 
     588                     DO jk = 1, nksr                         ! top 400 meters 
     589                        zc0 = zz0 * EXP( -fsdepw(ji,jj,jk  )*xsi0r ) + zz1 * EXP( -fsdepw(ji,jj,jk  )*xsi1r ) 
     590                        zc1 = zz0 * EXP( -fsdepw(ji,jj,jk+1)*xsi0r ) + zz1 * EXP( -fsdepw(ji,jj,jk+1)*xsi1r ) 
     591                        etot3(ji,jj,jk) = (  zc0 * tmask(ji,jj,jk) - zc1 * tmask(ji,jj,jk+1)  )  
     592                     END DO 
     593                     DO jk = nksr+1, jpk 
     594                        etot3(ji,jj,jk) = 0.e0       ! below 400m set to zero 
     595                     END DO 
     596                  END DO 
     597               END DO 
     598#else 
    483599               DO jk = 1, nksr                    !*  solar heat absorbed at T-point computed once for all 
    484600                  DO jj = 1, jpj                              ! top 400 meters 
    … …  
    491607               END DO 
    492608               etot3(:,:,nksr+1:jpk) = 0.e0                   ! below 400m set to zero 
     609#endif 
    493610               ! 
    494611            ENDIF 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/TRA/trasbc.F90

    r2715 r3211  
    3333 
    3434   PUBLIC   tra_sbc    ! routine called by step.F90 
     35 
     36   !! * Control permutation of array indices 
     37#  include "oce_ftrans.h90" 
     38#  include "sbc_oce_ftrans.h90" 
     39#  include "dom_oce_ftrans.h90" 
    3540 
    3641   !! * Substitutions 
    … …  
    108113      INTEGER  ::   ji, jj, jk, jn           ! dummy loop indices   
    109114      REAL(wp) ::   zfact, z1_e3t, zsrau, zdep 
     115 
     116!FTRANS ztrdt ztrds :I :I :z 
    110117      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::  ztrdt, ztrds 
    111118      !!---------------------------------------------------------------------- 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/TRA/traswp.F90

    r2715 r3211  
    1212   PUBLIC   tra_swap     ! routine called by step.F90 
    1313   PUBLIC   tra_unswap   ! routine called by step.F90 
     14 
     15   !! * Control permutation of array indices 
     16#  include "oce_ftrans.h90" 
    1417 
    1518   !!---------------------------------------------------------------------- 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/TRA/trazdf.F90

    r2715 r3211  
    4040   INTEGER ::   nzdf = 0   ! type vertical diffusion algorithm used (defined from ln_zdf...  namlist logicals) 
    4141 
     42   !! * Control permutation of array indices 
     43#  include "oce_ftrans.h90" 
     44#  include "dom_oce_ftrans.h90" 
     45#  include "domvvl_ftrans.h90" 
     46#  include "zdf_oce_ftrans.h90" 
     47#  include "sbc_oce_ftrans.h90" 
     48#  include "ldftra_oce_ftrans.h90" 
     49 
    4250   !! * Substitutions 
    4351#  include "domzgr_substitute.h90" 
    … …  
    5967      INTEGER, INTENT( in ) ::   kt      ! ocean time-step index 
    6068      !! 
    61       INTEGER  ::   jk                   ! Dummy loop indices 
     69      INTEGER  ::   ji, jj, jk           ! Dummy loop indices 
     70!FTRANS ztrdt ztrds :I :I :z 
    6271      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::   ztrdt, ztrds   ! 3D workspace 
    6372      !!--------------------------------------------------------------------- 
    … …  
    8897 
    8998      IF( l_trdtra )   THEN                      ! save the vertical diffusive trends for further diagnostics 
     99#if defined key_z_first 
     100         DO jj = 1, jpj 
     101            DO ji = 1, jpi 
     102               DO jk = 1, jpkm1 
     103                  ztrdt(ji,jj,jk) = ( ( tsa(ji,jj,jk,jp_tem) - tsb(ji,jj,jk,jp_tem) ) / r2dtra(jk) ) - ztrdt(ji,jj,jk) 
     104                  ztrds(ji,jj,jk) = ( ( tsa(ji,jj,jk,jp_sal) - tsb(ji,jj,jk,jp_sal) ) / r2dtra(jk) ) - ztrds(ji,jj,jk) 
     105               END DO 
     106            END DO 
     107         END DO 
     108#else 
    90109         DO jk = 1, jpkm1 
    91110            ztrdt(:,:,jk) = ( ( tsa(:,:,jk,jp_tem) - tsb(:,:,jk,jp_tem) ) / r2dtra(jk) ) - ztrdt(:,:,jk) 
    92111            ztrds(:,:,jk) = ( ( tsa(:,:,jk,jp_sal) - tsb(:,:,jk,jp_sal) ) / r2dtra(jk) ) - ztrds(:,:,jk) 
    93112         END DO 
     113#endif 
    94114         CALL trd_tra( kt, 'TRA', jp_tem, jptra_trd_zdf, ztrdt ) 
    95115         CALL trd_tra( kt, 'TRA', jp_sal, jptra_trd_zdf, ztrds ) 
    … …  
    119139      USE zdfgls 
    120140      USE zdfkpp 
     141#  include "zdftke_ftrans.h90" 
    121142      !!---------------------------------------------------------------------- 
    122143 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/TRA/trazdf_exp.F90

    r2715 r3211  
    3636 
    3737   PUBLIC   tra_zdf_exp   ! routine called by step.F90 
     38 
     39   !! * Control permutation of array indices 
     40#  include "oce_ftrans.h90" 
     41#  include "dom_oce_ftrans.h90" 
     42#  include "domvvl_ftrans.h90" 
     43#  include "zdf_oce_ftrans.h90" 
     44#  include "zdfddm_ftrans.h90" 
     45#  include "trc_oce_ftrans.h90" 
    3846 
    3947   !! * Substitutions 
    … …  
    7583      USE wrk_nemo, ONLY:   wrk_in_use, wrk_not_released 
    7684      USE wrk_nemo, ONLY:   zwx => wrk_3d_6, zwy => wrk_3d_7     ! 3D workspace 
     85 
     86      !! DCSE_NEMO: need additional directives for renamed module variables 
     87!FTRANS zwx zwy :I :I :z 
    7788      ! 
    7889      INTEGER                              , INTENT(in   ) ::   kt          ! ocean time-step index 
    … …  
    8192      INTEGER                              , INTENT(in   ) ::   kn_zdfexp   ! number of sub-time step 
    8293      REAL(wp), DIMENSION(        jpk     ), INTENT(in   ) ::   p2dt        ! vertical profile of tracer time-step 
    83       REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in   ) ::   ptb         ! before and now tracer fields 
    84       REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) ::   pta         ! tracer trend  
     94 
     95      !! DCSE_NEMO: This style defeats ftrans 
     96!     REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in   ) ::   ptb         ! before and now tracer fields 
     97!     REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) ::   pta         ! tracer trend  
     98 
     99!FTRANS ptb pta :I :I :z : 
     100      REAL(wp), INTENT(in   ) ::   ptb(jpi,jpj,jpk,kjpt)         ! before and now tracer fields 
     101      REAL(wp), INTENT(inout) ::   pta(jpi,jpj,jpk,kjpt)         ! tracer trend  
    85102      ! 
    86103      INTEGER  ::  ji, jj, jk, jn, jl        ! dummy loop indices 
    … …  
    116133         DO jl = 1, kn_zdfexp 
    117134            !                     ! first vertical derivative 
     135#if defined key_z_first 
     136            DO jj = 2, jpjm1  
     137               DO ji = 2, jpim1   ! vector opt. 
     138                  DO jk = 2, jpk 
     139#else 
    118140            DO jk = 2, jpk 
    119141               DO jj = 2, jpjm1  
    120142                  DO ji = fs_2, fs_jpim1   ! vector opt. 
     143#endif 
    121144                     zave3r = 1.e0 / fse3w_n(ji,jj,jk)  
    122145                     IF( cdtype == 'TRA' .AND. jn == jp_tem ) THEN  ! temperature : use of avt 
    … …  
    129152            END DO 
    130153            ! 
     154#if defined key_z_first 
     155            ! second vertical derivative   ==> tracer at kt+l*2*rdt/nn_zdfexp 
     156            DO jj = 2, jpjm1  
     157               DO ji = 2, jpim1 
     158                  DO jk = 1, jpkm1 
     159#else 
    131160            DO jk = 1, jpkm1      ! second vertical derivative   ==> tracer at kt+l*2*rdt/nn_zdfexp 
    132161               DO jj = 2, jpjm1  
    133162                  DO ji = fs_2, fs_jpim1   ! vector opt. 
     163#endif 
    134164                     ze3tr = zlavmr / fse3t_n(ji,jj,jk) 
    135165                     zwx(ji,jj,jk) = zwx(ji,jj,jk) + p2dt(jk) * ( zwy(ji,jj,jk) - zwy(ji,jj,jk+1) ) * ze3tr 
    … …  
    143173         ! ------------------------------ 
    144174         IF( lk_vvl ) THEN          ! variable level thickness : leap-frog on tracer*e3t 
     175#if defined key_z_first 
     176            DO jj = 2, jpjm1  
     177               DO ji = 2, jpim1 
     178                  DO jk = 1, jpkm1 
     179#else 
    145180            DO jk = 1, jpkm1 
    146181               DO jj = 2, jpjm1  
    147182                  DO ji = fs_2, fs_jpim1   ! vector opt. 
     183#endif 
    148184                     ze3tb = fse3t_b(ji,jj,jk) / fse3t(ji,jj,jk)                          ! before e3t 
    149185                     ztra  = zwx(ji,jj,jk) - ptb(ji,jj,jk,jn) + p2dt(jk) * pta(ji,jj,jk,jn)       ! total trends * 2*rdt  
    … …  
    153189            END DO 
    154190         ELSE                       ! fixed level thickness : leap-frog on tracers 
     191#if defined key_z_first 
     192            DO jj = 2, jpjm1  
     193               DO ji = 2, jpim1 
     194                  DO jk = 1, jpkm1 
     195#else 
    155196            DO jk = 1, jpkm1 
    156197               DO jj = 2, jpjm1  
    157198                  DO ji = fs_2, fs_jpim1   ! vector opt. 
     199#endif 
    158200                     pta(ji,jj,jk,jn) = ( zwx(ji,jj,jk) + p2dt(jk) * pta(ji,jj,jk,jn) ) * tmask(ji,jj,jk) 
    159201                  END DO 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/TRA/trazdf_imp.F90

    r2715 r3211  
    4242 
    4343   REAL(wp) ::  r_vvl     ! variable volume indicator, =1 if lk_vvl=T, =0 otherwise  
     44 
     45   !! * Control permutation of array indices 
     46#  include "oce_ftrans.h90" 
     47#  include "dom_oce_ftrans.h90" 
     48#  include "zdf_oce_ftrans.h90" 
     49#  include "trc_oce_ftrans.h90" 
     50#  include "domvvl_ftrans.h90" 
     51#  include "ldftra_oce_ftrans.h90" 
     52#  include "ldfslp_ftrans.h90" 
     53#  include "zdfddm_ftrans.h90" 
     54#  include "traldf_iso_grif_ftrans.h90" 
    4455 
    4556   !! * Substitutions 
    … …  
    7788      USE oce     , ONLY:   zwd => ua       , zws => va         ! (ua,va) used as 3D workspace 
    7889      USE wrk_nemo, ONLY:   zwi => wrk_3d_6 , zwt => wrk_3d_7   ! 3D workspace  
     90 
     91      !! DCSE_NEMO: Need additional directives for renamed module variables 
     92!FTRANS zwd zws :I :I :z 
     93!FTRANS zwi zwt :I :I :z 
    7994      ! 
    8095      INTEGER                              , INTENT(in   ) ::   kt       ! ocean time-step index 
    … …  
    8297      INTEGER                              , INTENT(in   ) ::   kjpt     ! number of tracers 
    8398      REAL(wp), DIMENSION(        jpk     ), INTENT(in   ) ::   p2dt     ! vertical profile of tracer time-step 
    84       REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in   ) ::   ptb      ! before and now tracer fields 
    85       REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) ::   pta      ! tracer trend  
     99 
     100      !! DCSE_NEMO: This style defeats ftrans 
     101!     REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in   ) ::   ptb      ! before and now tracer fields 
     102!     REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) ::   pta      ! tracer trend  
     103 
     104!FTRANS ptb pta :I :I :z : 
     105      REAL(wp), INTENT(in   ) ::   ptb(jpi,jpj,jpk,kjpt)      ! before and now tracer fields 
     106      REAL(wp), INTENT(inout) ::   pta(jpi,jpj,jpk,kjpt)      ! tracer trend  
    86107      ! 
    87108      INTEGER  ::  ji, jj, jk, jn   ! dummy loop indices 
    … …  
    115136            ! 
    116137            ! vertical mixing coef.: avt for temperature, avs for salinity and passive tracers 
     138#if defined key_z_first 
     139            IF( cdtype == 'TRA' .AND. jn == jp_tem ) THEN 
     140               DO jj = 1, jpj 
     141                  DO ji = 1, jpi 
     142                     zwt(ji,jj,1) = 0._wp 
     143                     DO jk = 2, jpk 
     144                        zwt(ji,jj,jk) = avt  (ji,jj,jk) 
     145                     END DO 
     146                  END DO 
     147               END DO 
     148            ELSE                                 
     149               DO jj = 1, jpj 
     150                  DO ji = 1, jpi 
     151                     zwt(ji,jj,1) = 0._wp 
     152                     DO jk = 2, jpk 
     153                        zwt(ji,jj,jk) = fsavs(ji,jj,jk) 
     154                     END DO 
     155                  END DO 
     156               END DO 
     157            ENDIF 
     158#else 
    117159            IF( cdtype == 'TRA' .AND. jn == jp_tem ) THEN   ;   zwt(:,:,2:jpk) = avt  (:,:,2:jpk) 
    118160            ELSE                                            ;   zwt(:,:,2:jpk) = fsavs(:,:,2:jpk) 
    119161            ENDIF 
    120162            zwt(:,:,1) = 0._wp 
     163#endif 
    121164            ! 
    122165#if defined key_ldfslp 
    123166            ! isoneutral diffusion: add the contribution  
    124167            IF( ln_traldf_grif    ) THEN     ! Griffies isoneutral diff 
     168#if defined key_z_first 
     169               DO jj = 2, jpjm1 
     170                  DO ji = 2, jpim1 
     171                     DO jk = 2, jpkm1 
     172#else 
    125173               DO jk = 2, jpkm1 
    126174                  DO jj = 2, jpjm1 
    127175                     DO ji = fs_2, fs_jpim1   ! vector opt. 
     176#endif 
    128177                        zwt(ji,jj,jk) = zwt(ji,jj,jk) + ah_wslp2(ji,jj,jk)        
    129178                     END DO 
    … …  
    131180               END DO 
    132181            ELSE IF( l_traldf_rot ) THEN     ! standard isoneutral diff 
     182#if defined key_z_first 
     183               DO jj = 2, jpjm1 
     184                  DO ji = 2, jpim1 
     185                     DO jk = 2, jpkm1 
     186#else 
    133187               DO jk = 2, jpkm1 
    134188                  DO jj = 2, jpjm1 
    135189                     DO ji = fs_2, fs_jpim1   ! vector opt. 
     190#endif 
    136191                        zwt(ji,jj,jk) = zwt(ji,jj,jk) + fsahtw(ji,jj,jk)                       & 
    137192                           &                          * (  wslpi(ji,jj,jk) * wslpi(ji,jj,jk)   & 
    … …  
    143198#endif 
    144199            ! Diagonal, lower (i), upper (s)  (including the bottom boundary condition since avt is masked) 
     200#if defined key_z_first 
     201            DO jj = 2, jpjm1 
     202               DO ji = 2, jpim1 
     203                  DO jk = 1, jpkm1 
     204                     ze3ta =  ( 1. - r_vvl ) +        r_vvl   * fse3t_a(ji,jj,jk)   ! after scale factor at T-point 
     205                     ze3tn =         r_vvl   + ( 1. - r_vvl ) * fse3t_n(ji,jj,jk)   ! now   scale factor at T-point 
     206                     zwi(ji,jj,jk) = - p2dt(jk) * zwt(ji,jj,jk  ) / ( ze3tn * fse3w(ji,jj,jk  ) ) 
     207                     zws(ji,jj,jk) = - p2dt(jk) * zwt(ji,jj,jk+1) / ( ze3tn * fse3w(ji,jj,jk+1) ) 
     208                     zwd(ji,jj,jk) = ze3ta - zwi(ji,jj,jk) - zws(ji,jj,jk) 
     209                 END DO 
     210#else 
    145211            DO jk = 1, jpkm1 
    146212               DO jj = 2, jpjm1 
    … …  
    154220               END DO 
    155221            END DO 
     222#endif 
    156223            ! 
    157224            !! Matrix inversion from the first level 
    … …  
    176243            ! first recurrence:   Tk = Dk - Ik Sk-1 / Tk-1   (increasing k) 
    177244            ! done once for all passive tracers (so included in the IF instruction) 
     245#if defined key_z_first 
     246                  zwt(ji,jj,1) = zwd(ji,jj,1) 
     247                  DO jk = 2, jpkm1 
     248                    zwt(ji,jj,jk) = zwd(ji,jj,jk) - zwi(ji,jj,jk) * zws(ji,jj,jk-1) / zwt(ji,jj,jk-1) 
     249                  END DO 
     250               END DO 
     251            END DO 
     252#else 
    178253            DO jj = 2, jpjm1 
    179254               DO ji = fs_2, fs_jpim1 
    … …  
    188263               END DO 
    189264            END DO 
     265#endif 
    190266            ! 
    191267         END IF  
    192268         !          
    193269         ! second recurrence:    Zk = Yk - Ik / Tk-1  Zk-1 
     270#if defined key_z_first 
     271         DO jj = 2, jpjm1 
     272            DO ji = 2, jpim1 
     273               ze3tb = ( 1. - r_vvl ) + r_vvl * fse3t_b(ji,jj,1) 
     274               ze3tn = ( 1. - r_vvl ) + r_vvl * fse3t(ji,jj,1) 
     275               pta(ji,jj,1,jn) = ze3tb * ptb(ji,jj,1,jn) + p2dt(1) * ze3tn * pta(ji,jj,1,jn) 
     276               DO jk = 2, jpkm1 
     277                  ze3tb = ( 1. - r_vvl ) + r_vvl * fse3t_b(ji,jj,jk) 
     278                  ze3tn = ( 1. - r_vvl ) + r_vvl * fse3t  (ji,jj,jk) 
     279                  zrhs = ze3tb * ptb(ji,jj,jk,jn) + p2dt(jk) * ze3tn * pta(ji,jj,jk,jn)   ! zrhs=right hand side  
     280                  pta(ji,jj,jk,jn) = zrhs - zwi(ji,jj,jk) / zwt(ji,jj,jk-1) * pta(ji,jj,jk-1,jn) 
     281               END DO 
     282#else 
    194283         DO jj = 2, jpjm1 
    195284            DO ji = fs_2, fs_jpim1 
    … …  
    209298            END DO 
    210299         END DO 
     300#endif 
    211301 
    212302         ! third recurrence:    Xk = (Zk - Sk Xk+1 ) / Tk   (result is the after tracer) 
     303#if defined key_z_first 
     304               pta(ji,jj,jpkm1,jn) = pta(ji,jj,jpkm1,jn) / zwt(ji,jj,jpkm1) * tmask(ji,jj,jpkm1) 
     305               DO jk = jpk-2, 1, -1 
     306                  pta(ji,jj,jk,jn) = ( pta(ji,jj,jk,jn) - zws(ji,jj,jk) * pta(ji,jj,jk+1,jn) )   & 
     307                     &             / zwt(ji,jj,jk) * tmask(ji,jj,jk) 
     308               END DO 
     309            END DO 
     310         END DO 
     311#else 
    213312         DO jj = 2, jpjm1 
    214313            DO ji = fs_2, fs_jpim1 
    … …  
    224323            END DO 
    225324         END DO 
     325#endif 
    226326         !                                            ! ================= ! 
    227327      END DO                                          !  end tracer loop  ! 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/TRA/zpshde.F90

    r2715 r3211  
    2626 
    2727   PUBLIC   zps_hde    ! routine called by step.F90 
     28 
     29   !! * Control permutation of array indices 
     30#  include "oce_ftrans.h90" 
     31#  include "dom_oce_ftrans.h90" 
    2832 
    2933   !! * Substitutions 
    … …  
    8791      INTEGER                              , INTENT(in   )           ::  kt          ! ocean time-step index 
    8892      INTEGER                              , INTENT(in   )           ::  kjpt        ! number of tracers 
    89       REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in   )           ::  pta         ! 4D tracers fields 
     93 
     94      !! DCSE_NEMO: This style defeats ftrans 
     95!     REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in   )           ::  pta         ! 4D tracers fields 
     96!FTRANS pta :I :I :z : 
     97      REAL(wp), INTENT(in   )                      ::  pta(jpi,jpj,jpk,kjpt)         ! 4D tracers fields 
     98 
    9099      REAL(wp), DIMENSION(jpi,jpj,    kjpt), INTENT(  out)           ::  pgtu, pgtv  ! hor. grad. of ptra at u- & v-pts  
    91       REAL(wp), DIMENSION(jpi,jpj,jpk     ), INTENT(in   ), OPTIONAL ::  prd         ! 3D density anomaly fields 
     100 
     101!     REAL(wp), DIMENSION(jpi,jpj,jpk     ), INTENT(in   ), OPTIONAL ::  prd         ! 3D density anomaly fields 
     102!FTRANS prd :I :I :z 
     103      REAL(wp), INTENT(in   ), OPTIONAL            ::  prd(jpi,jpj,jpk)              ! 3D density anomaly fields 
     104 
    92105      REAL(wp), DIMENSION(jpi,jpj         ), INTENT(  out), OPTIONAL ::  pgru, pgrv  ! hor. grad. of prd at u- & v-pts  
    93106      ! 
    … …  
    126139                  zti(ji,jj,jn) = pta(ji+1,jj,iku,jn) + zmaxu * ( pta(ji+1,jj,ikum1,jn) - pta(ji+1,jj,iku,jn) ) 
    127140                  ! gradient of  tracers 
     141#if defined key_z_first 
     142                  pgtu(ji,jj,jn) = umask_1(ji,jj) * ( zti(ji,jj,jn) - pta(ji,jj,iku,jn) ) 
     143#else 
    128144                  pgtu(ji,jj,jn) = umask(ji,jj,1) * ( zti(ji,jj,jn) - pta(ji,jj,iku,jn) ) 
     145#endif 
    129146               ELSE                           ! case 2 
    130147                  zmaxu = -ze3wu / fse3w(ji,jj,iku) 
    … …  
    132149                  zti(ji,jj,jn) = pta(ji,jj,iku,jn) + zmaxu * ( pta(ji,jj,ikum1,jn) - pta(ji,jj,iku,jn) ) 
    133150                  ! gradient of tracers 
     151#if defined key_z_first 
     152                  pgtu(ji,jj,jn) = umask_1(ji,jj) * ( pta(ji+1,jj,iku,jn) - zti(ji,jj,jn) ) 
     153#else 
    134154                  pgtu(ji,jj,jn) = umask(ji,jj,1) * ( pta(ji+1,jj,iku,jn) - zti(ji,jj,jn) ) 
     155#endif 
    135156               ENDIF 
    136157               ! 
    … …  
    141162                  ztj(ji,jj,jn) = pta(ji,jj+1,ikv,jn) + zmaxv * ( pta(ji,jj+1,ikvm1,jn) - pta(ji,jj+1,ikv,jn) ) 
    142163                  ! gradient of tracers 
     164#if defined key_z_first 
     165                  pgtv(ji,jj,jn) = vmask_1(ji,jj) * ( ztj(ji,jj,jn) - pta(ji,jj,ikv,jn) ) 
     166#else 
    143167                  pgtv(ji,jj,jn) = vmask(ji,jj,1) * ( ztj(ji,jj,jn) - pta(ji,jj,ikv,jn) ) 
     168#endif 
    144169               ELSE                           ! case 2 
    145170                  zmaxv =  -ze3wv / fse3w(ji,jj,ikv) 
    … …  
    147172                  ztj(ji,jj,jn) = pta(ji,jj,ikv,jn) + zmaxv * ( pta(ji,jj,ikvm1,jn) - pta(ji,jj,ikv,jn) ) 
    148173                  ! gradient of tracers 
     174#if defined key_z_first 
     175                  pgtv(ji,jj,jn) = vmask_1(ji,jj) * ( pta(ji,jj+1,ikv,jn) - ztj(ji,jj,jn) ) 
     176#else 
    149177                  pgtv(ji,jj,jn) = vmask(ji,jj,1) * ( pta(ji,jj+1,ikv,jn) - ztj(ji,jj,jn) ) 
     178#endif 
    150179               ENDIF 
    151180# if ! defined key_vectopt_loop 
Note: See TracChangeset for help on using the changeset viewer.