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 – NEMO

Changeset 3211


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
Files:
18 added
180 edited

Legend:

Unmodified
Added
Removed

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/ASM/asminc.F90

    r2715 r3211  
    7575 
    7676   REAL(wp), DIMENSION(:,:), ALLOCATABLE ::   ssh_bkg, ssh_bkginc   ! Background sea surface height and its increment 
     77 
     78   !! * Control permutation of array indices 
     79#  include "asminc_ftrans.h90" 
     80#  include "oce_ftrans.h90" 
     81#  include "dom_oce_ftrans.h90" 
    7782 
    7883   !!---------------------------------------------------------------------- 
    … …  
    409414            CALL iom_get( inum, jpdom_autoglo, 'bckineta', ssh_bkginc, 1 ) 
    410415            ! Apply the masks 
     416#if defined key_z_first 
     417            ssh_bkginc(:,:) = ssh_bkginc(:,:) * tmask_1(:,:) 
     418#else 
    411419            ssh_bkginc(:,:) = ssh_bkginc(:,:) * tmask(:,:,1) 
     420#endif 
    412421            ! Set missing increments to 0.0 rather than 1e+20 
    413422            ! to allow for differences in masks 
    … …  
    472481         IF ( ln_sshinc ) THEN 
    473482            CALL iom_get( inum, jpdom_autoglo, 'sshn', ssh_bkg ) 
     483#if defined key_z_first 
     484            ssh_bkg(:,:) = ssh_bkg(:,:) * tmask_1(:,:) 
     485#else 
    474486            ssh_bkg(:,:) = ssh_bkg(:,:) * tmask(:,:,1) 
     487#endif 
    475488         ENDIF 
    476489 
    … …  
    620633 
    621634            ! Update the tracer tendencies 
     635#if defined key_z_first 
     636            DO jj = 1, jpj 
     637               DO ji = 1, jpi 
     638                  DO jk = 1, jpkm1 
     639                     tsa(ji,jj,jk,jp_tem) = tsa(ji,jj,jk,jp_tem) + t_bkginc(ji,jj,jk) * zincwgt   
     640                     tsa(ji,jj,jk,jp_sal) = tsa(ji,jj,jk,jp_sal) + s_bkginc(ji,jj,jk) * zincwgt 
     641                  END DO 
     642               END DO 
     643            END DO 
     644#else 
    622645            DO jk = 1, jpkm1 
    623646               tsa(:,:,jk,jp_tem) = tsa(:,:,jk,jp_tem) + t_bkginc(:,:,jk) * zincwgt   
    624647               tsa(:,:,jk,jp_sal) = tsa(:,:,jk,jp_sal) + s_bkginc(:,:,jk) * zincwgt 
    625648            END DO 
     649#endif 
    626650 
    627651            ! Salinity fix 
    628652            IF (ln_salfix) THEN 
     653#if defined key_z_first 
     654               DO jj = 1, jpj 
     655                  DO ji= 1, jpi 
     656                     DO jk = 1, jpkm1 
     657#else 
    629658               DO jk = 1, jpkm1 
    630659                  DO jj = 1, jpj 
    631660                     DO ji= 1, jpi 
     661#endif 
    632662                        tsa(ji,jj,jk,jp_sal) = MAX( tsa(ji,jj,jk,jp_sal), salfixmin ) 
    633663                     END DO 
    … …  
    660690            ! Optional salinity fix 
    661691            IF (ln_salfix) THEN 
     692#if defined key_z_first 
     693               DO jj = 1, jpj 
     694                  DO ji= 1, jpi 
     695                     DO jk = 1, jpkm1 
     696#else 
    662697               DO jk = 1, jpkm1 
    663698                  DO jj = 1, jpj 
    664699                     DO ji= 1, jpi 
     700#endif 
    665701                        tsn(ji,jj,jk,jp_sal) = MAX( tsn(ji,jj,jk,jp_sal), salfixmin ) 
    666702                     END DO 
    … …  
    702738      ! 
    703739      INTEGER :: jk 
     740#if defined key_z_first 
     741      INTEGER :: ji, jj 
     742#endif 
    704743      INTEGER :: it 
    705744      REAL(wp) :: zincwgt  ! IAU weight for current time step 
    … …  
    725764 
    726765            ! Update the dynamic tendencies 
     766 
     767#if defined key_z_first 
     768            DO jj = 1, jpj 
     769               DO ji = 1, jpi 
     770                  DO jk = 1, jpkm1 
     771                     ua(ji,jj,jk) = ua(ji,jj,jk) + u_bkginc(ji,jj,jk) * zincwgt 
     772                     va(ji,jj,jk) = va(ji,jj,jk) + v_bkginc(ji,jj,jk) * zincwgt 
     773                  END DO 
     774               END DO 
     775            END DO 
     776#else 
    727777            DO jk = 1, jpkm1 
    728778               ua(:,:,jk) = ua(:,:,jk) + u_bkginc(:,:,jk) * zincwgt 
    729779               va(:,:,jk) = va(:,:,jk) + v_bkginc(:,:,jk) * zincwgt 
    730780            END DO 
     781#endif 
    731782            
    732783            IF ( kt == nitiaufin_r ) THEN 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/ASM/asmtrj.F90

    r2399 r3211  
    5050   PUBLIC   asm_trj_wri   !: Write out the background state 
    5151 
     52   !! * Control permutation of array indices 
     53#  include "oce_ftrans.h90" 
     54#  include "sbc_oce_ftrans.h90" 
     55#  include "zdf_oce_ftrans.h90" 
     56#  include "zdfddm_ftrans.h90" 
     57#  include "ldftra_oce_ftrans.h90" 
     58#  include "ldfslp_ftrans.h90" 
     59#  include "tradmp_ftrans.h90" 
     60#if defined key_zdftke 
     61#  include "zdftke_ftrans.h90" 
     62#endif 
     63 
    5264   !!---------------------------------------------------------------------- 
    5365   !! NEMO/OPA 3.3 , NEMO Consortium (2010) 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/BDY/bdy_oce.F90

    r2715 r3211  
    4141   ! 
    4242   INTEGER ::   nn_rimwidth = 7       !: boundary rim width 
    43    INTEGER ::   nn_dtactl   = 1       !: = 0 use the initial state as bdy dta ; = 1 read it in a NetCDF file 
     43   INTEGER ::   nn_dtactl   = 1       !: = 0 use the initial state as bdy dta ; = 1 read it in a NetCDF file 
    4444   INTEGER ::   nn_volctl   = 1       !: = 0 the total volume will have the variability of the surface Flux E-P  
    4545   !                                  !  = 1 the volume will be constant during all the integration. 
    … …  
    6363   INTEGER, DIMENSION(jpbdim,jpbgrd) ::   nbmap           !: Indices of data in file for data in memory  
    6464     
    65    REAL(wp) ::   bdysurftot                               !: Lateral surface of unstructured open boundary 
     65   REAL(wp) ::   bdysurftot                               !: Lateral surface of unstructured open boundary 
    6666 
    6767   REAL(wp), DIMENSION(jpbdim)        ::   flagu, flagv   !: Flag for normal velocity compnt for velocity components 
    … …  
    7171   REAL(wp), DIMENSION(jpbdim)     ::   ubtbdy, vbtbdy    !: Now clim of bdy barotropic velocity components 
    7272   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) ::   tbdy  , sbdy      !: Now clim of bdy temperature and salinity   
    73    REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) ::   ubdy  , vbdy    !: Now clim of bdy velocity components 
     73   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) ::   ubdy  , vbdy      !: Now clim of bdy velocity components 
    7474   REAL(wp), DIMENSION(jpbdim) ::   sshtide               !: Tidal boundary array : SSH 
    7575   REAL(wp), DIMENSION(jpbdim) ::   utide, vtide          !: Tidal boundary array : U and V 
    … …  
    7979   REAL(wp), DIMENSION(jpbdim) ::   hsnif_bdy   !: now snow thickness 
    8080#endif 
     81 
     82   !! * Control permutation of array indices 
     83   !!   We do not permute indices of boundary condition arrays! 
    8184 
    8285   !!---------------------------------------------------------------------- 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/BDY/bdy_par.F90

    r2528 r3211  
    2020   INTEGER, PUBLIC, PARAMETER ::   jpbdim  = 20000    !: Max length of bdy field on a processor 
    2121   INTEGER, PUBLIC, PARAMETER ::   jpbtime = 1000     !: Max number of time dumps per file 
    22    INTEGER, PUBLIC, PARAMETER ::   jpbgrd  = 6        !: Number of horizontal grid types used  (T, u, v, f) 
     22   INTEGER, PUBLIC, PARAMETER ::   jpbgrd  = 6        !: Number of horizontal grid types used  (T, u, v, f) 
    2323#else 
    2424   !!---------------------------------------------------------------------- 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/BDY/bdydta.F90

    r2715 r3211  
    5858   REAL(wp), DIMENSION(jpbdim,2)     ::   hsnif_bdydta         ! } 
    5959#endif 
     60 
     61   !! * Control permutation of array indices 
     62#  include "oce_ftrans.h90" 
     63#  include "dom_oce_ftrans.h90" 
    6064 
    6165   !!---------------------------------------------------------------------- 
    … …  
    114118      REAL(wp) ::   dayjul0, zdayjulini 
    115119      REAL(wp), DIMENSION(jpbtime)      ::   zstepr             ! REAL time array from data files 
     120!! DCSE_NEMO: do not ftrans! Beware! 
    116121      REAL(wp), DIMENSION(jpbdta,1,jpk) ::   zdta               ! temporary array for data fields 
    117122      !!--------------------------------------------------------------------------- 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/BDY/bdydyn.F90

    r2528 r3211  
    3535# endif 
    3636 
     37   !! * Control permutation of array indices 
     38#  include "oce_ftrans.h90" 
     39#  include "dom_oce_ftrans.h90" 
     40 
    3741   !!---------------------------------------------------------------------- 
    3842   !! NEMO/OPA 3.3 , NEMO Consortium (2010) 
    … …  
    133137      ! Flather boundary conditions     :! 
    134138      ! ---------------------------------!  
    135       
     139 
    136140      IF(ln_dyn_fla .OR. ln_tides) THEN ! If these are both false, then this routine does nothing.  
    137141 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/BDY/bdyice.F90

    r2715 r3211  
    2525 
    2626   PUBLIC   bdy_ice_frs    ! routine called in sbcmod 
     27 
     28   !! * Control permutation of array indices 
     29#  include "oce_ftrans.h90" 
     30#  include "dom_oce_ftrans.h90" 
    2731 
    2832   !!---------------------------------------------------------------------- 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/BDY/bdyini.F90

    r2715 r3211  
    3232 
    3333   PUBLIC   bdy_init   ! routine called by opa.F90 
     34 
     35   !! * Control permutation of array indices 
     36#  include "oce_ftrans.h90" 
     37#  include "dom_oce_ftrans.h90" 
    3438 
    3539   !!---------------------------------------------------------------------- 
    … …  
    336340      ! Mask corrections 
    337341      ! ---------------- 
     342#if defined key_z_first 
     343      DO ij = 1, jpj 
     344         DO ii = 1, jpi 
     345            DO ik = 1, jpkm1 
     346#else 
    338347      DO ik = 1, jpkm1 
    339348         DO ij = 1, jpj 
    340349            DO ii = 1, jpi 
     350#endif 
    341351               tmask(ii,ij,ik) = tmask(ii,ij,ik) * bdytmask(ii,ij) 
    342352               umask(ii,ij,ik) = umask(ii,ij,ik) * bdyumask(ii,ij) 
    … …  
    347357      END DO 
    348358 
     359#if defined key_z_first 
     360      DO ij = 2, jpjm1 
     361         DO ii = 2, jpim1 
     362            DO ik = 1, jpkm1 
     363#else 
    349364      DO ik = 1, jpkm1 
    350365         DO ij = 2, jpjm1 
    351366            DO ii = 2, jpim1 
     367#endif 
    352368               fmask(ii,ij,ik) = fmask(ii,ij,ik) * bdytmask(ii,ij  ) * bdytmask(ii+1,ij  )   & 
    353369                  &                              * bdytmask(ii,ij+1) * bdytmask(ii+1,ij+1) 
    … …  
    356372      END DO 
    357373 
     374#if defined key_z_first 
     375      bdytmask(:,:) = tmask(:,:,1) 
     376      tmask_i (:,:) = bdytmask(:,:) * tmask_i(:,:)              
     377#else 
    358378      tmask_i (:,:) = tmask(:,:,1) * tmask_i(:,:)              
    359379      bdytmask(:,:) = tmask(:,:,1) 
     380#endif 
    360381 
    361382      ! bdy masks and bmask are now set to zero on boundary points: 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/BDY/bdytides.F90

    r2528 r3211  
    5454   REAL(wp), DIMENSION(jpbdim,jptides_max)  ::   u1  , u2     ! Tidal constituents : U 
    5555   REAL(wp), DIMENSION(jpbdim,jptides_max)  ::   v1  , v2     ! Tidal constituents : V 
     56 
     57   !! * Control permutation of array indices 
     58#  include "oce_ftrans.h90" 
     59#  include "dom_oce_ftrans.h90" 
    5660    
    5761   !!---------------------------------------------------------------------- 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/BDY/bdytra.F90

    r2528 r3211  
    2323 
    2424   PUBLIC bdy_tra_frs     ! routine called in tranxt.F90  
     25 
     26   !! * Control permutation of array indices 
     27#  include "oce_ftrans.h90" 
     28#  include "dom_oce_ftrans.h90" 
    2529 
    2630   !!---------------------------------------------------------------------- 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/BDY/bdyvol.F90

    r2528 r3211  
    2626 
    2727   PUBLIC bdy_vol        ! routine called by dynspg_flt.h90 
     28 
     29   !! * Control permutation of array indices 
     30#  include "oce_ftrans.h90" 
     31#  include "dom_oce_ftrans.h90" 
     32#  include "sbc_oce_ftrans.h90" 
    2833 
    2934   !! * Substitutions 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/C1D/dyncor_c1d.F90

    r2409 r3211  
    2525   PUBLIC   cor_c1d      ! routine called by OPA.F90 
    2626   PUBLIC   dyn_cor_c1d  ! routine called by step1d.F90 
     27 
     28   !! * Array index permutations 
     29#  include "oce_ftrans.h90" 
     30#  include "dom_oce_ftrans.h90" 
    2731 
    2832   !! * Substitutions 
    … …  
    96100      ENDIF 
    97101      ! 
     102#if defined key_z_first 
     103      DO jj = 2, jpjm1 
     104         DO ji = 2, jpim1 
     105            DO jk = 1, jpkm1 
     106#else 
    98107      DO jk = 1, jpkm1 
    99108         DO jj = 2, jpjm1 
    100109            DO ji = fs_2, fs_jpim1   ! vector opt. 
     110#endif 
    101111               ua(ji,jj,jk) = ua(ji,jj,jk) + ff(ji,jj) * vn(ji,jj,jk) 
    102112               va(ji,jj,jk) = va(ji,jj,jk) - ff(ji,jj) * un(ji,jj,jk) 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/C1D/dynnxt_c1d.F90

    r2409 r3211  
    2323 
    2424   PUBLIC dyn_nxt_c1d                ! routine called by step.F90 
     25   !! * Array index permutations 
     26#  include "oce_ftrans.h90" 
     27#  include "dom_oce_ftrans.h90" 
    2528   !!---------------------------------------------------------------------- 
    2629   !! NEMO/C1D 3.3 , NEMO Consortium (2010) 
    … …  
    5154      INTEGER, INTENT( in ) ::   kt      ! ocean time-step index 
    5255      !! 
     56#if defined key_z_first 
     57      INTEGER  ::   ji, jj, jk   ! dummy loop indices 
     58#else 
    5359      INTEGER  ::   jk           ! dummy loop indices 
     60#endif 
    5461      REAL(wp) ::   z2dt         ! temporary scalar 
    5562      !!---------------------------------------------------------------------- 
    … …  
    6673      CALL lbc_lnk( ua, 'U', -1. )   ;   CALL lbc_lnk( va, 'V', -1. )      ! Lateral boundary conditions 
    6774 
     75#if defined key_z_first 
     76      DO jj = 1, jpj                                                       ! Next Velocity 
     77         DO ji = 1, jpi  
     78            DO jk = 1, jpkm1 
     79               ua(ji,jj,jk) = ( ub(ji,jj,jk) + z2dt * ua(ji,jj,jk) ) * umask(ji,jj,jk) 
     80               va(ji,jj,jk) = ( vb(ji,jj,jk) + z2dt * va(ji,jj,jk) ) * vmask(ji,jj,jk) 
     81            END DO 
     82         END DO 
     83      END DO  
     84#else 
    6885      DO jk = 1, jpkm1                                                     ! Next Velocity 
    6986         ua(:,:,jk) = ( ub(:,:,jk) + z2dt * ua(:,:,jk) ) * umask(:,:,jk) 
    7087         va(:,:,jk) = ( vb(:,:,jk) + z2dt * va(:,:,jk) ) * vmask(:,:,jk) 
    7188      END DO  
     89#endif 
    7290  
     91#if defined key_z_first 
     92      IF( neuler == 0 .AND. kt == nit000 ) THEN                            ! Euler (forward) time stepping 
     93         DO jj = 1, jpj                                                    ! Time filter and swap of dynamics arrays 
     94            DO ji = 1, jpi 
     95               ub(ji,jj,1:jpkm1) = un(ji,jj,1:jpkm1) 
     96               vb(ji,jj,1:jpkm1) = vn(ji,jj,1:jpkm1) 
     97               un(ji,jj,1:jpkm1) = ua(ji,jj,1:jpkm1) 
     98               vn(ji,jj,1:jpkm1) = va(ji,jj,1:jpkm1) 
     99            END DO 
     100         END DO 
     101      ELSE                                                                ! Leap-frog time stepping 
     102         DO jj =1 , jpj 
     103            DO ji = 1, jpi 
     104               DO jk = 1, jpkm1 
     105                  ub(ji,jj,jk) = atfp * ( ub(ji,jj,jk) + ua(ji,jj,jk) ) + atfp1 * un(ji,jj,jk) 
     106                  vb(ji,jj,jk) = atfp * ( vb(ji,jj,jk) + va(ji,jj,jk) ) + atfp1 * vn(ji,jj,jk) 
     107                  un(ji,jj,jk) = ua(ji,jj,jk) 
     108                  vn(ji,jj,jk) = va(ji,jj,jk) 
     109               END DO 
     110            END DO 
     111         END DO 
     112      ENDIF 
     113#else 
    73114      DO jk = 1, jpkm1                                                     ! Time filter and swap of dynamics arrays 
    74115         IF( neuler == 0 .AND. kt == nit000 ) THEN                               ! Euler (forward) time stepping 
    … …  
    84125         ENDIF 
    85126      END DO 
     127#endif 
    86128 
    87129      IF(ln_ctl)   CALL prt_ctl( tab3d_1=un, clinfo1=' nxt_c1d  - Un: ', mask1=umask,   & 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/C1D/step_c1d.F90

    r2409 r3211  
    2424 
    2525   PUBLIC stp_c1d      ! called by opa.F90 
     26 
     27   !! * Control permutation of array indices 
     28#  include "oce_ftrans.h90" 
     29#  include "dom_oce_ftrans.h90" 
    2630 
    2731   !! * Substitutions 
    … …  
    5357      !!---------------------------------------------------------------------- 
    5458      INTEGER, INTENT(in) ::   kstp   ! ocean time-step index 
    55       INTEGER ::   jk       ! dummy loop indice 
     59#if defined key_z_first 
     60      INTEGER ::   ji, jj, jk         ! dummy loop indices 
     61#else 
     62      INTEGER ::   jk                 ! dummy loop index 
     63#endif 
    5664      INTEGER ::   indic    ! error indicator if < 0 
    5765      !! --------------------------------------------------------------------- 
    … …  
    8795 
    8896      IF( ln_rnf_mouth ) THEN                         ! increase diffusivity at rivers mouths 
     97#if defined key_z_first 
     98         DO jj = 1, jpj 
     99            DO ji = 1, jpi 
     100               DO jk = 2, nkrnf 
     101                  avt(ji,jj,jk) = avt(ji,jj,jk) + 2.e0 * rn_avt_rnf * rnfmsk(ji,jj) 
     102               END DO 
     103            END DO 
     104         END DO 
     105#else 
    89106         DO jk = 2, nkrnf   ;   avt(:,:,jk) = avt(:,:,jk) + 2.e0 * rn_avt_rnf * rnfmsk(:,:)   ;   END DO 
     107#endif 
    90108      ENDIF 
    91109      IF( ln_zdfevd  )   CALL zdf_evd( kstp )         ! enhanced vertical eddy diffusivity 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/DIA/diaar5.F90

    r2715 r3211  
    77   !!            3.3  !  2010-10  (C. Ethe, G. Madec) reorganisation of initialisation phase + merge TRC-TRA 
    88   !!---------------------------------------------------------------------- 
     9 
    910#if defined key_diaar5   || defined key_esopa 
    1011   !!---------------------------------------------------------------------- 
    … …  
    1718   USE dom_oce        ! ocean space and time domain 
    1819   USE eosbn2         ! equation of state                (eos_bn2 routine) 
    19    USE lib_mpp        ! distribued memory computing library 
     20   USE lib_mpp        ! distributed memory computing library 
    2021   USE iom            ! I/O manager library 
    2122 
    … …  
    3536   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   sn0          ! initial salinity 
    3637       
     38   !! * Control permutation of array indices 
     39#  include "oce_ftrans.h90" 
     40#  include "dom_oce_ftrans.h90" 
     41!FTRANS sn0 :I :I :z 
     42 
    3743   !! * Substitutions 
    3844#  include "domzgr_substitute.h90" 
    … …  
    6975      USE wrk_nemo, ONLY:   zrhd      => wrk_3d_1 , zrhop    => wrk_3d_2   ! 3D      - 
    7076      USE wrk_nemo, ONLY:   ztsn      => wrk_4d_1                          ! 4D      - 
     77 
     78      !! DCSE_NEMO: need additional directives for renamed module variables 
     79!FTRANS zrhd zrhop :I :I :z 
     80!FTRANS ztsn :I :I :z : 
     81 
    7182      ! 
    7283      INTEGER, INTENT( in ) ::   kt   ! ocean time-step index 
    … …  
    99110      CALL eos( ztsn, zrhd )                       ! now in situ density using initial salinity 
    100111      ! 
     112#if defined key_z_first 
     113      DO jj = 1, jpj 
     114         DO ji = 1, jpi 
     115            zbotpres(ji,jj) = 0._wp                ! no atmospheric surface pressure, levitating sea-ice 
     116            DO jk = 1, jpkm1 
     117               zbotpres(ji,jj) = zbotpres(ji,jj) + fse3t(ji,jj,jk) * zrhd(ji,jj,jk) 
     118            END DO 
     119      END DO 
     120#else 
    101121      zbotpres(:,:) = 0._wp                        ! no atmospheric surface pressure, levitating sea-ice 
    102122      DO jk = 1, jpkm1 
    103123         zbotpres(:,:) = zbotpres(:,:) + fse3t(:,:,jk) * zrhd(:,:,jk) 
    104124      END DO 
     125#endif 
    105126      IF( .NOT.lk_vvl )   zbotpres(:,:) = zbotpres(:,:) + sshn(:,:) * zrhd(:,:,1) 
    106127      !                                          
    … …  
    115136      CALL iom_put( 'rhop', zrhop ) 
    116137      ! 
     138#if defined key_z_first 
     139      DO jj = 1, jpj 
     140         DO ji = 1, jpi 
     141            zbotpres(ji,jj) = 0._wp                ! no atmospheric surface pressure, levitating sea-ice 
     142            DO jk = 1, jpkm1 
     143               zbotpres(ji,jj) = zbotpres(ji,jj) + fse3t(ji,jj,jk) * zrhd(ji,jj,jk) 
     144            END DO 
     145      END DO 
     146#else 
    117147      zbotpres(:,:) = 0._wp                        ! no atmospheric surface pressure, levitating sea-ice 
    118148      DO jk = 1, jpkm1 
    119149         zbotpres(:,:) = zbotpres(:,:) + fse3t(:,:,jk) * zrhd(:,:,jk) 
    120150      END DO 
     151#endif 
    121152      IF( .NOT.lk_vvl )   zbotpres(:,:) = zbotpres(:,:) + sshn(:,:) * zrhd(:,:,1) 
    122153      !     
    … …  
    134165      ztemp = 0._wp 
    135166      zsal  = 0._wp 
     167#if defined key_z_first 
     168      DO jj = 1, jpj 
     169         DO ji = 1, jpi 
     170            DO jk = 1, jpkm1 
     171#else 
    136172      DO jk = 1, jpkm1 
    137173         DO jj = 1, jpj 
    138174            DO ji = 1, jpi 
     175#endif 
    139176               zztmp = area(ji,jj) * fse3t(ji,jj,jk) 
    140177               ztemp = ztemp + zztmp * tn(ji,jj,jk) 
    … …  
    166203   END SUBROUTINE dia_ar5 
    167204 
     205   !! * Reset control of array index permutation 
     206#  include "oce_ftrans.h90" 
     207#  include "dom_oce_ftrans.h90" 
     208!FTRANS sn0 :I :I :z 
    168209 
    169210   SUBROUTINE dia_ar5_init 
    … …  
    181222      REAL(wp) ::   zztmp   
    182223      REAL(wp), POINTER, DIMENSION(:,:,:,:) ::   zsaldta   ! Jan/Dec levitus salinity 
     224!FTRANS zsaldta :I :I :z : 
    183225      !!---------------------------------------------------------------------- 
    184226      ! 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/DIA/diadimg.F90

    r2715 r3211  
    2222   REAL(sp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: z42d    ! 2d temporary workspace (sp) 
    2323   REAL(sp), ALLOCATABLE, SAVE, DIMENSION(:)   :: z4dep   ! vertical level (sp) 
     24 
     25   !! * Control permutation of array indices 
     26#  include "oce_ftrans.h90" 
     27#  include "dom_oce_ftrans.h90" 
    2428 
    2529   !! * Substitutions 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/DIA/diafwb.F90

    r2528 r3211  
    3333      &                        a_sshb, a_sshn, a_salb, a_saln 
    3434   REAL(wp), DIMENSION(4) ::   a_flxi, a_flxo, a_temi, a_temo, a_sali, a_salo 
     35 
     36   !! * Control permutation of array indices 
     37#  include "oce_ftrans.h90" 
     38#  include "dom_oce_ftrans.h90" 
     39#  include "sbc_oce_ftrans.h90" 
     40#  include "zdf_oce_ftrans.h90" 
    3541 
    3642   !! * Substitutions 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/DIA/diahsb.F90

    r2528 r3211  
    1919   USE trabbc          ! bottom boundary condition 
    2020   USE bdy_par         ! (for lk_bdy) 
    21    USE obc_par         ! (for lk_obc) 
     21 
     22!! DCSE_NEMO: 
     23!  USE obc_par         ! (for lk_obc) 
     24   USE obc_par, ONLY: lk_obc         ! (for lk_obc) 
    2225 
    2326   IMPLICIT NONE 
    … …  
    3740   REAL(dp), DIMENSION(:,:)  , ALLOCATABLE ::   surf      , ssh_ini              ! 
    3841   REAL(dp), DIMENSION(:,:,:), ALLOCATABLE ::   hc_loc_ini, sc_loc_ini, e3t_ini  ! 
     42 
     43   !! * Control permutation of array indices 
     44#  include "oce_ftrans.h90" 
     45#  include "dom_oce_ftrans.h90" 
     46#  include "sbc_oce_ftrans.h90" 
     47#  include "domvvl_ftrans.h90" 
     48!FTRANS hc_loc_ini sc_loc_ini e3t_ini :I :I :z 
    3949 
    4050   !! * Substitutions 
    … …  
    6474      INTEGER, INTENT(in) ::   kt   ! ocean time-step index 
    6575      !! 
    66       INTEGER    ::   jk                          ! dummy loop indice 
     76      INTEGER    ::   ji, jj, jk                  ! dummy loop indices 
    6777      REAL(dp)   ::   zdiff_hc    , zdiff_sc      ! heat and salt content variations 
    6878      REAL(dp)   ::   zdiff_v1    , zdiff_v2      ! volume variation 
    … …  
    98108      zdiff_hc = 0.d0 
    99109      zdiff_sc = 0.d0 
     110#if defined key_z_first 
     111      ! volume variation (calculated with ssh) 
     112      zdiff_v1 = SUM( surf(:,:) * tmask_1(:,:) * ( sshn(:,:) - ssh_ini(:,:) ) ) 
     113      DO jj = 1, jpj 
     114         DO ji = 1, jpi 
     115            DO jk = 1, jpkm1 
     116               ! volume variation (calculated with scale factors) 
     117               zdiff_v2 = zdiff_v2 + ( surf(ji,jj) * tmask(ji,jj,jk)    & 
     118                  &                       * ( fse3t_n(ji,jj,jk)         & 
     119                  &                           - e3t_ini(ji,jj,jk) ) )  
     120               ! heat content variation 
     121               zdiff_hc = zdiff_hc + ( surf(ji,jj) * tmask(ji,jj,jk)             & 
     122                  &                       * ( fse3t_n(ji,jj,jk) * tn(ji,jj,jk)   & 
     123                  &                           - hc_loc_ini(ji,jj,jk) ) ) 
     124               ! salt content variation 
     125               zdiff_sc = zdiff_sc + ( surf(ji,jj) * tmask(ji,jj,jk)             & 
     126                  &                       * ( fse3t_n(ji,jj,jk) * sn(ji,jj,jk)   & 
     127                  &                           - sc_loc_ini(ji,jj,jk) ) ) 
     128            END DO 
     129         END DO 
     130      END DO 
     131#else 
    100132      ! volume variation (calculated with ssh) 
    101133      zdiff_v1 = SUM( surf(:,:) * tmask(:,:,1) * ( sshn(:,:) - ssh_ini(:,:) ) ) 
    … …  
    114146            &                           - sc_loc_ini(:,:,jk) ) ) 
    115147      ENDDO 
    116  
     148#endif 
    117149      IF( lk_mpp ) THEN 
    118150         CALL mpp_sum( zdiff_hc ) 
    … …  
    156188      !!             - Compute coefficients for conversion 
    157189      !!--------------------------------------------------------------------------- 
    158       CHARACTER (len=32) ::   cl_name  ! output file name 
    159       INTEGER            ::   jk       ! dummy loop indice 
    160       INTEGER            ::   ierror   ! local integer 
     190      CHARACTER (len=32) ::   cl_name      ! output file name 
     191      INTEGER            ::   ji, jj, jk   ! dummy loop indices 
     192      INTEGER            ::   ierror       ! local integer 
    161193      !! 
    162194      NAMELIST/namhsb/ ln_diahsb 
    … …  
    209241      ENDIF 
    210242      cl_name    = 'heat_salt_volume_budgets.txt'                         ! name of output file 
     243#if defined key_z_first 
     244      surf(:,:) = e1t(:,:) * e2t(:,:) * tmask_1(:,:) * tmask_i(:,:)      ! masked surface grid cell area 
     245#else 
    211246      surf(:,:) = e1t(:,:) * e2t(:,:) * tmask(:,:,1) * tmask_i(:,:)      ! masked surface grid cell area 
     247#endif 
    212248      surf_tot  = SUM( surf(:,:) )                                       ! total ocean surface area 
    213249      vol_tot   = 0.d0                                                   ! total ocean volume 
    … …  
    249285      ! ---------------------------------- ! 
    250286      ssh_ini(:,:) = sshn(:,:)                               ! initial ssh 
     287#if defined key_z_first 
     288      DO jj = 1, jpj 
     289         DO ji = 1, jpi 
     290            e3t_ini   (ji,jj,:) = fse3t_n(ji,jj,:)                 ! initial vertical scale factors 
     291            hc_loc_ini(ji,jj,:) = tn(ji,jj,:) * fse3t_n(ji,jj,:)   ! initial heat content 
     292            sc_loc_ini(ji,jj,:) = sn(ji,jj,:) * fse3t_n(ji,jj,:)   ! initial salt content 
     293         END DO 
     294      END DO 
     295#else 
    251296      DO jk = 1, jpk 
    252297         e3t_ini   (:,:,jk) = fse3t_n(:,:,jk)                ! initial vertical scale factors 
    … …  
    254299         sc_loc_ini(:,:,jk) = sn(:,:,jk) * fse3t_n(:,:,jk)   ! initial salt content 
    255300      END DO 
     301#endif 
    256302      frc_v = 0.d0                                           ! volume       trend due to forcing 
    257303      frc_t = 0.d0                                           ! heat content   -    -   -    -    

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/DIA/diahth.F90

    r2715 r3211  
    3636   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hd28   !: depth of 28 C isotherm                         [m] 
    3737   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   htc3   !: heat content of first 300 m                    [W] 
     38 
     39   !! * Control permutation of array indices 
     40#  include "oce_ftrans.h90" 
     41#  include "dom_oce_ftrans.h90" 
    3842 
    3943   !! * Substitutions 
    … …  
    179183      ! MLD: rho = rho(1) + zrho1                                     ! 
    180184      ! ------------------------------------------------------------- ! 
     185#if defined key_z_first 
     186      DO jj = 1, jpj 
     187         DO ji = 1, jpi 
     188            DO jk = jpkm1, 2, -1   ! loop from bottom to 2 
     189#else 
    181190      DO jk = jpkm1, 2, -1   ! loop from bottom to 2 
    182191         DO jj = 1, jpj 
    183192            DO ji = 1, jpi 
     193#endif 
    184194               ! 
    185195               zzdep = fsdepw(ji,jj,jk) 
    … …  
    215225      ! depth of temperature inversion                                ! 
    216226      ! ------------------------------------------------------------- ! 
     227#if defined key_z_first 
     228      DO jj = 1, jpj 
     229         DO ji = 1, jpi 
     230            DO jk = jpkm1, nlb10, -1   ! loop from bottom to nlb10 
     231#else 
    217232      DO jk = jpkm1, nlb10, -1   ! loop from bottom to nlb10 
    218233         DO jj = 1, jpj 
    219234            DO ji = 1, jpi 
     235#endif 
    220236               ! 
    221237               zzdep = fsdepw(ji,jj,jk) * tmask(ji,jj,1) 
    … …  
    251267      ik20(:,:) = 1 
    252268      ik28(:,:) = 1 
     269#if defined key_z_first 
     270      DO jj = 1, jpj 
     271         DO ji = 1, jpi 
     272            DO jk = 1, jpkm1   ! beware temperature is not always decreasing with depth =>  
     273               !               ! loop from top to bottom 
     274#else 
    253275      DO jk = 1, jpkm1   ! beware temperature is not always decreasing with depth => loop from top to bottom 
    254276         DO jj = 1, jpj 
    255277            DO ji = 1, jpi 
     278#endif 
    256279               zztmp = tn(ji,jj,jk) 
    257280               IF( zztmp >= 20. )   ik20(ji,jj) = jk 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/DIA/dianam.F90

    r2528 r3211  
    2121 
    2222   PUBLIC dia_nam 
     23 
     24   !! * Control permutation of array indices 
     25#  include "dom_oce_ftrans.h90" 
    2326 
    2427   !!---------------------------------------------------------------------- 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/DIA/diaptr.F90

    r2715 r3211  
    8080   INTEGER, ALLOCATABLE, SAVE, DIMENSION(:) :: ndex_h, ndex_h_atl_30, ndex_h_pac_30, ndex_h_ind_30, ndex_h_ipc_30 
    8181 
     82   !! * Control permutation of array indices 
     83#  include "oce_ftrans.h90" 
     84#  include "dom_oce_ftrans.h90" 
     85#  include "ldftra_oce_ftrans.h90" 
     86 
    8287   !! * Substitutions 
    8388#  include "domzgr_substitute.h90" 
    … …  
    138143      !! ** Action  : - p_fval: i-k-mean poleward flux of pva 
    139144      !!---------------------------------------------------------------------- 
    140       REAL(wp) , INTENT(in), DIMENSION(jpi,jpj,jpk) ::   pva   ! mask flux array at V-point 
     145!FTRANS pva :I :I :z 
     146!! DCSE_NEMO: work around deficiency in ftrans 
     147!     REAL(wp) , INTENT(in), DIMENSION(jpi,jpj,jpk) ::   pva   ! mask flux array at V-point 
     148      REAL(wp) , INTENT(in)    ::   pva(jpi,jpj,jpk)           ! mask flux array at V-point 
    141149      !! 
    142150      INTEGER                  ::   ji, jj, jk   ! dummy loop arguments 
    … …  
    149157      ijpj = jpj 
    150158      p_fval(:) = 0._wp 
     159#if defined key_z_first 
     160      DO jj = 2, jpjm1 
     161         DO ji = 2, jpim1 
     162            DO jk = 1, jpkm1 
     163#else 
    151164      DO jk = 1, jpkm1 
    152165         DO jj = 2, jpjm1 
    153166            DO ji = fs_2, fs_jpim1   ! Vector opt. 
     167#endif 
    154168               p_fval(jj) = p_fval(jj) + pva(ji,jj,jk) * tmask_i(ji,jj)  
    155169            END DO 
    … …  
    162176   END FUNCTION ptr_vj_3d 
    163177 
     178!FTRANS CLEAR 
     179   !! * Re-instate directives to control permutation of array indices 
     180#  include "oce_ftrans.h90" 
     181#  include "dom_oce_ftrans.h90" 
     182#  include "ldftra_oce_ftrans.h90" 
    164183 
    165184   FUNCTION ptr_vj_2d( pva )   RESULT ( p_fval ) 
    … …  
    215234      !! 
    216235      IMPLICIT none 
    217       REAL(wp) , INTENT(in), DIMENSION(jpi,jpj,jpk)           ::   pva    ! mask flux array at V-point 
     236!FTRANS pva :I :I :z 
     237!! DCSE_NEMO: work around a deficiency in ftrans 
     238!     REAL(wp) , INTENT(in), DIMENSION(jpi,jpj,jpk)           ::   pva    ! mask flux array at V-point 
     239      REAL(wp) , INTENT(in)             ::   pva(jpi,jpj,jpk)             ! mask flux array at V-point 
    218240      REAL(wp) , INTENT(in), DIMENSION(jpi,jpj)    , OPTIONAL ::   pmsk   ! Optional 2D basin mask 
    219241      !! 
    … …  
    236258 
    237259      p_fval(:,:) = 0._wp 
     260 
    238261      ! 
    239262      IF( PRESENT( pmsk ) ) THEN  
    … …  
    270293   END FUNCTION ptr_vjk 
    271294 
     295!FTRANS CLEAR 
     296   !! * Re-instate directives to control permutation of array indices 
     297#  include "oce_ftrans.h90" 
     298#  include "dom_oce_ftrans.h90" 
     299#  include "ldftra_oce_ftrans.h90" 
    272300 
    273301   FUNCTION ptr_tjk( pta, pmsk )   RESULT ( p_fval ) 
    … …  
    286314#endif 
    287315      !! 
    288       REAL(wp) , INTENT(in), DIMENSION(jpi,jpj,jpk) ::   pta    ! tracer flux array at T-point 
     316!FTRANS pta :I :I :z 
     317!! DCSE_NEMO: work around a deficiency in ftrans 
     318!     REAL(wp) , INTENT(in), DIMENSION(jpi,jpj,jpk) ::   pta    ! tracer flux array at T-point 
     319      REAL(wp) , INTENT(in)             :: pta(jpi,jpj,jpk)     ! tracer flux array at T-point 
    289320      REAL(wp) , INTENT(in), DIMENSION(jpi,jpj)     ::   pmsk   ! Optional 2D basin mask 
    290321      !! 
    … …  
    307338 
    308339      p_fval(:,:) = 0._wp 
     340#if defined key_z_first 
     341      DO jj = 2, jpjm1 
     342         DO ji =  nldi, nlei 
     343            DO jk = 1, jpkm1 
     344#else 
    309345      DO jk = 1, jpkm1 
    310346         DO jj = 2, jpjm1 
    311347            DO ji =  nldi, nlei   ! No vector optimisation here. Better use a mask ? 
     348#endif 
    312349               p_fval(jj,jk) = p_fval(jj,jk) + pta(ji,jj,jk) * e1t(ji,jj) * fse3t(ji,jj,jk) * pmsk(ji,jj) 
    313350            END DO 
    … …  
    328365   END FUNCTION ptr_tjk 
    329366 
     367!FTRANS CLEAR 
     368   !! * Re-instate directives to control permutation of array indices 
     369#  include "oce_ftrans.h90" 
     370#  include "dom_oce_ftrans.h90" 
     371#  include "ldftra_oce_ftrans.h90" 
    330372 
    331373   SUBROUTINE dia_ptr( kt ) 
    … …  
    334376      !!---------------------------------------------------------------------- 
    335377      USE oce,     vt  =>   ua   ! use ua as workspace 
    336       USE oce,     vs  =>   ua   ! use ua as workspace 
     378!! DCSE_NEMO: see ticket 873 
     379      USE oce,     vs  =>   va   ! use va as workspace 
     380!! DCSE_NEMO: ua, va are re-named, so need additional directives 
     381!FTRANS vt vs :I :I :z 
    337382      IMPLICIT none 
    338383      !! 
    … …  
    370415            !                                ! local heat & salt transports at T-points  ( tn*mj[vn+v_eiv] ) 
    371416            vt(:,:,jpk) = 0._wp   ;   vs(:,:,jpk) = 0._wp 
     417 
    372418            DO jk= 1, jpkm1 
    373419               DO jj = 2, jpj 
    … …  
    434480   END SUBROUTINE dia_ptr 
    435481 
     482!FTRANS CLEAR 
     483   !! * Re-instate directives to control permutation of array indices 
     484#  include "oce_ftrans.h90" 
     485#  include "dom_oce_ftrans.h90" 
     486#  include "ldftra_oce_ftrans.h90" 
    436487 
    437488   SUBROUTINE dia_ptr_init 
    … …  
    489540         btmsk(:,:,5) = MAX ( btmsk(:,:,3), btmsk(:,:,4) )          ! Indo-Pacific basin 
    490541         WHERE( gphit(:,:) < -30._wp)   ;   btm30(:,:) = 0._wp      ! mask out Southern Ocean 
     542#if defined key_z_first 
     543         ELSE WHERE                     ;   btm30(:,:) = tmask_1(:,:) 
     544#else 
    491545         ELSE WHERE                     ;   btm30(:,:) = tmask(:,:,1) 
     546#endif 
    492547         END WHERE 
    493548      ENDIF 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/DIA/diawri.F90

    r2715 r3211  
    4949   USE dtasal 
    5050   USE lib_mpp         ! MPP library 
     51   USE zpermute, ONLY : permute_z_last   ! Re-order a 3d array back to external (z-last) ordering  
     52   USE prtctl 
    5153 
    5254   IMPLICIT NONE 
    … …  
    6567   INTEGER, SAVE, ALLOCATABLE, DIMENSION(:) :: ndex_T, ndex_U, ndex_V 
    6668 
     69   !! * Control permutation of array indices 
     70#  include "oce_ftrans.h90" 
     71#  include "dom_oce_ftrans.h90" 
     72#  include "zdf_oce_ftrans.h90" 
     73#  include "ldftra_oce_ftrans.h90" 
     74#  include "ldfdyn_oce_ftrans.h90" 
     75#  include "sbc_oce_ftrans.h90" 
     76#  include "zdfddm_ftrans.h90" 
     77#  include "dtatem_ftrans.h90" 
     78#  include "dtasal_ftrans.h90" 
     79 
    6780   !! * Substitutions 
    6881#  include "zdfddm_substitute.h90" 
    … …  
    96109   !!   'key_dimgout'                                      DIMG output file 
    97110   !!---------------------------------------------------------------------- 
     111!! DCSE_NEMO: As at November 2011, the version of dia_wri() included here 
     112!! has not been modified or tested for z_first ordering. It will need attention. 
    98113#   include "diawri_dimg.h90" 
    99114 
    … …  
    117132      !!---------------------------------------------------------------------- 
    118133      USE oce, ONLY :   z3d => ta   ! use ta as 3D workspace 
     134!! DCSE_NEMO: ta renamed, so need an additional directive 
     135!FTRANS z3d :I :I :z 
    119136      USE wrk_nemo, ONLY: wrk_in_use, wrk_not_released 
    120137      USE wrk_nemo, ONLY: z2d => wrk_2d_1 
    … …  
    175192         zztmp = 0.5 * rcp 
    176193         z2d(:,:) = 0.e0  
     194#if defined key_z_first 
     195         DO jj = 2, jpjm1 
     196            DO ji = 2, jpim1 
     197               DO jk = 1, jpkm1 
     198#else 
    177199         DO jk = 1, jpkm1 
    178200            DO jj = 2, jpjm1 
    179201               DO ji = fs_2, fs_jpim1   ! vector opt. 
     202#endif 
    180203                  z2d(ji,jj) = z2d(ji,jj) + z3d(ji,jj,jk) * zztmp * ( tn(ji,jj,jk) + tn(ji+1,jj,jk) ) 
    181204               END DO 
    … …  
    189212         CALL iom_put( "v_masstr", z3d )                  ! mass transport in j-direction 
    190213         z2d(:,:) = 0.e0  
     214#if defined key_z_first 
     215         DO jj = 2, jpjm1 
     216            DO ji = 2, jpim1 
     217               DO jk = 1, jpkm1 
     218#else 
    191219         DO jk = 1, jpkm1 
    192220            DO jj = 2, jpjm1 
    193221               DO ji = fs_2, fs_jpim1   ! vector opt. 
     222#endif 
    194223                  z2d(ji,jj) = z2d(ji,jj) + z3d(ji,jj,jk) * zztmp * ( tn(ji,jj,jk) + tn(ji,jj+1,jk) ) 
    195224               END DO 
    … …  
    416445            &          jpi, jpj, nh_T, 1  , 1, 1  , -99 , 32, clop, zsto, zout ) 
    417446#endif 
     447 
    418448         clmx ="l_max(only(x))"    ! max index on a period 
     449!! DCSE_NEMO: Warning! (November 2011) 
     450!!            The results for sobowlin do not match between level-first and level-last 
     451!!            ordering when the variable is defined using the operator "l_max(only(x))" 
     452!!            but they do match when clop is used instead. There may be a bug deep inside 
     453!!            the hist routines. 
     454!!            This is a temporary change for testing purposes only. 
     455!        CALL histdef( nid_T, "sobowlin", "Bowl Index"                         , "W-point",   &  ! bowl INDEX  
     456!           &          jpi, jpj, nh_T, 1  , 1, 1  , -99 , 32, clmx, zsto, zout ) 
    419457         CALL histdef( nid_T, "sobowlin", "Bowl Index"                         , "W-point",   &  ! bowl INDEX  
    420             &          jpi, jpj, nh_T, 1  , 1, 1  , -99 , 32, clmx, zsto, zout ) 
     458            &          jpi, jpj, nh_T, 1  , 1, 1  , -99 , 32, clop, zsto, zout ) 
    421459#if defined key_diahth 
    422460         CALL histdef( nid_T, "sothedep", "Thermocline Depth"                  , "m"      ,   & ! hth 
    … …  
    516554 
    517555      ! Write fields on T grid 
     556#if defined key_z_first 
     557      !! Need to transform 3d arrays back to external (z_last) ordering for dumping history 
     558      CALL histwrite( nid_T, "votemper", it, permute_z_last(tn), ndim_T , ndex_T  )   ! temperature 
     559      CALL histwrite( nid_T, "vosaline", it, permute_z_last(sn), ndim_T , ndex_T  )   ! salinity 
     560#else 
    518561      CALL histwrite( nid_T, "votemper", it, tn            , ndim_T , ndex_T  )   ! temperature 
    519562      CALL histwrite( nid_T, "vosaline", it, sn            , ndim_T , ndex_T  )   ! salinity 
     563#endif 
    520564      CALL histwrite( nid_T, "sosstsst", it, tn(:,:,1)     , ndim_hT, ndex_hT )   ! sea surface temperature 
    521565      CALL histwrite( nid_T, "sosaline", it, sn(:,:,1)     , ndim_hT, ndex_hT )   ! sea surface salinity 
    … …  
    528572!!$      CALL histwrite( nid_T, "sorunoff", it, runoff        , ndim_hT, ndex_hT )   ! runoff 
    529573      CALL histwrite( nid_T, "sowaflcd", it, ( emps-rnf )  , ndim_hT, ndex_hT )   ! c/d water flux 
     574#if defined key_z_first 
     575      zw2d(:,:) = ( emps(:,:) - rnf(:,:) ) * sn(:,:,1) * tmask_1(:,:) 
     576#else 
    530577      zw2d(:,:) = ( emps(:,:) - rnf(:,:) ) * sn(:,:,1) * tmask(:,:,1) 
     578#endif 
    531579      CALL histwrite( nid_T, "sosalflx", it, zw2d          , ndim_hT, ndex_hT )   ! c/d salt flux 
    532580      CALL histwrite( nid_T, "sohefldo", it, qns + qsr     , ndim_hT, ndex_hT )   ! total heat flux 
    … …  
    537585      CALL histwrite( nid_T, "sowindsp", it, wndm          , ndim_hT, ndex_hT )   ! wind speed    
    538586#if ! defined key_coupled 
    539       CALL histwrite( nid_T, "sohefldp", it, qrp           , ndim_hT, ndex_hT )   ! heat flux damping 
    540       CALL histwrite( nid_T, "sowafldp", it, erp           , ndim_hT, ndex_hT )   ! freshwater flux damping 
     587      !! DCSE_NEMO: Warning! In testing, found that qrp and erp are sometimes written 
     588      !!            without being allocated. There should be a better way of fixing this. 
     589      IF (ALLOCATED(qrp)) THEN 
     590         CALL histwrite( nid_T, "sohefldp", it, qrp           , ndim_hT, ndex_hT )   ! heat flux damping 
     591!     ELSE 
     592!        CALL ctl_warn('dia_wri: WARNING - qrp not allocated.') 
     593      ENDIF 
     594      IF (ALLOCATED(erp)) THEN 
     595         CALL histwrite( nid_T, "sowafldp", it, erp           , ndim_hT, ndex_hT )   ! freshwater flux damping 
     596!     ELSE 
     597!        CALL ctl_warn('dia_wri: WARNING - erp not allocated.') 
     598      ENDIF 
    541599      IF( ln_ssr ) zw2d(:,:) = erp(:,:) * sn(:,:,1) * tmask(:,:,1) 
    542600      CALL histwrite( nid_T, "sosafldp", it, zw2d          , ndim_hT, ndex_hT )   ! salt flux damping 
    543601#endif 
    544602#if ( defined key_coupled && ! defined key_lim3 && ! defined key_lim2 )  
    545       CALL histwrite( nid_T, "sohefldp", it, qrp           , ndim_hT, ndex_hT )   ! heat flux damping 
    546       CALL histwrite( nid_T, "sowafldp", it, erp           , ndim_hT, ndex_hT )   ! freshwater flux damping 
     603      !! DCSE_NEMO: Warning! In testing, found that qrp and erp are sometimes written 
     604      !!            without being allocated. There should be a better way of fixing this. 
     605      IF (ALLOCATED(qrp)) THEN 
     606         CALL histwrite( nid_T, "sohefldp", it, qrp           , ndim_hT, ndex_hT )   ! heat flux damping 
     607!     ELSE 
     608!        CALL ctl_warn('dia_wri: WARNING - qrp not allocated.') 
     609      ENDIF 
     610      IF (ALLOCATED(erp)) THEN 
     611         CALL histwrite( nid_T, "sowafldp", it, erp           , ndim_hT, ndex_hT )   ! freshwater flux damping 
     612!     ELSE 
     613!        CALL ctl_warn('dia_wri: WARNING - erp not allocated.') 
     614      ENDIF 
     615#if defined key_z_first 
     616         IF( ln_ssr ) zw2d(:,:) = erp(:,:) * sn(:,:,1) * tmask_1(:,:) 
     617#else 
    547618         IF( ln_ssr ) zw2d(:,:) = erp(:,:) * sn(:,:,1) * tmask(:,:,1) 
     619#endif 
    548620      CALL histwrite( nid_T, "sosafldp", it, zw2d          , ndim_hT, ndex_hT )   ! salt flux damping 
    549621#endif 
    550622      zw2d(:,:) = FLOAT( nmln(:,:) ) * tmask(:,:,1) 
     623 
     624      IF(ln_ctl)   CALL prt_ctl( tab2d_1=REAL(nmln,wp), clinfo1=' dw/nmln : ', tab2d_2=tmask_1, clinfo2=' dw/tm_1 : ', ovlap=1 ) 
     625      IF(ln_ctl)   CALL prt_ctl( tab2d_1=zw2d, clinfo1=' dw/zw2d : ', ovlap=1 ) 
     626 
    551627      CALL histwrite( nid_T, "sobowlin", it, zw2d          , ndim_hT, ndex_hT )   ! ??? 
    552628 
    … …  
    569645#endif 
    570646         ! Write fields on U grid 
     647#if defined key_z_first 
     648      CALL histwrite( nid_U, "vozocrtx", it, permute_z_last(un), ndim_U , ndex_U )    ! i-current 
     649#if defined key_diaeiv 
     650      CALL histwrite( nid_U, "vozoeivu", it, permute_z_last(u_eiv), ndim_U , ndex_U )    ! i-eiv current 
     651#endif 
     652#else 
    571653      CALL histwrite( nid_U, "vozocrtx", it, un            , ndim_U , ndex_U )    ! i-current 
    572654#if defined key_diaeiv 
    573655      CALL histwrite( nid_U, "vozoeivu", it, u_eiv         , ndim_U , ndex_U )    ! i-eiv current 
    574656#endif 
     657#endif 
    575658      CALL histwrite( nid_U, "sozotaux", it, utau          , ndim_hU, ndex_hU )   ! i-wind stress 
    576659 
    577660         ! Write fields on V grid 
     661#if defined key_z_first 
     662      CALL histwrite( nid_V, "vomecrty", it, permute_z_last(vn), ndim_V , ndex_V  )   ! j-current 
     663#if defined key_diaeiv 
     664      CALL histwrite( nid_V, "vomeeivv", it, permute_z_last(v_eiv), ndim_V , ndex_V  )   ! j-eiv current 
     665#endif 
     666#else 
    578667      CALL histwrite( nid_V, "vomecrty", it, vn            , ndim_V , ndex_V  )   ! j-current 
    579668#if defined key_diaeiv 
    580669      CALL histwrite( nid_V, "vomeeivv", it, v_eiv         , ndim_V , ndex_V  )   ! j-eiv current 
    581670#endif 
     671#endif 
    582672      CALL histwrite( nid_V, "sometauy", it, vtau          , ndim_hV, ndex_hV )   ! j-wind stress 
    583673 
    584674         ! Write fields on W grid 
     675#if defined key_z_first 
     676      CALL histwrite( nid_W, "vovecrtz", it, permute_z_last(wn), ndim_T, ndex_T )    ! vert. current 
     677#   if defined key_diaeiv 
     678      CALL histwrite( nid_W, "voveeivw", it, permute_z_last(w_eiv), ndim_T, ndex_T )    ! vert. eiv current 
     679#   endif 
     680      CALL histwrite( nid_W, "votkeavt", it, permute_z_last(avt), ndim_T, ndex_T )    ! T vert. eddy diff. coef. 
     681      CALL histwrite( nid_W, "votkeavm", it, permute_z_last(avmu), ndim_T, ndex_T )    ! T vert. eddy visc. coef. 
     682      IF( lk_zdfddm ) THEN 
     683         CALL histwrite( nid_W, "voddmavs", it, permute_z_last(fsavs(:,:,:)), ndim_T, ndex_T )    ! S vert. eddy diff. coef. 
     684      ENDIF 
     685#else 
    585686      CALL histwrite( nid_W, "vovecrtz", it, wn             , ndim_T, ndex_T )    ! vert. current 
    586687#   if defined key_diaeiv 
    … …  
    592693         CALL histwrite( nid_W, "voddmavs", it, fsavs(:,:,:), ndim_T, ndex_T )    ! S vert. eddy diff. coef. 
    593694      ENDIF 
     695#endif 
    594696#if defined key_traldf_c2d 
    595697      CALL histwrite( nid_W, "soleahtw", it, ahtw          , ndim_hT, ndex_hT )   ! lateral eddy diff. coef. 
    … …  
    711813 
    712814      ! Write all fields on T grid 
    713       CALL histwrite( id_i, "votemper", kt, tn      , jpi*jpj*jpk, idex )    ! now temperature 
    714       CALL histwrite( id_i, "vosaline", kt, sn      , jpi*jpj*jpk, idex )    ! now salinity 
     815#if defined key_z_first 
     816      CALL histwrite( id_i, "votemper", kt, permute_z_last(tn), jpi*jpj*jpk, idex )    ! now temperature 
     817      CALL histwrite( id_i, "vosaline", kt, permute_z_last(sn), jpi*jpj*jpk, idex )    ! now salinity 
     818      CALL histwrite( id_i, "sossheig", kt, sshn              , jpi*jpj    , idex )    ! sea surface height 
     819      CALL histwrite( id_i, "vozocrtx", kt, permute_z_last(un), jpi*jpj*jpk, idex )    ! now i-velocity 
     820      CALL histwrite( id_i, "vomecrty", kt, permute_z_last(vn), jpi*jpj*jpk, idex )    ! now j-velocity 
     821      CALL histwrite( id_i, "vovecrtz", kt, permute_z_last(wn), jpi*jpj*jpk, idex )    ! now k-velocity 
     822#else 
     823      CALL histwrite( id_i, "votemper", kt, tn       , jpi*jpj*jpk, idex )    ! now temperature 
     824      CALL histwrite( id_i, "vosaline", kt, sn       , jpi*jpj*jpk, idex )    ! now salinity 
    715825      CALL histwrite( id_i, "sossheig", kt, sshn     , jpi*jpj    , idex )    ! sea surface height 
    716826      CALL histwrite( id_i, "vozocrtx", kt, un       , jpi*jpj*jpk, idex )    ! now i-velocity 
    717827      CALL histwrite( id_i, "vomecrty", kt, vn       , jpi*jpj*jpk, idex )    ! now j-velocity 
    718828      CALL histwrite( id_i, "vovecrtz", kt, wn       , jpi*jpj*jpk, idex )    ! now k-velocity 
     829#endif 
    719830      CALL histwrite( id_i, "sowaflup", kt, (emp-rnf), jpi*jpj    , idex )    ! freshwater budget 
    720831      CALL histwrite( id_i, "sohefldo", kt, qsr + qns, jpi*jpj    , idex )    ! total heat flux 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/DOM/closea.F90

    r2715 r3211  
    4040 
    4141   REAL(wp), DIMENSION (jpncs+1)       ::   surf             ! closed sea surface 
     42 
     43   !! * Control permutation of array indices 
     44#  include "oce_ftrans.h90" 
     45#  include "dom_oce_ftrans.h90" 
     46#  include "sbc_oce_ftrans.h90" 
    4247 
    4348   !! * Substitutions 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/DOM/daymod.F90

    r2715 r3211  
    4343   INTEGER ::   nsecd, nsecd05, ndt, ndt05 
    4444 
     45   !! * Control permutation of array indices 
     46#  include "dom_oce_ftrans.h90" 
     47 
    4548   !!---------------------------------------------------------------------- 
    4649   !! NEMO/OPA 3.3 , NEMO Consortium (2010) 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/DOM/dom_oce.F90

    r2715 r3211  
    8383   INTEGER, PUBLIC ::   npolj             !: north fold mark (0, 3 or 4) 
    8484   INTEGER, PUBLIC ::   nlci, nldi, nlei  !: i-dimensions of the local subdomain and its first and last indoor indices 
    85    INTEGER, PUBLIC ::   nlcj, nldj, nlej  !: i-dimensions of the local subdomain and its first and last indoor indices 
     85   INTEGER, PUBLIC ::   nlcj, nldj, nlej  !: j-dimensions of the local subdomain and its first and last indoor indices 
    8686   INTEGER, PUBLIC ::   noea, nowe        !: index of the local neighboring processors in 
    8787   INTEGER, PUBLIC ::   noso, nono        !: east, west, south and north directions 
    … …  
    9494   INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   mig        !: local  ==> global domain i-index 
    9595   INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   mjg        !: local  ==> global domain j-index 
    96    INTEGER, PUBLIC,               DIMENSION(jpidta) ::   mi0, mi1   !: global ==> local  domain i-index    !!bug ==> other solution? 
     96   INTEGER, PUBLIC,               DIMENSION(jpidta) ::   mi0, mi1   !: global ==> local  domain i-index 
     97   !                                                  !!bug ==> other solution? 
    9798   !                                                  ! (mi0=1 and mi1=0 if the global index is not in the local domain) 
    98    INTEGER, PUBLIC,               DIMENSION(jpjdta) ::   mj0, mj1   !: global ==> local  domain j-index     !!bug ==> other solution? 
     99   INTEGER, PUBLIC,               DIMENSION(jpjdta) ::   mj0, mj1   !: global ==> local  domain j-index 
     100   !                                                  !!bug ==> other solution? 
    99101   !                                                  ! (mi0=1 and mi1=0 if the global index is not in the local domain) 
    100102   INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   nimppt, njmppt   !: i-, j-indexes for each processor 
    … …  
    130132   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   gdep3w          !: depth of T-points (sum of e3w) (m) 
    131133   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   gdept , gdepw   !: analytical depth at T-W  points (m) 
    132    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   e3v   , e3f     !: analytical vertical scale factors at  V--F 
    133    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   e3t   , e3u     !:                                       T--U  points (m) 
    134    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   e3vw            !: analytical vertical scale factors at  VW-- 
    135    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   e3w   , e3uw    !:                                        W--UW  points (m) 
     134   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   & 
     135             & e3v   , e3f     !: analytical vertical scale factors at  V--F 
     136   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   & 
     137             & e3t   , e3u     !:                                       T--U  points (m) 
     138   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   & 
     139             & e3vw            !: analytical vertical scale factors at  VW-- 
     140   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   & 
     141             & e3w   , e3uw    !:                                        W--UW  points (m) 
    136142#if defined key_vvl 
    137143   LOGICAL, PUBLIC, PARAMETER ::   lk_vvl = .TRUE.    !: variable grid flag 
    … …  
    142148   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   gdept_1, gdepw_1   !: analytical depth at T-W  points (m) 
    143149   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   e3v_1  , e3f_1     !: analytical vertical scale factors at  V--F 
    144    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   e3t_1  , e3u_1     !:                                       T--U  points (m) 
     150   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   & 
     151             & e3t_1  , e3u_1     !:                                       T--U  points (m) 
    145152   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   e3vw_1             !: analytical vertical scale factors at  VW-- 
    146    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   e3w_1  , e3uw_1    !:                                       W--UW  points (m) 
    147    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   e3t_b              !: before         -      -      -    -   T      points (m) 
    148    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   e3u_b  , e3v_b     !:   -            -      -      -    -   U--V   points (m) 
     153   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   & 
     154             & e3w_1  , e3uw_1    !:                                       W--UW  points (m) 
     155   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   & 
     156             & e3t_b              !: before         -      -      -    -   T      points (m) 
     157   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   & 
     158             & e3u_b  , e3v_b     !:   -            -      -      -    -   U--V   points (m) 
    149159#else 
    150160   LOGICAL, PUBLIC, PARAMETER ::   lk_vvl = .FALSE.   !: fixed grid flag 
    … …  
    160170   !! =-----------------====------ 
    161171   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:)   :: gdept_0, gdepw_0 !: reference depth of t- and w-points (m) 
    162    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:)   :: e3t_0  , e3w_0   !: reference vertical scale factors at T- and W-pts (m) 
     172   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:)   :: & 
     173             & e3t_0  , e3w_0   !: reference vertical scale factors at T- and W-pts (m) 
    163174   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: e3tp   , e3wp    !: ocean bottom level thickness at T and W points 
    164175 
    165176   !! s-coordinate and hybrid z-s-coordinate 
    166177   !! =----------------======--------------- 
    167    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   gsigt, gsigw   !: model level depth coefficient at t-, w-levels (analytic) 
    168    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   gsi3w          !: model level depth coefficient at w-level (sum of gsigw) 
    169    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   esigt, esigw   !: vertical scale factor coef. at t-, w-levels 
     178   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   & 
     179             & gsigt, gsigw   !: model level depth coefficient at t-, w-levels (analytic) 
     180   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   & 
     181             & gsi3w          !: model level depth coefficient at w-level (sum of gsigw) 
     182   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   & 
     183             & esigt, esigw   !: vertical scale factor coef. at t-, w-levels 
    170184 
    171185   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hbatv , hbatf    !: ocean depth at the vertical of  V--F 
    172    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hbatt , hbatu    !:                                 T--U  points (m) 
     186   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   & 
     187             & hbatt , hbatu    !:                                 T--U  points (m) 
    173188   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   scosrf, scobot   !: ocean surface and bottom topographies  
    174189   !                                        !  (if deviating from coordinate surfaces in HYBRID) 
    175190   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hifv  , hiff     !: interface depth between stretching at  V--F 
    176    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hift  , hifu     !: and quasi-uniform spacing              T--U  points (m) 
     191   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   & 
     192             & hift  , hifu     !: and quasi-uniform spacing              T--U  points (m) 
    177193 
    178194   !!---------------------------------------------------------------------- 
    … …  
    181197   INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   mbathy       !: number of ocean level (=0, 1, ... , jpk-1) 
    182198   INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   mbkt         !: vertical index of the bottom last T- ocean level 
    183    INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   mbku, mbkv   !: vertical index of the bottom last U- and W- ocean level 
     199   INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   & 
     200             & mbku, mbkv   !: vertical index of the bottom last U- and W- ocean level 
    184201   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   bathy        !: ocean depth (meters) 
    185202   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   tmask_i      !: interior domain T-point mask 
    186203   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   bmask        !: land/ocean mask of barotropic stream function 
    187204 
    188    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: tmask, umask, vmask, fmask   !: land/ocean mask at T-, U-, V- and F-pts 
     205   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: tmask, umask, vmask, fmask   !: land/ocean masks 
     206   !                                                                                     !  at T-, U-, V- and F-pts 
     207#if defined key_z_first 
     208   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: tmask_1, umask_1, vmask_1, fmask_1   !: as above, at sea surface only  
     209#endif 
    189210 
    190211   REAL(wp), PUBLIC, DIMENSION(jpiglo) ::   tpol, fpol          !: north fold mask (jperio= 3 or 4) 
    … …  
    235256#endif 
    236257 
     258   !! * Control permutation of array indices 
     259#  include "dom_oce_ftrans.h90" 
     260 
    237261   !!---------------------------------------------------------------------- 
    238262   !! NEMO/OPA 4.0 , NEMO Consortium (2011) 
    … …  
    257281   INTEGER FUNCTION dom_oce_alloc() 
    258282      !!---------------------------------------------------------------------- 
    259       INTEGER, DIMENSION(11) :: ierr 
     283      INTEGER, DIMENSION(12) :: ierr 
    260284      !!---------------------------------------------------------------------- 
    261285      ierr(:) = 0 
    … …  
    307331      ALLOCATE( npcoa(4,jpk), nicoa(2*(jpi+jpj),4,jpk), njcoa(2*(jpi+jpj),4,jpk), STAT=ierr(11) ) 
    308332#endif 
     333 
     334#if defined key_z_first 
     335      ALLOCATE( tmask_1(jpi,jpj) ,   umask_1(jpi,jpj),     &  
     336         &      vmask_1(jpi,jpj) ,   fmask_1(jpi,jpj), STAT=ierr(12) ) 
     337#endif 
     338 
    309339      ! 
    310340      dom_oce_alloc = MAXVAL(ierr) 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/DOM/domain.F90

    r2528 r3211  
    4141   PUBLIC   dom_init   ! called by opa.F90 
    4242 
     43   !! * Control permutation of array indices 
     44#  include "oce_ftrans.h90" 
     45#  include "dom_oce_ftrans.h90" 
     46#  include "sbc_oce_ftrans.h90" 
     47#  include "domvvl_ftrans.h90" 
     48 
    4349   !! * Substitutions 
    4450#  include "domzgr_substitute.h90" 
    … …  
    8793         umask(:,:,:) = tmask(:,:,:)           ! U, V moved at T-point 
    8894         vmask(:,:,:) = tmask(:,:,:) 
     95#if defined key_z_first 
     96         umask_1(:,:) = umask(:,:,1) 
     97         vmask_1(:,:) = vmask(:,:,1) 
     98#endif 
    8999      END IF 
    90100      ! 
    … …  
    96106      END DO 
    97107      !                                        ! Inverse of the local depth 
     108#if defined key_z_first 
     109      hur(:,:) = 1. / ( hu(:,:) + 1.e0 - umask_1(:,:) ) * umask_1(:,:) 
     110      hvr(:,:) = 1. / ( hv(:,:) + 1.e0 - vmask_1(:,:) ) * vmask_1(:,:) 
     111#else 
    98112      hur(:,:) = 1. / ( hu(:,:) + 1.e0 - umask(:,:,1) ) * umask(:,:,1) 
    99113      hvr(:,:) = 1. / ( hv(:,:) + 1.e0 - vmask(:,:,1) ) * vmask(:,:,1) 
     114#endif 
    100115 
    101116                             CALL dom_stp      ! time step 
    … …  
    283298      ! 
    284299      IF(lk_mpp) THEN 
     300#if defined key_z_first 
     301         CALL mpp_minloc( e1t(:,:), tmask_1(:,:), ze1min, iimi1,ijmi1 ) 
     302         CALL mpp_minloc( e2t(:,:), tmask_1(:,:), ze2min, iimi2,ijmi2 ) 
     303         CALL mpp_maxloc( e1t(:,:), tmask_1(:,:), ze1max, iima1,ijma1 ) 
     304         CALL mpp_maxloc( e2t(:,:), tmask_1(:,:), ze2max, iima2,ijma2 ) 
     305#else 
    285306         CALL mpp_minloc( e1t(:,:), tmask(:,:,1), ze1min, iimi1,ijmi1 ) 
    286307         CALL mpp_minloc( e2t(:,:), tmask(:,:,1), ze2min, iimi2,ijmi2 ) 
    287308         CALL mpp_maxloc( e1t(:,:), tmask(:,:,1), ze1max, iima1,ijma1 ) 
    288309         CALL mpp_maxloc( e2t(:,:), tmask(:,:,1), ze2max, iima2,ijma2 ) 
     310#endif 
    289311      ELSE 
    290312         ze1min = MINVAL( e1t(:,:), mask = tmask(:,:,1) == 1.e0 )     

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/DOM/domcfg.F90

    r2715 r3211  
    2020 
    2121   PUBLIC   dom_cfg    ! called by opa.F90 
     22 
     23   !! * Control permutation of array indices 
     24#  include "dom_oce_ftrans.h90" 
    2225 
    2326   !!---------------------------------------------------------------------- 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/DOM/domhgr.F90

    r2715 r3211  
    3232 
    3333   PUBLIC   dom_hgr   ! called by domain.F90 
     34 
     35   !! * Control permutation of array indices 
     36#  include "dom_oce_ftrans.h90" 
    3437 
    3538   !!---------------------------------------------------------------------- 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/DOM/dommsk.F90

    r2715 r3211  
    4242   INTEGER, ALLOCATABLE, SAVE, DIMENSION(:,:) ::  icoord ! Workspace for dom_msk_nsa() 
    4343 
     44   !! * Control permutation of array indices 
     45#  include "oce_ftrans.h90" 
     46#  include "dom_oce_ftrans.h90" 
     47#  include "obc_oce_ftrans.h90" 
     48 
    4449   !! * Substitutions 
    4550#  include "vectopt_loop_substitute.h90" 
    … …  
    165170      ! 
    166171      tmask(:,:,:) = 0._wp 
     172#if defined key_z_first 
     173      DO jj = 1, jpj 
     174         DO ji = 1, jpi 
     175            DO jk = 1, jpk 
     176#else 
    167177      DO jk = 1, jpk 
    168178         DO jj = 1, jpj 
    169179            DO ji = 1, jpi 
     180#endif 
    170181               IF( REAL( mbathy(ji,jj) - jk, wp ) + 0.1_wp >= 0._wp )   tmask(ji,jj,jk) = 1._wp 
    171182            END DO   
    … …  
    226237      ! 2. Ocean/land mask at u-,  v-, and z-points (computed from tmask) 
    227238      ! ------------------------------------------- 
     239#ifdef key_z_first 
     240      DO jj = 1, jpjm1 
     241         DO ji = 1, jpim1 
     242            DO jk = 1, jpk 
     243               umask(ji,jj,jk) = tmask(ji,jj  ,jk) * tmask(ji+1,jj  ,jk) 
     244               vmask(ji,jj,jk) = tmask(ji,jj  ,jk) * tmask(ji  ,jj+1,jk) 
     245            END DO 
     246         END DO 
     247         DO ji = 1, jpim1         ! NO vector opt. 
     248            DO jk = 1, jpk 
     249               fmask(ji,jj,jk) = tmask(ji,jj  ,jk) * tmask(ji+1,jj  ,jk)   & 
     250                  &            * tmask(ji,jj+1,jk) * tmask(ji+1,jj+1,jk) 
     251            END DO 
     252         END DO 
     253      END DO 
     254#else 
    228255      DO jk = 1, jpk 
    229256         DO jj = 1, jpjm1 
    … …  
    238265         END DO 
    239266      END DO 
     267#endif 
    240268      CALL lbc_lnk( umask, 'U', 1._wp )      ! Lateral boundary conditions 
    241269      CALL lbc_lnk( vmask, 'V', 1._wp ) 
    … …  
    390418      CALL lbc_lnk( fmask, 'F', 1._wp )      ! Lateral boundary conditions on fmask 
    391419 
     420#if defined key_z_first 
     421      !! 2d masks defined at sea surface only sometimes help performance 
     422      tmask_1(:,:) = tmask(:,:,1) 
     423      umask_1(:,:) = umask(:,:,1) 
     424      vmask_1(:,:) = vmask(:,:,1) 
     425      fmask_1(:,:) = fmask(:,:,1) 
     426#endif 
    392427             
    393428      IF( nprint == 1 .AND. lwp ) THEN      ! Control print 
    … …  
    491526      ! convex corners 
    492527       
     528#if defined key_z_first 
     529      DO jj = 1, jpjm1 
     530         DO ji = 1, jpim1 
     531            DO jk = 1, jpkm1 
     532#else 
    493533      DO jk = 1, jpkm1 
    494534         DO jj = 1, jpjm1 
    495535            DO ji = 1, jpim1 
     536#endif 
    496537               zaa = tmask(ji  ,jj,jk) + tmask(ji  ,jj+1,jk)   & 
    497538                  &+ tmask(ji+1,jj,jk) + tmask(ji+1,jj+1,jk) 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/DOM/domngb.F90

    r2715 r3211  
    1717 
    1818   PUBLIC   dom_ngb   ! routine called in iom.F90 module 
     19 
     20   !! * Control permutation of array indices 
     21#  include "dom_oce_ftrans.h90" 
    1922 
    2023   !!---------------------------------------------------------------------- 
    … …  
    4952      zmask(:,:) = 0._wp 
    5053      SELECT CASE( cdgrid ) 
     54#if defined key_z_first 
     55      CASE( 'U' )  ; zglam(:,:) = glamu(:,:) ; zgphi(:,:) = gphiu(:,:) ; zmask(nldi:nlei,nldj:nlej) = umask_1(nldi:nlei,nldj:nlej) 
     56      CASE( 'V' )  ; zglam(:,:) = glamv(:,:) ; zgphi(:,:) = gphiv(:,:) ; zmask(nldi:nlei,nldj:nlej) = vmask_1(nldi:nlei,nldj:nlej) 
     57      CASE( 'F' )  ; zglam(:,:) = glamf(:,:) ; zgphi(:,:) = gphif(:,:) ; zmask(nldi:nlei,nldj:nlej) = fmask_1(nldi:nlei,nldj:nlej) 
     58      CASE DEFAULT ; zglam(:,:) = glamt(:,:) ; zgphi(:,:) = gphit(:,:) ; zmask(nldi:nlei,nldj:nlej) = tmask_1(nldi:nlei,nldj:nlej) 
     59#else 
    5160      CASE( 'U' )  ; zglam(:,:) = glamu(:,:) ; zgphi(:,:) = gphiu(:,:) ; zmask(nldi:nlei,nldj:nlej) = umask(nldi:nlei,nldj:nlej,1) 
    5261      CASE( 'V' )  ; zglam(:,:) = glamv(:,:) ; zgphi(:,:) = gphiv(:,:) ; zmask(nldi:nlei,nldj:nlej) = vmask(nldi:nlei,nldj:nlej,1) 
    5362      CASE( 'F' )  ; zglam(:,:) = glamf(:,:) ; zgphi(:,:) = gphif(:,:) ; zmask(nldi:nlei,nldj:nlej) = fmask(nldi:nlei,nldj:nlej,1) 
    5463      CASE DEFAULT ; zglam(:,:) = glamt(:,:) ; zgphi(:,:) = gphit(:,:) ; zmask(nldi:nlei,nldj:nlej) = tmask(nldi:nlei,nldj:nlej,1) 
     64#endif 
    5565      END SELECT 
    5666 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/DOM/domstp.F90

    r2715 r3211  
    2121 
    2222   PUBLIC   dom_stp   ! routine called by inidom.F90 
     23 
     24   !! * Control permutation of array indices 
     25#  include "oce_ftrans.h90" 
     26#  include "dom_oce_ftrans.h90" 
    2327 
    2428   !! * Substitutions 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/DOM/domvvl.F90

    r2715 r3211  
    3232   REAL(wp),         ALLOCATABLE, SAVE, DIMENSION(:)     ::   r2dt   ! vertical profile time-step, = 2 rdttra  
    3333      !                                                              ! except at nit000 (=rdttra) if neuler=0 
     34 
     35   !! * Control permutation of array indices 
     36#  include "oce_ftrans.h90" 
     37#  include "dom_oce_ftrans.h90" 
     38#  include "sbc_oce_ftrans.h90" 
     39#  include "domvvl_ftrans.h90" 
    3440 
    3541   !! * Substitutions 
    … …  
    110116      END DO   
    111117      !                                         ! Compute and mask the inverse of the local depth at T, U, V and F points 
     118#if defined key_z_first 
     119      ee_t(:,:) = 1. / ee_t(:,:) * tmask_1(:,:) 
     120      ee_u(:,:) = 1. / ee_u(:,:) * umask_1(:,:) 
     121      ee_v(:,:) = 1. / ee_v(:,:) * vmask_1(:,:) 
     122      DO jj = 1, jpjm1                               ! f-point case fmask cannot be used  
     123         ee_f(:,jj) = 1. / ee_f(:,jj) * umask_1(:,jj) * umask_1(:,jj+1) 
     124      END DO 
     125#else 
    112126      ee_t(:,:) = 1. / ee_t(:,:) * tmask(:,:,1) 
    113127      ee_u(:,:) = 1. / ee_u(:,:) * umask(:,:,1) 
    … …  
    116130         ee_f(:,jj) = 1. / ee_f(:,jj) * umask(:,jj,1) * umask(:,jj+1,1) 
    117131      END DO 
     132#endif 
    118133      CALL lbc_lnk( ee_f, 'F', 1. )                  ! lateral boundary condition on ee_f 
    119134      ! 
    … …  
    172187                                                ! initialise before scale factors at (u/v)-points 
    173188      ! Scale factor anomaly at (u/v)-points: surface averaging of scale factor at t-points 
     189#if defined key_z_first 
     190      DO jj = 1, jpjm1 
     191         DO ji = 1, jpim1 
     192            DO jk = 1, jpkm1 
     193#else 
    174194      DO jk = 1, jpkm1 
    175195         DO jj = 1, jpjm1 
    176196            DO ji = 1, jpim1 
     197#endif 
    177198               zv_t_ij           = zs_t(ji  ,jj  ) * fse3t_b(ji  ,jj  ,jk) 
    178199               zv_t_ip1j         = zs_t(ji+1,jj  ) * fse3t_b(ji+1,jj  ,jk) 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/DOM/domwri.F90

    r2715 r3211  
    2626   PUBLIC dom_wri        ! routine called by inidom.F90 
    2727 
     28   !! * Control permutation of array indices 
     29#  include "dom_oce_ftrans.h90" 
     30 
    2831   !! * Substitutions 
    2932#  include "vectopt_loop_substitute.h90" 
    … …  
    6669      USE wrk_nemo, ONLY:   zprt  => wrk_2d_1 , zprw  => wrk_2d_2    ! 2D workspace 
    6770      USE wrk_nemo, ONLY:   zdepu => wrk_3d_1 , zdepv => wrk_3d_2    ! 3D     - 
     71 
     72      !! DCSE_NEMO: wrk_3d_1, wrk_3d_2 are re-named, need additional directives 
     73!FTRANS zdepu :I :I :z 
     74!FTRANS zdepv :I :I :z 
     75 
    6876      !! 
    6977      INTEGER           ::   inum0    ! temprary units for 'mesh_mask.nc' file 
    … …  
    129137       
    130138      CALL dom_uniq( zprw, 'T' ) 
     139#if defined key_z_first 
     140      zprt = tmask_1(:,:) * zprw                               !    ! unique point mask 
     141#else 
    131142      zprt = tmask(:,:,1) * zprw                               !    ! unique point mask 
     143#endif 
    132144      CALL iom_rstput( 0, 0, inum2, 'tmaskutil', zprt, ktype = jp_i1 )   
    133145      CALL dom_uniq( zprw, 'U' ) 
     146#if defined key_z_first 
     147      zprt = umask_1(:,:) * zprw 
     148#else 
    134149      zprt = umask(:,:,1) * zprw 
     150#endif 
    135151      CALL iom_rstput( 0, 0, inum2, 'umaskutil', zprt, ktype = jp_i1 )   
    136152      CALL dom_uniq( zprw, 'V' ) 
     153#if defined key_z_first 
     154      zprt = vmask_1(:,:) * zprw 
     155#else 
    137156      zprt = vmask(:,:,1) * zprw 
     157#endif 
    138158      CALL iom_rstput( 0, 0, inum2, 'vmaskutil', zprt, ktype = jp_i1 )   
    139159      CALL dom_uniq( zprw, 'F' ) 
     160#if defined key_z_first 
     161      zprt = fmask_1(:,:) * zprw 
     162#else 
    140163      zprt = fmask(:,:,1) * zprw 
     164#endif 
    141165      CALL iom_rstput( 0, 0, inum2, 'fmaskutil', zprt, ktype = jp_i1 )   
    142166 
    … …  
    165189       
    166190      ! note that mbkt is set to 1 over land ==> use surface tmask 
     191#if defined key_z_first 
     192      zprt(:,:) = tmask_1(:,:) * REAL( mbkt(:,:) , wp ) 
     193#else 
    167194      zprt(:,:) = tmask(:,:,1) * REAL( mbkt(:,:) , wp ) 
     195#endif 
    168196      CALL iom_rstput( 0, 0, inum4, 'mbathy', zprt, ktype = jp_i2 )     !    ! nb of ocean T-points 
    169197             
    … …  
    209237         IF( nmsh <= 3 ) THEN                                   !    ! 3D depth 
    210238            CALL iom_rstput( 0, 0, inum4, 'gdept', gdept, ktype = jp_r4 )      
    211             DO jk = 1,jpk    
     239#if defined key_z_first 
     240            DO jj = 1, jpjm1    
     241               DO ji = 1, jpim1         ! NO vector opt. 
     242                  DO jk = 1, jpk    
     243#else 
     244            DO jk = 1, jpk    
    212245               DO jj = 1, jpjm1    
    213246                  DO ji = 1, fs_jpim1   ! vector opt. 
     247#endif 
    214248                     zdepu(ji,jj,jk) = MIN( gdept(ji,jj,jk) , gdept(ji+1,jj  ,jk) ) 
    215249                     zdepv(ji,jj,jk) = MIN( gdept(ji,jj,jk) , gdept(ji  ,jj+1,jk) ) 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/DOM/domzgr.F90

    r2715 r3211  
    5555   REAL(wp) ::   rn_hc       =  150._wp     ! Critical depth for s-sigma coordinates 
    5656 
     57   !! * Control permutation of array indices 
     58#  include "oce_ftrans.h90" 
     59#  include "dom_oce_ftrans.h90" 
     60 
    5761  !! * Substitutions 
    5862#  include "domzgr_substitute.h90" 
    … …  
    7882      !!                   ln_zco=T   z-coordinate    
    7983      !!                   ln_zps=T   z-coordinate with partial steps 
    80       !!                   ln_zco=T   s-coordinate  
     84      !!                   ln_sco=T   s-coordinate  
    8185      !! 
    8286      !! ** Action  :   define gdep., e3., mbathy and bathy 
    … …  
    758762      !! ** Method  :   set 3D coord. arrays to reference 1D array  
    759763      !!---------------------------------------------------------------------- 
     764#if defined key_z_first 
     765      INTEGER  ::   ji, jj   ! Dummy loop indices 
     766#else 
    760767      INTEGER  ::   jk 
    761       !!---------------------------------------------------------------------- 
    762       ! 
     768#endif 
     769      !!---------------------------------------------------------------------- 
     770      ! 
     771#if defined key_z_first 
     772      DO jj = 1, jpj 
     773         DO ji = 1, jpi 
     774            fsdept(ji,jj,:) = gdept_0(:) 
     775            fsdepw(ji,jj,:) = gdepw_0(:) 
     776            fsde3w(ji,jj,:) = gdepw_0(:) 
     777            fse3t (ji,jj,:) = e3t_0(:) 
     778            fse3u (ji,jj,:) = e3t_0(:) 
     779            fse3v (ji,jj,:) = e3t_0(:) 
     780            fse3f (ji,jj,:) = e3t_0(:) 
     781            fse3w (ji,jj,:) = e3w_0(:) 
     782            fse3uw(ji,jj,:) = e3w_0(:) 
     783            fse3vw(ji,jj,:) = e3w_0(:) 
     784         END DO 
     785      END DO 
     786#else 
    763787      DO jk = 1, jpk 
    764788         fsdept(:,:,jk) = gdept_0(jk) 
    … …  
    773797         fse3vw(:,:,jk) = e3w_0(jk) 
    774798      END DO 
     799#endif 
    775800      ! 
    776801   END SUBROUTINE zgr_zco 
    … …  
    824849      USE wrk_nemo, ONLY:   wrk_in_use, wrk_not_released 
    825850      USE wrk_nemo, ONLY:   zprt => wrk_3d_1 
     851      !! DCSE_NEMO: wrk_3d_1 renamed, need additional directive 
     852!FTRANS zprt :I :I :z 
    826853      !! 
    827854      INTEGER  ::   ji, jj, jk       ! dummy loop indices 
    … …  
    871898 
    872899      ! Scale factors and depth at T- and W-points 
     900#if defined key_z_first 
     901      DO jj = 1, jpj 
     902         DO ji = 1, jpi                     ! intitialization to the reference z-coordinate 
     903            gdept(ji,jj,:) = gdept_0(:) 
     904            gdepw(ji,jj,:) = gdepw_0(:) 
     905            e3t  (ji,jj,:) = e3t_0  (:) 
     906            e3w  (ji,jj,:) = e3w_0  (:) 
     907         END DO 
     908      END DO 
     909#else 
    873910      DO jk = 1, jpk                        ! intitialization to the reference z-coordinate 
    874911         gdept(:,:,jk) = gdept_0(jk) 
    … …  
    877914         e3w  (:,:,jk) = e3w_0  (jk) 
    878915      END DO 
     916#endif 
    879917      !  
    880918      DO jj = 1, jpj 
    … …  
    938976 
    939977      ! Scale factors and depth at U-, V-, UW and VW-points 
     978#if defined key_z_first 
     979      DO jj = 1, jpj                        ! initialisation to z-scale factors 
     980         DO ji = 1, jpi 
     981            e3u (ji,jj,:) = e3t_0(:) 
     982            e3v (ji,jj,:) = e3t_0(:) 
     983            e3uw(ji,jj,:) = e3w_0(:) 
     984            e3vw(ji,jj,:) = e3w_0(:) 
     985         END IF 
     986      END DO 
     987#else 
    940988      DO jk = 1, jpk                        ! initialisation to z-scale factors 
    941989         e3u (:,:,jk) = e3t_0(jk) 
    … …  
    944992         e3vw(:,:,jk) = e3w_0(jk) 
    945993      END DO 
    946       DO jk = 1,jpk                         ! Computed as the minimum of neighbooring scale factors 
     994#endif 
     995#if defined key_z_first 
     996      DO jj = 1, jpjm1 
     997         DO ji = 1, jpim1 
     998            DO jk = 1, jpk        ! Computed as the minimum of neighbouring scale factors 
     999#else 
     1000      DO jk = 1,jpk               ! Computed as the minimum of neighbouring scale factors 
    9471001         DO jj = 1, jpjm1 
    9481002            DO ji = 1, fs_jpim1   ! vector opt. 
     1003#endif 
    9491004               e3u (ji,jj,jk) = MIN( e3t(ji,jj,jk), e3t(ji+1,jj,jk) ) 
    9501005               e3v (ji,jj,jk) = MIN( e3t(ji,jj,jk), e3t(ji,jj+1,jk) ) 
    … …  
    9651020       
    9661021      ! Scale factor at F-point 
     1022#if defined key_z_first 
     1023      DO jj = 1, jpj 
     1024         DO ji = 1, jpi                     ! initialisation to z-scale factors 
     1025            e3f(ji,jj,:) = e3t_0(:) 
     1026         END DO 
     1027      END DO 
     1028      DO jj = 1, jpjm1 
     1029         DO ji = 1, jpim1                   ! NO vector opt. 
     1030            DO jk = 1, jpk                  ! Computed as the minimum of neighbooring V-scale factors 
     1031               e3f(ji,jj,jk) = MIN( e3v(ji,jj,jk), e3v(ji+1,jj,jk) ) 
     1032            END DO 
     1033         END DO 
     1034      END DO 
     1035#else 
    9671036      DO jk = 1, jpk                        ! initialisation to z-scale factors 
    9681037         e3f(:,:,jk) = e3t_0(jk) 
    … …  
    9751044         END DO 
    9761045      END DO 
     1046#endif 
    9771047      CALL lbc_lnk( e3f, 'F', 1._wp )       ! Lateral boundary conditions 
    9781048      ! 
    … …  
    11291199      USE wrk_nemo, ONLY:   esigwu3 => wrk_3d_9 
    11301200      USE wrk_nemo, ONLY:   esigwv3 => wrk_3d_10 
     1201      !! DCSE_NEMO: wrk_nemo module variables renamed, need additional directives 
     1202!FTRANS gsigw3 :I :I :z 
     1203!FTRANS gsigt3 :I :I :z 
     1204!FTRANS gsi3w3 :I :I :z 
     1205!FTRANS esigt3 :I :I :z 
     1206!FTRANS esigw3 :I :I :z 
     1207!FTRANS esigtu3 :I :I :z 
     1208!FTRANS esigtv3 :I :I :z 
     1209!FTRANS esigtf3 :I :I :z 
     1210!FTRANS esigwu3 :I :I :z 
     1211!FTRANS esigwv3 :I :I :z 
    11311212      ! 
    11321213      INTEGER  ::   ji, jj, jk, jl           ! dummy loop argument 
    … …  
    15741655 
    15751656!!gm bug?  no more necessary?  if ! defined key_helsinki 
     1657#if defined key_z_first 
     1658      DO jj = 1, jpj 
     1659         DO ji = 1, jpi 
     1660            DO jk = 1, jpk 
     1661#else 
    15761662      DO jk = 1, jpk 
    15771663         DO jj = 1, jpj 
    15781664            DO ji = 1, jpi 
     1665#endif 
    15791666               IF( fse3w(ji,jj,jk) <= 0._wp .OR. fse3t(ji,jj,jk) <= 0._wp ) THEN 
    15801667                  WRITE(ctmp1,*) 'zgr_sco :   e3w   or e3t   =< 0  at point (i,j,k)= ', ji, jj, jk 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/DOM/istate.F90

    r2715 r3211  
    5050   PUBLIC   istate_init   ! routine called by step.F90 
    5151 
     52   !! * Control permutation of array indices 
     53#  include "oce_ftrans.h90" 
     54#  include "dom_oce_ftrans.h90" 
     55#  include "ldftra_oce_ftrans.h90" 
     56#  include "zdf_oce_ftrans.h90" 
     57#  include "dtatem_ftrans.h90" 
     58#  include "dtasal_ftrans.h90" 
     59#  include "domvvl_ftrans.h90" 
     60 
    5261   !! * Substitutions 
    5362#  include "domzgr_substitute.h90" 
    … …  
    6776      !!---------------------------------------------------------------------- 
    6877      ! - ML - needed for initialization of e3t_b 
    69       INTEGER  ::  jk     ! dummy loop indice 
     78      INTEGER  ::  ji, jj, jk     ! dummy loop indices 
    7079 
    7180      IF(lwp) WRITE(numout,*) 
    … …  
    134143         ! - ML - sshn could be modified by istate_eel, so that initialization of fse3t_b is done here 
    135144         IF( lk_vvl ) THEN 
     145#if defined key_z_first 
     146            fse3t_b(:,:,:) = fse3t_n(:,:,:) 
     147#else 
    136148            DO jk = 1, jpk 
    137149               fse3t_b(:,:,jk) = fse3t_n(:,:,jk) 
    138150            ENDDO 
     151#endif 
    139152         ENDIF 
    140153         !  
    … …  
    169182      IF(lwp) WRITE(numout,*) '~~~~~~~~~~' 
    170183      ! 
     184#if defined key_z_first 
     185      DO jj = 1, jpj 
     186         DO ji = 1, jpi 
     187            DO jk = 1, jpk 
     188#else 
    171189      DO jk = 1, jpk 
    172190         DO jj = 1, jpj 
    173191            DO ji = 1, jpi 
     192#endif 
    174193               tn(ji,jj,jk) = (  ( ( 7.5 - 0.*ABS(gphit(ji,jj))/30. )   & 
    175194                  &               *( 1.-TANH((fsdept(ji,jj,jk)-80.)/30.) )   & 
    … …  
    253272            zcst   = ( zt1 * ( zh1 - zh2) - ( zt1 - zt2 ) * zh1 ) / ( zh1 - zh2 ) 
    254273            ! 
     274#if defined key_z_first 
     275            DO jj = 1, jpj 
     276               DO ji = 1, jpi 
     277                  DO jk = 1, jpk 
     278                     tn(ji,jj,jk) = ( zt2 + zt1 * exp( - fsdept(ji,jj,jk) / 1000 ) ) * tmask(ji,jj,jk) 
     279                     tb(ji,jj,jk) = tn(ji,jj,jk) 
     280                  END DO 
     281               END DO 
     282            END DO 
     283#else 
    255284            DO jk = 1, jpk 
    256285               tn(:,:,jk) = ( zt2 + zt1 * exp( - fsdept(:,:,jk) / 1000 ) ) * tmask(:,:,jk) 
    257286               tb(:,:,jk) = tn(:,:,jk) 
    258287            END DO 
     288#endif 
    259289            ! 
    260290            IF(lwp) CALL prizre( tn    , jpi   , jpj   , jpk   , jpj/2 ,   & 
    … …  
    294324            DO jj = 1, nlcj 
    295325               DO ji = 1, nlci 
     326#if defined key_z_first 
     327                  sshb(ji,jj) = zssh( mig(ji) , mjg(jj) ) * tmask_1(ji,jj) 
     328#else 
    296329                  sshb(ji,jj) = zssh( mig(ji) , mjg(jj) ) * tmask(ji,jj,1) 
     330#endif 
    297331               END DO 
    298332            END DO 
    … …  
    374408         IF(lwp) WRITE(numout,*) '~~~~~~~~~~~' 
    375409 
     410#if defined key_z_first 
     411         DO jj = 1, jpj 
     412            DO ji = 1, jpi 
     413               DO jk = 1, jpk 
     414#else 
    376415         DO jk = 1, jpk 
    377416            DO jj = 1, jpj 
    378417               DO ji = 1, jpi 
     418#endif 
    379419                  tn(ji,jj,jk) = (  16. - 12. * TANH( (fsdept(ji,jj,jk) - 400) / 700 )         )   & 
    380420                       &           * (-TANH( (500-fsdept(ji,jj,jk)) / 150 ) + 1) / 2               & 
    … …  
    448488      USE wrk_nemo, ONLY:   wrk_in_use, wrk_not_released 
    449489      USE wrk_nemo, ONLY:   zprn => wrk_3d_1    ! 3D workspace 
     490      !! DCSE_NEMO: wrk_3d_1 renamed, need additional directive 
     491!FTRANS zprn :I :I :z 
    450492 
    451493      USE dynspg          ! surface pressure gradient             (dyn_spg routine) 
    … …  
    473515      zprn(:,:,1) = zalfg * fse3w(:,:,1) * ( 1 + rhd(:,:,1) )       ! Surface value 
    474516 
     517#if defined key_z_first 
     518      DO jj = 1, jpj 
     519         DO ji = 1, jpi 
     520            DO jk = 2, jpkm1                                        ! Vertical integration from the surface 
     521               zprn(ji,jj,jk) = zprn(ji,jj,jk-1)   & 
     522                  &           + zalfg * fse3w(ji,jj,jk) * ( 2. + rhd(ji,jj,jk) + rhd(ji,jj,jk-1) ) 
     523            END DO   
     524         END DO   
     525      END DO   
     526#else 
    475527      DO jk = 2, jpkm1                                              ! Vertical integration from the surface 
    476528         zprn(:,:,jk) = zprn(:,:,jk-1)   & 
    477529            &         + zalfg * fse3w(:,:,jk) * ( 2. + rhd(:,:,jk) + rhd(:,:,jk-1) ) 
    478530      END DO   
     531#endif 
    479532 
    480533      ! Compute geostrophic balance 
    481534      ! --------------------------- 
     535#if defined key_z_first 
     536      DO jj = 2, jpjm1 
     537         DO ji = 2, jpim1 
     538            DO jk = 1, jpkm1 
     539#else 
    482540      DO jk = 1, jpkm1 
    483541         DO jj = 2, jpjm1 
    484             DO ji = fs_2, fs_jpim1   ! vertor opt. 
     542            DO ji = fs_2, fs_jpim1   ! vector opt. 
     543#endif 
    485544               zmsv = 1. / MAX(  umask(ji-1,jj+1,jk) + umask(ji  ,jj+1,jk)   & 
    486545                               + umask(ji-1,jj  ,jk) + umask(ji  ,jj  ,jk) , 1.  ) 
    … …  
    511570      ! to have a zero bottom velocity 
    512571 
     572#if defined key_z_first 
     573      DO jj = 1, jpj 
     574         DO ji = 1, jpi 
     575            DO jk = 1, jpkm1 
     576               un(ji,jj,jk) = ( un(ji,jj,jk) - un(ji,jj,jpkm1) ) * umask(ji,jj,jk) 
     577               vn(ji,jj,jk) = ( vn(ji,jj,jk) - vn(ji,jj,jpkm1) ) * vmask(ji,jj,jk) 
     578            END DO 
     579         END DO 
     580      END DO 
     581#else 
    513582      DO jk = 1, jpkm1 
    514583         un(:,:,jk) = ( un(:,:,jk) - un(:,:,jpkm1) ) * umask(:,:,jk) 
    515584         vn(:,:,jk) = ( vn(:,:,jk) - vn(:,:,jpkm1) ) * vmask(:,:,jk) 
    516585      END DO 
     586#endif 
    517587 
    518588      CALL lbc_lnk( un, 'U', -1. ) 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/DTA/dtasal.F90

    r2715 r3211  
    3232 
    3333   TYPE(FLD), ALLOCATABLE, DIMENSION(:) ::   sf_sal   ! structure of input SST (file informations, fields read) 
     34 
     35   !! * Control permutation of array indices 
     36#  include "dtasal_ftrans.h90" 
     37#  include "oce_ftrans.h90" 
     38#  include "dom_oce_ftrans.h90" 
    3439 
    3540   !! * Substitutions 
    … …  
    158163#endif    
    159164         
    160       s_dta(:,:,:)=sf_sal(1)%fnow(:,:,:) 
     165#if defined key_z_first 
     166      !! DCSE_NEMO: Beware! These arrays will not be conformable after permuting indices of t_dta 
     167      DO jk = 1, jpk 
     168         DO jj = 1, jpj 
     169            DO ji = 1, jpi 
     170               s_dta(ji,jj,jk) = sf_sal(1)%fnow(ji,jj,jk) 
     171            END DO 
     172         END DO 
     173      END DO 
     174#else 
     175      s_dta(:,:,:) = sf_sal(1)%fnow(:,:,:) 
     176#endif 
    161177         
    162178      IF( ln_sco ) THEN 
    163          DO jj = 1, jpj                  ! interpolation of salinites 
     179         DO jj = 1, jpj                  ! interpolation of salinities 
    164180            DO ji = 1, jpi 
    165181               DO jk = 1, jpk 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/DTA/dtatem.F90

    r2715 r3211  
    3232 
    3333   TYPE(FLD), ALLOCATABLE, DIMENSION(:) ::   sf_tem      ! structure of input SST (file informations, fields read) 
     34 
     35   !! * Control permutation of array indices 
     36#  include "dtatem_ftrans.h90" 
     37#  include "oce_ftrans.h90" 
     38#  include "dom_oce_ftrans.h90" 
    3439 
    3540   !! * Substitutions 
    … …  
    171176#endif 
    172177          
     178#if defined key_z_first 
     179      !! DCSE_NEMO: Beware! These arrays will not be conformable after permuting indices of t_dta 
     180      DO jk = 1, jpk 
     181         DO jj = 1, jpj 
     182            DO ji = 1, jpi 
     183               t_dta(ji,jj,jk) = sf_tem(1)%fnow(ji,jj,jk)  
     184            END DO 
     185         END DO 
     186      END DO 
     187#else 
    173188      t_dta(:,:,:) = sf_tem(1)%fnow(:,:,:)  
     189#endif 
     190 
    174191          
    175192      IF( ln_sco ) THEN 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/DYN/divcur.F90

    r2715 r3211  
    3737 
    3838   PUBLIC   div_cur    ! routine called by step.F90 and istate.F90 
     39 
     40   !! * Control permutation of array indices 
     41#  include "oce_ftrans.h90" 
     42#  include "dom_oce_ftrans.h90" 
     43#  include "obc_oce_ftrans.h90" 
    3944 
    4045   !! * Substitutions 
    … …  
    285290      ENDIF 
    286291 
     292#if defined key_z_first 
     293      !                                             ! -------- 
     294      ! Horizontal divergence                       !   div  
     295      !                                             ! -------- 
     296      hdivb(:,:,1:jpkm1) = hdivn(:,:,1:jpkm1)    ! time swap of div arrays 
     297      DO jj = 2, jpjm1 
     298         DO ji = 2, jpim1 
     299            DO jk = 1, jpkm1 
     300               hdivn(ji,jj,jk) =   & 
     301                  (  e2u(ji,jj)*fse3u(ji,jj,jk) * un(ji,jj,jk) - e2u(ji-1,jj)*fse3u(ji-1,jj,jk) * un(ji-1,jj,jk)       & 
     302                   + e1v(ji,jj)*fse3v(ji,jj,jk) * vn(ji,jj,jk) - e1v(ji,jj-1)*fse3v(ji,jj-1,jk) * vn(ji,jj-1,jk)  )    & 
     303                  / ( e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) ) 
     304            END DO   
     305         END DO   
     306      END DO 
     307 
     308#if defined key_obc 
     309      IF( Agrif_Root() ) THEN 
     310         ! open boundaries (div must be zero behind the open boundary) 
     311         !  mpp remark: The zeroing of hdivn can probably be extended to 1->jpi/jpj for the correct row/column 
     312         IF( lp_obc_east  )   hdivn(nie0p1:nie1p1,nje0  :nje1  ,1:jpkm1) = 0.e0      ! east 
     313         IF( lp_obc_west  )   hdivn(niw0  :niw1  ,njw0  :njw1  ,1:jpkm1) = 0.e0      ! west 
     314         IF( lp_obc_north )   hdivn(nin0  :nin1  ,njn0p1:njn1p1,1:jpkm1) = 0.e0      ! north 
     315         IF( lp_obc_south )   hdivn(nis0  :nis1  ,njs0  :njs1  ,1:jpkm1) = 0.e0      ! south 
     316      ENDIF 
     317#endif          
     318      IF( .NOT. AGRIF_Root() ) THEN 
     319         IF ((nbondi ==  1).OR.(nbondi == 2)) hdivn(nlci-1 , :     ,1:jpkm1) = 0.e0      ! east 
     320         IF ((nbondi == -1).OR.(nbondi == 2)) hdivn(2      , :     ,1:jpkm1) = 0.e0      ! west 
     321         IF ((nbondj ==  1).OR.(nbondj == 2)) hdivn(:      ,nlcj-1 ,1:jpkm1) = 0.e0      ! north 
     322         IF ((nbondj == -1).OR.(nbondj == 2)) hdivn(:      ,2      ,1:jpkm1) = 0.e0      ! south 
     323      ENDIF 
     324 
     325         !                                             ! -------- 
     326         ! relative vorticity                          !   rot  
     327         !                                             ! -------- 
     328      rotb (:,:,1:jpkm1) = rotn (:,:,1:jpkm1)    ! time swap of rot arrays 
     329      DO jj = 1, jpjm1 
     330         DO ji = 1, jpim1 
     331            DO jk = 1, jpkm1 
     332               rotn(ji,jj,jk) = (  e2v(ji+1,jj  ) * vn(ji+1,jj  ,jk) - e2v(ji,jj) * vn(ji,jj,jk)    & 
     333                  &              - e1u(ji  ,jj+1) * un(ji  ,jj+1,jk) + e1u(ji,jj) * un(ji,jj,jk)  ) & 
     334                  &           * fmask(ji,jj,jk) / ( e1f(ji,jj) * e2f(ji,jj) ) 
     335            END DO 
     336         END DO 
     337      END DO 
     338#else 
     339 
    287340      !                                                ! =============== 
    288341      DO jk = 1, jpkm1                                 ! Horizontal slab 
    … …  
    334387      END DO                                           !   End of slab 
    335388      !                                                ! =============== 
     389#endif 
    336390 
    337391      IF( ln_rnf      )   CALL sbc_rnf_div( hdivn )          ! runoffs (update hdivn field) 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/DYN/dynadv.F90

    r2715 r3211  
    3131    
    3232   INTEGER ::   nadv   ! choice of the formulation and scheme for the advection 
     33 
     34   !! * Control permutation of array indices 
     35#  include "dom_oce_ftrans.h90" 
    3336 
    3437   !! * Substitutions 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/DYN/dynadv_cen2.F90

    r2715 r3211  
    2626   PUBLIC   dyn_adv_cen2   ! routine called by step.F90 
    2727 
     28   !! * Control permutation of array indices 
     29#  include "oce_ftrans.h90" 
     30#  include "dom_oce_ftrans.h90" 
     31 
    2832   !! * Substitutions 
    2933#  include "domzgr_substitute.h90" 
    … …  
    5256      USE wrk_nemo, ONLY:   zfu_f => wrk_3d_2 , zfv_f => wrk_3d_5 , zfv_vw =>wrk_3d_7 
    5357      USE wrk_nemo, ONLY:   zfw   => wrk_3d_3  
     58      !! DCSE_NEMO: module variables renamed, need additional directives 
     59!FTRANS zfu :I :I :z 
     60!FTRANS zfv :I :I :z 
     61!FTRANS zfu_t :I :I :z 
     62!FTRANS zfv_t :I :I :z 
     63!FTRANS zfu_uw :I :I :z 
     64!FTRANS zfu_f :I :I :z 
     65!FTRANS zfv_f :I :I :z 
     66!FTRANS zfv_vw :I :I :z 
     67!FTRANS zfw :I :I :z 
    5468      ! 
    5569      INTEGER, INTENT( in ) ::   kt   ! ocean time-step index 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/DYN/dynadv_ubs.F90

    r2715 r3211  
    3030 
    3131   PUBLIC   dyn_adv_ubs   ! routine called by step.F90 
     32 
     33   !! * Control permutation of array indices 
     34#  include "oce_ftrans.h90" 
     35#  include "dom_oce_ftrans.h90" 
    3236 
    3337   !! * Substitutions 
    … …  
    7579      USE wrk_nemo, ONLY:   zlu_uu => wrk_4d_1 , zlv_vv=>wrk_4d_3   ! 4D workspace 
    7680      USE wrk_nemo, ONLY:   zlu_uv => wrk_4d_2 , zlv_vu=>wrk_4d_4 
     81      !! DCSE_NEMO: module variables renamed, need additional directives 
     82!FTRANS zfu :I :I :z 
     83!FTRANS zfv :I :I :z 
     84!FTRANS zfu_t :I :I :z 
     85!FTRANS zfv_t :I :I :z 
     86!FTRANS zfu_uw :I :I :z 
     87!FTRANS zfu_f :I :I :z 
     88!FTRANS zfv_f :I :I :z 
     89!FTRANS zfv_vw :I :I :z 
     90!FTRANS zfw :I :I :z 
     91!FTRANS zlu_uu :I :I :z :I 
     92!FTRANS zlv_vv :I :I :z :I 
     93!FTRANS zlu_uv :I :I :z :I 
     94!FTRANS zlv_vu :I :I :z :I 
    7795      ! 
    7896      INTEGER, INTENT(in) ::   kt     ! ocean time-step index 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/DYN/dynbfr.F90

    r2715 r3211  
    2323   PUBLIC   dyn_bfr    !  routine called by step.F90 
    2424 
     25   !! * Control permutation of array indices 
     26#  include "oce_ftrans.h90" 
     27#  include "dom_oce_ftrans.h90" 
     28#  include "zdf_oce_ftrans.h90" 
     29 
    2530   !! * Substitutions 
    2631#  include "domzgr_substitute.h90" 
    … …  
    4348      !!--------------------------------------------------------------------- 
    4449      USE oce, ONLY:   ztrduv => tsa   ! tsa used as 4D workspace 
     50      !! DCSE_NEMO: module variable renamed, need additional directives 
     51!FTRANS ztrduv :I :I :z :I 
     52 
    4553      !! 
    4654      INTEGER, INTENT(in) ::   kt   ! ocean time-step index 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/DYN/dynhpg.F90

    r2715 r3211  
    5757   INTEGER  ::   nhpg  =  0   ! = 0 to 6, type of pressure gradient scheme used ! (deduced from ln_hpg_... flags) 
    5858 
     59   !! * Control permutation of array indices 
     60#  include "oce_ftrans.h90" 
     61#  include "dom_oce_ftrans.h90" 
     62 
    5963   !! * Substitutions 
    6064#  include "domzgr_substitute.h90" 
    … …  
    7983      USE wrk_nemo, ONLY:   wrk_in_use, wrk_not_released 
    8084      USE wrk_nemo, ONLY:   ztrdu => wrk_3d_1 , ztrdv => wrk_3d_2   ! 3D workspace 
     85      !! DCSE_NEMO: need additional directives for renamed module variables 
     86!FTRANS ztrdu :I :I :z 
     87!FTRANS ztrdv :I :I :z 
     88 
    8189      !! 
    8290      INTEGER, INTENT(in) ::   kt   ! ocean time-step index 
    … …  
    194202      !!---------------------------------------------------------------------- 
    195203      USE oce, ONLY:   zhpi => ta , zhpj => sa   ! (ta,sa) used as 3D workspace 
     204      !! DCSE_NEMO: need additional directives for renamed module variables 
     205!FTRANS zhpi :I :I :z 
     206!FTRANS zhpj :I :I :z 
     207 
    196208      !! 
    197209      INTEGER, INTENT(in) ::   kt    ! ocean time-step index 
    … …  
    223235      ! 
    224236      ! interior value (2=<jk=<jpkm1) 
     237#if defined key_z_first 
     238      DO jj = 2, jpjm1 
     239         DO ji = 2, jpim1 
     240            DO jk = 2, jpkm1 
     241#else 
    225242      DO jk = 2, jpkm1 
    226243         DO jj = 2, jpjm1 
    227244            DO ji = fs_2, fs_jpim1   ! vector opt. 
     245#endif 
    228246               zcoef1 = zcoef0 * fse3w(ji,jj,jk) 
    229247               ! hydrostatic pressure gradient 
    … …  
    254272      !!----------------------------------------------------------------------  
    255273      USE oce, ONLY:   zhpi => ta , zhpj => sa   ! (ta,sa) used as 3D workspace 
     274      !! DCSE_NEMO: need additional directives for renamed module variables 
     275!FTRANS zhpi :I :I :z 
     276!FTRANS zhpj :I :I :z 
    256277      !! 
    257278      INTEGER, INTENT(in) ::   kt    ! ocean time-step index 
    … …  
    285306 
    286307      ! interior value (2=<jk=<jpkm1) 
     308#if defined key_z_first 
     309      DO jj = 2, jpjm1 
     310         DO ji = 2, jpim1 
     311            DO jk = 2, jpkm1 
     312#else 
    287313      DO jk = 2, jpkm1 
    288314         DO jj = 2, jpjm1 
    289315            DO ji = fs_2, fs_jpim1   ! vector opt. 
     316#endif 
    290317               zcoef1 = zcoef0 * fse3w(ji,jj,jk) 
    291318               ! hydrostatic pressure gradient 
    … …  
    355382      !!---------------------------------------------------------------------- 
    356383      USE oce, ONLY:   zhpi => ta , zhpj => sa   ! (ta,sa) used as 3D workspace 
     384      !! DCSE_NEMO: need additional directives for renamed module variables 
     385!FTRANS zhpi :I :I :z 
     386!FTRANS zhpj :I :I :z 
    357387      !! 
    358388      INTEGER, INTENT(in) ::   kt    ! ocean time-step index 
    … …  
    395425             
    396426      ! interior value (2=<jk=<jpkm1) 
     427#if defined key_z_first 
     428      DO jj = 2, jpjm1      
     429         DO ji = 2, jpim1 
     430            DO jk = 2, jpkm1                                   
     431#else 
    397432      DO jk = 2, jpkm1                                   
    398433         DO jj = 2, jpjm1      
    399434            DO ji = fs_2, fs_jpim1   ! vector opt.       
     435#endif 
    400436               ! hydrostatic pressure gradient along s-surfaces 
    401437               zhpi(ji,jj,jk) = zhpi(ji,jj,jk-1) + zcoef0 / e1u(ji,jj)   &  
    … …  
    440476      !!---------------------------------------------------------------------- 
    441477      USE oce, ONLY:   zhpi => ta , zhpj => sa   ! (ta,sa) used as 3D workspace 
     478      !! DCSE_NEMO: need additional directives for renamed module variables 
     479!FTRANS zhpi :I :I :z 
     480!FTRANS zhpj :I :I :z 
    442481      !! 
    443482      INTEGER, INTENT(in) ::   kt    ! ocean time-step index 
    … …  
    476515      ! 
    477516      ! interior value (2=<jk=<jpkm1) 
     517#if defined key_z_first 
     518      DO jj = 2, jpjm1 
     519         DO ji = 2, jpim1 
     520            DO jk = 2, jpkm1 
     521#else 
    478522      DO jk = 2, jpkm1 
    479523         DO jj = 2, jpjm1 
    480524            DO ji = fs_2, fs_jpim1   ! vector opt. 
     525#endif 
    481526               ! hydrostatic pressure gradient along s-surfaces 
    482527               zhpi(ji,jj,jk) = zhpi(ji,jj,jk-1) & 
    … …  
    516561      !!---------------------------------------------------------------------- 
    517562      USE oce, ONLY:   zhpi => ta , zhpj => sa   ! (ta,sa) used as 3D workspace 
     563      !! DCSE_NEMO: need additional directives for renamed module variables 
     564!FTRANS zhpi :I :I :z 
     565!FTRANS zhpj :I :I :z 
    518566      !! 
    519567      INTEGER, INTENT(in) ::   kt    ! ocean time-step index 
    … …  
    555603 
    556604      ! Interior value (2=<jk=<jpkm1) (weighted with zalph & zbeta) 
     605#if defined key_z_first 
     606      DO jj = 2, jpjm1 
     607         DO ji = 2, jpim1 
     608            DO jk = 2, jpkm1 
     609#else 
    557610      DO jk = 2, jpkm1 
    558611         DO jj = 2, jpjm1 
    559612            DO ji = fs_2, fs_jpim1   ! vector opt. 
     613#endif 
    560614               zhpi(ji,jj,jk) = zhpi(ji,jj,jk-1) + zcoef0 / e1u(ji,jj)                            & 
    561615                  &           * (   (            fsde3w(ji+1,jj,jk  ) + fsde3w(ji,jj,jk  )        & 
    … …  
    603657      USE wrk_nemo, ONLY:   drhow => wrk_3d_13 , dzw  => wrk_3d_14 
    604658      USE wrk_nemo, ONLY:   rho_k => wrk_3d_15 
     659      !! DCSE_NEMO: need additional directives for renamed module variables 
     660!FTRANS zhpi :I :I :z 
     661!FTRANS zhpj :I :I :z 
     662!FTRANS drhox :I :I :z 
     663!FTRANS dzx :I :I :z 
     664!FTRANS drhou :I :I :z 
     665!FTRANS dzu :I :I :z 
     666!FTRANS rho_i :I :I :z 
     667!FTRANS drhoy :I :I :z 
     668!FTRANS dzy :I :I :z 
     669!FTRANS drhov :I :I :z 
     670!FTRANS dzv :I :I :z 
     671!FTRANS rho_j :I :I :z 
     672!FTRANS drhoz :I :I :z 
     673!FTRANS dzz :I :I :z 
     674!FTRANS drhow :I :I :z 
     675!FTRANS dzw :I :I :z 
     676!FTRANS rho_k :I :I :z 
    605677      !! 
    606678      INTEGER, INTENT(in) ::   kt    ! ocean time-step index 
    … …  
    633705!!bug gm   Not a true bug, but... dzz=e3w  for dzx, dzy verify what it is really 
    634706 
     707#if defined key_z_first 
     708      DO jj = 2, jpjm1 
     709         DO ji = 2, jpim1 
     710            DO jk = 2, jpkm1 
     711#else 
    635712      DO jk = 2, jpkm1 
    636713         DO jj = 2, jpjm1 
    637714            DO ji = fs_2, fs_jpim1   ! vector opt. 
     715#endif 
    638716               drhoz(ji,jj,jk) = rhd   (ji  ,jj  ,jk) - rhd   (ji,jj,jk-1) 
    639717               dzz  (ji,jj,jk) = fsde3w(ji  ,jj  ,jk) - fsde3w(ji,jj,jk-1) 
    … …  
    654732!!bug  gm  idem for drhox, drhoy et ji=jpi and jj=jpj 
    655733 
     734#if defined key_z_first 
     735      DO jj = 2, jpjm1 
     736         DO ji = 2, jpim1 
     737            DO jk = 2, jpkm1 
     738#else 
    656739      DO jk = 2, jpkm1 
    657740         DO jj = 2, jpjm1 
    658741            DO ji = fs_2, fs_jpim1   ! vector opt. 
     742#endif 
    659743               cffw = 2._wp * drhoz(ji  ,jj  ,jk) * drhoz(ji,jj,jk-1) 
    660744 
    … …  
    739823!!bug gm    : optimisation: 1/10 and 1/12 the division should be done before the loop 
    740824 
     825#if defined key_z_first 
     826      DO jj = 2, jpjm1 
     827         DO ji = 2, jpim1 
     828            DO jk = 2, jpkm1 
     829#else 
    741830      DO jk = 2, jpkm1 
    742831         DO jj = 2, jpjm1 
    743832            DO ji = fs_2, fs_jpim1   ! vector opt. 
     833#endif 
    744834 
    745835               rho_k(ji,jj,jk) = zcoef0 * ( rhd   (ji,jj,jk) + rhd   (ji,jj,jk-1) )                                   & 
    … …  
    794884      !  interior value   (2=<jk=<jpkm1) 
    795885      ! ---------------- 
     886#if defined key_z_first 
     887      DO jj = 2, jpjm1  
     888         DO ji = 2, jpim1 
     889            DO jk = 2, jpkm1 
     890#else 
    796891      DO jk = 2, jpkm1 
    797892         DO jj = 2, jpjm1  
    798893            DO ji = fs_2, fs_jpim1   ! vector opt. 
     894#endif 
    799895               ! hydrostatic pressure gradient along s-surfaces 
    800896               zhpi(ji,jj,jk) = zhpi(ji,jj,jk-1)                                & 
    … …  
    832928      USE wrk_nemo, ONLY:   zhpjorg => wrk_3d_5 , zhpjrot => wrk_3d_6 
    833929      USE wrk_nemo, ONLY:   zhpjtra => wrk_3d_7 , zhpjne  => wrk_3d_8 
     930      !! DCSE_NEMO: need additional directives for renamed module variables 
     931!FTRANS zhpi :I :I :z 
     932!FTRANS zhpj :I :I :z 
     933!FTRANS zhpiorg :I :I :z 
     934!FTRANS zhpirot :I :I :z 
     935!FTRANS zhpitra :I :I :z 
     936!FTRANS zhpine :I :I :z 
     937!FTRANS zhpjorg :I :I :z 
     938!FTRANS zhpjrot :I :I :z 
     939!FTRANS zhpjtra :I :I :z 
     940!FTRANS zhpjne :I :I :z 
    834941      !! 
    835942      INTEGER, INTENT(in) ::   kt    ! ocean time-step index 
    … …  
    891998      DO jj = 1, jpjm1 
    892999         DO ji = 1, fs_jpim1   ! vector opt. 
     1000#if defined key_z_first 
     1001            zmskd1 = tmask_1(ji+1,jj+1) * tmask_1(ji  ,jj)      ! mask in the 1st diagnonal 
     1002            zmskd2 = tmask_1(ji  ,jj+1) * tmask_1(ji+1,jj)      ! mask in the 2nd diagnonal 
     1003#else 
    8931004            zmskd1 = tmask(ji+1,jj+1,1) * tmask(ji  ,jj,1)      ! mask in the 1st diagnonal 
    8941005            zmskd2 = tmask(ji  ,jj+1,1) * tmask(ji+1,jj,1)      ! mask in the 2nd diagnonal 
     1006#endif 
    8951007            ! hydrostatic pressure gradient along s-surfaces 
    8961008            zhpitra(ji,jj,1) = zdistr(ji,jj) * zmskd1 * (  fse3t(ji+1,jj+1,1) * rhd(ji+1,jj+1,1)   & 
    … …  
    9271039      ! ----------------- 
    9281040      ! compute and add to the general trend the pressure gradients along the axes 
     1041#if defined key_z_first 
     1042      DO jj = 2, jpjm1 
     1043         DO ji = 2, jpim1 
     1044            DO jk = 2, jpkm1 
     1045#else 
    9291046      DO jk = 2, jpkm1 
    9301047         DO jj = 2, jpjm1 
    9311048            DO ji = fs_2, fs_jpim1   ! vector opt. 
     1049#endif 
    9321050               ! hydrostatic pressure gradient along s-surfaces 
    9331051               zhpiorg(ji,jj,jk) = zhpiorg(ji,jj,jk-1)                                                 & 
    … …  
    9541072 
    9551073      ! compute the pressure gradients in the diagonal directions 
     1074#if defined key_z_first 
     1075      DO jj = 1, jpjm1 
     1076         DO ji = 1, jpim1 
     1077            DO jk = 2, jpkm1 
     1078#else 
    9561079      DO jk = 2, jpkm1 
    9571080         DO jj = 1, jpjm1 
    9581081            DO ji = 1, fs_jpim1   ! vector opt. 
     1082#endif 
    9591083               zmskd1  = tmask(ji+1,jj+1,jk  ) * tmask(ji  ,jj,jk  )      ! level jk   mask in the 1st diagnonal 
    9601084               zmskd1m = tmask(ji+1,jj+1,jk-1) * tmask(ji  ,jj,jk-1)      ! level jk-1    "               "      
    … …  
    9871111 
    9881112      ! interpolate and add to the general trend 
     1113#if defined key_z_first 
     1114      DO jj = 2, jpjm1 
     1115         DO ji = 2, jpim1 
     1116            DO jk = 2, jpkm1 
     1117#else 
    9891118      DO jk = 2, jpkm1 
    9901119         DO jj = 2, jpjm1 
    9911120            DO ji = fs_2, fs_jpim1   ! vector opt. 
     1121#endif 
    9921122               ! averaging 
    9931123               zhpirot(ji,jj,jk) = 0.5 * ( zhpine(ji,jj,jk) + zhpine(ji  ,jj-1,jk) ) 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/DYN/dynkeg.F90

    r2715 r3211  
    2424 
    2525   PUBLIC   dyn_keg    ! routine called by step module 
     26 
     27   !! * Control permutation of array indices 
     28#  include "oce_ftrans.h90" 
     29#  include "dom_oce_ftrans.h90" 
    2630    
    2731   !! * Substitutions 
    … …  
    5559      USE oce     , ONLY:   ztrdu => ta       , ztrdv => sa   ! (ta,sa) used as 3D workspace    
    5660      USE wrk_nemo, ONLY:   zhke  => wrk_3d_1                 ! 3D workspace 
     61      !! DCSE_NEMO: need additional directives for renamed module variables 
     62!FTRANS ztrdu ztrdv zhke :I :I :z 
     63 
    5764      !! 
    5865      INTEGER, INTENT( in ) ::   kt   ! ocean time-step index 
    … …  
    7784      ENDIF 
    7885       
     86#if defined key_z_first 
     87      DO jj = 2, jpj            ! Horizontal kinetic energy at T-point 
     88         DO ji = 2, jpi 
     89            DO jk = 1, jpkm1 
     90               zhke(ji,jj,jk) = 0.25 * (   un(ji-1,jj  ,jk) * un(ji-1,jj  ,jk)   & 
     91                  &                      + un(ji  ,jj  ,jk) * un(ji  ,jj  ,jk)   & 
     92                                         + vn(ji  ,jj-1,jk) * vn(ji  ,jj-1,jk)   & 
     93                  &                      + vn(ji  ,jj  ,jk) * vn(ji  ,jj  ,jk)   ) 
     94            END DO   
     95         END DO   
     96      END DO 
     97      DO jj = 2, jpjm1          ! add the gradient of kinetic energy to the general momentum trends 
     98         DO ji = 2, jpim1 
     99            DO jk = 1, jpkm1 
     100               ua(ji,jj,jk) = ua(ji,jj,jk) - ( zhke(ji+1,jj  ,jk) - zhke(ji,jj,jk) ) / e1u(ji,jj) 
     101               va(ji,jj,jk) = va(ji,jj,jk) - ( zhke(ji  ,jj+1,jk) - zhke(ji,jj,jk) ) / e2v(ji,jj) 
     102            END DO  
     103         END DO 
     104      END DO 
     105#else 
    79106      !                                                ! =============== 
    80107      DO jk = 1, jpkm1                                 ! Horizontal slab 
    … …  
    126153      END DO                                           !   End of slab 
    127154      !                                                ! =============== 
     155#endif 
    128156 
    129157      IF( l_trddyn ) THEN      ! save the Kinetic Energy trends for diagnostic 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/DYN/dynldf.F90

    r2715 r3211  
    3535   INTEGER ::   nldf = -2   ! type of lateral diffusion used defined from ln_dynldf_... namlist logicals) 
    3636 
     37   !! * Control permutation of array indices 
     38#  include "oce_ftrans.h90" 
     39#  include "dom_oce_ftrans.h90" 
     40#  include "ldfdyn_oce_ftrans.h90" 
     41#  include "ldfslp_ftrans.h90" 
     42 
    3743   !! * Substitutions 
    3844#  include "domzgr_substitute.h90" 
    … …  
    5359      USE wrk_nemo, ONLY:   wrk_in_use, wrk_not_released 
    5460      USE wrk_nemo, ONLY:   ztrdu => wrk_3d_1 , ztrdv => wrk_3d_2 
     61      !! DCSE_NEMO: need additional directives for renamed module variables 
     62!FTRANS ztrdu :I :I :z 
     63!FTRANS ztrdv :I :I :z 
     64 
    5565      ! 
    5666      INTEGER, INTENT(in) ::   kt   ! ocean time-step index 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/DYN/dynldf_bilap.F90

    r2715 r3211  
    2828 
    2929   PUBLIC   dyn_ldf_bilap   ! called by step.F90 
     30 
     31   !! * Control permutation of array indices 
     32#  include "oce_ftrans.h90" 
     33#  include "dom_oce_ftrans.h90" 
     34#  include "ldfdyn_oce_ftrans.h90" 
    3035 
    3136   !! * Substitutions 
    … …  
    7580      !!---------------------------------------------------------------------- 
    7681      USE wrk_nemo, ONLY:   wrk_in_use, wrk_not_released 
    77       USE wrk_nemo, ONLY:   zcu => wrk_2d_1 , zcv => wrk_2d_2   ! 3D workspace 
     82      USE wrk_nemo, ONLY:   zcu => wrk_2d_1 , zcv => wrk_2d_2   ! 2D workspace 
    7883      USE wrk_nemo, ONLY:   zuf => wrk_3d_3 , zut => wrk_3d_4   ! 3D workspace 
    7984      USE wrk_nemo, ONLY:   zlu => wrk_3d_5 , zlv => wrk_3d_6 
     85      !! DCSE_NEMO: need additional directives for renamed module variables 
     86!FTRANS zuf :I :I :z 
     87!FTRANS zut :I :I :z 
     88!FTRANS zlu :I :I :z 
     89!FTRANS zlv :I :I :z 
    8090      ! 
    8191      INTEGER, INTENT(in) ::   kt   ! ocean time-step index 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/DYN/dynldf_bilapg.F90

    r2715 r3211  
    3535   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) ::  zfuw, zfvw , zdiu, zdiv   ! 2D workspace (ldfguv) 
    3636   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) ::  zdju, zdj1u, zdjv, zdj1v  ! 2D workspace (ldfguv) 
     37 
     38   !! * Control permutation of array indices 
     39#  include "oce_ftrans.h90" 
     40#  include "dom_oce_ftrans.h90" 
     41#  include "ldfdyn_oce_ftrans.h90" 
     42#  include "zdf_oce_ftrans.h90" 
     43#  include "ldfslp_ftrans.h90" 
    3744 
    3845   !! * Substitutions 
    … …  
    8794      USE wrk_nemo, ONLY:   zwk1 => wrk_3d_3 , zwk2 => wrk_3d_4   ! 3D workspace 
    8895      USE oce     , ONLY:   zwk3 => ta       , zwk4 => sa         ! ta, sa used as 3D workspace    
     96      !! DCSE_NEMO: need additional directives for renamed module variables 
     97!FTRANS zwk1 :I :I :z 
     98!FTRANS zwk2 :I :I :z 
     99!FTRANS zwk3 :I :I :z 
     100!FTRANS zwk4 :I :I :z 
    89101      ! 
    90102      INTEGER, INTENT( in ) ::   kt           ! ocean time-step index 
    … …  
    120132      ! Update the momentum trends 
    121133      ! -------------------------- 
     134#if defined key_z_first 
     135      DO jj = 2, jpjm1               ! add the diffusive trend to the general momentum trends 
     136         DO ji = 2, jpim1 
     137            DO jk = 1, jpkm1 
     138#else 
    122139      DO jj = 2, jpjm1               ! add the diffusive trend to the general momentum trends 
    123140         DO jk = 1, jpkm1 
    124141            DO ji = 2, jpim1 
     142#endif 
    125143               ua(ji,jj,jk) = ua(ji,jj,jk) + zwk3(ji,jj,jk) 
    126144               va(ji,jj,jk) = va(ji,jj,jk) + zwk4(ji,jj,jk) 
    … …  
    180198      USE wrk_nemo, ONLY:   zdkv => wrk_2d_7 , zdk1v => wrk_2d_8 
    181199      !! 
    182       REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in   ) ::   pu , pv    ! 1st call: before horizontal velocity  
     200!FTRANS pu :I :I :z 
     201!FTRANS pv :I :I :z 
     202!FTRANS plu :I :I :z 
     203!FTRANS plv :I :I :z 
     204!! DCSE_NEMO: work around deficiency in ftrans 
     205!     REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in   ) ::   pu , pv    ! 1st call: before horizontal velocity  
    183206      !                                                               ! 2nd call: ahm x these fields 
    184       REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(  out) ::   plu, plv   ! partial harmonic operator applied to 
     207      REAL(wp), INTENT(in   ) ::   pu(jpi,jpj,jpk) , pv(jpi,jpj,jpk) 
     208!     REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(  out) ::   plu, plv   ! partial harmonic operator applied to 
    185209      !                                                               ! pu and pv (all the components except 
    186210      !                                                               ! second order vertical derivative term) 
     211      REAL(wp), INTENT(  out) ::   plu(jpi,jpj,jpk), plv(jpi,jpj,jpk) ! partial harmonic operator applied to 
    187212      INTEGER                         , INTENT(in   ) ::   kahm       ! =1 1st call ; =2 2nd call 
    188213      ! 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/DYN/dynldf_iso.F90

    r2715 r3211  
    3838   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: zfuw, zdiu, zdju, zdj1u   ! 2D workspace (dyn_ldf_iso)  
    3939   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: zfvw, zdiv, zdjv, zdj1v   !  -      - 
     40 
     41   !! * Control permutation of array indices 
     42#  include "oce_ftrans.h90" 
     43#  include "dom_oce_ftrans.h90" 
     44#  include "ldfdyn_oce_ftrans.h90" 
     45#  include "ldftra_oce_ftrans.h90" 
     46#  include "ldfslp_ftrans.h90" 
     47#  include "zdf_oce_ftrans.h90" 
    4048 
    4149   !! * Substitutions 
    … …  
    134142      IF( ln_dynldf_hor .AND. ln_traldf_iso ) THEN 
    135143         ! 
     144#if defined key_z_first 
     145         DO jj = 2, jpjm1       ! set the slopes of iso-level 
     146            DO ji = fs_2, fs_jpim1     
     147               DO jk = 1, jpk        
     148#else 
    136149         DO jk = 1, jpk         ! set the slopes of iso-level 
    137150            DO jj = 2, jpjm1 
    138151               DO ji = fs_2, fs_jpim1   ! vector opt. 
     152#endif 
    139153                  uslp (ji,jj,jk) = -1./e1u(ji,jj) * ( fsdept(ji+1,jj,jk) - fsdept(ji ,jj ,jk) ) * umask(ji,jj,jk) 
    140154                  vslp (ji,jj,jk) = -1./e2v(ji,jj) * ( fsdept(ji,jj+1,jk) - fsdept(ji ,jj ,jk) ) * vmask(ji,jj,jk) 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/DYN/dynldf_lap.F90

    r2715 r3211  
    2828 
    2929   PUBLIC dyn_ldf_lap  ! called by step.F90 
     30 
     31   !! * Control permutation of array indices 
     32#  include "oce_ftrans.h90" 
     33#  include "dom_oce_ftrans.h90" 
     34#  include "ldfdyn_oce_ftrans.h90" 
     35#  include "zdf_oce_ftrans.h90" 
     36#  include "ldfslp_ftrans.h90" 
    3037 
    3138   !! * Substitutions 
    … …  
    7380         IF(lwp) WRITE(numout,*) '~~~~~~~ ' 
    7481      ENDIF 
     82#if defined key_z_first 
     83      DO jj = 2, jpjm1 
     84         DO ji = 2, jpim1 
     85            DO jk = 1, jpkm1 
     86#else 
    7587      !                                                ! =============== 
    7688      DO jk = 1, jpkm1                                 ! Horizontal slab 
    … …  
    7890         DO jj = 2, jpjm1 
    7991            DO ji = fs_2, fs_jpim1   ! vector opt. 
     92#endif 
    8093               ze2u = rotb (ji,jj,jk) * fsahmf(ji,jj,jk) * fse3f(ji,jj,jk) 
    8194               ze1v = hdivb(ji,jj,jk) * fsahmt(ji,jj,jk) 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/DYN/dynnxt.F90

    r2723 r3211  
    4949   PUBLIC    dyn_nxt   ! routine called by step.F90 
    5050 
     51   !! * Control permutation of array indices 
     52#  include "oce_ftrans.h90" 
     53#  include "dom_oce_ftrans.h90" 
     54#  include "sbc_oce_ftrans.h90" 
     55#  include "domvvl_ftrans.h90" 
     56#  include "obc_oce_ftrans.h90" 
     57 
    5158   !! * Substitutions 
    5259#  include "domzgr_substitute.h90" 
    … …  
    95102      USE oce     , ONLY:   ze3u_f => ta       , ze3v_f => sa       ! (ta,sa) used as 3D workspace 
    96103      USE wrk_nemo, ONLY:   zs_t   => wrk_2d_1 , zs_u_1 => wrk_2d_2 , zs_v_1 => wrk_2d_3 
     104      !! DCSE_NEMO: need additional directives for renamed module variables 
     105!FTRANS ze3u_f :I :I :z 
     106!FTRANS ze3v_f :I :I :z 
    97107      ! 
    98108      INTEGER, INTENT( in ) ::   kt      ! ocean time-step index 
    … …  
    214224      ! ------------------------------------------ 
    215225      IF( neuler == 0 .AND. kt == nit000 ) THEN        !* Euler at first time-step: only swap 
     226#if defined key_z_first 
     227         DO jj = 1, jpj 
     228            DO ji = 1, jpi 
     229               DO jk = 1, jpkm1 
     230                  un(ji,jj,jk) = ua(ji,jj,jk)                ! un <-- ua 
     231                  vn(ji,jj,jk) = va(ji,jj,jk) 
     232               END DO 
     233            END DO 
     234         END DO 
     235#else 
    216236         DO jk = 1, jpkm1 
    217237            un(:,:,jk) = ua(:,:,jk)                          ! un <-- ua 
    218238            vn(:,:,jk) = va(:,:,jk) 
    219239         END DO 
     240#endif 
    220241      ELSE                                             !* Leap-Frog : Asselin filter and swap 
    221242         !                                ! =============! 
    222243         IF( .NOT. lk_vvl ) THEN          ! Fixed volume ! 
    223244            !                             ! =============! 
     245#if defined key_z_first 
     246            DO jj = 1, jpj 
     247               DO ji = 1, jpi     
     248                  DO jk = 1, jpkm1                               
     249#else 
    224250            DO jk = 1, jpkm1                               
    225251               DO jj = 1, jpj 
    226252                  DO ji = 1, jpi     
     253#endif 
    227254                     zuf = un(ji,jj,jk) + atfp * ( ub(ji,jj,jk) - 2.e0 * un(ji,jj,jk) + ua(ji,jj,jk) ) 
    228255                     zvf = vn(ji,jj,jk) + atfp * ( vb(ji,jj,jk) - 2.e0 * vn(ji,jj,jk) + va(ji,jj,jk) ) 
    … …  
    247274            ! Add volume filter correction only at the first level of t-point scale factors 
    248275            zec = atfp * rdt / rau0 
     276#if defined key_z_first 
     277            fse3t_b(:,:,1) = fse3t_b(:,:,1) - zec * ( emp_b(:,:) - emp(:,:) ) * tmask_1(:,:) 
     278#else 
    249279            fse3t_b(:,:,1) = fse3t_b(:,:,1) - zec * ( emp_b(:,:) - emp(:,:) ) * tmask(:,:,1) 
     280#endif 
    250281            ! surface at t-points and inverse surface at (u/v)-points used in surface averaging computations 
    251282            zs_t  (:,:) =       e1t(:,:) * e2t(:,:) 
    … …  
    257288               ! ----------------------------------- 
    258289               ! Scale factor anomaly at (u/v)-points: surface averaging of scale factor at t-points 
     290#if defined key_z_first 
     291               DO jj = 1, jpjm1 
     292                  DO ji = 1, jpim1 
     293                     DO jk = 1, jpkm1 
     294#else 
    259295               DO jk = 1, jpkm1 
    260296                  DO jj = 1, jpjm1 
    261297                     DO ji = 1, jpim1 
     298#endif 
    262299                        zv_t_ij           = zs_t(ji  ,jj  ) * fse3t_b(ji  ,jj  ,jk) 
    263300                        zv_t_ip1j         = zs_t(ji+1,jj  ) * fse3t_b(ji+1,jj  ,jk) 
    … …  
    276313               ! Leap-Frog - Asselin filter and swap: applied on velocity 
    277314               ! ----------------------------------- 
     315#if defined key_z_first 
     316               DO jj = 1, jpj 
     317                  DO ji = 1, jpi 
     318                     DO jk = 1, jpkm1 
     319#else 
    278320               DO jk = 1, jpkm1 
    279321                  DO jj = 1, jpj 
    280322                     DO ji = 1, jpi 
     323#endif 
    281324                        zuf = un(ji,jj,jk) + atfp * ( ub(ji,jj,jk) - 2.e0 * un(ji,jj,jk) + ua(ji,jj,jk) ) 
    282325                        zvf = vn(ji,jj,jk) + atfp * ( vb(ji,jj,jk) - 2.e0 * vn(ji,jj,jk) + va(ji,jj,jk) ) 
    … …  
    294337               !----------------------------------------------- 
    295338               ! Scale factor anomaly at (u/v)-points: surface averaging of scale factor at t-points 
     339#if defined key_z_first 
     340               DO jj = 1, jpjm1 
     341                  DO ji = 1, jpim1 
     342                     DO jk = 1, jpkm1 
     343#else 
    296344               DO jk = 1, jpkm1 
    297345                  DO jj = 1, jpjm1 
    298346                     DO ji = 1, jpim1 
     347#endif 
    299348                        zv_t_ij          = zs_t(ji  ,jj  ) * fse3t_b(ji  ,jj  ,jk) 
    300349                        zv_t_ip1j        = zs_t(ji+1,jj  ) * fse3t_b(ji+1,jj  ,jk) 
    … …  
    313362               ! Leap-Frog - Asselin filter and swap: applied on thickness weighted velocity 
    314363               ! -----------------------------------             =========================== 
     364#if defined key_z_first 
     365               DO jj = 1, jpj 
     366                  DO ji = 1, jpim1 
     367                     DO jk = 1, jpkm1 
     368#else 
    315369               DO jk = 1, jpkm1 
    316370                  DO jj = 1, jpj 
    317371                     DO ji = 1, jpim1 
     372#endif 
    318373                        zue3a = ua(ji,jj,jk) * fse3u_a(ji,jj,jk) 
    319374                        zve3a = va(ji,jj,jk) * fse3v_a(ji,jj,jk) 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/DYN/dynspg.F90

    r2715 r3211  
    3838   INTEGER ::   nspg = 0   ! type of surface pressure gradient scheme defined from lk_dynspg_...  
    3939 
     40   !! * Control permutation of array indices 
     41#  include "oce_ftrans.h90" 
     42#  include "dom_oce_ftrans.h90" 
     43#  include "obc_oce_ftrans.h90" 
     44#  include "sbc_oce_ftrans.h90" 
     45 
    4046   !! * Substitutions 
    4147#  include "domzgr_substitute.h90" 
    … …  
    7682      USE wrk_nemo, ONLY:   wrk_in_use, wrk_not_released 
    7783      USE wrk_nemo, ONLY:   ztrdu => wrk_3d_4 , ztrdv => wrk_3d_5    ! 3D workspace 
     84      !! DCSE_NEMO: need additional directives for renamed module variables 
     85!FTRANS ztrdu :I :I :z 
     86!FTRANS ztrdv :I :I :z 
     87 
    7888      ! 
    7989      INTEGER, INTENT(in   ) ::   kt       ! ocean time-step index 
    … …  
    108118            END DO 
    109119         END DO 
     120#if defined key_z_first 
     121         DO jj = 2, jpjm1                          ! Add the apg to the general trend 
     122            DO ji = 2, jpim1 
     123               DO jk = 1, jpkm1 
     124#else 
    110125         DO jk = 1, jpkm1                          ! Add the apg to the general trend 
    111126            DO jj = 2, jpjm1 
    112127               DO ji = fs_2, fs_jpim1   ! vector opt. 
     128#endif 
    113129                  ua(ji,jj,jk) = ua(ji,jj,jk) + spgu(ji,jj) 
    114130                  va(ji,jj,jk) = va(ji,jj,jk) + spgv(ji,jj) 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/DYN/dynspg_exp.F90

    r2715 r3211  
    3333 
    3434   PUBLIC   dyn_spg_exp   ! routine called by step.F90 
     35 
     36   !! * Control permutation of array indices 
     37#  include "oce_ftrans.h90" 
     38#  include "dom_oce_ftrans.h90" 
     39#  include "sbc_oce_ftrans.h90" 
     40#  include "obc_oce_ftrans.h90" 
    3541 
    3642   !! * Substitutions 
    … …  
    8995            END DO  
    9096         END DO  
     97#if defined key_z_first 
     98         DO jj = 2, jpjm1                    ! Add it to the general trend 
     99            DO ji = 2, jpim1 
     100               DO jk = 1, jpkm1 
     101#else 
    91102         DO jk = 1, jpkm1                    ! Add it to the general trend 
    92103            DO jj = 2, jpjm1 
    93104               DO ji = fs_2, fs_jpim1   ! vector opt. 
     105#endif 
    94106                  ua(ji,jj,jk) = ua(ji,jj,jk) + spgu(ji,jj) 
    95107                  va(ji,jj,jk) = va(ji,jj,jk) + spgv(ji,jj) 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/DYN/dynspg_flt.F90

    r2715 r3211  
    5656   PUBLIC   flt_rst      ! routine called by istate.F90 
    5757 
     58   !! * Control permutation of array indices 
     59#  include "oce_ftrans.h90" 
     60#  include "dom_oce_ftrans.h90" 
     61#  include "zdf_oce_ftrans.h90" 
     62#  include "sbc_oce_ftrans.h90" 
     63#  include "obc_oce_ftrans.h90" 
     64#  include "domvvl_ftrans.h90" 
     65 
    5866   !! * Substitutions 
    5967#  include "domzgr_substitute.h90" 
    … …  
    104112      !!--------------------------------------------------------------------- 
    105113      USE oce, ONLY:   zub   => ta , zvb   => sa   ! (ta,sa) used as workspace 
     114      !! DCSE_NEMO: need additional directives for renamed module variables 
     115!FTRANS zub :I :I :z 
     116!FTRANS zvb :I :I :z 
    106117      !! 
    107118      INTEGER, INTENT(in   ) ::   kt       ! ocean time-step index 
    … …  
    138149         ! 
    139150         IF( ln_dynadv_vec ) THEN      ! vector form : applied on velocity 
     151#if defined key_z_first 
     152            DO jj = 2, jpjm1 
     153               DO ji = 2, jpim1 
     154                  DO jk = 1, jpkm1 
     155#else 
    140156            DO jk = 1, jpkm1 
    141157               DO jj = 2, jpjm1 
    142158                  DO ji = fs_2, fs_jpim1   ! vector opt. 
     159#endif 
    143160                     ua(ji,jj,jk) = (  ub(ji,jj,jk) + z2dt * ua(ji,jj,jk)  ) * umask(ji,jj,jk) 
    144161                     va(ji,jj,jk) = (  vb(ji,jj,jk) + z2dt * va(ji,jj,jk)  ) * vmask(ji,jj,jk) 
    … …  
    148165            ! 
    149166         ELSE                          ! flux form : applied on thickness weighted velocity 
     167#if defined key_z_first 
     168            DO jj = 2, jpjm1 
     169               DO ji = 2, jpim1 
     170                  DO jk = 1, jpkm1 
     171#else 
    150172            DO jk = 1, jpkm1 
    151173               DO jj = 2, jpjm1 
    152174                  DO ji = fs_2, fs_jpim1   ! vector opt. 
     175#endif 
    153176                     ua(ji,jj,jk) = (        ub(ji,jj,jk) * fse3u_b(ji,jj,jk)      & 
    154177                        &           + z2dt * ua(ji,jj,jk) * fse3u_n(ji,jj,jk)  )   & 
    … …  
    171194            END DO  
    172195         END DO  
     196#if defined key_z_first 
     197         DO jj = 2, jpjm1              ! unweighted time stepping  
     198            DO ji = 2, jpim1 
     199               DO jk = 1, jpkm1 
     200#else 
    173201         DO jk = 1, jpkm1              ! unweighted time stepping  
    174202            DO jj = 2, jpjm1 
    175203               DO ji = fs_2, fs_jpim1   ! vector opt. 
     204#endif 
    176205                  ua(ji,jj,jk) = (  ub(ji,jj,jk) + z2dt * ( ua(ji,jj,jk) + spgu(ji,jj) )  ) * umask(ji,jj,jk) 
    177206                  va(ji,jj,jk) = (  vb(ji,jj,jk) + z2dt * ( va(ji,jj,jk) + spgv(ji,jj) )  ) * vmask(ji,jj,jk) 
    … …  
    214243         END DO 
    215244      ELSE                        ! No  vector opt. 
     245#if defined key_z_first 
     246         DO jj = 2, jpjm1 
     247            DO ji = 2, jpim1 
     248               DO jk = 1, jpkm1 
     249#else 
    216250         DO jk = 1, jpkm1 
    217251            DO jj = 2, jpjm1 
    218252               DO ji = 2, jpim1 
     253#endif 
    219254                  spgu(ji,jj) = spgu(ji,jj) + fse3u(ji,jj,jk) * ua(ji,jj,jk) 
    220255                  spgv(ji,jj) = spgv(ji,jj) + fse3v(ji,jj,jk) * va(ji,jj,jk) 
    … …  
    333368      !                       trend, the leap-frog time stepping will not 
    334369      !                       be done in dynnxt.F90 routine) 
     370#if defined key_z_first 
     371      DO jj = 2, jpjm1 
     372         DO ji = 2, jpim1 
     373            DO jk = 1, jpkm1 
     374#else 
    335375      DO jk = 1, jpkm1 
    336376         DO jj = 2, jpjm1 
    337377            DO ji = fs_2, fs_jpim1   ! vector opt. 
     378#endif 
    338379               ua(ji,jj,jk) = ( ua(ji,jj,jk) + spgu(ji,jj) ) * umask(ji,jj,jk) 
    339380               va(ji,jj,jk) = ( va(ji,jj,jk) + spgv(ji,jj) ) * vmask(ji,jj,jk) 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/DYN/dynspg_ts.F90

    r2724 r3211  
    5757   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   ub_b, vb_b   ! before averaged velocity 
    5858 
     59   !! * Control permutation of array indices 
     60#  include "oce_ftrans.h90" 
     61#  include "dom_oce_ftrans.h90" 
     62#  include "sbc_oce_ftrans.h90" 
     63#  include "domvvl_ftrans.h90" 
     64#  include "obc_oce_ftrans.h90" 
     65#  include "zdf_oce_ftrans.h90" 
     66 
    5967   !! * Substitutions 
    6068#  include "domzgr_substitute.h90" 
    … …  
    179187      zva(:,:) = 0.e0   ;   zvn(:,:) = 0.e0   ;   vb_b(:,:) = 0.e0 
    180188      ! 
     189#if defined key_z_first 
     190      DO jj = 1, jpj 
     191         DO ji = 1, jpi 
     192            DO jk = 1, jpkm1 
     193#else 
    181194      DO jk = 1, jpkm1 
    182195#if defined key_vectopt_loop 
    … …  
    186199         DO jj = 1, jpj 
    187200            DO ji = 1, jpi 
     201#endif 
    188202#endif 
    189203               !                                                                              ! now trend 
    … …  
    206220 
    207221      !                                   !* baroclinic momentum trend (remove the vertical mean trend) 
     222#if defined key_z_first 
     223      DO jj = 2, jpjm1 
     224         DO ji = 2, jpim1 
     225            DO jk = 1, jpkm1 
     226#else 
    208227      DO jk = 1, jpkm1                    ! -------------------------- 
    209228         DO jj = 2, jpjm1 
    210229            DO ji = fs_2, fs_jpim1   ! vector opt. 
     230#endif 
    211231               ua(ji,jj,jk) = ua(ji,jj,jk) - zua(ji,jj) * hur(ji,jj) 
    212232               va(ji,jj,jk) = va(ji,jj,jk) - zva(ji,jj) * hvr(ji,jj) 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/DYN/dynvor.F90

    r2715 r3211  
    5252   INTEGER ::   ntot = 4   ! =4 total vorticity (relative + planetary) ; =5 coriolis + metric term 
    5353 
     54   !! * Control permutation of array indices 
     55#  include "oce_ftrans.h90" 
     56#  include "dom_oce_ftrans.h90" 
     57 
    5458   !! * Substitutions 
    5559#  include "domzgr_substitute.h90" 
    … …  
    7276      !!---------------------------------------------------------------------- 
    7377      USE oce, ONLY:   ztrdu => ta , ztrdv => sa   ! (ta,sa) used as 3D workspace 
     78      !! DCSE_NEMO: need additional directives for renamed module variables 
     79!FTRANS ztrdu :I :I :z 
     80!FTRANS ztrdv :I :I :z 
     81 
    7482      ! 
    7583      INTEGER, INTENT( in ) ::   kt   ! ocean time-step index 
    … …  
    210218      INTEGER , INTENT(in   )                         ::   kvor   ! =ncor (planetary) ; =ntot (total) ; 
    211219      !                                                           ! =nrvm (relative vorticity or metric) 
    212       REAL(wp), INTENT(inout), DIMENSION(jpi,jpj,jpk) ::   pua    ! total u-trend 
    213       REAL(wp), INTENT(inout), DIMENSION(jpi,jpj,jpk) ::   pva    ! total v-trend 
     220!FTRANS pua :I :I :z 
     221!FTRANS pva :I :I :z 
     222!! DCSE_NEMO: work around a deficiency in ftrans 
     223!     REAL(wp), INTENT(inout), DIMENSION(jpi,jpj,jpk) ::   pua    ! total u-trend 
     224!     REAL(wp), INTENT(inout), DIMENSION(jpi,jpj,jpk) ::   pva    ! total v-trend 
     225      REAL(wp), INTENT(inout) ::   pua(jpi,jpj,jpk)    ! total u-trend 
     226      REAL(wp), INTENT(inout) ::   pva(jpi,jpj,jpk)    ! total v-trend 
    214227      ! 
    215228      INTEGER  ::   ji, jj, jk   ! dummy loop indices 
    … …  
    441454      INTEGER , INTENT(in   )                         ::   kvor   ! =ncor (planetary) ; =ntot (total) ; 
    442455         !                                                        ! =nrvm (relative vorticity or metric) 
    443       REAL(wp), INTENT(inout), DIMENSION(jpi,jpj,jpk) ::   pua    ! total u-trend 
    444       REAL(wp), INTENT(inout), DIMENSION(jpi,jpj,jpk) ::   pva    ! total v-trend 
     456!FTRANS pua :I :I :z 
     457!FTRANS pva :I :I :z 
     458!! DCSE_NEMO: work around a deficiency in ftrans 
     459!     REAL(wp), INTENT(inout), DIMENSION(jpi,jpj,jpk) ::   pua    ! total u-trend 
     460!     REAL(wp), INTENT(inout), DIMENSION(jpi,jpj,jpk) ::   pva    ! total v-trend 
     461      REAL(wp), INTENT(inout) ::   pua(jpi,jpj,jpk)    ! total u-trend 
     462      REAL(wp), INTENT(inout) ::   pva(jpi,jpj,jpk)    ! total v-trend 
    445463      ! 
    446464      INTEGER  ::   ji, jj, jk           ! dummy loop indices 
    … …  
    552570      USE wrk_nemo, ONLY:   ztsw => wrk_2d_6 , ztse => wrk_2d_7 
    553571#if defined key_vvl 
     572!FTRANS ze3f :I :I :z 
    554573      USE wrk_nemo, ONLY:   ze3f => wrk_3d_1                                           ! 3D workspace (lk_vvl=T) 
    555574#endif 
    … …  
    558577      INTEGER , INTENT(in   )                         ::   kvor   ! =ncor (planetary) ; =ntot (total) ; 
    559578      !                                                           ! =nrvm (relative vorticity or metric) 
    560       REAL(wp), INTENT(inout), DIMENSION(jpi,jpj,jpk) ::   pua    ! total u-trend 
    561       REAL(wp), INTENT(inout), DIMENSION(jpi,jpj,jpk) ::   pva    ! total v-trend 
     579!FTRANS pua :I :I :z 
     580!FTRANS pva :I :I :z 
     581!! DCSE_NEMO: work around a deficiency in ftrans 
     582!     REAL(wp), INTENT(inout), DIMENSION(jpi,jpj,jpk) ::   pua    ! total u-trend 
     583!     REAL(wp), INTENT(inout), DIMENSION(jpi,jpj,jpk) ::   pva    ! total v-trend 
     584      REAL(wp), INTENT(inout) ::   pua(jpi,jpj,jpk)    ! total u-trend 
     585      REAL(wp), INTENT(inout) ::   pva(jpi,jpj,jpk)   ! total v-trend 
    562586      !! 
    563587      INTEGER  ::   ji, jj, jk         ! dummy loop indices 
    … …  
    565589      REAL(wp) ::   zfac12, zua, zva   ! local scalars 
    566590#if ! defined key_vvl 
     591!FTRANS ze3f :I :I :z 
    567592      REAL(wp), ALLOCATABLE, DIMENSION(:,:,:), SAVE ::   ze3f     ! lk_vvl=F, ze3f=1/e3f saved one for all 
    568593#endif 
    … …  
    599624      zfac12 = 1._wp / 12._wp    ! Local constant initialization 
    600625 
    601        
    602626!CDIR PARALLEL DO PRIVATE( zwx, zwy, zwz, ztnw, ztne, ztsw, ztse ) 
    603627      !                                                ! =============== 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/DYN/dynzad.F90

    r2715 r3211  
    2626    
    2727   PUBLIC   dyn_zad   ! routine called by step.F90 
     28 
     29   !! * Control permutation of array indices 
     30#  include "oce_ftrans.h90" 
     31#  include "dom_oce_ftrans.h90" 
     32#  include "sbc_oce_ftrans.h90" 
    2833 
    2934   !! * Substitutions 
    … …  
    5762      USE oce     , ONLY:   zwuw  => ta       , zwvw  => sa          ! (ta,sa) used as 3D workspace 
    5863      USE wrk_nemo, ONLY:   ztrdu => wrk_3d_1 , ztrdv => wrk_3d_2    ! 3D workspace 
     64      !! DCSE_NEMO: need additional directives for renamed module variables 
     65!FTRANS zwuw  :I :I :z 
     66!FTRANS zwvw  :I :I :z 
     67!FTRANS ztrdu :I :I :z 
     68!FTRANS ztrdv :I :I :z 
    5969      ! 
    6070      INTEGER, INTENT(in) ::   kt   ! ocean time-step inedx 
    … …  
    7787         ztrdv(:,:,:) = va(:,:,:)  
    7888      ENDIF 
    79        
     89 
     90#if defined key_z_first 
     91      !! DCSE_NEMO: Attention! Eliminate k-dependence from zww to re-order loops 
     92      DO jj = 2, jpj                   ! vertical fluxes  
     93         DO ji = 2, jpi 
     94            zww(ji,jj) = 0.25 * e1t(ji,jj) * e2t(ji,jj) 
     95         END DO 
     96      END DO 
     97      DO jj = 2, jpjm1                 ! vertical momentum advection at w-point 
     98         DO ji = 2, jpim1 
     99            zwuw(ji,jj, 1 ) = 0.e0     ! Surface values set to zero 
     100            zwvw(ji,jj, 1 ) = 0.e0 
     101            DO jk = 2, jpkm1 
     102               zwuw(ji,jj,jk) =   ( zww(ji+1,jj  )*wn(ji+1,jj  ,jk) + zww(ji,jj)*wn(ji,jj,jk) )   & 
     103                  &             * ( un(ji,jj,jk-1)-un(ji,jj,jk) )  
     104               zwvw(ji,jj,jk) =   ( zww(ji  ,jj+1)*wn(ji  ,jj+1,jk) + zww(ji,jj)*wn(ji,jj,jk) )   & 
     105                  &             * ( vn(ji,jj,jk-1)-vn(ji,jj,jk) ) 
     106            END DO   
     107            zwuw(ji,jj,jpk) = 0.e0     ! Bottom values set to zero 
     108            zwvw(ji,jj,jpk) = 0.e0 
     109         END DO    
     110      END DO 
     111#else 
    80112      DO jk = 2, jpkm1              ! Vertical momentum advection at level w and u- and v- vertical 
    81113         DO jj = 2, jpj                   ! vertical fluxes  
    … …  
    99131         END DO   
    100132      END DO 
     133#endif 
    101134 
     135#if defined key_z_first 
     136      DO jj = 2, jpjm1              ! Vertical momentum advection at u- and v-points 
     137         DO ji = 2, jpim1 
     138            DO jk = 1, jpkm1 
     139#else 
    102140      DO jk = 1, jpkm1              ! Vertical momentum advection at u- and v-points 
    103141         DO jj = 2, jpjm1 
    104142            DO ji = fs_2, fs_jpim1       ! vector opt. 
     143#endif 
    105144               !                         ! vertical momentum advective trends 
    106145               zua = - ( zwuw(ji,jj,jk) + zwuw(ji,jj,jk+1) ) / ( e1u(ji,jj) * e2u(ji,jj) * fse3u(ji,jj,jk) ) 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/DYN/dynzdf.F90

    r2715 r3211  
    3535   REAL(wp) ::   r2dt       ! time-step, = 2 rdttra except at nit000 (=rdttra) if neuler=0 
    3636 
     37   !! * Control permutation of array indices 
     38#  include "oce_ftrans.h90" 
     39#  include "dom_oce_ftrans.h90" 
     40#  include "zdf_oce_ftrans.h90" 
     41#  include "ldfdyn_oce_ftrans.h90" 
     42 
    3743   !! * Substitutions 
    3844#  include "domzgr_substitute.h90" 
    … …  
    5561      USE wrk_nemo, ONLY:   wrk_in_use, wrk_not_released 
    5662      USE wrk_nemo, ONLY:   ztrdu => wrk_3d_1 , ztrdv => wrk_3d_2    ! 3D workspace 
     63      !! DCSE_NEMO: need additional directives for renamed module variables 
     64!FTRANS ztrdu :I :I :z 
     65!FTRANS ztrdv :I :I :z 
    5766      !! 
    5867      INTEGER, INTENT( in ) ::   kt      ! ocean time-step index 
    … …  
    112121      USE zdfgls 
    113122      USE zdfkpp 
     123#  include "zdftke_ftrans.h90" 
    114124      !!---------------------------------------------------------------------- 
    115125      ! 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/DYN/dynzdf_exp.F90

    r2715 r3211  
    2727 
    2828   PUBLIC   dyn_zdf_exp   ! called by step.F90 
     29 
     30   !! * Control permutation of array indices 
     31#  include "oce_ftrans.h90" 
     32#  include "dom_oce_ftrans.h90" 
     33#  include "zdf_oce_ftrans.h90" 
     34#  include "sbc_oce_ftrans.h90" 
    2935    
    3036   !! * Substitutions 
    … …  
    5763      USE oce     , ONLY:   zwx => ta       , zwy => sa         ! (ta,sa) used as 3D workspace 
    5864      USE wrk_nemo, ONLY:   zwz => wrk_3d_1 , zww => wrk_3d_2   ! 3D workspace 
     65      !! DCSE_NEMO: need additional directives for renamed module variables 
     66!FTRANS zwx :I :I :z 
     67!FTRANS zwy :I :I :z 
     68!FTRANS zwz :I :I :z 
     69!FTRANS zww :I :I :z 
    5970      ! 
    6071      INTEGER , INTENT(in) ::   kt     ! ocean time-step index 
    … …  
    8596         END DO   
    8697      END DO   
     98#if defined key_z_first 
     99      DO jj = 2, jpjm1                 ! Initialization of x, z and contingently trends array 
     100         DO ji = 2, jpim1 
     101            DO jk = 1, jpk 
     102#else 
    87103      DO jk = 1, jpk                   ! Initialization of x, z and contingently trends array 
    88104         DO jj = 2, jpjm1  
    89105            DO ji = 2, jpim1 
     106#endif 
    90107               zwx(ji,jj,jk) = ub(ji,jj,jk) 
    91108               zwz(ji,jj,jk) = vb(ji,jj,jk) 
    … …  
    96113      DO jl = 1, nn_zdfexp             ! Time splitting loop 
    97114         ! 
     115#if defined key_z_first 
     116         DO jj = 2, jpjm1  
     117            DO ji = 2, jpim1 
     118               DO jk = 2, jpk                ! First vertical derivative 
     119#else 
    98120         DO jk = 2, jpk                      ! First vertical derivative 
    99121            DO jj = 2, jpjm1  
    100122               DO ji = 2, jpim1 
     123#endif 
    101124                  zwy(ji,jj,jk) = avmu(ji,jj,jk) * ( zwx(ji,jj,jk-1) - zwx(ji,jj,jk) ) / fse3uw(ji,jj,jk)  
    102125                  zww(ji,jj,jk) = avmv(ji,jj,jk) * ( zwz(ji,jj,jk-1) - zwz(ji,jj,jk) ) / fse3vw(ji,jj,jk) 
    … …  
    104127            END DO   
    105128         END DO   
     129#if defined key_z_first 
     130         DO jj = 2, jpjm1  
     131            DO ji = 2, jpim1 
     132               DO jk = 1, jpkm1              ! Second vertical derivative and trend estimation at kt+l*rdt/nn_zdfexp 
     133#else 
    106134         DO jk = 1, jpkm1                    ! Second vertical derivative and trend estimation at kt+l*rdt/nn_zdfexp 
    107135            DO jj = 2, jpjm1  
    108136               DO ji = 2, jpim1 
     137#endif 
    109138                  zua = zlavmr * ( zwy(ji,jj,jk) - zwy(ji,jj,jk+1) ) / fse3u(ji,jj,jk) 
    110139                  zva = zlavmr * ( zww(ji,jj,jk) - zww(ji,jj,jk+1) ) / fse3v(ji,jj,jk) 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/DYN/dynzdf_imp.F90

    r2715 r3211  
    2525 
    2626   PUBLIC   dyn_zdf_imp   ! called by step.F90 
     27 
     28   !! * Control permutation of array indices 
     29#  include "oce_ftrans.h90" 
     30#  include "dom_oce_ftrans.h90" 
     31#  include "sbc_oce_ftrans.h90" 
     32#  include "zdf_oce_ftrans.h90" 
    2733 
    2834   !! * Substitutions 
    … …  
    5763      USE oce     , ONLY:  zwd  => ta       , zws   => sa   ! (ta,sa) used as 3D workspace 
    5864      USE wrk_nemo, ONLY:   zwi => wrk_3d_3                 ! 3D workspace 
     65      !! DCSE_NEMO: need additional directives for renamed module variables 
     66!FTRANS zwd :I :I :z 
     67!FTRANS zws :I :I :z 
     68!FTRANS zwi :I :I :z 
    5969      !! 
    6070      INTEGER , INTENT(in) ::   kt    ! ocean time-step index 
    … …  
    6272      !! 
    6373      INTEGER  ::   ji, jj, jk   ! dummy loop indices 
    64       REAL(wp) ::   z1_p2dt, zcoef, zzwi, zzws, zrhs   ! local scalars 
     74      REAL(wp) ::   z1_p2dt, zcoef, zzwi, zzws, zrhs, zzwibd   ! local scalars 
    6575      !!---------------------------------------------------------------------- 
    6676 
    … …  
    8898      ! is no need to include these in the implicit calculation. 
    8999      ! 
    90       DO jk = 1, jpkm1        ! Matrix 
    91          DO jj = 2, jpjm1  
    92             DO ji = fs_2, fs_jpim1   ! vector opt. 
     100#if defined key_z_first 
     101      DO jj = 2, jpjm1  
     102         DO ji = 2, jpim1 
     103            DO jk = 1, jpkm1 
    93104               zcoef = - p2dt / fse3u(ji,jj,jk) 
    94105               zzwi          = zcoef * avmu (ji,jj,jk  ) / fse3uw(ji,jj,jk  ) 
    … …  
    98109               zwd(ji,jj,jk) = 1._wp - zwi(ji,jj,jk) - zzws 
    99110            END DO 
    100          END DO 
    101       END DO 
    102       DO jj = 2, jpjm1        ! Surface boudary conditions 
    103          DO ji = fs_2, fs_jpim1   ! vector opt. 
     111            ! Surface boundary conditions 
    104112            zwi(ji,jj,1) = 0._wp 
    105113            zwd(ji,jj,1) = 1._wp - zws(ji,jj,1) 
    106114         END DO 
    107115      END DO 
     116#else 
     117      DO jk = 1, jpkm1        ! Matrix 
     118         DO jj = 2, jpjm1  
     119            DO ji = fs_2, fs_jpim1   ! vector opt. 
     120               zcoef = - p2dt / fse3u(ji,jj,jk) 
     121               zzwi          = zcoef * avmu (ji,jj,jk  ) / fse3uw(ji,jj,jk  ) 
     122               zwi(ji,jj,jk) = zzwi  * umask(ji,jj,jk) 
     123               zzws          = zcoef * avmu (ji,jj,jk+1) / fse3uw(ji,jj,jk+1) 
     124               zws(ji,jj,jk) = zzws  * umask(ji,jj,jk+1) 
     125               zwd(ji,jj,jk) = 1._wp - zwi(ji,jj,jk) - zzws 
     126            END DO 
     127         END DO 
     128      END DO 
     129      DO jj = 2, jpjm1        ! Surface boudary conditions 
     130         DO ji = fs_2, fs_jpim1   ! vector opt. 
     131            zwi(ji,jj,1) = 0._wp 
     132            zwd(ji,jj,1) = 1._wp - zws(ji,jj,1) 
     133         END DO 
     134      END DO 
     135#endif 
    108136 
    109137      ! Matrix inversion starting from the first level 
    … …  
    122150      !----------------------------------------------------------------------- 
    123151      ! 
    124       DO jk = 2, jpkm1        !==  First recurrence : Dk = Dk - Lk * Uk-1 / Dk-1   (increasing k)  == 
    125          DO jj = 2, jpjm1    
    126             DO ji = fs_2, fs_jpim1   ! vector opt. 
    127                zwd(ji,jj,jk) = zwd(ji,jj,jk) - zwi(ji,jj,jk) * zws(ji,jj,jk-1) / zwd(ji,jj,jk-1) 
    128             END DO 
    129          END DO 
    130       END DO 
    131       ! 
    132       DO jj = 2, jpjm1        !==  second recurrence:    SOLk = RHSk - Lk / Dk-1  Lk-1  == 
    133          DO ji = fs_2, fs_jpim1   ! vector opt. 
     152#if defined key_z_first 
     153      DO jj = 2, jpjm1  
     154         DO ji = 2, jpim1 
     155            !== Do first and second recurrences in the same loop 
    134156            ua(ji,jj,1) = ub(ji,jj,1) + p2dt * (  ua(ji,jj,1) + 0.5_wp * ( utau_b(ji,jj) + utau(ji,jj) )   & 
    135157               &                                                       / ( fse3u(ji,jj,1) * rau0       )  ) 
     158            DO jk = 2, jpkm1 
     159               zzwibd = zwi(ji,jj,jk) / zwd(ji,jj,jk-1) 
     160               !==  First recurrence : Dk = Dk - Lk * Uk-1 / Dk-1   (increasing k)  == 
     161               zwd(ji,jj,jk) = zwd(ji,jj,jk) - zzwibd * zws(ji,jj,jk-1) 
     162               !==  second recurrence:    SOLk = RHSk - Lk / Dk-1  Lk-1  == 
     163               zrhs = ub(ji,jj,jk) + p2dt * ua(ji,jj,jk)   ! zrhs=right hand side 
     164               ua(ji,jj,jk) = zrhs - zzwibd * ua(ji,jj,jk-1) 
     165            END DO 
     166            !==  third recurrence : SOLk = ( Lk - Uk * Ek+1 ) / Dk  == 
     167            ua(ji,jj,jpkm1) = ua(ji,jj,jpkm1) / zwd(ji,jj,jpkm1) 
     168            DO jk = jpk-2, 1, -1 
     169               ua(ji,jj,jk) = ( ua(ji,jj,jk) - zws(ji,jj,jk) * ua(ji,jj,jk+1) ) / zwd(ji,jj,jk) 
     170            END DO 
     171            ! Normalization to obtain the general momentum trend ua 
     172            DO jk = 1, jpkm1 
     173               ua(ji,jj,jk) = ( ua(ji,jj,jk) - ub(ji,jj,jk) ) * z1_p2dt 
     174            END DO 
     175         END DO 
     176      END DO 
     177#else 
     178      DO jk = 2, jpkm1        !==  First recurrence : Dk = Dk - Lk * Uk-1 / Dk-1   (increasing k)  == 
     179         DO jj = 2, jpjm1    
     180            DO ji = fs_2, fs_jpim1   ! vector opt. 
     181               zwd(ji,jj,jk) = zwd(ji,jj,jk) - zwi(ji,jj,jk) * zws(ji,jj,jk-1) / zwd(ji,jj,jk-1) 
     182            END DO 
     183         END DO 
     184      END DO 
     185      ! 
     186      DO jj = 2, jpjm1        !==  second recurrence:    SOLk = RHSk - Lk / Dk-1  Lk-1  == 
     187         DO ji = fs_2, fs_jpim1   ! vector opt. 
     188            ua(ji,jj,1) = ub(ji,jj,1) + p2dt * (  ua(ji,jj,1) + 0.5_wp * ( utau_b(ji,jj) + utau(ji,jj) )   & 
     189               &                                                       / ( fse3u(ji,jj,1) * rau0       )  ) 
    136190         END DO 
    137191      END DO 
    … …  
    145199      END DO 
    146200      ! 
    147       DO jj = 2, jpjm1        !==  thrid recurrence : SOLk = ( Lk - Uk * Ek+1 ) / Dk  == 
     201      DO jj = 2, jpjm1        !==  third recurrence : SOLk = ( Lk - Uk * Ek+1 ) / Dk  == 
    148202         DO ji = fs_2, fs_jpim1   ! vector opt. 
    149203            ua(ji,jj,jpkm1) = ua(ji,jj,jpkm1) / zwd(ji,jj,jpkm1) 
    … …  
    157211         END DO 
    158212      END DO 
    159  
    160213      ! Normalization to obtain the general momentum trend ua 
    161214      DO jk = 1, jpkm1 
    … …  
    166219         END DO 
    167220      END DO 
    168  
     221#endif 
    169222 
    170223      ! 2. Vertical diffusion on v 
    … …  
    177230      ! is no need to include these in the implicit calculation. 
    178231      ! 
    179       DO jk = 1, jpkm1        ! Matrix 
    180          DO jj = 2, jpjm1    
    181             DO ji = fs_2, fs_jpim1   ! vector opt. 
     232#if defined key_z_first 
     233      DO jj = 2, jpjm1    
     234         DO ji = 2, jpim1 
     235            DO jk = 1, jpkm1        ! Matrix 
    182236               zcoef = -p2dt / fse3v(ji,jj,jk) 
    183237               zzwi          = zcoef * avmv (ji,jj,jk  ) / fse3vw(ji,jj,jk  ) 
    … …  
    187241               zwd(ji,jj,jk) = 1._wp - zwi(ji,jj,jk) - zzws 
    188242            END DO 
    189          END DO 
    190       END DO 
    191       DO jj = 2, jpjm1        ! Surface boudary conditions 
    192          DO ji = fs_2, fs_jpim1   ! vector opt. 
     243            ! Surface boundary conditions 
    193244            zwi(ji,jj,1) = 0._wp 
    194245            zwd(ji,jj,1) = 1._wp - zws(ji,jj,1) 
    195246         END DO 
    196247      END DO 
     248#else 
     249      DO jk = 1, jpkm1        ! Matrix 
     250         DO jj = 2, jpjm1    
     251            DO ji = fs_2, fs_jpim1   ! vector opt. 
     252               zcoef = -p2dt / fse3v(ji,jj,jk) 
     253               zzwi          = zcoef * avmv (ji,jj,jk  ) / fse3vw(ji,jj,jk  ) 
     254               zwi(ji,jj,jk) =  zzwi * vmask(ji,jj,jk) 
     255               zzws          = zcoef * avmv (ji,jj,jk+1) / fse3vw(ji,jj,jk+1) 
     256               zws(ji,jj,jk) =  zzws * vmask(ji,jj,jk+1) 
     257               zwd(ji,jj,jk) = 1._wp - zwi(ji,jj,jk) - zzws 
     258            END DO 
     259         END DO 
     260      END DO 
     261      DO jj = 2, jpjm1        ! Surface boudary conditions 
     262         DO ji = fs_2, fs_jpim1   ! vector opt. 
     263            zwi(ji,jj,1) = 0._wp 
     264            zwd(ji,jj,1) = 1._wp - zws(ji,jj,1) 
     265         END DO 
     266      END DO 
     267#endif 
    197268 
    198269      ! Matrix inversion 
    … …  
    211282      !----------------------------------------------------------------------- 
    212283      ! 
    213       DO jk = 2, jpkm1        !==  First recurrence : Dk = Dk - Lk * Uk-1 / Dk-1   (increasing k)  == 
    214          DO jj = 2, jpjm1    
    215             DO ji = fs_2, fs_jpim1   ! vector opt. 
    216                zwd(ji,jj,jk) = zwd(ji,jj,jk) - zwi(ji,jj,jk) * zws(ji,jj,jk-1) / zwd(ji,jj,jk-1) 
    217             END DO 
    218          END DO 
    219       END DO 
    220       ! 
    221       DO jj = 2, jpjm1        !==  second recurrence:    SOLk = RHSk - Lk / Dk-1  Lk-1  == 
    222          DO ji = fs_2, fs_jpim1   ! vector opt. 
     284#if defined key_z_first 
     285      DO jj = 2, jpjm1    
     286         DO ji = 2, jpim1 
     287            !== Do first and second recurrences in the same loop 
    223288            va(ji,jj,1) = vb(ji,jj,1) + p2dt * (  va(ji,jj,1) + 0.5_wp * ( vtau_b(ji,jj) + vtau(ji,jj) )   & 
    224289               &                                                       / ( fse3v(ji,jj,1) * rau0       )  ) 
     290            DO jk = 2, jpkm1 
     291               zzwibd = zwi(ji,jj,jk) / zwd(ji,jj,jk-1) 
     292               !==  First recurrence : Dk = Dk - Lk * Uk-1 / Dk-1   (increasing k)  == 
     293               zwd(ji,jj,jk) = zwd(ji,jj,jk) - zzwibd * zws(ji,jj,jk-1) 
     294               !==  second recurrence:    SOLk = RHSk - Lk / Dk-1  Lk-1  == 
     295               zrhs = vb(ji,jj,jk) + p2dt * va(ji,jj,jk)   ! zrhs=right hand side 
     296               va(ji,jj,jk) = zrhs - zzwibd * va(ji,jj,jk-1) 
     297            END DO 
     298            !==  third recurrence : SOLk = ( Lk - Uk * SOLk+1 ) / Dk  == 
     299            va(ji,jj,jpkm1) = va(ji,jj,jpkm1) / zwd(ji,jj,jpkm1) 
     300            DO jk = jpk-2, 1, -1 
     301               va(ji,jj,jk) = ( va(ji,jj,jk) - zws(ji,jj,jk) * va(ji,jj,jk+1) ) / zwd(ji,jj,jk) 
     302            END DO 
     303            ! Normalization to obtain the general momentum trend va 
     304            DO jk = 1, jpkm1 
     305               va(ji,jj,jk) = ( va(ji,jj,jk) - vb(ji,jj,jk) ) * z1_p2dt 
     306            END DO 
     307         END DO 
     308      END DO 
     309#else 
     310      DO jk = 2, jpkm1        !==  First recurrence : Dk = Dk - Lk * Uk-1 / Dk-1   (increasing k)  == 
     311         DO jj = 2, jpjm1    
     312            DO ji = fs_2, fs_jpim1   ! vector opt. 
     313               zwd(ji,jj,jk) = zwd(ji,jj,jk) - zwi(ji,jj,jk) * zws(ji,jj,jk-1) / zwd(ji,jj,jk-1) 
     314            END DO 
     315         END DO 
     316      END DO 
     317      ! 
     318      DO jj = 2, jpjm1        !==  second recurrence:    SOLk = RHSk - Lk / Dk-1  Lk-1  == 
     319         DO ji = fs_2, fs_jpim1   ! vector opt. 
     320            va(ji,jj,1) = vb(ji,jj,1) + p2dt * (  va(ji,jj,1) + 0.5_wp * ( vtau_b(ji,jj) + vtau(ji,jj) )   & 
     321               &                                                       / ( fse3v(ji,jj,1) * rau0       )  ) 
    225322         END DO 
    226323      END DO 
    … …  
    234331      END DO 
    235332      ! 
    236       DO jj = 2, jpjm1        !==  thrid recurrence : SOLk = ( Lk - Uk * SOLk+1 ) / Dk  == 
     333      DO jj = 2, jpjm1        !==  third recurrence : SOLk = ( Lk - Uk * SOLk+1 ) / Dk  == 
    237334         DO ji = fs_2, fs_jpim1   ! vector opt. 
    238335            va(ji,jj,jpkm1) = va(ji,jj,jpkm1) / zwd(ji,jj,jpkm1) 
    … …  
    255352         END DO 
    256353      END DO 
     354#endif 
    257355      ! 
    258356      IF( wrk_not_released(3, 3) )   CALL ctl_stop('dyn_zdf_imp: failed to release workspace array') 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/DYN/sshwzv.F90

    r2715 r3211  
    4646   PUBLIC   ssh_nxt    ! called by step.F90 
    4747 
     48   !! * Control permutation of array indices 
     49#  include "oce_ftrans.h90" 
     50#  include "dom_oce_ftrans.h90" 
     51#  include "sbc_oce_ftrans.h90" 
     52#  include "domvvl_ftrans.h90" 
     53#  include "obc_oce_ftrans.h90" 
     54#if defined key_asminc  
     55#  include "asminc_ftrans.h90" 
     56#endif 
     57 
    4858   !! * Substitutions 
    4959#  include "domzgr_substitute.h90" 
    … …  
    7888      USE oce     , ONLY:   z3d   => ta                           ! ta used as 3D workspace 
    7989      USE wrk_nemo, ONLY:   zhdiv => wrk_2d_1 , z2d => wrk_2d_2   ! 2D workspace 
     90      !! DCSE_NEMO: need additional directives for renamed module variables 
     91!FTRANS z3d :I :I :z 
    8092      ! 
    8193      INTEGER, INTENT(in) ::   kt   ! time step 
    … …  
    100112            DO jj = 1, jpjm1 
    101113               DO ji = 1, jpim1                    ! caution: use of Vector Opt. not possible 
     114#if defined key_z_first 
     115                  zcoefu = 0.5  * umask_1(ji,jj) / ( e1u(ji,jj) * e2u(ji,jj) ) 
     116                  zcoefv = 0.5  * vmask_1(ji,jj) / ( e1v(ji,jj) * e2v(ji,jj) ) 
     117                  zcoeff = 0.25 * umask_1(ji,jj) * umask_1(ji,jj+1) 
     118#else 
    102119                  zcoefu = 0.5  * umask(ji,jj,1) / ( e1u(ji,jj) * e2u(ji,jj) ) 
    103120                  zcoefv = 0.5  * vmask(ji,jj,1) / ( e1v(ji,jj) * e2v(ji,jj) ) 
    104121                  zcoeff = 0.25 * umask(ji,jj,1) * umask(ji,jj+1,1) 
     122#endif 
    105123                  sshu_b(ji,jj) = zcoefu * ( e1t(ji  ,jj) * e2t(ji  ,jj) * sshb(ji  ,jj)     & 
    106124                     &                     + e1t(ji+1,jj) * e2t(ji+1,jj) * sshb(ji+1,jj) ) 
    … …  
    117135            DO jj = 1, jpjm1 
    118136               DO ji = 1, jpim1      ! NO Vector Opt. 
     137#if defined key_z_first 
     138                  sshf_n(ji,jj) = 0.5  * umask_1(ji,jj) * umask_1(ji,jj+1)                   & 
     139                       &               / ( e1f(ji,jj  ) * e2f(ji,jj  ) )                     & 
     140                       &               * ( e1u(ji,jj  ) * e2u(ji,jj  ) * sshu_n(ji,jj  )     & 
     141                       &                 + e1u(ji,jj+1) * e2u(ji,jj+1) * sshu_n(ji,jj+1) ) 
     142#else 
    119143                  sshf_n(ji,jj) = 0.5  * umask(ji,jj,1) * umask(ji,jj+1,1)                   & 
    120144                       &               / ( e1f(ji,jj  ) * e2f(ji,jj  ) )                     & 
    121145                       &               * ( e1u(ji,jj  ) * e2u(ji,jj  ) * sshu_n(ji,jj  )     & 
    122146                       &                 + e1u(ji,jj+1) * e2u(ji,jj+1) * sshu_n(ji,jj+1) ) 
     147#endif 
    123148               END DO 
    124149            END DO 
    … …  
    131156      IF( lk_vvl ) THEN                           !  Regridding: Update Now Vertical coord.  !   (only in vvl case) 
    132157         !                                        !------------------------------------------! 
     158#if defined key_z_first 
     159         fsdept(:,:,1:jpkm1) = fsdept_n(:,:,1:jpkm1)   ! now local depths stored in fsdep. arrays 
     160         fsdepw(:,:,1:jpkm1) = fsdepw_n(:,:,1:jpkm1) 
     161         fsde3w(:,:,1:jpkm1) = fsde3w_n(:,:,1:jpkm1) 
     162         ! 
     163         fse3t (:,:,1:jpkm1) = fse3t_n (:,:,1:jpkm1)   ! vertical scale factors stored in fse3. arrays 
     164         fse3u (:,:,1:jpkm1) = fse3u_n (:,:,1:jpkm1) 
     165         fse3v (:,:,1:jpkm1) = fse3v_n (:,:,1:jpkm1) 
     166         fse3f (:,:,1:jpkm1) = fse3f_n (:,:,1:jpkm1) 
     167         fse3w (:,:,1:jpkm1) = fse3w_n (:,:,1:jpkm1) 
     168         fse3uw(:,:,1:jpkm1) = fse3uw_n(:,:,1:jpkm1) 
     169         fse3vw(:,:,1:jpkm1) = fse3vw_n(:,:,1:jpkm1) 
     170#else 
    133171         DO jk = 1, jpkm1 
    134172            fsdept(:,:,jk) = fsdept_n(:,:,jk)         ! now local depths stored in fsdep. arrays 
    … …  
    144182            fse3vw(:,:,jk) = fse3vw_n(:,:,jk) 
    145183         END DO 
     184#endif 
    146185         ! 
    147186         hu(:,:) = hu_0(:,:) + sshu_n(:,:)            ! now ocean depth (at u- and v-points) 
    148187         hv(:,:) = hv_0(:,:) + sshv_n(:,:) 
    149188         !                                            ! now masked inverse of the ocean depth (at u- and v-points) 
     189#if defined key_z_first 
     190         hur(:,:) = umask_1(:,:) / ( hu(:,:) + 1._wp - umask_1(:,:) ) 
     191         hvr(:,:) = vmask_1(:,:) / ( hv(:,:) + 1._wp - vmask_1(:,:) ) 
     192#else 
    150193         hur(:,:) = umask(:,:,1) / ( hu(:,:) + 1._wp - umask(:,:,1) ) 
    151194         hvr(:,:) = vmask(:,:,1) / ( hv(:,:) + 1._wp - vmask(:,:,1) ) 
     195#endif 
    152196         !  
    153197      ENDIF 
    … …  
    162206      !                                           !------------------------------! 
    163207      zhdiv(:,:) = 0._wp 
     208#if defined key_z_first 
     209      DO jj = 1, jpj 
     210         DO ji = 1, jpi 
     211            DO jk = 1, jpkm1                           ! Horizontal divergence of barotropic transports 
     212               zhdiv(ji,jj) = zhdiv(ji,jj) + fse3t(ji,jj,jk) * hdivn(ji,jj,jk) 
     213            END DO 
     214         END DO 
     215      END DO 
     216#else 
    164217      DO jk = 1, jpkm1                                 ! Horizontal divergence of barotropic transports 
    165218        zhdiv(:,:) = zhdiv(:,:) + fse3t(:,:,jk) * hdivn(:,:,jk) 
    166219      END DO 
     220#endif 
    167221      !                                                ! Sea surface elevation time stepping 
    168222      ! In forward Euler time stepping case, the same formulation as in the leap-frog case can be used 
    169223      ! because emp_b field is initialized with the vlaues of emp field. Hence, 0.5 * ( emp + emp_b ) = emp 
    170224      z1_rau0 = 0.5 / rau0 
     225#if defined key_z_first 
     226      ssha(:,:) = (  sshb(:,:) - z2dt * ( z1_rau0 * ( emp_b(:,:) + emp(:,:) ) + zhdiv(:,:) )  ) * tmask_1(:,:) 
     227#else 
    171228      ssha(:,:) = (  sshb(:,:) - z2dt * ( z1_rau0 * ( emp_b(:,:) + emp(:,:) ) + zhdiv(:,:) )  ) * tmask(:,:,1) 
     229#endif 
    172230 
    173231#if defined key_agrif 
    … …  
    189247         DO jj = 1, jpjm1 
    190248            DO ji = 1, jpim1      ! NO Vector Opt. 
     249#if defined key_z_first 
     250               sshu_a(ji,jj) = 0.5  * umask_1(ji,jj) / ( e1u(ji  ,jj) * e2u(ji  ,jj) )                   & 
     251                  &                                  * ( e1t(ji  ,jj) * e2t(ji  ,jj) * ssha(ji  ,jj)     & 
     252                  &                                    + e1t(ji+1,jj) * e2t(ji+1,jj) * ssha(ji+1,jj) ) 
     253               sshv_a(ji,jj) = 0.5  * vmask_1(ji,jj) / ( e1v(ji,jj  ) * e2v(ji,jj  ) )                   & 
     254                  &                                  * ( e1t(ji,jj  ) * e2t(ji,jj  ) * ssha(ji,jj  )     & 
     255                  &                                    + e1t(ji,jj+1) * e2t(ji,jj+1) * ssha(ji,jj+1) ) 
     256#else 
    191257               sshu_a(ji,jj) = 0.5  * umask(ji,jj,1) / ( e1u(ji  ,jj) * e2u(ji  ,jj) )                   & 
    192258                  &                                  * ( e1t(ji  ,jj) * e2t(ji  ,jj) * ssha(ji  ,jj)     & 
    … …  
    195261                  &                                  * ( e1t(ji,jj  ) * e2t(ji,jj  ) * ssha(ji,jj  )     & 
    196262                  &                                    + e1t(ji,jj+1) * e2t(ji,jj+1) * ssha(ji,jj+1) ) 
     263#endif 
    197264            END DO 
    198265         END DO 
    … …  
    212279      !                                           !------------------------------! 
    213280      z1_2dt = 1.e0 / z2dt 
     281#if defined key_z_first 
     282      DO jj = 1, jpj 
     283         DO ji = 1, jpi 
     284            DO jk = jpkm1, 1, -1                      ! integrate from the bottom the hor. divergence 
     285                wn(ji,jj,jk) = wn(ji,jj,jk+1)                               & 
     286                   &         -   fse3t_n(ji,jj,jk) * hdivn(ji,jj,jk)        & 
     287                   &         - ( fse3t_a(ji,jj,jk) - fse3t_b(ji,jj,jk) )    & 
     288                   &            * tmask(ji,jj,jk) * z1_2dt 
     289#if defined key_bdy 
     290                wn(ji,jj,jk) = wn(ji,jj,jk) * bdytmask(ji,jj) 
     291#endif 
     292            END DO 
     293         END DO 
     294      END DO 
     295#else 
    214296      DO jk = jpkm1, 1, -1                             ! integrate from the bottom the hor. divergence 
    215297         ! - ML - need 3 lines here because replacement of fse3t by its expression yields too long lines otherwise 
    … …  
    221303#endif 
    222304      END DO 
     305#endif 
    223306 
    224307      !                                           !------------------------------! 
    … …  
    231314         ! Caution: in the VVL case, it only correponds to the baroclinic mass transport. 
    232315         z2d(:,:) = rau0 * e1t(:,:) * e2t(:,:) 
     316#if defined key_z_first 
     317         DO jj = 1, jpj 
     318            DO ji = 1, jpi 
     319               DO jk = 1, jpk 
     320                  z3d(ji,jj,jk) = wn(ji,jj,jk) * z2d(ji,jj) 
     321               END DO 
     322            END DO 
     323         END DO 
     324#else 
    233325         DO jk = 1, jpk 
    234326            z3d(:,:,jk) = wn(:,:,jk) * z2d(:,:) 
    235327         END DO 
     328#endif 
    236329         CALL iom_put( "w_masstr" , z3d                     )   
    237330         CALL iom_put( "w_masstr2", z3d(:,:,:) * z3d(:,:,:) ) 
    … …  
    286379            DO jj = 1, jpjm1                                ! ssh now at f-point 
    287380               DO ji = 1, jpim1      ! NO Vector Opt. 
     381#if defined key_z_first 
     382                  sshf_n(ji,jj) = 0.5  * umask_1(ji,jj) * umask_1(ji,jj+1)                 & 
     383                     &               / ( e1f(ji,jj  ) * e2f(ji,jj  ) )                     & 
     384                     &               * ( e1u(ji,jj  ) * e2u(ji,jj  ) * sshu_n(ji,jj  )     & 
     385                     &                 + e1u(ji,jj+1) * e2u(ji,jj+1) * sshu_n(ji,jj+1) ) 
     386#else 
    288387                  sshf_n(ji,jj) = 0.5  * umask(ji,jj,1) * umask(ji,jj+1,1)                 & 
    289388                     &               / ( e1f(ji,jj  ) * e2f(ji,jj  ) )                     & 
    290389                     &               * ( e1u(ji,jj  ) * e2u(ji,jj  ) * sshu_n(ji,jj  )     & 
    291390                     &                 + e1u(ji,jj+1) * e2u(ji,jj+1) * sshu_n(ji,jj+1) ) 
     391#endif 
    292392               END DO 
    293393            END DO 
    … …  
    298398            DO jj = 1, jpj 
    299399               DO ji = 1, jpi                               ! before <-- now filtered 
     400#if defined key_z_first 
     401                  sshb  (ji,jj) = sshn  (ji,jj) + atfp * ( sshb(ji,jj) - 2 * sshn(ji,jj) + ssha(ji,jj) )   & 
     402                     &                          - zec  * ( emp_b(ji,jj) - emp(ji,jj) ) * tmask_1(ji,jj) 
     403#else 
    300404                  sshb  (ji,jj) = sshn  (ji,jj) + atfp * ( sshb(ji,jj) - 2 * sshn(ji,jj) + ssha(ji,jj) )   & 
    301405                     &                          - zec  * ( emp_b(ji,jj) - emp(ji,jj) ) * tmask(ji,jj,1) 
     406#endif 
    302407                  sshn  (ji,jj) = ssha  (ji,jj)             ! now <-- after 
    303408                  sshu_n(ji,jj) = sshu_a(ji,jj) 
    … …  
    307412            DO jj = 1, jpjm1                                ! ssh now at f-point 
    308413               DO ji = 1, jpim1      ! NO Vector Opt. 
     414#if defined key_z_first 
     415                  sshf_n(ji,jj) = 0.5  * umask_1(ji,jj) * umask_1(ji,jj+1)                 & 
     416                     &               / ( e1f(ji,jj  ) * e2f(ji,jj  ) )                     & 
     417                     &               * ( e1u(ji,jj  ) * e2u(ji,jj  ) * sshu_n(ji,jj  )     & 
     418                     &                 + e1u(ji,jj+1) * e2u(ji,jj+1) * sshu_n(ji,jj+1) ) 
     419#else 
    309420                  sshf_n(ji,jj) = 0.5  * umask(ji,jj,1) * umask(ji,jj+1,1)                 & 
    310421                     &               / ( e1f(ji,jj  ) * e2f(ji,jj  ) )                     & 
    311422                     &               * ( e1u(ji,jj  ) * e2u(ji,jj  ) * sshu_n(ji,jj  )     & 
    312423                     &                 + e1u(ji,jj+1) * e2u(ji,jj+1) * sshu_n(ji,jj+1) ) 
     424#endif 
    313425               END DO 
    314426            END DO 
    … …  
    317429            DO jj = 1, jpjm1                                ! ssh before at u- & v-points 
    318430               DO ji = 1, jpim1      ! NO Vector Opt. 
     431#if defined key_z_first 
     432                  sshu_b(ji,jj) = 0.5  * umask_1(ji,jj) / ( e1u(ji  ,jj) * e2u(ji  ,jj) )                   & 
     433                     &                                  * ( e1t(ji  ,jj) * e2t(ji  ,jj) * sshb(ji  ,jj)     & 
     434                     &                                    + e1t(ji+1,jj) * e2t(ji+1,jj) * sshb(ji+1,jj) ) 
     435                  sshv_b(ji,jj) = 0.5  * vmask_1(ji,jj) / ( e1v(ji,jj  ) * e2v(ji,jj  ) )                   & 
     436                     &                                  * ( e1t(ji,jj  ) * e2t(ji,jj  ) * sshb(ji,jj  )     & 
     437                     &                                    + e1t(ji,jj+1) * e2t(ji,jj+1) * sshb(ji,jj+1) ) 
     438#else 
    319439                  sshu_b(ji,jj) = 0.5  * umask(ji,jj,1) / ( e1u(ji  ,jj) * e2u(ji  ,jj) )                   & 
    320440                     &                                  * ( e1t(ji  ,jj) * e2t(ji  ,jj) * sshb(ji  ,jj)     & 
    … …  
    323443                     &                                  * ( e1t(ji,jj  ) * e2t(ji,jj  ) * sshb(ji,jj  )     & 
    324444                     &                                    + e1t(ji,jj+1) * e2t(ji,jj+1) * sshb(ji,jj+1) ) 
     445#endif 
    325446               END DO 
    326447            END DO 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/FLO/flo4rk.F90

    r2528 r3211  
    2727   REAL(wp), DIMENSION (4) ::   rcoef  = (/-1./6. , 1./2. ,-1./2. , 1./6. /)   ! 
    2828   REAL(wp), DIMENSION (3) ::   scoef1 = (/  0.5  ,  0.5  ,  1.0  /)           ! 
     29 
     30   !! * Control permutation of array indices 
     31#  include "oce_ftrans.h90" 
     32#  include "dom_oce_ftrans.h90" 
     33#  include "flo_oce_ftrans.h90" 
    2934 
    3035   !! * Substitutions 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/FLO/flo_oce.F90

    r2715 r3211  
    4545   INTEGER, PUBLIC  ::   nn_stockfl = 450        !: frequency of float restart file 
    4646 
     47   !! * Control permutation of array indices 
     48#  include "flo_oce_ftrans.h90" 
     49 
    4750   !!---------------------------------------------------------------------- 
    4851   !! NEMO/OPA 4.0 , NEMO Consortium (2011) 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/FLO/floats.F90

    r2715 r3211  
    2828   PUBLIC   flo_stp    ! routine called by step.F90 
    2929   PUBLIC   flo_init   ! routine called by opa.F90 
     30 
     31   !! * Control permutation of array indices 
     32#  include "oce_ftrans.h90" 
     33#  include "flo_oce_ftrans.h90" 
    3034 
    3135   !!---------------------------------------------------------------------- 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/FLO/floblk.F90

    r2715 r3211  
    2222 
    2323   PUBLIC   flo_blk    ! routine called by floats.F90 
     24 
     25   !! * Control permutation of array indices 
     26#  include "oce_ftrans.h90" 
     27#  include "dom_oce_ftrans.h90" 
     28#  include "flo_oce_ftrans.h90" 
    2429 
    2530   !! * Substitutions 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/FLO/flodom.F90

    r2528 r3211  
    2424 
    2525   PUBLIC   flo_dom    ! routine called by floats.F90 
     26 
     27   !! * Control permutation of array indices 
     28#  include "oce_ftrans.h90" 
     29#  include "dom_oce_ftrans.h90" 
     30#  include "flo_oce_ftrans.h90" 
    2631 
    2732   !! * Substitutions 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/FLO/flowri.F90

    r2715 r3211  
    3333   ! member arrays. 
    3434   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) ::   ztemp, zsal   ! 2D workspace 
     35 
     36   !! * Control permutation of array indices 
     37#  include "oce_ftrans.h90" 
     38#  include "dom_oce_ftrans.h90" 
     39#  include "flo_oce_ftrans.h90" 
    3540 
    3641   !! * Substitutions 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/IOM/iom.F90

    r2715 r3211  
    1919   !!-------------------------------------------------------------------- 
    2020   USE dom_oce         ! ocean space and time domain 
    21    USE lbclnk          ! lateal boundary condition / mpp exchanges 
     21   USE lbclnk          ! lateral boundary condition / mpp exchanges 
    2222   USE iom_def         ! iom variables definitions 
    2323   USE iom_ioipsl      ! NetCDF format with IOIPSL library 
    … …  
    3434   USE mod_attribut 
    3535# endif 
     36   USE zpermute, ONLY : permute_z_last   ! Re-order a 3d array back to external (z-last) ordering 
    3637 
    3738   IMPLICIT NONE 
    … …  
    7071   END INTERFACE 
    7172# endif 
     73 
     74   !! * Control permutation of array indices 
     75#  include "dom_oce_ftrans.h90" 
    7276 
    7377   !!---------------------------------------------------------------------- 
    … …  
    540544      INTEGER                        ::   ix1, ix2, iy1, iy2   ! subdomain indexes 
    541545      INTEGER                        ::   ji, jj      ! loop counters 
    542       INTEGER                        ::   irankpv       !  
     546      INTEGER                        ::   irankpv     !  
    543547      INTEGER                        ::   ind1, ind2  ! substring index 
    544548      INTEGER, DIMENSION(jpmax_dims) ::   istart      ! starting point to read for each axis 
    … …  
    551555      CHARACTER(LEN=100)             ::   clname      ! file name 
    552556      CHARACTER(LEN=1)               ::   clrankpv, cldmspc      !  
     557 
     558#if defined key_z_first 
     559      !! DCSE_NEMO: need a work array to match layout on disk, which is always z-last 
     560      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::   wpv_r3d         ! copy of pv_r3d with dimensions permuted 
     561      INTEGER                                 ::   istat_wpv_r3d   ! result of attempt to allocate the above 
     562      INTEGER, DIMENSION(3)                   ::   ishape_pv_r3d   ! size of the dimensions of pv_r3d 
     563      INTEGER                                 ::   jk              ! loop counter 
     564#endif 
     565 
    553566      !--------------------------------------------------------------------- 
    554567      ! 
    … …  
    670683         END DO 
    671684 
     685#if defined key_z_first 
     686         !! DCSE_NEMO: Allocate 3d work-array with z-index last 
     687         !!            to match layout on disk 
     688         IF (PRESENT(pv_r3d)) THEN 
     689            ishape_pv_r3d = SHAPE(pv_r3d) 
     690            IF (ishape_pv_r3d(1) /= jpk) THEN 
     691               WRITE( ctmp1, FMT="('leading dimension is ',i5,', not ',i5,' (jpk) as expected')" ) & 
     692                  &  ishape_pv_r3d(1), jpk 
     693               CALL ctl_warn( trim(clinfo), 'beware: possible problem with 3d array, ', ctmp1 )  
     694            ENDIF 
     695            ALLOCATE(wpv_r3d(ishape_pv_r3d(2),ishape_pv_r3d(3),ishape_pv_r3d(1)),STAT=istat_wpv_r3d) 
     696            IF (istat_wpv_r3d /= 0) THEN 
     697               CALL ctl_stop( trim(clinfo), 'failed to allocate wpv_r3d' ) 
     698            ENDIF 
     699         ENDIF 
     700#endif 
     701 
    672702         ! check that icnt matches the input array 
    673703         !-      
     704 
     705         !! DCSE_NEMO: beware! want ishape to match wpv_r3d, not pv_r3d 
     706 
    674707         IF( idom == jpdom_unknown ) THEN 
    675708            IF( irankpv == 1 )        ishape(1:1) = SHAPE(pv_r1d) 
    676709            IF( irankpv == 2 )        ishape(1:2) = SHAPE(pv_r2d) 
     710#if defined key_z_first 
     711            IF( irankpv == 3 )        ishape(1:3) = SHAPE(wpv_r3d) 
     712#else 
    677713            IF( irankpv == 3 )        ishape(1:3) = SHAPE(pv_r3d) 
     714#endif 
    678715            ctmp1 = 'd' 
    679716         ELSE 
    … …  
    688725! JMM + SM: ugly patch before getting the new version of lib_mpp) 
    689726!               ishape(1:3) = SHAPE(pv_r3d(nldi:nlei,nldj:nlej,:))   ;   ctmp1 = 'd(nldi:nlei,nldj:nlej,:)' 
    690                IF( llnoov ) THEN ; ishape(1:3)=SHAPE(pv_r3d(nldi:nlei,nldj:nlej,:)) ; ctmp1='d(nldi:nlei,nldj:nlej,:)' 
    691                ELSE              ; ishape(1:3)=SHAPE(pv_r3d(1   :nlci,1   :nlcj,:)) ; ctmp1='d(1:nlci,1:nlcj,:)' 
     727#if defined key_z_first 
     728               IF( llnoov ) THEN 
     729                  ishape(1:3)=SHAPE(wpv_r3d(nldi:nlei,nldj:nlej,:)) 
     730                  ctmp1='d(nldi:nlei,nldj:nlej,:)' 
     731               ELSE 
     732                  ishape(1:3)=SHAPE(wpv_r3d(1   :nlci,1   :nlcj,:)) 
     733                  ctmp1='d(1:nlci,1:nlcj,:)' 
    692734               ENDIF 
     735#else 
     736               IF( llnoov ) THEN 
     737                  ishape(1:3)=SHAPE(pv_r3d(nldi:nlei,nldj:nlej,:)) 
     738                  ctmp1='d(nldi:nlei,nldj:nlej,:)' 
     739               ELSE 
     740                  ishape(1:3)=SHAPE(pv_r3d(1   :nlci,1   :nlcj,:)) 
     741                  ctmp1='d(1:nlci,1:nlcj,:)' 
     742               ENDIF 
     743#endif 
    693744            ENDIF 
    694745         ENDIF 
    … …  
    720771         ENDIF 
    721772       
     773#if defined key_z_first 
     774         SELECT CASE (iom_file(kiomid)%iolib) 
     775         CASE (jpioipsl ) 
     776            IF  (PRESENT(pv_r3d)) THEN 
     777               CALL iom_ioipsl_get(  kiomid, idvar, inbdim, istart, icnt, ix1, ix2, iy1, iy2, pv_r1d, pv_r2d, wpv_r3d ) 
     778            ELSE 
     779               CALL iom_ioipsl_get(  kiomid, idvar, inbdim, istart, icnt, ix1, ix2, iy1, iy2, pv_r1d, pv_r2d ) 
     780            ENDIF 
     781         CASE (jpnf90   ) 
     782            IF (PRESENT(pv_r3d)) THEN 
     783               CALL iom_nf90_get(    kiomid, idvar, inbdim, istart, icnt, ix1, ix2, iy1, iy2, pv_r1d, pv_r2d, wpv_r3d ) 
     784            ELSE 
     785               CALL iom_nf90_get(    kiomid, idvar, inbdim, istart, icnt, ix1, ix2, iy1, iy2, pv_r1d, pv_r2d ) 
     786            ENDIF 
     787         CASE (jprstdimg) 
     788            IF (PRESENT(pv_r3d)) THEN 
     789               CALL iom_rstdimg_get( kiomid, idom, idvar, ix1, ix2, iy1, iy2, pv_r1d, pv_r2d, wpv_r3d ) 
     790            ELSE 
     791               CALL iom_rstdimg_get( kiomid, idom, idvar, ix1, ix2, iy1, iy2, pv_r1d, pv_r2d ) 
     792            ENDIF 
     793         CASE DEFAULT     
     794            CALL ctl_stop( TRIM(clinfo)//' accepted IO library are only jpioipsl, jpnf90 and jprstdimg' ) 
     795         END SELECT 
     796#else 
    722797         SELECT CASE (iom_file(kiomid)%iolib) 
    723798         CASE (jpioipsl )   ;   CALL iom_ioipsl_get(  kiomid, idvar, inbdim, istart, icnt, ix1, ix2, iy1, iy2,   & 
    … …  
    730805            CALL ctl_stop( TRIM(clinfo)//' accepted IO library are only jpioipsl, jpnf90 and jprstdimg' ) 
    731806         END SELECT 
     807#endif 
     808 
     809#if defined key_z_first 
     810         !! DCSE_NEMO: if necessary, copy 3d work array back into pv_r3d, 
     811         !!            and de-allocate the work array 
     812         IF (PRESENT(pv_r3d)) THEN 
     813            ! This assumes that pv_r3d is not ftransed 
     814            DO jk = 1, ishape_pv_r3d(3) 
     815               DO jj = 1, ishape_pv_r3d(2) 
     816                  DO ji = 1, ishape_pv_r3d(1) 
     817                     pv_r3d(jk, ji, jj) = wpv_r3d(ji, jj, jk) 
     818                  ENDDO 
     819               ENDDO 
     820            ENDDO 
     821            DEALLOCATE(wpv_r3d) 
     822         ENDIF 
     823#endif 
    732824 
    733825         IF( istop == nstop ) THEN   ! no additional errors until this point... 
    734826            IF(lwp) WRITE(numout,"(10x,' read ',a,' (rec: ',i4,') in ',a,' ok')") TRIM(cdvar), itime, TRIM(iom_file(kiomid)%name) 
    735827           
    736             !--- overlap areas and extra hallows (mpp) 
     828            !--- overlap areas and extra haloes (mpp) 
    737829            IF(     PRESENT(pv_r2d) .AND. idom /= jpdom_unknown ) THEN 
    738830               CALL lbc_lnk( pv_r2d,'Z',-999.,'no0' ) 
    … …  
    9341026      INTEGER         , INTENT(in), OPTIONAL               ::   ktype    ! variable external type 
    9351027      INTEGER :: ivid   ! variable id 
     1028#if defined key_z_first 
     1029      !! DCSE_NEMO: Need to transpose the dimensions of pvar from internal to external orderings 
     1030      !  We do not use ftrans here 
     1031      REAL(wp), ALLOCATABLE, DIMENSION(:,:,:)              ::   pvar_trans    ! transposed pvar 
     1032      INTEGER                                              ::   ji, jj, jk    ! Dummy loop indices 
     1033      IF( kiomid > 0 ) THEN 
     1034         IF( iom_file(kiomid)%nfid > 0 ) THEN 
     1035            ivid = iom_varid( kiomid, cdvar, ldstop = .FALSE. ) 
     1036            IF (      (SIZE(pvar, DIM=1) /= jpk )   & 
     1037               & .OR. (SIZE(pvar, DIM=2) /= jpi )   & 
     1038               & .OR. (SIZE(pvar, DIM=3) /= jpj ) ) THEN 
     1039               CALL ctl_stop( 'iom_rp3d: unexpected shape for variable ', cdvar ) 
     1040            END IF 
     1041            ALLOCATE( pvar_trans(jpi, jpj, jpk) ) 
     1042            DO jk = 1, jpk 
     1043               DO jj = 1, jpj 
     1044                  DO ji = 1, jpi 
     1045                     pvar_trans(ji, jj, jk) = pvar(jk, ji, jj) 
     1046                  END DO 
     1047               END DO 
     1048            END DO 
     1049            SELECT CASE (iom_file(kiomid)%iolib) 
     1050            CASE (jpioipsl )   ;   CALL iom_ioipsl_rstput( kt, kwrite, kiomid, cdvar, ivid, ktype, pv_r3d = pvar_trans ) 
     1051            CASE (jpnf90   )   ;   CALL iom_nf90_rstput(   kt, kwrite, kiomid, cdvar, ivid, ktype, pv_r3d = pvar_trans ) 
     1052            CASE (jprstdimg)   ;   IF( kt == kwrite )   CALL iom_rstdimg_rstput( kiomid, cdvar, ivid, pv_r3d = pvar_trans ) 
     1053            CASE DEFAULT      
     1054               CALL ctl_stop( 'iom_rp3d: accepted IO library are only jpioipsl and jprstdimg' ) 
     1055            END SELECT 
     1056            DEALLOCATE( pvar_trans ) 
     1057         ENDIF 
     1058      ENDIF 
     1059#else 
    9361060      IF( kiomid > 0 ) THEN 
    9371061         IF( iom_file(kiomid)%nfid > 0 ) THEN 
    … …  
    9461070         ENDIF 
    9471071      ENDIF 
     1072#endif 
    9481073   END SUBROUTINE iom_rp3d 
    9491074 
    … …  
    9761101      REAL(wp),       DIMENSION(:,:,:), INTENT(in) ::   pfield3d 
    9771102#if defined key_iomput 
     1103#if defined key_z_first 
     1104!FTRANS ASSERT :z :I 
     1105!FTRANS pfield3d :I :I :z 
     1106      CALL event__write_field3D( cdname, permute_z_last(pfield3d(nldi:nlei, nldj:nlej, :)) ) 
     1107#else 
     1108!FTRANS ASSERT :I :z 
    9781109      CALL event__write_field3D( cdname, pfield3d(nldi:nlei, nldj:nlej, :) ) 
     1110#endif 
    9791111#else 
    9801112      IF( .FALSE. )   WRITE(numout,*) cdname, pfield3d   ! useless test to avoid compilation warnings 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/IOM/iom_ioipsl.F90

    r2715 r3211  
    3535      MODULE PROCEDURE iom_ioipsl_rp0123d 
    3636   END INTERFACE 
     37 
     38   !! * Control permutation of array indices 
     39#  include "dom_oce_ftrans.h90" 
     40 
    3741   !!---------------------------------------------------------------------- 
    3842   !! NEMO/OPA 3.3 , NEMO Consortium (2010) 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/IOM/iom_nf90.F90

    r2715 r3211  
    4040      MODULE PROCEDURE iom_nf90_rp0123d 
    4141   END INTERFACE 
     42 
     43   !! * Control permutation of array indices 
     44#  include "dom_oce_ftrans.h90" 
    4245 
    4346   !!---------------------------------------------------------------------- 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/IOM/iom_rstdimg.F90

    r2715 r3211  
    3434 
    3535   INTEGER, PARAMETER ::   jpvnl          = 32   ! variable name length 
     36 
     37   !! * Control permutation of array indices 
     38#  include "dom_oce_ftrans.h90" 
    3639       
    3740   !!---------------------------------------------------------------------- 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/IOM/prtctl.F90

    r2715 r3211  
    2828   PUBLIC prt_ctl_info    ! called by all subroutines 
    2929   PUBLIC prt_ctl_init    ! called by opa.F90 
     30 
     31   !! * Control permutation of array indices 
     32#  include "dom_oce_ftrans.h90" 
    3033 
    3134   !!---------------------------------------------------------------------- 
    … …  
    7780      USE wrk_nemo, ONLY:   zmask1   => wrk_3d_11 , zmask2   => wrk_3d_12  
    7881      USE wrk_nemo, ONLY:   ztab3d_1 => wrk_3d_13 , ztab3d_2 => wrk_3d_14 
     82 
     83      !! DCSE_NEMO: Need additional directives for renamed module variables 
     84!FTRANS zmask1 zmask2 ztab3d_1 ztab3d_2 :I :I :z 
     85 
     86!FTRANS tab3d_1 mask1 :I :I :z 
     87!FTRANS tab3d_2 mask2 :I :I :z 
     88 
    7989      ! 
    8090      REAL(wp), DIMENSION(:,:)  , INTENT(in), OPTIONAL ::   tab2d_1 
    … …  
    120130      IF( PRESENT(tab2d_1) )   ztab2d_1(:,:)        = tab2d_1(:,:) 
    121131      IF( PRESENT(tab2d_2) )   ztab2d_2(:,:)        = tab2d_2(:,:) 
     132   !! DCSE_NEMO: attention! 
    122133      IF( PRESENT(tab3d_1) )   ztab3d_1(:,:,1:kdir) = tab3d_1(:,:,:) 
    123134      IF( PRESENT(tab3d_2) )   ztab3d_2(:,:,1:kdir) = tab3d_2(:,:,:) 
    … …  
    209220   END SUBROUTINE prt_ctl 
    210221 
     222   !! * Reset control of array index permutation 
     223!FTRANS CLEAR 
     224#  include "dom_oce_ftrans.h90" 
    211225 
    212226   SUBROUTINE prt_ctl_info (clinfo1, ivar1, clinfo2, ivar2, itime) 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/IOM/restart.F90

    r2528 r3211  
    3535   LOGICAL, PUBLIC ::   lrst_oce =  .FALSE.   !: logical to control the oce restart write  
    3636   INTEGER, PUBLIC ::   numror, numrow        !: logical unit for cean restart (read and write) 
     37 
     38   !! * Control permutation of array indices 
     39#  include "oce_ftrans.h90" 
     40#  include "dom_oce_ftrans.h90" 
     41#  include "trdmld_oce_ftrans.h90" 
     42#  include "domvvl_ftrans.h90" 
    3743 
    3844   !! * Substitutions 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/LBC/cla.F90

    r2715 r3211  
    5454 
    5555   REAL(wp), ALLOCATABLE, SAVE, DIMENSION (:) ::   t_171_94_hor, s_171_94_hor       ! Temperature, salinity in Hormuz strait 
     56 
     57   !! * Control permutation of array indices 
     58#  include "oce_ftrans.h90" 
     59#  include "dom_oce_ftrans.h90" 
     60#  include "sbc_oce_ftrans.h90" 
    5661    
    5762   !! * Substitutions 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/LBC/lbclnk.F90

    r2442 r3211  
    6060   PUBLIC   lbc_lnk       ! ocean/ice  lateral boundary conditions 
    6161   PUBLIC   lbc_lnk_e  
    62     
     62 
     63   !! * Control permutation of array indices 
     64#  include "oce_ftrans.h90" 
     65#  include "dom_oce_ftrans.h90" 
     66 
    6367   !!---------------------------------------------------------------------- 
    6468   !! NEMO/OPA 3.3 , NEMO Consortium (2010) 
    … …  
    8185      !!---------------------------------------------------------------------- 
    8286      CHARACTER(len=1)                , INTENT(in   ) ::   cd_type1, cd_type2   ! nature of pt3d grid-points 
    83       REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   pt3d1   , pt3d2      ! 3D array on which the lbc is applied 
    84       REAL(wp)                        , INTENT(in   ) ::   psgn                 ! control of the sign  
     87!FTRANS pt3d1 :I :I :z 
     88!FTRANS pt3d2 :I :I :z 
     89! DCSE_NEMO: work around a deficiency in ftrans 
     90!     REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   pt3d1   , pt3d2      ! 3D array on which the lbc is applied 
     91      REAL(wp), INTENT(inout)   ::   pt3d1(jpi,jpj,jpk)   , pt3d2(jpi,jpj,jpk) 
     92      REAL(wp), INTENT(in   )   ::   psgn                 ! control of the sign  
    8593      !!---------------------------------------------------------------------- 
    8694      ! 
    … …  
    104112      !!---------------------------------------------------------------------- 
    105113      CHARACTER(len=1)                , INTENT(in   )           ::   cd_type   ! nature of pt3d grid-points 
    106       REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout)           ::   pt3d      ! 3D array on which the lbc is applied 
     114!FTRANS pt3d :I :I :z 
     115!! DCSE_NEMO: work around a deficiency in ftrans 
     116!     REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout)           ::   pt3d      ! 3D array on which the lbc is applied 
     117      REAL(wp), INTENT(inout)                                   ::   pt3d(jpi,jpj,jpk) 
    107118      REAL(wp)                        , INTENT(in   )           ::   psgn      ! control of the sign  
    108119      CHARACTER(len=3)                , INTENT(in   ), OPTIONAL ::   cd_mpp    ! MPP only (here do nothing) 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/LBC/lbcnfd.F90

    r2715 r3211  
    2424   PUBLIC   lbc_nfd   ! north fold conditions 
    2525 
     26   !! * Control permutation of array indices 
     27#  include "dom_oce_ftrans.h90" 
     28 
    2629   !!---------------------------------------------------------------------- 
    2730   !! NEMO/OPA 3.3 , NEMO Consortium (2010) 
    … …  
    4750      !                                                        !   = -1. , the sign is changed if north fold boundary 
    4851      !                                                        !   =  1. , the sign is kept  if north fold boundary 
     52!FTRANS pt3d :I :I :z 
    4953      REAL(wp), DIMENSION(:,:,:), INTENT(inout) ::   pt3d      ! 3D array on which the boundary condition is applied 
    5054      ! 
    … …  
    5963      ijpjm1 = ijpj-1 
    6064 
     65#if !defined key_z_first 
    6166      DO jk = 1, jpk 
     67#endif 
    6268         ! 
    6369         SELECT CASE ( npolj ) 
    … …  
    6975               DO ji = 2, jpiglo 
    7076                  ijt = jpiglo-ji+2 
     77#if defined key_z_first 
     78                  DO jk = 1, jpk 
     79                     pt3d(ji,ijpj,jk) = psgn * pt3d(ijt,ijpj-2,jk) 
     80                  END DO 
     81#else 
    7182                  pt3d(ji,ijpj,jk) = psgn * pt3d(ijt,ijpj-2,jk) 
     83#endif 
    7284               END DO 
    7385               DO ji = jpiglo/2+1, jpiglo 
    7486                  ijt = jpiglo-ji+2 
     87#if defined key_z_first 
     88                  DO jk = 1, jpk 
     89                     pt3d(ji,ijpjm1,jk) = psgn * pt3d(ijt,ijpjm1,jk) 
     90                  END DO 
     91#else 
    7592                  pt3d(ji,ijpjm1,jk) = psgn * pt3d(ijt,ijpjm1,jk) 
     93#endif 
    7694               END DO 
    7795            CASE ( 'U' )                               ! U-point 
    7896               DO ji = 1, jpiglo-1 
    7997                  iju = jpiglo-ji+1 
     98#if defined key_z_first 
     99                  DO jk = 1, jpk 
     100                     pt3d(ji,ijpj,jk) = psgn * pt3d(iju,ijpj-2,jk) 
     101                  END DO 
     102#else 
    80103                  pt3d(ji,ijpj,jk) = psgn * pt3d(iju,ijpj-2,jk) 
     104#endif 
    81105               END DO 
    82106               DO ji = jpiglo/2, jpiglo-1 
    83107                  iju = jpiglo-ji+1 
     108#if defined key_z_first 
     109                  DO jk = 1, jpk 
     110                     pt3d(ji,ijpjm1,jk) = psgn * pt3d(iju,ijpjm1,jk) 
     111                  END DO 
     112#else 
    84113                  pt3d(ji,ijpjm1,jk) = psgn * pt3d(iju,ijpjm1,jk) 
     114#endif 
    85115               END DO 
    86116            CASE ( 'V' )                               ! V-point 
    87117               DO ji = 2, jpiglo 
    88118                  ijt = jpiglo-ji+2 
     119#if defined key_z_first 
     120                  DO jk = 1, jpk 
     121                     pt3d(ji,ijpj-1,jk) = psgn * pt3d(ijt,ijpj-2,jk) 
     122                     pt3d(ji,ijpj  ,jk) = psgn * pt3d(ijt,ijpj-3,jk) 
     123                  END DO 
     124#else 
    89125                  pt3d(ji,ijpj-1,jk) = psgn * pt3d(ijt,ijpj-2,jk) 
    90126                  pt3d(ji,ijpj  ,jk) = psgn * pt3d(ijt,ijpj-3,jk) 
     127#endif 
    91128               END DO 
    92129            CASE ( 'F' )                               ! F-point 
    93130               DO ji = 1, jpiglo-1 
    94131                  iju = jpiglo-ji+1 
     132#if defined key_z_first 
     133                  DO jk = 1, jpk 
     134                     pt3d(ji,ijpj-1,jk) = psgn * pt3d(iju,ijpj-2,jk) 
     135                     pt3d(ji,ijpj  ,jk) = psgn * pt3d(iju,ijpj-3,jk) 
     136                  END DO 
     137#else 
    95138                  pt3d(ji,ijpj-1,jk) = psgn * pt3d(iju,ijpj-2,jk) 
    96139                  pt3d(ji,ijpj  ,jk) = psgn * pt3d(iju,ijpj-3,jk) 
     140#endif 
    97141               END DO 
    98142            END SELECT 
    … …  
    104148               DO ji = 1, jpiglo 
    105149                  ijt = jpiglo-ji+1 
     150#if defined key_z_first 
     151                  DO jk = 1, jpk 
     152                     pt3d(ji,ijpj,jk) = psgn * pt3d(ijt,ijpj-1,jk) 
     153                  END DO 
     154#else 
    106155                  pt3d(ji,ijpj,jk) = psgn * pt3d(ijt,ijpj-1,jk) 
     156#endif 
    107157               END DO 
    108158            CASE ( 'U' )                               ! U-point 
    109159               DO ji = 1, jpiglo-1 
    110160                  iju = jpiglo-ji 
     161#if defined key_z_first 
     162                  DO jk = 1, jpk 
     163                     pt3d(ji,ijpj,jk) = psgn * pt3d(iju,ijpj-1,jk) 
     164                  END DO 
     165#else 
    111166                  pt3d(ji,ijpj,jk) = psgn * pt3d(iju,ijpj-1,jk) 
     167#endif 
    112168               END DO 
    113169            CASE ( 'V' )                               ! V-point 
    114170               DO ji = 1, jpiglo 
    115171                  ijt = jpiglo-ji+1 
     172#if defined key_z_first 
     173                  DO jk = 1, jpk 
     174                     pt3d(ji,ijpj,jk) = psgn * pt3d(ijt,ijpj-2,jk) 
     175                  END DO 
     176#else 
    116177                  pt3d(ji,ijpj,jk) = psgn * pt3d(ijt,ijpj-2,jk) 
     178#endif 
    117179               END DO 
    118180               DO ji = jpiglo/2+1, jpiglo 
    119181                  ijt = jpiglo-ji+1 
     182#if defined key_z_first 
     183                  DO jk = 1, jpk 
     184                     pt3d(ji,ijpjm1,jk) = psgn * pt3d(ijt,ijpjm1,jk) 
     185                  END DO 
     186#else 
    120187                  pt3d(ji,ijpjm1,jk) = psgn * pt3d(ijt,ijpjm1,jk) 
     188#endif 
    121189               END DO 
    122190            CASE ( 'F' )                               ! F-point 
    123191               DO ji = 1, jpiglo-1 
    124192                  iju = jpiglo-ji 
     193#if defined key_z_first 
     194                  DO jk = 1, jpk 
     195                     pt3d(ji,ijpj  ,jk) = psgn * pt3d(iju,ijpj-2,jk) 
     196                  END DO 
     197#else 
    125198                  pt3d(ji,ijpj  ,jk) = psgn * pt3d(iju,ijpj-2,jk) 
     199#endif 
    126200               END DO 
    127201               DO ji = jpiglo/2+1, jpiglo-1 
    128202                  iju = jpiglo-ji 
     203#if defined key_z_first 
     204                  DO jk = 1, jpk 
     205                     pt3d(ji,ijpjm1,jk) = psgn * pt3d(iju,ijpjm1,jk) 
     206                  END DO 
     207#else 
    129208                  pt3d(ji,ijpjm1,jk) = psgn * pt3d(iju,ijpjm1,jk) 
     209#endif 
    130210               END DO 
    131211            END SELECT 
    … …  
    135215            SELECT CASE ( cd_type) 
    136216            CASE ( 'T' , 'U' , 'V' , 'W' )             ! T-, U-, V-, W-points 
     217#if defined key_z_first 
     218               pt3d(:, 1  ,:) = 0.e0 
     219               pt3d(:,ijpj,:) = 0.e0 
     220#else 
    137221               pt3d(:, 1  ,jk) = 0.e0 
    138222               pt3d(:,ijpj,jk) = 0.e0 
     223#endif 
    139224            CASE ( 'F' )                               ! F-point 
     225#if defined key_z_first 
     226               pt3d(:,ijpj,:) = 0.e0 
     227#else 
    140228               pt3d(:,ijpj,jk) = 0.e0 
     229#endif 
    141230            END SELECT 
    142231            ! 
    143232         END SELECT     !  npolj 
    144233         ! 
     234#if !defined key_z_first 
    145235      END DO 
     236#endif 
    146237      ! 
    147238   END SUBROUTINE lbc_nfd_3d 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90

    r2731 r3211  
    129129   INTEGER ::   ngrp_znl        ! group ID for the znl processors 
    130130   INTEGER ::   ndim_rank_znl   ! number of processors on the same zonal average 
    131    INTEGER, DIMENSION(:), ALLOCATABLE, SAVE ::   nrank_znl  ! dimension ndim_rank_znl, number of the procs into the same znl domain 
     131   INTEGER, DIMENSION(:), ALLOCATABLE, SAVE ::   nrank_znl  ! dimension ndim_rank_znl,  
     132   !                                                        ! number of the procs into the same znl domain 
    132133    
    133134   ! North fold condition in mpp_mpi with jpni > 1 
    … …  
    172173   REAL(wp), DIMENSION(:,:)  , ALLOCATABLE, SAVE    ::   ztab_e, znorthloc_e 
    173174   REAL(wp), DIMENSION(:,:,:), ALLOCATABLE, SAVE    ::   znorthgloio_e 
     175 
     176   !! * Control permutation of array indices 
     177#  include "dom_oce_ftrans.h90" 
     178!! These arrays are all private to the module 
     179!FTRANS t4ns :I :I :z :I :I 
     180!FTRANS t4sn :I :I :z :I :I 
     181!FTRANS t4ew :I :I :z :I :I 
     182!FTRANS t4we :I :I :z :I :I 
     183!FTRANS t3ns :I :I :z :I 
     184!FTRANS t3sn :I :I :z :I 
     185!FTRANS t3ew :I :I :z :I 
     186!FTRANS t3we :I :I :z :I 
     187!FTRANS ztab :I :I :z 
     188!FTRANS znorthloc :I :I :z 
     189!FTRANS znorthgloio :I :I :z :I 
    174190 
    175191   !!---------------------------------------------------------------------- 
    … …  
    347363 
    348364 
    349    SUBROUTINE mpp_lnk_3d( ptab, cd_type, psgn, cd_mpp, pval ) 
     365   SUBROUTINE mpp_lnk_3d( ptab3d, cd_type, psgn, cd_mpp, pval ) 
    350366      !!---------------------------------------------------------------------- 
    351367      !!                  ***  routine mpp_lnk_3d  *** 
    … …  
    368384      !! 
    369385      !!---------------------------------------------------------------------- 
    370       REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   ptab     ! 3D array on which the boundary condition is applied 
     386!FTRANS ptab3d :I :I :z 
     387!! DCSE_NEMO: work around a deficiency in ftrans 
     388!     REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   ptab3d   ! 3D array on which the boundary condition is applied 
     389      REAL(wp),                         INTENT(inout) ::   ptab3d(jpi,jpj,jpk) 
    371390      CHARACTER(len=1)                , INTENT(in   ) ::   cd_type  ! define the nature of ptab array grid-points 
    372391      !                                                             ! = T , U , V , F , W points 
    … …  
    391410      IF( PRESENT( cd_mpp ) ) THEN      ! only fill added line/raw with existing values 
    392411         ! 
    393          ! WARNING ptab is defined only between nld and nle 
     412         ! WARNING ptab3d is defined only between nld and nle 
     413#if defined key_z_first 
     414         DO jj = nlcj+1, jpj                    ! added line(s)   (inner only) 
     415            DO jk = 1, jpk 
     416#else 
    394417         DO jk = 1, jpk 
    395418            DO jj = nlcj+1, jpj                 ! added line(s)   (inner only) 
    396                ptab(nldi  :nlei  , jj          ,jk) = ptab(nldi:nlei,     nlej,jk)    
    397                ptab(1     :nldi-1, jj          ,jk) = ptab(nldi     ,     nlej,jk) 
    398                ptab(nlei+1:nlci  , jj          ,jk) = ptab(     nlei,     nlej,jk) 
     419#endif 
     420               ptab3d(nldi  :nlei  , jj          ,jk) = ptab3d(nldi:nlei,     nlej,jk)    
     421               ptab3d(1     :nldi-1, jj          ,jk) = ptab3d(nldi     ,     nlej,jk) 
     422               ptab3d(nlei+1:nlci  , jj          ,jk) = ptab3d(     nlei,     nlej,jk) 
    399423            END DO 
     424#if defined key_z_first 
     425         END DO 
     426         DO ji = nlci+1, jpi                    ! added column(s) (full) 
     427            DO jk = 1, jpk 
     428#else 
    400429            DO ji = nlci+1, jpi                 ! added column(s) (full) 
    401                ptab(ji           ,nldj  :nlej  ,jk) = ptab(     nlei,nldj:nlej,jk) 
    402                ptab(ji           ,1     :nldj-1,jk) = ptab(     nlei,nldj     ,jk) 
    403                ptab(ji           ,nlej+1:jpj   ,jk) = ptab(     nlei,     nlej,jk) 
     430#endif 
     431               ptab3d(ji           ,nldj  :nlej  ,jk) = ptab3d(     nlei,nldj:nlej,jk) 
     432               ptab3d(ji           ,1     :nldj-1,jk) = ptab3d(     nlei,nldj     ,jk) 
     433               ptab3d(ji           ,nlej+1:jpj   ,jk) = ptab3d(     nlei,     nlej,jk) 
    404434            END DO 
    405435         END DO 
    … …  
    410440         !                                        !* Cyclic east-west 
    411441         IF( nbondi == 2 .AND. (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN 
    412             ptab( 1 ,:,:) = ptab(jpim1,:,:) 
    413             ptab(jpi,:,:) = ptab(  2  ,:,:) 
     442            ptab3d( 1 ,:,:) = ptab3d(jpim1,:,:) 
     443            ptab3d(jpi,:,:) = ptab3d(  2  ,:,:) 
    414444         ELSE                                     !* closed 
    415             IF( .NOT. cd_type == 'F' )   ptab(     1       :jpreci,:,:) = zland    ! south except F-point 
    416                                          ptab(nlci-jpreci+1:jpi   ,:,:) = zland    ! north 
     445            IF( .NOT. cd_type == 'F' )   ptab3d(     1       :jpreci,:,:) = zland    ! south except F-point 
     446                                         ptab3d(nlci-jpreci+1:jpi   ,:,:) = zland    ! north 
    417447         ENDIF 
    418448         !                                   ! North-South boundaries (always closed) 
    419          IF( .NOT. cd_type == 'F' )   ptab(:,     1       :jprecj,:) = zland       ! south except F-point 
    420                                       ptab(:,nlcj-jprecj+1:jpj   ,:) = zland       ! north 
     449         IF( .NOT. cd_type == 'F' )   ptab3d(:,     1       :jprecj,:) = zland       ! south except F-point 
     450                                      ptab3d(:,nlcj-jprecj+1:jpj   ,:) = zland       ! north 
    421451         ! 
    422452      ENDIF 
    … …  
    430460         iihom = nlci-nreci 
    431461         DO jl = 1, jpreci 
    432             t3ew(:,jl,:,1) = ptab(jpreci+jl,:,:) 
    433             t3we(:,jl,:,1) = ptab(iihom +jl,:,:) 
     462            t3ew(:,jl,:,1) = ptab3d(jpreci+jl,:,:) 
     463            t3we(:,jl,:,1) = ptab3d(iihom +jl,:,:) 
    434464         END DO 
    435465      END SELECT   
    … …  
    462492      CASE ( -1 ) 
    463493         DO jl = 1, jpreci 
    464             ptab(iihom+jl,:,:) = t3ew(:,jl,:,2) 
     494            ptab3d(iihom+jl,:,:) = t3ew(:,jl,:,2) 
    465495         END DO 
    466496      CASE ( 0 )  
    467497         DO jl = 1, jpreci 
    468             ptab(jl      ,:,:) = t3we(:,jl,:,2) 
    469             ptab(iihom+jl,:,:) = t3ew(:,jl,:,2) 
     498            ptab3d(jl      ,:,:) = t3we(:,jl,:,2) 
     499            ptab3d(iihom+jl,:,:) = t3ew(:,jl,:,2) 
    470500         END DO 
    471501      CASE ( 1 ) 
    472502         DO jl = 1, jpreci 
    473             ptab(jl      ,:,:) = t3we(:,jl,:,2) 
     503            ptab3d(jl      ,:,:) = t3we(:,jl,:,2) 
    474504         END DO 
    475505      END SELECT 
    … …  
    483513         ijhom = nlcj-nrecj 
    484514         DO jl = 1, jprecj 
    485             t3sn(:,jl,:,1) = ptab(:,ijhom +jl,:) 
    486             t3ns(:,jl,:,1) = ptab(:,jprecj+jl,:) 
     515            t3sn(:,jl,:,1) = ptab3d(:,ijhom +jl,:) 
     516            t3ns(:,jl,:,1) = ptab3d(:,jprecj+jl,:) 
    487517         END DO 
    488518      ENDIF 
    … …  
    515545      CASE ( -1 ) 
    516546         DO jl = 1, jprecj 
    517             ptab(:,ijhom+jl,:) = t3ns(:,jl,:,2) 
     547            ptab3d(:,ijhom+jl,:) = t3ns(:,jl,:,2) 
    518548         END DO 
    519549      CASE ( 0 )  
    520550         DO jl = 1, jprecj 
    521             ptab(:,jl      ,:) = t3sn(:,jl,:,2) 
    522             ptab(:,ijhom+jl,:) = t3ns(:,jl,:,2) 
     551            ptab3d(:,jl      ,:) = t3sn(:,jl,:,2) 
     552            ptab3d(:,ijhom+jl,:) = t3ns(:,jl,:,2) 
    523553         END DO 
    524554      CASE ( 1 ) 
    525555         DO jl = 1, jprecj 
    526             ptab(:,jl,:) = t3sn(:,jl,:,2) 
     556            ptab3d(:,jl,:) = t3sn(:,jl,:,2) 
    527557         END DO 
    528558      END SELECT 
    … …  
    535565         ! 
    536566         SELECT CASE ( jpni ) 
    537          CASE ( 1 )     ;   CALL lbc_nfd      ( ptab, cd_type, psgn )   ! only 1 northern proc, no mpp 
    538          CASE DEFAULT   ;   CALL mpp_lbc_north( ptab, cd_type, psgn )   ! for all northern procs. 
     567         CASE ( 1 )     ;   CALL lbc_nfd      ( ptab3d, cd_type, psgn )   ! only 1 northern proc, no mpp 
     568         CASE DEFAULT   ;   CALL mpp_lbc_north( ptab3d, cd_type, psgn )   ! for all northern procs. 
    539569         END SELECT 
    540570         ! 
    … …  
    742772      !!                  ***  routine mpp_lnk_3d_gather  *** 
    743773      !! 
    744       !! ** Purpose :   Message passing manadgement for two 3D arrays 
     774      !! ** Purpose :   Message passing management for two 3D arrays 
    745775      !! 
    746776      !! ** Method  :   Use mppsend and mpprecv function for passing mask  
    … …  
    759789      !! 
    760790      !!---------------------------------------------------------------------- 
    761       REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   ptab1     ! first and second 3D array on which  
    762       REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   ptab2     ! the boundary condition is applied 
     791!FTRANS ptab1 :I :I :z 
     792!FTRANS ptab2 :I :I :z 
     793!! DCSE_NEMO: work around a deficiency in ftrans 
     794!     REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   ptab1     ! first and second 3D array on which  
     795!     REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   ptab2     ! the boundary condition is applied 
     796      REAL(wp),                         INTENT(inout) ::   ptab1(jpi,jpj,jpk) 
     797      REAL(wp),                         INTENT(inout) ::   ptab2(jpi,jpj,jpk) 
    763798      CHARACTER(len=1)                , INTENT(in   ) ::   cd_type1  ! nature of ptab1 and ptab2 arrays  
    764799      CHARACTER(len=1)                , INTENT(in   ) ::   cd_type2  ! i.e. grid-points = T , U , V , F or W points 
    … …  
    11131148      !!                  ***  routine mppsend  *** 
    11141149      !!                    
    1115       !! ** Purpose :   Send messag passing array 
     1150      !! ** Purpose :   Send message passing array 
    11161151      !! 
    11171152      !!---------------------------------------------------------------------- 
    … …  
    15751610 
    15761611 
    1577    SUBROUTINE mpp_minloc3d( ptab, pmask, pmin, ki, kj ,kk) 
     1612   SUBROUTINE mpp_minloc3d( ptab3d, pmask3d, pmin, ki, kj ,kk) 
    15781613      !!------------------------------------------------------------------------ 
    15791614      !!             ***  routine mpp_minloc  *** 
    … …  
    15851620      !! 
    15861621      !!-------------------------------------------------------------------------- 
    1587       REAL(wp), DIMENSION (jpi,jpj,jpk), INTENT(in   ) ::   ptab         ! Local 2D array 
    1588       REAL(wp), DIMENSION (jpi,jpj,jpk), INTENT(in   ) ::   pmask        ! Local mask 
     1622!FTRANS ptab3d  :I :I :z 
     1623!FTRANS pmask3d :I :I :z 
     1624!! DCSE_NEMO: work around a deficiency in ftrans 
     1625!     REAL(wp), DIMENSION (jpi,jpj,jpk), INTENT(in   ) ::   ptab3d       ! Local 3D array 
     1626!     REAL(wp), DIMENSION (jpi,jpj,jpk), INTENT(in   ) ::   pmask3d      ! Local mask 
     1627      REAL(wp), INTENT(in   )                          ::   ptab3d(jpi,jpj,jpk) 
     1628      REAL(wp), INTENT(in   )                          ::   pmask3d(jpi,jpj,jpk) 
    15891629      REAL(wp)                         , INTENT(  out) ::   pmin         ! Global minimum of ptab 
    15901630      INTEGER                          , INTENT(  out) ::   ki, kj, kk   ! index of minimum in global frame 
    … …  
    15961636      !!----------------------------------------------------------------------- 
    15971637      ! 
    1598       zmin  = MINVAL( ptab(:,:,:) , mask= pmask == 1.e0 ) 
    1599       ilocs = MINLOC( ptab(:,:,:) , mask= pmask == 1.e0 ) 
    1600       ! 
     1638      zmin  = MINVAL( ptab3d(:,:,:) , mask= pmask3d == 1.e0 ) 
     1639      ilocs = MINLOC( ptab3d(:,:,:) , mask= pmask3d == 1.e0 ) 
     1640      ! 
     1641!! DCSE_NEMO: Attention!  
     1642#if defined key_z_first 
     1643      ki = ilocs(2) + nimpp - 1 
     1644      kj = ilocs(3) + njmpp - 1 
     1645      kk = ilocs(1) 
     1646#else 
    16011647      ki = ilocs(1) + nimpp - 1 
    16021648      kj = ilocs(2) + njmpp - 1 
    16031649      kk = ilocs(3) 
     1650#endif 
    16041651      ! 
    16051652      zain(1,:)=zmin 
    … …  
    16551702 
    16561703 
    1657    SUBROUTINE mpp_maxloc3d( ptab, pmask, pmax, ki, kj, kk ) 
     1704   SUBROUTINE mpp_maxloc3d( ptab3d, pmask3d, pmax, ki, kj, kk ) 
    16581705      !!------------------------------------------------------------------------ 
    16591706      !!             ***  routine mpp_maxloc  *** 
    … …  
    16651712      !! 
    16661713      !!-------------------------------------------------------------------------- 
    1667       REAL(wp), DIMENSION (jpi,jpj,jpk), INTENT(in   ) ::   ptab         ! Local 2D array 
    1668       REAL(wp), DIMENSION (jpi,jpj,jpk), INTENT(in   ) ::   pmask        ! Local mask 
     1714!FTRANS ptab3d  :I :I :z 
     1715!FTRANS pmask3d :I :I :z 
     1716!! DCSE_NEMO: work around a deficiency in ftrans 
     1717!     REAL(wp), DIMENSION (jpi,jpj,jpk), INTENT(in   ) ::   ptab3d       ! Local 2D array 
     1718!     REAL(wp), DIMENSION (jpi,jpj,jpk), INTENT(in   ) ::   pmask3d      ! Local mask 
     1719      REAL(wp), INTENT(in   )                          ::   ptab3d(jpi,jpj,jpk)       ! Local 2D array 
     1720      REAL(wp), INTENT(in   )                          ::   pmask3d(jpi,jpj,jpk)      ! Local mask 
    16691721      REAL(wp)                         , INTENT(  out) ::   pmax         ! Global maximum of ptab 
    16701722      INTEGER                          , INTENT(  out) ::   ki, kj, kk   ! index of maximum in global frame 
    … …  
    16761728      !!----------------------------------------------------------------------- 
    16771729      ! 
    1678       zmax  = MAXVAL( ptab(:,:,:) , mask= pmask == 1.e0 ) 
    1679       ilocs = MAXLOC( ptab(:,:,:) , mask= pmask == 1.e0 ) 
    1680       ! 
     1730      zmax  = MAXVAL( ptab3d(:,:,:) , mask= pmask3d == 1.e0 ) 
     1731      ilocs = MAXLOC( ptab3d(:,:,:) , mask= pmask3d == 1.e0 ) 
     1732      ! 
     1733!! DCSE_NEMO: Attention! 
     1734#if defined key_z_first 
     1735      ki = ilocs(2) + nimpp - 1 
     1736      kj = ilocs(3) + njmpp - 1 
     1737      kk = ilocs(1) 
     1738#else 
    16811739      ki = ilocs(1) + nimpp - 1 
    16821740      kj = ilocs(2) + njmpp - 1 
    16831741      kk = ilocs(3) 
     1742#endif 
    16841743      ! 
    16851744      zain(1,:)=zmax 
    … …  
    17311790      !!                  ***  routine mppobc  *** 
    17321791      !!  
    1733       !! ** Purpose :   Message passing manadgement for open boundary 
     1792      !! ** Purpose :   Message passing management for open boundary 
    17341793      !!     conditions array 
    17351794      !! 
    … …  
    17481807      !!---------------------------------------------------------------------- 
    17491808      USE wrk_nemo, ONLY:   wrk_in_use, wrk_not_released 
    1750       USE wrk_nemo, ONLY:   ztab => wrk_2d_1 
     1809!! DCSE_NEMO: Warning! ztab is also a lib_mpp module variable 
     1810!     USE wrk_nemo, ONLY:   ztab => wrk_2d_1 
     1811      USE wrk_nemo, ONLY:   ztab2d => wrk_2d_1 
    17511812      ! 
    17521813      INTEGER , INTENT(in   )                     ::   kd1, kd2   ! starting and ending indices 
    … …  
    17751836      ! boundary condition initialization 
    17761837      ! --------------------------------- 
    1777       ztab(:,:) = 0.e0 
     1838      ztab2d(:,:) = 0.e0 
    17781839      ! 
    17791840      IF( ktype==1 ) THEN                                  ! north/south boundaries 
    … …  
    18051866            DO jj = ijpt0, ijpt1 
    18061867               DO ji = iipt0, iipt1 
    1807                   ztab(ji,jj) = ptab(ji,jk) 
     1868                  ztab2d(ji,jj) = ptab(ji,jk) 
    18081869               END DO 
    18091870            END DO 
    … …  
    18111872            DO jj = ijpt0, ijpt1 
    18121873               DO ji = iipt0, iipt1 
    1813                   ztab(ji,jj) = ptab(jj,jk) 
     1874                  ztab2d(ji,jj) = ptab(jj,jk) 
    18141875               END DO 
    18151876            END DO 
    … …  
    18231884            iihom = nlci-nreci 
    18241885            DO jl = 1, jpreci 
    1825                t2ew(:,jl,1) = ztab(jpreci+jl,:) 
    1826                t2we(:,jl,1) = ztab(iihom +jl,:) 
     1886               t2ew(:,jl,1) = ztab2d(jpreci+jl,:) 
     1887               t2we(:,jl,1) = ztab2d(iihom +jl,:) 
    18271888            END DO 
    18281889         ENDIF 
    … …  
    18531914         IF( nbondi == 0 .OR. nbondi == 1 ) THEN 
    18541915            DO jl = 1, jpreci 
    1855                ztab(jl,:) = t2we(:,jl,2) 
     1916               ztab2d(jl,:) = t2we(:,jl,2) 
    18561917            END DO 
    18571918         ENDIF 
    18581919         IF( nbondi == -1 .OR. nbondi == 0 ) THEN 
    18591920            DO jl = 1, jpreci 
    1860                ztab(iihom+jl,:) = t2ew(:,jl,2) 
     1921               ztab2d(iihom+jl,:) = t2ew(:,jl,2) 
    18611922            END DO 
    18621923         ENDIF 
    … …  
    18691930            ijhom = nlcj-nrecj 
    18701931            DO jl = 1, jprecj 
    1871                t2sn(:,jl,1) = ztab(:,ijhom +jl) 
    1872                t2ns(:,jl,1) = ztab(:,jprecj+jl) 
     1932               t2sn(:,jl,1) = ztab2d(:,ijhom +jl) 
     1933               t2ns(:,jl,1) = ztab2d(:,jprecj+jl) 
    18731934            END DO 
    18741935         ENDIF 
    … …  
    18981959         IF( nbondj == 0 .OR. nbondj == 1 ) THEN 
    18991960            DO jl = 1, jprecj 
    1900                ztab(:,jl) = t2sn(:,jl,2) 
     1961               ztab2d(:,jl) = t2sn(:,jl,2) 
    19011962            END DO 
    19021963         ENDIF 
    19031964         IF( nbondj == 0 .OR. nbondj == -1 ) THEN 
    19041965            DO jl = 1, jprecj 
    1905                ztab(:,ijhom+jl) = t2ns(:,jl,2) 
     1966               ztab2d(:,ijhom+jl) = t2ns(:,jl,2) 
    19061967            END DO 
    19071968         ENDIF 
    … …  
    19091970            DO jj = ijpt0, ijpt1            ! north/south boundaries 
    19101971               DO ji = iipt0,ilpt1 
    1911                   ptab(ji,jk) = ztab(ji,jj)   
     1972                  ptab(ji,jk) = ztab2d(ji,jj)   
    19121973               END DO 
    19131974            END DO 
    … …  
    19151976            DO jj = ijpt0, ilpt1            ! east/west boundaries 
    19161977               DO ji = iipt0,iipt1 
    1917                   ptab(jj,jk) = ztab(ji,jj)  
     1978                  ptab(jj,jk) = ztab2d(ji,jj)  
    19181979               END DO 
    19191980            END DO 
    … …  
    22012262      !! 
    22022263      !!---------------------------------------------------------------------- 
    2203       REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   pt3d      ! 3D array on which the b.c. is applied 
     2264!FTRANS pt3d :I :I :z 
     2265!! DCSE_NEMO: work around a deficiency in ftrans 
     2266!     REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   pt3d      ! 3D array on which the b.c. is applied 
     2267      REAL(wp),                         INTENT(inout) ::   pt3d(jpi,jpj,jpk) 
    22042268      CHARACTER(len=1)                , INTENT(in   ) ::   cd_type   ! nature of pt3d grid-points 
    22052269      !                                                              !   = T ,  U , V , F or W  gridpoints 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/LBC/mppini.F90

    r2715 r3211  
    2222   PUBLIC mpp_init       ! called by opa.F90 
    2323   PUBLIC mpp_init2      ! called by opa.F90 
     24 
     25   !! * Control permutation of array indices 
     26#  include "dom_oce_ftrans.h90" 
    2427 
    2528   !! * Substitutions 
    … …  
    142145      !  Computation of local domain sizes ilcit() ilcjt() 
    143146      !  These dimensions depend on global sizes jpni,jpnj and jpiglo,jpjglo 
    144       !  The subdomains are squares leeser than or equal to the global 
     147      !  The subdomains are squares lesser than or equal to the global 
    145148      !  dimensions divided by the number of processors minus the overlap 
    146149      !  array (cf. par_oce.F90). 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/LDF/ldfdyn.F90

    r2715 r3211  
    3232     MODULE PROCEDURE ldf_zpf_1d, ldf_zpf_1d_3d, ldf_zpf_3d 
    3333  END INTERFACE 
     34 
     35   !! * Control permutation of array indices 
     36#  include "oce_ftrans.h90" 
     37#  include "dom_oce_ftrans.h90" 
     38#  include "ldfdyn_oce_ftrans.h90" 
     39#  include "ldfslp_ftrans.h90" 
    3440 
    3541   !! * Substitutions 
    … …  
    207213      REAL(wp), INTENT(in   )                         ::   pbot       ! bottom value (0<pbot<= 1) 
    208214      REAL(wp), INTENT(in   ), DIMENSION          (:) ::   pdep       ! depth of the gridpoint (T, U, V, F) 
     215!FTRANS pah :I :I :z 
    209216      REAL(wp), INTENT(inout), DIMENSION      (:,:,:) ::   pah        ! adimensional vertical profile 
    210217      !! 
    … …  
    248255      REAL(wp), INTENT(in   )                         ::   pwam       ! width of inflection 
    249256      REAL(wp), INTENT(in   )                         ::   pbot       ! bottom value (0<pbot<= 1) 
     257!FTRANS pdep pah :I :I :z 
    250258      REAL(wp), INTENT(in   ), DIMENSION      (:,:,:) ::   pdep       ! dep of the gridpoint (T, U, V, F) 
    251259      REAL(wp), INTENT(inout), DIMENSION      (:,:,:) ::   pah        ! adimensional vertical profile 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/LDF/ldfdyn_oce.F90

    r2715 r3211  
    3535#endif 
    3636 
     37   !! * Control permutation of array indices 
     38#  include "ldfdyn_oce_ftrans.h90" 
     39 
    3740   !!---------------------------------------------------------------------- 
    3841   !! NEMO/OPA 4.0 , NEMO Consortium (2011) 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/LDF/ldfdyn_substitute.h90

    r2528 r3211  
    2020#    define   fsahmu(i,j,k)    ahm3(i,j,k) 
    2121#    define   fsahmv(i,j,k)    ahm4(i,j,k) 
     22#    include "ldfdyn_oce_ftrans.h90" 
    2223#elif defined key_dynldf_c2d 
    2324!   ' key_dynldf_c2d' :                 2D coefficient 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/LDF/ldfeiv.F90

    r2715 r3211  
    3131   PUBLIC   ldf_eiv    ! routine called by step.F90 
    3232    
     33   !! * Control permutation of array indices 
     34#  include "oce_ftrans.h90" 
     35#  include "dom_oce_ftrans.h90" 
     36#  include "sbc_oce_ftrans.h90" 
     37#  include "ldftra_oce_ftrans.h90" 
     38#  include "ldfslp_ftrans.h90" 
     39 
    3340   !! * Substitutions 
    3441#  include "domzgr_substitute.h90" 
    … …  
    8491      ! ---------------------------------------- 
    8592      IF( ln_traldf_grif ) THEN 
    86          DO jk = 1, jpk 
    8793#  if defined key_vectopt_loop   
     94         DO jk = 1, jpk 
    8895!CDIR NOVERRCHK  
    8996            DO ji = 1, jpij   ! vector opt. 
    … …  
    100107               zhw(ji,1) = zhw(ji,1) + ze3w 
    101108            END DO 
     109         END DO 
    102110#  else 
     111#     if defined key_z_first 
     112         DO jj = 2, jpjm1 
     113            DO ji = 2, jpim1 
     114               DO jk = 1, jpk 
     115#     else 
     116         DO jk = 1, jpk 
    103117            DO jj = 2, jpjm1 
    104118!CDIR NOVERRCHK  
    105119               DO ji = 2, jpim1 
     120#     endif 
    106121                  ! Take the max of N^2 and zero then take the vertical sum  
    107122                  ! of the square root of the resulting N^2 ( required to compute  
    … …  
    117132               END DO 
    118133            END DO 
     134         END DO 
    119135#  endif 
    120          END DO 
    121136      ELSE 
    122          DO jk = 1, jpk 
    123137#  if defined key_vectopt_loop   
     138         DO jk = 1, jpk 
    124139!CDIR NOVERRCHK  
    125140            DO ji = 1, jpij   ! vector opt. 
    … …  
    137152               zhw(ji,1) = zhw(ji,1) + ze3w 
    138153            END DO 
     154         END DO 
    139155#  else 
     156#     if defined key_z_first 
     157         DO jj = 2, jpjm1 
     158            DO ji = 2, jpim1 
     159               DO jk = 1, jpk 
     160#     else 
     161         DO jk = 1, jpk 
    140162            DO jj = 2, jpjm1 
    141163!CDIR NOVERRCHK  
    142164               DO ji = 2, jpim1 
     165#     endif 
    143166                  ! Take the max of N^2 and zero then take the vertical sum  
    144167                  ! of the square root of the resulting N^2 ( required to compute  
    … …  
    155178               END DO 
    156179            END DO 
     180         END DO 
    157181#  endif 
    158          END DO 
    159182      END IF 
    160183 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/LDF/ldfslp.F90

    r2715 r3211  
    4646   !                                                                !! Griffies operator 
    4747   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)     ::   wslp2                !: wslp**2 from Griffies quarter cells 
    48    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:,:) ::   triadi_g, triadj_g   !: skew flux  slopes relative to geopotentials  
    49    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:,:) ::   triadi  , triadj     !: isoneutral slopes relative to model-coordinate 
     48   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:,:) ::   & 
     49             &   triadi_g, triadj_g   !: skew flux  slopes relative to geopotentials  
     50   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:,:) ::   & 
     51             &   triadi  , triadj     !: isoneutral slopes relative to model-coordinate 
    5052 
    5153   !                                                              !! Madec operator 
    … …  
    6264   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) ::   zdzrho , zdyrho, zdxrho     ! Horizontal and vertical density gradients 
    6365   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) ::   zti_mlb, ztj_mlb            ! for Griffies operator only 
     66 
     67   !! * Control permutation of array indices 
     68#  include "ldfslp_ftrans.h90" 
     69!FTRANS zdxrho :I :I :z : 
     70!FTRANS zdyrho :I :I :z : 
     71!FTRANS zdzrho :I :I :z : 
     72#  include "oce_ftrans.h90" 
     73#  include "dom_oce_ftrans.h90" 
     74#  include "ldftra_oce_ftrans.h90" 
     75#  include "ldfdyn_oce_ftrans.h90" 
    6476 
    6577   !! * Substitutions 
    … …  
    119131      USE oce     , ONLY:   zgrv => ta       , zwz => sa   ! (ta,sa) used as workspace 
    120132      USE wrk_nemo, ONLY:   zdzr => wrk_3d_1               ! 3D workspace 
     133      !! DCSE_NEMO: need additional directives for renamed module variables 
     134!FTRANS zgru :I :I :z 
     135!FTRANS zww  :I :I :z 
     136!FTRANS zgrv :I :I :z 
     137!FTRANS zwz  :I :I :z 
     138!FTRANS zdzr :I :I :z 
     139 
    121140      !! 
    122141      INTEGER , INTENT(in)                   ::   kt    ! ocean time-step index 
     142!FTRANS prd :I :I :z 
     143!FTRANS pn2 :I :I :z 
    123144      REAL(wp), INTENT(in), DIMENSION(:,:,:) ::   prd   ! in situ density 
    124145      REAL(wp), INTENT(in), DIMENSION(:,:,:) ::   pn2   ! Brunt-Vaisala frequency (locally ref.) 
    … …  
    145166      zwz(:,:,:) = 0._wp 
    146167      ! 
     168#if defined key_z_first 
     169      DO jj = 1, jpjm1           !==   i- & j-gradient of density   ==! 
     170         DO ji = 1, jpim1 
     171            DO jk = 1, jpk 
     172#else 
    147173      DO jk = 1, jpk             !==   i- & j-gradient of density   ==! 
    148174         DO jj = 1, jpjm1 
    149175            DO ji = 1, fs_jpim1   ! vector opt. 
     176#endif 
    150177               zgru(ji,jj,jk) = umask(ji,jj,jk) * ( prd(ji+1,jj  ,jk) - prd(ji,jj,jk) )  
    151178               zgrv(ji,jj,jk) = vmask(ji,jj,jk) * ( prd(ji  ,jj+1,jk) - prd(ji,jj,jk) )  
    … …  
    154181      END DO 
    155182      IF( ln_zps ) THEN                           ! partial steps correction at the bottom ocean level 
    156 # if defined key_vectopt_loop   
     183!! DCSE_NEMO: Attention! key_vectopt_loop will break key_z_first 
     184# if ( defined key_vectopt_loop ) && ! ( defined key_z_first )  
    157185         DO jj = 1, 1 
    158186            DO ji = 1, jpij-jpi   ! vector opt. (forced unrolling) 
    … …  
    167195      ENDIF 
    168196      ! 
     197#if defined key__first 
     198      DO jj = 1, jpj 
     199         DO ji = 1, jpi 
     200            zdzr(ji,jj,1) = 0._wp   !==   Local vertical density gradient at T-point   == !   (evaluated from N^2) 
     201            DO jk = 2, jpkm1 
     202               zdzr(ji,jj,jk) = zm1_g * ( prd(ji,jj,jk) + 1._wp )              & 
     203                  &                   * ( pn2(ji,jj,jk) + pn2(ji,jj,jk+1) ) * ( 1._wp - 0.5_wp * tmask(ji,jj,jk+1) ) 
     204            END DO 
     205         END DO 
     206      END DO 
     207#else 
    169208      zdzr(:,:,1) = 0._wp        !==   Local vertical density gradient at T-point   == !   (evaluated from N^2) 
    170209      DO jk = 2, jpkm1 
    … …  
    177216            &                 * ( pn2(:,:,jk) + pn2(:,:,jk+1) ) * ( 1._wp - 0.5_wp * tmask(:,:,jk+1) ) 
    178217      END DO 
     218#endif 
    179219      ! 
    180220      !                          !==   Slopes just below the mixed layer   ==! 
    … …  
    185225      ! ===========================      | vslp = d/dj( prd ) / d/dz( prd ) 
    186226      !                
     227#if defined key_z_first 
     228      DO jj = 2, jpjm1               !* Slopes at u and v points 
     229         DO ji = 2, jpim1 
     230            DO jk = 2, jpkm1 
     231#else 
    187232      DO jk = 2, jpkm1                            !* Slopes at u and v points 
    188233         DO jj = 2, jpjm1 
    189234            DO ji = fs_2, fs_jpim1   ! vector opt. 
     235#endif 
    190236               !                                      ! horizontal and vertical density gradient at u- and v-points 
    191237               zau = zgru(ji,jj,jk) / e1u(ji,jj) 
    … …  
    223269      ! 
    224270      !                                            !* horizontal Shapiro filter 
     271#if defined key_z_first 
     272      DO jj = 2, jpjm1, MAX(1, jpj-3)                        ! rows jj=2 and =jpjm1 only 
     273         DO ji = 2, jpim1   
     274            DO jk = 2, jpkm1 
     275#else 
    225276      DO jk = 2, jpkm1 
    226277         DO jj = 2, jpjm1, MAX(1, jpj-3)                        ! rows jj=2 and =jpjm1 only 
    227278            DO ji = 2, jpim1   
     279#endif 
    228280               uslp(ji,jj,jk) = z1_16 * (        zwz(ji-1,jj-1,jk) + zwz(ji+1,jj-1,jk)      & 
    229281                  &                       +      zwz(ji-1,jj+1,jk) + zwz(ji+1,jj+1,jk)      & 
    … …  
    238290            END DO 
    239291         END DO 
     292#if defined key_z_first 
     293      END DO 
     294      DO jj = 3, jpj-2                               ! other rows 
     295         DO ji = 2, jpim1 
     296            DO jk = 2, jpkm1 
     297#else 
    240298         DO jj = 3, jpj-2                               ! other rows 
    241299            DO ji = fs_2, fs_jpim1   ! vector opt. 
     300#endif 
    242301               uslp(ji,jj,jk) = z1_16 * (        zwz(ji-1,jj-1,jk) + zwz(ji+1,jj-1,jk)      & 
    243302                  &                       +      zwz(ji-1,jj+1,jk) + zwz(ji+1,jj+1,jk)      & 
    … …  
    252311            END DO 
    253312         END DO 
     313#if defined key_z_first 
     314      END DO 
     315      !                                           !* decrease along coastal boundaries 
     316      DO jj = 2, jpjm1 
     317         DO ji = 2, jpim1 
     318            DO jk = 2, jpkm1 
     319#else 
    254320         !                                        !* decrease along coastal boundaries 
    255321         DO jj = 2, jpjm1 
    256322            DO ji = fs_2, fs_jpim1   ! vector opt. 
     323#endif 
    257324               uslp(ji,jj,jk) = uslp(ji,jj,jk) * ( umask(ji,jj+1,jk) + umask(ji,jj-1,jk  ) ) * 0.5_wp   & 
    258325                  &                            * ( umask(ji,jj  ,jk) + umask(ji,jj  ,jk+1) ) * 0.5_wp 
    … …  
    267334      ! ===========================      | wslpj = mij( d/dj( prd ) / d/dz( prd ) 
    268335      !                
     336#if defined key_z_first 
     337      DO jj = 2, jpjm1 
     338         DO ji = 2, jpim1 
     339            DO jk = 2, jpkm1 
     340#else 
    269341      DO jk = 2, jpkm1 
    270342         DO jj = 2, jpjm1 
    271343            DO ji = fs_2, fs_jpim1   ! vector opt. 
     344#endif 
    272345               !                                  !* Local vertical density gradient evaluated from N^2 
    273346               zbw = zm1_2g * pn2 (ji,jj,jk) * ( prd (ji,jj,jk) + prd (ji,jj,jk-1) + 2. ) 
    … …  
    305378      ! 
    306379      !                                           !* horizontal Shapiro filter 
     380#if defined key_z_first 
     381      DO jj = 2, jpjm1, MAX(1, jpj-3)                           ! rows jj=2 and =jpjm1 only 
     382         DO ji = 2, jpim1 
     383            DO jk = 2, jpkm1 
     384#else 
    307385      DO jk = 2, jpkm1 
    308386         DO jj = 2, jpjm1, MAX(1, jpj-3)                        ! rows jj=2 and =jpjm1 only 
    309387            DO ji = 2, jpim1 
     388#endif 
    310389               wslpi(ji,jj,jk) = (        zwz(ji-1,jj-1,jk) + zwz(ji+1,jj-1,jk)     & 
    311390                  &                +      zwz(ji-1,jj+1,jk) + zwz(ji+1,jj+1,jk)     & 
    … …  
    321400            END DO 
    322401         END DO   
     402#if defined key_z_first 
     403      END DO 
     404      DO jj = 3, jpj-2                                  ! other rows 
     405         DO ji = 2, jpim1 
     406            DO jk = 2, jpkm1 
     407#else 
    323408         DO jj = 3, jpj-2                               ! other rows 
    324409            DO ji = fs_2, fs_jpim1   ! vector opt. 
     410#endif 
    325411               wslpi(ji,jj,jk) = (        zwz(ji-1,jj-1,jk) + zwz(ji+1,jj-1,jk)     & 
    326412                  &                +      zwz(ji-1,jj+1,jk) + zwz(ji+1,jj+1,jk)     & 
    … …  
    336422            END DO 
    337423         END DO 
     424#if defined key_z_first 
     425      END DO 
     426      !                                           !* decrease along coastal boundaries 
     427      DO jj = 2, jpjm1 
     428         DO ji = 2, jpim1 
     429            DO jk = 2, jpkm1 
     430#else 
    338431         !                                        !* decrease along coastal boundaries 
    339432         DO jj = 2, jpjm1 
    340433            DO ji = fs_2, fs_jpim1   ! vector opt. 
     434#endif 
    341435               zck =   ( umask(ji,jj,jk) + umask(ji-1,jj,jk) )   & 
    342436                  &  * ( vmask(ji,jj,jk) + vmask(ji,jj-1,jk) ) * 0.25 
    … …  
    383477   END SUBROUTINE ldf_slp 
    384478    
     479   !! * Reset control of array index permutation 
     480!FTRANS CLEAR 
     481#  include "ldfslp_ftrans.h90" 
     482!FTRANS zdxrho :I :I :z : 
     483!FTRANS zdyrho :I :I :z : 
     484!FTRANS zdzrho :I :I :z : 
     485#  include "oce_ftrans.h90" 
     486#  include "dom_oce_ftrans.h90" 
     487#  include "ldftra_oce_ftrans.h90" 
     488#  include "ldfdyn_oce_ftrans.h90" 
    385489 
    386490   SUBROUTINE ldf_slp_grif ( kt ) 
    … …  
    404508      USE wrk_nemo, ONLY:   zalpha  => wrk_3d_4 , zbeta => wrk_3d_5    ! alpha, beta at T points, at depth fsgdept 
    405509      USE wrk_nemo, ONLY:   z1_mlbw => wrk_2d_1 
     510      !! DCSE_NEMO: need additional directives for renamed module variables 
     511!FTRANS zdit   :I :I :z 
     512!FTRANS zdis   :I :I :z 
     513!FTRANS zdjt   :I :I :z 
     514!FTRANS zdjs   :I :I :z 
     515!FTRANS zdkt   :I :I :z 
     516!FTRANS zdks   :I :I :z 
     517!FTRANS zalpha :I :I :z 
     518!FTRANS zbeta  :I :I :z 
    406519      ! 
    407520      INTEGER, INTENT( in ) ::   kt   ! ocean time-step index 
    … …  
    426539      CALL eos_alpbet( tsb, zalpha, zbeta )     !==  before thermal and haline expension coeff. at T-points  ==! 
    427540      ! 
     541#if defined key_z_first 
     542      DO jj = 1, jpjm1 
     543         DO ji = 1, jpim1 
     544            DO jk = 1, jpkm1                    !==  before lateral T & S gradients at T-level jk  ==! 
     545#else 
    428546      DO jk = 1, jpkm1                          !==  before lateral T & S gradients at T-level jk  ==! 
    429547         DO jj = 1, jpjm1 
    430548            DO ji = 1, fs_jpim1   ! vector opt. 
     549#endif 
    431550               zdit(ji,jj,jk) = ( tb(ji+1,jj,jk) - tb(ji,jj,jk) ) * umask(ji,jj,jk)   ! i-gradient of T and S at jj 
    432551               zdis(ji,jj,jk) = ( sb(ji+1,jj,jk) - sb(ji,jj,jk) ) * umask(ji,jj,jk) 
    … …  
    437556      END DO 
    438557      IF( ln_zps ) THEN                               ! partial steps: correction at the last level 
    439 # if defined key_vectopt_loop 
     558# if ( defined key_vectopt_loop ) && ! ( defined key_z_first ) 
    440559         DO jj = 1, 1 
    441560            DO ji = 1, jpij-jpi   ! vector opt. (forced unrolling) 
    … …  
    452571      ENDIF 
    453572      ! 
     573#if defined key_z_first 
     574      DO jj = 1, jpj 
     575         DO ji = 1, jpi 
     576            zdkt(ji,jj,1) = 0._wp            !==  before vertical T & S gradient at w-level  ==! 
     577            zdks(ji,jj,1) = 0._wp 
     578            DO jk = 2, jpk 
     579               zdkt(ji,jj,jk) = ( tb(ji,jj,jk-1) - tb(ji,jj,jk) ) * tmask(ji,jj,jk) 
     580               zdks(ji,jj,jk) = ( sb(ji,jj,jk-1) - sb(ji,jj,jk) ) * tmask(ji,jj,jk) 
     581            END DO 
     582         END DO 
     583      END DO 
     584#else 
    454585      zdkt(:,:,1) = 0._wp                    !==  before vertical T & S gradient at w-level  ==! 
    455586      zdks(:,:,1) = 0._wp 
    … …  
    458589         zdks(:,:,jk) = ( sb(:,:,jk-1) - sb(:,:,jk) ) * tmask(:,:,jk) 
    459590      END DO 
     591#endif 
    460592      ! 
    461593      ! 
    462594      DO jl = 0, 1                           !==  density i-, j-, and k-gradients  ==! 
    463595         ip = jl   ;   jp = jl         ! guaranteed nonzero gradients ( absolute value larger than repsln) 
     596#if defined key_z_first 
     597         DO jj = 1, jpjm1                          ! NB: not masked due to the minimum value set 
     598            DO ji = 1, jpim1 
     599               DO jk = 1, jpkm1                    ! done each pair of triad 
     600#else 
    464601         DO jk = 1, jpkm1                          ! done each pair of triad 
    465602            DO jj = 1, jpjm1                       ! NB: not masked due to the minimum value set 
    466603               DO ji = 1, fs_jpim1   ! vector opt.  
     604#endif 
    467605                  zdxrho_raw = ( zalpha(ji+ip,jj   ,jk) * zdit(ji,jj,jk) + zbeta(ji+ip,jj   ,jk) * zdis(ji,jj,jk) ) / e1u(ji,jj) 
    468606                  zdyrho_raw = ( zalpha(ji   ,jj+jp,jk) * zdjt(ji,jj,jk) + zbeta(ji   ,jj+jp,jk) * zdjs(ji,jj,jk) ) / e2v(ji,jj) 
    … …  
    474612      END DO 
    475613     DO kp = 0, 1                           !==  density i-, j-, and k-gradients  ==! 
     614#if defined key_z_first 
     615         DO jj = 1, jpj                         ! NB: not masked due to the minimum value set 
     616            DO ji = 1, jpi 
     617               DO jk = 1, jpkm1                    ! done each pair of triad 
     618#else 
    476619         DO jk = 1, jpkm1                          ! done each pair of triad 
    477620            DO jj = 1, jpj                       ! NB: not masked due to the minimum value set 
    478621               DO ji = 1, jpi   ! vector opt.  
     622#endif 
    479623                  zdzrho_raw = ( zalpha(ji,jj,jk) * zdkt(ji,jj,jk+kp) + zbeta(ji,jj,jk) * zdks(ji,jj,jk+kp) )   & 
    480624                     &       / fse3w(ji,jj,jk+kp) 
    … …  
    530674         DO jl = 0, 1 
    531675            ip = jl   ;   jp = jl         ! i- and j-indices of triads (i-k and j-k planes) 
     676#if defined key_z_first 
     677            DO jj = 1, jpjm1 
     678               DO ji = 1, jpim1 
     679                  DO jk = 1, jpkm1 
     680#else 
    532681            DO jk = 1, jpkm1 
    533682               DO jj = 1, jpjm1 
    534683                  DO ji = 1, fs_jpim1   ! vector opt. 
     684#endif 
    535685                     ! 
    536686                     ! Calculate slope relative to geopotentials used for GM skew fluxes 
    … …  
    605755   END SUBROUTINE ldf_slp_grif 
    606756 
     757   !! * Reset control of array index permutation 
     758!FTRANS CLEAR 
     759#  include "ldfslp_ftrans.h90" 
     760!FTRANS zdxrho :I :I :z : 
     761!FTRANS zdyrho :I :I :z : 
     762!FTRANS zdzrho :I :I :z : 
     763#  include "oce_ftrans.h90" 
     764#  include "dom_oce_ftrans.h90" 
     765#  include "ldftra_oce_ftrans.h90" 
     766#  include "ldfdyn_oce_ftrans.h90" 
    607767 
    608768   SUBROUTINE ldf_slp_mxl( prd, pn2, p_gru, p_grv, p_dzr ) 
    … …  
    622782      !!                omlmask         :  mixed layer mask 
    623783      !!---------------------------------------------------------------------- 
     784!FTRANS prd   :I :I :z 
     785!FTRANS pn2   :I :I :z 
     786!FTRANS p_gru :I :I :z 
     787!FTRANS p_grv :I :I :z 
     788!FTRANS p_dzr :I :I :z 
    624789      REAL(wp), DIMENSION(:,:,:), INTENT(in) ::   prd            ! in situ density 
    625790      REAL(wp), DIMENSION(:,:,:), INTENT(in) ::   pn2            ! Brunt-Vaisala frequency (locally ref.) 
    … …  
    646811      !                          !==   surface mixed layer mask   ! 
    647812      DO jk = 1, jpk                      ! =1 inside the mixed layer, =0 otherwise 
    648 # if defined key_vectopt_loop 
     813# if ( defined key_vectopt_loop ) && ! ( defined key_z_first ) 
    649814         DO jj = 1, 1 
    650815            DO ji = 1, jpij   ! vector opt. (forced unrolling) 
    … …  
    672837      !----------------------------------------------------------------------- 
    673838      ! 
    674 # if defined key_vectopt_loop 
     839# if ( defined key_vectopt_loop ) && ! ( defined key_z_first ) 
    675840      DO jj = 1, 1 
    676841         DO ji = jpi+2, jpij-jpi-1   ! vector opt. (forced unrolling) 
    … …  
    727892   END SUBROUTINE ldf_slp_mxl 
    728893 
     894   !! * Reset control of array index permutation 
     895!FTRANS CLEAR 
     896#  include "ldfslp_ftrans.h90" 
     897!FTRANS zdxrho :I :I :z : 
     898!FTRANS zdyrho :I :I :z : 
     899!FTRANS zdzrho :I :I :z : 
     900#  include "oce_ftrans.h90" 
     901#  include "dom_oce_ftrans.h90" 
     902#  include "ldftra_oce_ftrans.h90" 
     903#  include "ldfdyn_oce_ftrans.h90" 
    729904 
    730905   SUBROUTINE ldf_slp_init 
    … …  
    780955            ! set the slope of diffusion to the slope of s-surfaces 
    781956            !      ( c a u t i o n : minus sign as fsdep has positive value ) 
     957#if defined key_z_first 
     958            DO jj = 2, jpjm1 
     959               DO ji = 2, jpim1 
     960                  DO jk = 1, jpk 
     961#else 
    782962            DO jk = 1, jpk 
    783963               DO jj = 2, jpjm1 
    784964                  DO ji = fs_2, fs_jpim1   ! vector opt. 
     965#endif 
    785966                     uslp (ji,jj,jk) = -1./e1u(ji,jj) * ( fsdept(ji+1,jj,jk) - fsdept(ji ,jj ,jk) ) * umask(ji,jj,jk) 
    786967                     vslp (ji,jj,jk) = -1./e2v(ji,jj) * ( fsdept(ji,jj+1,jk) - fsdept(ji ,jj ,jk) ) * vmask(ji,jj,jk) 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/LDF/ldftra.F90

    r2715 r3211  
    2929 
    3030   PUBLIC   ldf_tra_init   ! called by opa.F90 
     31 
     32   !! * Control permutation of array indices 
     33#  include "oce_ftrans.h90" 
     34#  include "dom_oce_ftrans.h90" 
     35#  include "ldftra_oce_ftrans.h90" 
     36#  include "ldfslp_ftrans.h90" 
    3137 
    3238   !! * Substitutions 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/LDF/ldftra_oce.F90

    r2715 r3211  
    3636 
    3737#if defined key_traldf_c3d 
    38    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   ahtt, ahtu, ahtv, ahtw   !: ** 3D coefficients ** at T-,U-,V-,W-points 
     38   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   ahtt, ahtu, ahtv, ahtw   !: ** 3D coefficients ** 
     39   !                                                                                   !  at T-,U-,V-,W-points 
    3940#elif defined key_traldf_c2d 
    40    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   ahtt, ahtu, ahtv, ahtw   !: ** 2D coefficients ** at T-,U-,V-,W-points 
     41   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   ahtt, ahtu, ahtv, ahtw   !: ** 2D coefficients ** 
     42   !                                                                                   !  at T-,U-,V-,W-points 
    4143#elif defined key_traldf_c1d 
    42    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:)     ::   ahtt, ahtu, ahtv, ahtw   !: ** 1D coefficients ** at T-,U-,V-,W-points 
     44   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:)     ::   ahtt, ahtu, ahtv, ahtw   !: ** 1D coefficients **  
     45   !                                                                                   !  at T-,U-,V-,W-points 
    4346#else 
    44    REAL(wp), PUBLIC                                      ::   ahtt, ahtu, ahtv, ahtw   !: ** 0D coefficients ** at T-,U-,V-,W-points 
     47   REAL(wp), PUBLIC                                      ::   ahtt, ahtu, ahtv, ahtw   !: ** 0D coefficients ** ! 
     48   !                                                                                   !  at T-,U-,V-,W-points 
    4549#endif 
    4650 
    … …  
    7276   REAL(wp), PUBLIC            ::   aeiu, aeiv, aeiw            !: eddy induced coef. (not used) 
    7377#endif 
     78 
     79   !! * Control permutation of array indices 
     80#  include "ldftra_oce_ftrans.h90" 
    7481 
    7582   !!---------------------------------------------------------------------- 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/OBC/obc_oce.F90

    r2715 r3211  
    219219      !                                                   !  (repsectively) at the south OB (u_cynbnd = cx rdt ) 
    220220   REAL(wp), ALLOCATABLE, SAVE,     DIMENSION(:,:) ::   usmsk, vsmsk, tsmsk  !: 2D mask for the South OB 
     221 
     222   !! * Control permutation of array indices 
     223#  include "obc_oce_ftrans.h90" 
    221224 
    222225   !!---------------------------------------------------------------------- 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/OBC/obc_vectopt_loop_substitute.h90

    r2528 r3211  
    22   !!                 ***  obc_vectopt_loop_substitute.h90  *** 
    33   !!---------------------------------------------------------------------- 
    4    !! ** purpose :   substitute the inner loop starting and inding indices  
     4   !! ** purpose :   substitute the inner loop starting and ending indices  
    55   !!      to allow unrolling of do-loop using CPP macro. 
    66   !!---------------------------------------------------------------------- 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/OBC/obcdta.F90

    r2722 r3211  
    5454   INTEGER ::   nt_m=0, ntobc_m 
    5555   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:)   :: ubtedta, vbtedta, sshedta    ! East 
    56    REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:)   :: ubtwdta, vbtwdta, sshwdta    ! West 
    57    REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:)   :: ubtndta, vbtndta, sshndta    ! North 
    58    REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:)   :: ubtsdta, vbtsdta, sshsdta    ! South 
     56   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:)   :: ubtwdta, vbtwdta, sshwdta    ! West 
     57   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:)   :: ubtndta, vbtndta, sshndta    ! North 
     58   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:)   :: ubtsdta, vbtsdta, sshsdta    ! South 
    5959   ! arrays used for interpolating time dependent data on the boundaries 
    6060   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: uedta, vedta, tedta, sedta    ! East 
    … …  
    6868   LOGICAL , ALLOCATABLE, SAVE, DIMENSION(:,:)   :: ltnmsk, lunmsk, lvnmsk  ! checks 
    6969   LOGICAL , ALLOCATABLE, SAVE, DIMENSION(:,:)   :: ltsmsk, lusmsk, lvsmsk 
     70 
     71   !! * Control permutation of array indices 
     72#  include "oce_ftrans.h90" 
     73#  include "dom_oce_ftrans.h90" 
     74#  include "obc_oce_ftrans.h90" 
     75   !! No public arrays in this module require index permutation 
     76!FTRANS uedta vedta tedta sedta :I :z : 
     77!FTRANS uwdta vwdta twdta swdta :I :z : 
     78!FTRANS undta vndta tndta sndta :I :z : 
     79!FTRANS usdta vsdta tsdta ssdta :I :z : 
     80!FTRANS ltemsk luemsk lvemsk :I :z 
     81!FTRANS ltwmsk luwmsk lvwmsk :I :z 
     82!FTRANS ltnmsk lunmsk lvnmsk :I :z 
     83!FTRANS ltsmsk lusmsk lvsmsk :I :z 
    7084 
    7185   !! * Substitutions 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/OBC/obcdyn.F90

    r2528 r3211  
    4545   REAL(wp) ::   rtaue  , rtauw  , rtaun  , rtaus  ,  & 
    4646                 rtauein, rtauwin, rtaunin, rtausin 
     47 
     48   !! * Control permutation of array indices 
     49#  include "oce_ftrans.h90" 
     50#  include "dom_oce_ftrans.h90" 
     51#  include "obc_oce_ftrans.h90" 
    4752 
    4853   !!--------------------------------------------------------------------------------- 
    … …  
    147152         ! 1.1 U zonal velocity     
    148153         ! -------------------- 
     154#if defined key_z_first 
     155         DO jj = 1, jpj 
     156            DO ji = nie0, nie1 
     157               DO jk = 1, jpkm1 
     158#else 
    149159         DO ji = nie0, nie1 
    150160            DO jk = 1, jpkm1 
    151161               DO jj = 1, jpj 
     162#endif 
    152163                  ua(ji,jj,jk) = ua(ji,jj,jk) * (1.-uemsk(jj,jk)) + & 
    153164                                 uemsk(jj,jk)*ufoe(jj,jk) 
    … …  
    158169         ! 1.2 V meridional velocity 
    159170         ! ------------------------- 
     171#if defined key_z_first 
     172         DO jj = 1, jpj 
     173            DO ji = nie0+1, nie1+1 
     174               DO jk = 1, jpkm1 
     175#else 
    160176         DO ji = nie0+1, nie1+1 
    161177            DO jk = 1, jpkm1 
    162178               DO jj = 1, jpj 
     179#endif 
    163180                  va(ji,jj,jk) = va(ji,jj,jk) * (1.-vemsk(jj,jk)) + & 
    164181                                 vfoe(jj,jk)*vemsk(jj,jk) 
    … …  
    191208         ! ... radiative conditions on the total part + relaxation toward climatology 
    192209         ! ... (jpjedp1, jpjefm1),jpieob 
     210#if defined key_z_first 
     211         DO jj = 1, jpj 
     212            DO ji = nie0, nie1 
     213               DO jk = 1, jpkm1 
     214#else 
    193215         DO ji = nie0, nie1 
    194216            DO jk = 1, jpkm1 
    195217               DO jj = 1, jpj 
     218#endif 
    196219                  z05cx = u_cxebnd(jj,jk) 
    197220                  z05cx = z05cx / e1t(ji,jj) 
    … …  
    229252         ! ... radiative condition 
    230253         ! ... (jpjedp1, jpjefm1), jpieob+1 
     254#if defined key_z_first 
     255         DO jj = 1, jpj 
     256            DO ji = nie0+1, nie1+1 
     257               DO jk = 1, jpkm1 
     258#else 
    231259         DO ji = nie0+1, nie1+1 
    232260            DO jk = 1, jpkm1 
    233261               DO jj = 1, jpj 
     262#endif 
    234263                  z05cx = v_cxebnd(jj,jk)  
    235264                  z05cx = z05cx / e1f(ji-1,jj) 
    … …  
    289318         ! 1.1 U zonal velocity 
    290319         ! --------------------- 
     320#if defined key_z_first 
     321         DO jj = 1, jpj 
     322            DO ji = niw0, niw1 
     323               DO jk = 1, jpkm1 
     324#else 
    291325         DO ji = niw0, niw1 
    292326            DO jk = 1, jpkm1 
    293327               DO jj = 1, jpj 
     328#endif 
    294329                  ua(ji,jj,jk) = ua(ji,jj,jk) * (1.-uwmsk(jj,jk)) + & 
    295330                                 uwmsk(jj,jk)*ufow(jj,jk) 
    … …  
    300335         ! 1.2 V meridional velocity 
    301336         ! ------------------------- 
     337#if defined key_z_first 
     338         DO jj = 1, jpj 
     339            DO ji = niw0, niw1 
     340               DO jk = 1, jpkm1 
     341#else 
    302342         DO ji = niw0, niw1 
    303343            DO jk = 1, jpkm1 
    304344               DO jj = 1, jpj 
     345#endif 
    305346                  va(ji,jj,jk) = va(ji,jj,jk) * (1.-vwmsk(jj,jk)) + & 
    306347                                 vfow(jj,jk)*vwmsk(jj,jk) 
    … …  
    333374         ! ... radiative conditions on the total part + relaxation toward climatology 
    334375         ! ... (jpjwdp1, jpjwfm1), jpiwob 
     376#if defined key_z_first 
     377         DO jj = 1, jpj 
     378            DO ji = niw0, niw1 
     379               DO jk = 1, jpkm1 
     380#else 
    335381         DO ji = niw0, niw1 
    336382            DO jk = 1, jpkm1 
    337383               DO jj = 1, jpj 
     384#endif 
    338385                  z05cx = u_cxwbnd(jj,jk) 
    339386                  z05cx = z05cx / e1t(ji+1,jj) 
    … …  
    370417         ! ... radiative condition plus Raymond-Kuo 
    371418         ! ... (jpjwdp1, jpjwfm1),jpiwob 
     419#if defined key_z_first 
     420         DO jj = 1, jpj 
     421            DO ji = niw0, niw1 
     422               DO jk = 1, jpkm1 
     423#else 
    372424         DO ji = niw0, niw1 
    373425            DO jk = 1, jpkm1 
    374426               DO jj = 1, jpj 
     427#endif 
    375428                  z05cx = v_cxwbnd(jj,jk)   
    376429                  z05cx = z05cx / e1f(ji,jj) 
    … …  
    429482         ! -------------------- 
    430483         DO jj = njn0+1, njn1+1 
     484#if defined key_z_first 
     485            DO ji = 1, jpi 
     486               DO jk = 1, jpkm1 
     487#else 
    431488            DO jk = 1, jpkm1 
    432489               DO ji = 1, jpi 
     490#endif 
    433491                  ua(ji,jj,jk)= ua(ji,jj,jk) * (1.-unmsk(ji,jk)) + & 
    434492                                ufon(ji,jk)*unmsk(ji,jk) 
    … …  
    440498         ! ------------------------- 
    441499         DO jj = njn0, njn1 
     500#if defined key_z_first 
     501            DO ji = 1, jpi 
     502               DO jk = 1, jpkm1 
     503#else 
    442504            DO jk = 1, jpkm1 
    443505               DO ji = 1, jpi 
     506#endif 
    444507                  va(ji,jj,jk)= va(ji,jj,jk) * (1.-vnmsk(ji,jk)) + & 
    445508                                vfon(ji,jk)*vnmsk(ji,jk) 
    … …  
    474537         ! ... jpjnob+1,(jpindp1, jpinfm1) 
    475538         DO jj = njn0+1, njn1+1 
     539#if defined key_z_first 
     540            DO ji = 1, jpi 
     541               DO jk = 1, jpkm1 
     542#else 
    476543            DO jk = 1, jpkm1 
    477544               DO ji = 1, jpi 
     545#endif 
    478546                  z05cx= u_cynbnd(ji,jk)  
    479547                  z05cx = z05cx / e2f(ji, jj-1) 
    … …  
    518586         ! ... jpjnob,(jpindp1, jpinfm1) 
    519587         DO jj = njn0, njn1 
     588#if defined key_z_first 
     589            DO ji = 1, jpi 
     590               DO jk = 1, jpkm1 
     591#else 
    520592            DO jk = 1, jpkm1 
    521593               DO ji = 1, jpi 
     594#endif 
    522595         ! ... 2* gradj(v) (T-point i=nibm, time mean) 
    523596                  z05cx = v_cynbnd(ji,jk) 
    … …  
    580653         ! -------------------- 
    581654         DO jj = njs0, njs1 
     655#if defined key_z_first 
     656            DO ji = 1, jpi 
     657               DO jk = 1, jpkm1 
     658#else 
    582659            DO jk = 1, jpkm1 
    583660               DO ji = 1, jpi 
     661#endif 
    584662                  ua(ji,jj,jk)= ua(ji,jj,jk) * (1.-usmsk(ji,jk)) + & 
    585663                                usmsk(ji,jk) * ufos(ji,jk) 
    … …  
    591669         ! ------------------------- 
    592670         DO jj = njs0, njs1 
     671#if defined key_z_first 
     672            DO ji = 1, jpi 
     673               DO jk = 1, jpkm1 
     674#else 
    593675            DO jk = 1, jpkm1 
    594676               DO ji = 1, jpi 
     677#endif 
    595678                  va(ji,jj,jk)= va(ji,jj,jk) * (1.-vsmsk(ji,jk)) + & 
    596679                                vsmsk(ji,jk) * vfos(ji,jk) 
    … …  
    624707         ! ... jpjsob,(jpisdp1, jpisfm1) 
    625708         DO jj = njs0, njs1 
     709#if defined key_z_first 
     710            DO ji = 1, jpi 
     711               DO jk = 1, jpkm1 
     712#else 
    626713            DO jk = 1, jpkm1 
    627714               DO ji = 1, jpi 
     715#endif 
    628716                  z05cx= u_cysbnd(ji,jk)  
    629717                  z05cx = z05cx / e2f(ji, jj) 
    … …  
    665753         ! ... jpjsob,(jpisdp1,jpisfm1) 
    666754         DO jj = njs0, njs1 
     755#if defined key_z_first 
     756            DO ji = 1, jpi 
     757               DO jk = 1, jpkm1 
     758#else 
    667759            DO jk = 1, jpkm1 
    668760               DO ji = 1, jpi 
     761#endif 
    669762                  z05cx = v_cysbnd(ji,jk) 
    670763                  z05cx = z05cx / e2t(ji,jj+1) 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/OBC/obcdyn_bt.F90

    r2715 r3211  
    3232 
    3333   PUBLIC   obc_dyn_bt  ! routine called in dynnxt (explicit free surface case) 
     34 
     35   !! * Control permutation of array indices 
     36#  include "oce_ftrans.h90" 
     37#  include "dom_oce_ftrans.h90" 
     38#  include "obc_oce_ftrans.h90" 
    3439 
    3540   !!---------------------------------------------------------------------- 
    … …  
    9297      !!---------------------------------------------------------------------- 
    9398 
     99#if defined key_z_first 
     100      DO jj = 1, jpj 
     101         DO ji = nie0, nie1 
     102            DO jk = 1, jpkm1 
     103#else 
    94104      DO ji = nie0, nie1 
    95105         DO jk = 1, jpkm1 
    96106            DO jj = 1, jpj 
     107#endif 
    97108               ua(ji,jj,jk) = ua(ji,jj,jk) + sqrt( grav*hur (ji,jj) )               & 
    98109                  &                      * ( ( sshn(ji,jj) + sshn(ji+1,jj) ) * 0.5  & 
    … …  
    123134      ! 
    124135      DO ji = niw0, niw1 
     136#if defined key_z_first 
     137         DO jj = 1, jpj 
     138            DO jk = 1, jpkm1 
     139#else 
    125140         DO jk = 1, jpkm1 
    126141            DO jj = 1, jpj 
     142#endif 
    127143               ua(ji,jj,jk) = ua(ji,jj,jk) - sqrt( grav*hur (ji,jj) )               & 
    128144                  &                      * ( ( sshn(ji,jj) + sshn(ji+1,jj) ) * 0.5  & 
    … …  
    151167      ! 
    152168      DO jj = njn0, njn1 
     169#if defined key_z_first 
     170         DO ji = 1, jpi 
     171            DO jk = 1, jpkm1 
     172#else 
    153173         DO jk = 1, jpkm1 
    154174            DO ji = 1, jpi 
     175#endif 
    155176               va(ji,jj,jk) = va(ji,jj,jk) + sqrt( grav*hvr (ji,jj) )               & 
    156177                  &                      * ( ( sshn(ji,jj) + sshn(ji,jj+1) ) * 0.5  & 
    … …  
    181202      ! 
    182203      DO jj = njs0, njs1 
     204#if defined key_z_first 
     205         DO ji = 1, jpi 
     206            DO jk = 1, jpkm1 
     207#else 
    183208         DO jk = 1, jpkm1 
    184209            DO ji = 1, jpi 
     210#endif 
    185211               va(ji,jj,jk) = va(ji,jj,jk) - sqrt( grav*hvr (ji,jj) )               & 
    186212                  &                       * ( ( sshn(ji,jj) + sshn(ji,jj+1) ) * 0.5 & 
    … …  
    209235      !!---------------------------------------------------------------------- 
    210236      ! 
     237#if defined key_z_first 
     238      DO jj = 1, jpj 
     239         DO ji = nie0, nie1 
     240             DO jk = 1, jpkm1 
     241#else 
    211242      DO ji = nie0, nie1 
    212243         DO jk = 1, jpkm1 
    213244            DO jj = 1, jpj 
     245#endif 
    214246               ua(ji,jj,jk) = ( ua(ji,jj,jk) + sshfoe_b(ji,jj) ) * uemsk(jj,jk) 
    215247            END DO 
    216248         END DO 
    217249      END DO 
     250#if defined key_z_first 
     251      DO jj = 1, jpj 
     252         DO ji = nie0p1, nie1p1 
     253#else 
    218254      DO ji = nie0p1, nie1p1 
    219255         DO jj = 1, jpj 
     256#endif 
    220257            sshn(ji,jj) = sshn(ji,jj) * (1.-temsk(jj,1)) + temsk(jj,1)*sshn_b(ji,jj) 
    221258         END DO 
    … …  
    236273      !!---------------------------------------------------------------------- 
    237274      ! 
     275#if defined key_z_first 
     276      DO jj = 1, jpj 
     277         DO ji = niw0, niw1 
     278            DO jk = 1, jpkm1 
     279               ua(ji,jj,jk) = ( ua(ji,jj,jk) + sshfow_b(ji,jj) ) * uwmsk(jj,jk) 
     280            END DO 
     281         END DO 
     282      END DO 
     283      DO jj = 1, jpj 
     284         DO ji = niw0, niw1 
     285            sshn(ji,jj) = sshn(ji,jj) * (1.-twmsk(jj,1)) + twmsk(jj,1)*sshn_b(ji,jj) 
     286         END DO 
     287      END DO 
     288#else 
    238289      DO ji = niw0, niw1 
    239290         DO jk = 1, jpkm1 
    … …  
    246297         END DO 
    247298      END DO 
     299#endif 
    248300      ! 
    249301   END SUBROUTINE obc_dyn_bt_west 
    … …  
    262314      !!---------------------------------------------------------------------- 
    263315      ! 
     316#if defined key_z_first 
    264317      DO jj = njn0, njn1 
     318         DO ji = 1, jpi 
     319            DO jk = 1, jpkm1 
     320#else 
     321      DO jj = njn0, njn1 
    265322         DO jk = 1, jpkm1 
    266323            DO ji = 1, jpi 
     324#endif 
    267325               va(ji,jj,jk) = ( va(ji,jj,jk) + sshfon_b(ji,jj) ) * vnmsk(jj,jk) 
    268326            END DO 
    … …  
    291349      ! 
    292350      DO jj = njs0, njs1 
     351#if defined key_z_first 
     352         DO ji = 1, jpi 
     353            DO jk = 1, jpkm1 
     354#else 
    293355         DO jk = 1, jpkm1 
    294356            DO ji = 1, jpi 
     357#endif 
    295358               va(ji,jj,jk) = ( va(ji,jj,jk) + sshfos_b(ji,jj) ) * vsmsk(jj,jk) 
    296359            END DO 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/OBC/obcfla.F90

    r2715 r3211  
    3030 
    3131   PUBLIC   obc_fla_ts   ! routine called in dynspg_ts (free surface time splitting case) 
     32 
     33   !! * Control permutation of array indices 
     34#  include "oce_ftrans.h90" 
     35#  include "dom_oce_ftrans.h90" 
     36#  include "obc_oce_ftrans.h90" 
    3237 
    3338   !!---------------------------------------------------------------------- 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/OBC/obcini.F90

    r2715 r3211  
    2828 
    2929   PUBLIC   obc_init   ! routine called by opa.F90 
     30 
     31   !! * Control permutation of array indices 
     32#  include "oce_ftrans.h90" 
     33#  include "dom_oce_ftrans.h90" 
     34#  include "obc_oce_ftrans.h90" 
    3035 
    3136   !! * Substitutions 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/OBC/obcrad.F90

    r2715 r3211  
    3535      nitm  = 2,   & ! nitm   = before 
    3636      nitm2 = 3      ! nitm2  = before-before 
     37 
     38   !! * Control permutation of array indices 
     39#  include "oce_ftrans.h90" 
     40#  include "dom_oce_ftrans.h90" 
     41#  include "obc_oce_ftrans.h90" 
    3742 
    3843   !! * Substitutions 
    … …  
    114119 
    115120         ! ... advance in time (time filter, array swap)  
     121#if defined key_z_first 
     122         DO jj = 1, jpj 
     123            DO jk = 1, jpkm1 
     124#else 
    116125         DO jk = 1, jpkm1 
    117126            DO jj = 1, jpj 
     127#endif 
    118128               uebnd(jj,jk,nib  ,nitm2) = uebnd(jj,jk,nib  ,nitm)*uemsk(jj,jk) 
    119129               uebnd(jj,jk,nibm ,nitm2) = uebnd(jj,jk,nibm ,nitm)*uemsk(jj,jk) 
    … …  
    159169 
    160170         ! ... advance in time (time filter, array swap) 
     171#if defined key_z_first 
     172         DO jj = 1, jpj 
     173            DO jk = 1, jpkm1 
     174#else 
    161175         DO jk = 1, jpkm1 
    162176            DO jj = 1, jpj 
     177#endif 
    163178         ! ... fields nitm2 <== nitm 
    164179               vebnd(jj,jk,nib  ,nitm2) = vebnd(jj,jk,nib  ,nitm)*vemsk(jj,jk) 
    … …  
    169184 
    170185         DO ji = fs_nie0+1, fs_nie1+1 ! Vector opt. 
     186#if defined key_z_first 
     187            DO jj = 1, jpj 
     188               DO jk = 1, jpkm1 
     189#else 
    171190            DO jk = 1, jpkm1 
    172191               DO jj = 1, jpj 
     192#endif 
    173193                  vebnd(jj,jk,nib  ,nitm) = vebnd(jj,jk,nib,  nit)*vemsk(jj,jk) 
    174194                  vebnd(jj,jk,nibm ,nitm) = vebnd(jj,jk,nibm ,nit)*vemsk(jj,jk) 
    … …  
    201221 
    202222         ! ... advance in time (time filter, array swap) 
     223#if defined key_z_first 
     224         DO jj = 1, jpj 
     225            DO jk = 1, jpkm1 
     226#else 
    203227         DO jk = 1, jpkm1 
    204228            DO jj = 1, jpj 
     229#endif 
    205230         ! ... fields nitm <== nit  plus time filter at the boundary 
    206231               tebnd(jj,jk,nib,nitm) = tebnd(jj,jk,nib,nit)*temsk(jj,jk) 
    … …  
    210235 
    211236         DO ji = fs_nie0+1, fs_nie1+1 ! Vector opt. 
     237#if defined key_z_first 
     238            DO jj = 1, jpj 
     239               DO jk = 1, jpkm1 
     240#else 
    212241            DO jk = 1, jpkm1 
    213242               DO jj = 1, jpj 
     243#endif 
    214244                  tebnd(jj,jk,nibm,nitm) = tebnd(jj,jk,nibm,nit)*temsk(jj,jk) 
    215245                  sebnd(jj,jk,nibm,nitm) = sebnd(jj,jk,nibm,nit)*temsk(jj,jk) 
    … …  
    266296         ! ... (jpjedp1, jpjefm1),jpieob 
    267297         DO ji = fs_nie0, fs_nie1 ! Vector opt. 
     298#if defined key_z_first 
     299            DO jj = 2, jpjm1 
     300               DO jk = 1, jpkm1 
     301#else 
    268302            DO jk = 1, jpkm1 
    269303               DO jj = 2, jpjm1 
     304#endif 
    270305         ! ... 2* gradi(u) (T-point i=nibm, time mean) 
    271306                  z2dx = ( uebnd(jj,jk,nibm ,nit) + uebnd(jj,jk,nibm ,nitm2) & 
    … …  
    302337         ! ... (jpjedp1, jpjefm1), jpieob+1 
    303338         DO ji = fs_nie0+1, fs_nie1+1 ! Vector opt. 
     339#if defined key_z_first 
     340            DO jj = 2, jpjm1 
     341               DO jk = 1, jpkm1 
     342#else 
    304343            DO jk = 1, jpkm1 
    305344               DO jj = 2, jpjm1 
     345#endif 
    306346         ! ... 2* i-gradient of v (f-point i=nibm, time mean) 
    307347                  z2dx = ( vebnd(jj,jk,nibm ,nit) + vebnd(jj,jk,nibm ,nitm2) & 
    … …  
    378418 
    379419         ! ... advance in time (time filter, array swap)  
     420#if defined key_z_first 
     421         DO jj = 1, jpj  
     422            DO jk = 1, jpkm1 
     423#else 
    380424         DO jk = 1, jpkm1 
    381425            DO jj = 1, jpj  
     426#endif 
    382427               uwbnd(jj,jk,nib  ,nitm2) = uwbnd(jj,jk,nib  ,nitm)*uwmsk(jj,jk) 
    383428               uwbnd(jj,jk,nibm ,nitm2) = uwbnd(jj,jk,nibm ,nitm)*uwmsk(jj,jk) 
    … …  
    388433         ! ... fields nitm <== nit  plus time filter at the boundary  
    389434         DO ji = fs_niw0, fs_niw1 ! Vector opt. 
     435#if defined key_z_first 
     436            DO jj = 1, jpj 
     437               DO jk = 1, jpkm1 
     438#else 
    390439            DO jk = 1, jpkm1 
    391440               DO jj = 1, jpj 
     441#endif 
    392442                  uwbnd(jj,jk,nib  ,nitm) = uwbnd(jj,jk,nib  ,nit)*uwmsk(jj,jk) 
    393443                  uwbnd(jj,jk,nibm ,nitm) = uwbnd(jj,jk,nibm ,nit)*uwmsk(jj,jk) 
    … …  
    425475 
    426476         ! ... advance in time (time filter, array swap) 
     477#if defined key_z_first 
    427478         DO jk = 1, jpkm1 
    428479            DO jj = 1, jpj  
     480#else 
     481         DO jj = 1, jpj  
     482            DO jk = 1, jpkm1 
     483#endif 
    429484         ! ... fields nitm2 <== nitm 
    430485                  vwbnd(jj,jk,nib  ,nitm2) = vwbnd(jj,jk,nib  ,nitm)*vwmsk(jj,jk) 
    … …  
    435490 
    436491         DO ji = fs_niw0, fs_niw1 ! Vector opt. 
     492#if defined key_z_first 
     493            DO jj = 1, jpj 
     494               DO jk = 1, jpkm1 
     495#else 
    437496            DO jk = 1, jpkm1 
    438497               DO jj = 1, jpj 
     498#endif 
    439499                  vwbnd(jj,jk,nib  ,nitm) = vwbnd(jj,jk,nib,  nit)*vwmsk(jj,jk) 
    440500                  vwbnd(jj,jk,nibm ,nitm) = vwbnd(jj,jk,nibm ,nit)*vwmsk(jj,jk) 
    … …  
    467527  
    468528         ! ... advance in time (time filter, array swap) 
     529#if defined key_z_first 
     530         DO jj = 1, jpj 
     531            DO jk = 1, jpkm1 
     532#else 
    469533         DO jk = 1, jpkm1 
    470534            DO jj = 1, jpj 
     535#endif 
    471536         ! ... fields nitm <== nit  plus time filter at the boundary 
    472537               twbnd(jj,jk,nib,nitm) = twbnd(jj,jk,nib,nit)*twmsk(jj,jk) 
    … …  
    476541  
    477542         DO ji = fs_niw0, fs_niw1 ! Vector opt. 
     543#if defined key_z_first 
     544            DO jj = 1, jpj 
     545               DO jk = 1, jpkm1 
     546#else 
    478547            DO jk = 1, jpkm1 
    479548               DO jj = 1, jpj 
     549#endif 
    480550                  twbnd(jj,jk,nibm ,nitm) = twbnd(jj,jk,nibm ,nit)*twmsk(jj,jk) 
    481551                  swbnd(jj,jk,nibm ,nitm) = swbnd(jj,jk,nibm ,nit)*twmsk(jj,jk) 
    … …  
    534604         ! ... (jpjwdp1, jpjwfm1), jpiwob 
    535605         DO ji = fs_niw0, fs_niw1 ! Vector opt. 
     606#if defined key_z_first 
     607            DO jj = 2, jpjm1 
     608               DO jk = 1, jpkm1 
     609#else 
    536610            DO jk = 1, jpkm1 
    537611               DO jj = 2, jpjm1 
     612#endif 
    538613         ! ... 2* gradi(u) (T-point i=nibm, time mean) 
    539614                  z2dx = ( - uwbnd(jj,jk,nibm ,nit) -  uwbnd(jj,jk,nibm ,nitm2) & 
    … …  
    571646         ! ... (jpjwdp1, jpjwfm1),jpiwob 
    572647         DO ji = fs_niw0, fs_niw1 ! Vector opt. 
     648#if defined key_z_first 
     649            DO jj = 2, jpjm1 
     650               DO jk = 1, jpkm1 
     651#else 
    573652            DO jk = 1, jpkm1 
    574653               DO jj = 2, jpjm1 
     654#endif 
    575655         ! ... 2* i-gradient of v (f-point i=nibm, time mean) 
    576656                  z2dx = ( - vwbnd(jj,jk,nibm ,nit) - vwbnd(jj,jk,nibm ,nitm2) & 
    … …  
    647727 
    648728         ! ... advance in time (time filter, array swap) 
     729#if defined key_z_first 
     730         DO ji = 1, jpi 
     731            DO jk = 1, jpkm1 
     732#else 
    649733         DO jk = 1, jpkm1 
    650734            DO ji = 1, jpi 
     735#endif 
    651736         ! ... fields nitm2 <== nitm 
    652737               unbnd(ji,jk,nib  ,nitm2) = unbnd(ji,jk,nib  ,nitm)*unmsk(ji,jk) 
    … …  
    657742 
    658743         DO jj = fs_njn0+1, fs_njn1+1  ! Vector opt. 
     744#if defined key_z_first 
     745            DO ji = 1, jpi 
     746               DO jk = 1, jpkm1 
     747#else 
    659748            DO jk = 1, jpkm1 
    660749               DO ji = 1, jpi 
     750#endif 
    661751                  unbnd(ji,jk,nib  ,nitm) = unbnd(ji,jk,nib,  nit)*unmsk(ji,jk) 
    662752                  unbnd(ji,jk,nibm ,nitm) = unbnd(ji,jk,nibm ,nit)*unmsk(ji,jk) 
    … …  
    689779 
    690780         ! ... advance in time (time filter, array swap)  
     781#if defined key_z_first 
     782         DO ji = 1, jpi 
     783            DO jk = 1, jpkm1 
     784#else 
    691785         DO jk = 1, jpkm1 
    692786            DO ji = 1, jpi 
     787#endif 
    693788         ! ... fields nitm2 <== nitm  
    694789               vnbnd(ji,jk,nib  ,nitm2) = vnbnd(ji,jk,nib  ,nitm)*vnmsk(ji,jk) 
    … …  
    699794 
    700795         DO jj = fs_njn0, fs_njn1  ! Vector opt. 
     796#if defined key_z_first 
     797            DO ji = 1, jpi 
     798               DO jk = 1, jpkm1 
     799#else 
    701800            DO jk = 1, jpkm1 
    702801               DO ji = 1, jpi 
     802#endif 
    703803                  vnbnd(ji,jk,nib  ,nitm) = vnbnd(ji,jk,nib,  nit)*vnmsk(ji,jk) 
    704804                  vnbnd(ji,jk,nibm ,nitm) = vnbnd(ji,jk,nibm ,nit)*vnmsk(ji,jk) 
    … …  
    736836 
    737837         ! ... advance in time (time filter, array swap) 
     838#if defined key_z_first 
     839         DO ji = 1, jpi 
     840            DO jk = 1, jpkm1 
     841#else 
    738842         DO jk = 1, jpkm1 
    739843            DO ji = 1, jpi 
     844#endif 
    740845         ! ... fields nitm <== nit  plus time filter at the boundary 
    741846               tnbnd(ji,jk,nib ,nitm) = tnbnd(ji,jk,nib,nit)*tnmsk(ji,jk) 
    … …  
    745850 
    746851         DO jj = fs_njn0+1, fs_njn1+1  ! Vector opt. 
     852#if defined key_z_first 
     853            DO ji = 1, jpi 
     854               DO jk = 1, jpkm1 
     855#else 
    747856            DO jk = 1, jpkm1 
    748857               DO ji = 1, jpi 
     858#endif 
    749859                  tnbnd(ji,jk,nibm ,nitm) = tnbnd(ji,jk,nibm ,nit)*tnmsk(ji,jk) 
    750860                  snbnd(ji,jk,nibm ,nitm) = snbnd(ji,jk,nibm ,nit)*tnmsk(ji,jk) 
    … …  
    803913         ! ... jpjnob+1,(jpindp1, jpinfm1) 
    804914         DO jj = fs_njn0+1, fs_njn1+1  ! Vector opt. 
     915#if defined key_z_first 
     916            DO ji = 2, jpim1 
     917               DO jk = 1, jpkm1 
     918#else 
    805919            DO jk = 1, jpkm1 
    806920               DO ji = 2, jpim1 
     921#endif 
    807922         ! ... 2* j-gradient of u (f-point i=nibm, time mean) 
    808923                  z2dx = ( unbnd(ji,jk,nibm ,nit) + unbnd(ji,jk,nibm ,nitm2) & 
    … …  
    860975         ! ... jpjnob,(jpindp1, jpinfm1) 
    861976         DO jj = fs_njn0, fs_njn1  ! Vector opt. 
     977#if defined key_z_first 
     978            DO ji = 2, jpim1 
     979               DO jk = 1, jpkm1 
     980#else 
    862981            DO jk = 1, jpkm1 
    863982               DO ji = 2, jpim1 
     983#endif 
    864984         ! ... 2* gradj(v) (T-point i=nibm, time mean) 
    865985                  ii = ji -1 + nimpp 
    … …  
    9211041 
    9221042         ! ... advance in time (time filter, array swap) 
     1043#if defined key_z_first 
     1044         DO ji = 1, jpi 
     1045            DO jk = 1, jpkm1 
     1046#else 
    9231047         DO jk = 1, jpkm1 
    9241048            DO ji = 1, jpi 
     1049#endif 
    9251050         ! ... fields nitm2 <== nitm 
    9261051                  usbnd(ji,jk,nib  ,nitm2) = usbnd(ji,jk,nib  ,nitm)*usmsk(ji,jk) 
    … …  
    9311056  
    9321057         DO jj = fs_njs0, fs_njs1  ! Vector opt. 
     1058#if defined key_z_first 
     1059            DO ji = 1, jpi 
     1060               DO jk = 1, jpkm1 
     1061#else 
    9331062            DO jk = 1, jpkm1 
    9341063               DO ji = 1, jpi 
     1064#endif 
    9351065                  usbnd(ji,jk,nib  ,nitm) = usbnd(ji,jk,nib,  nit)*usmsk(ji,jk) 
    9361066                  usbnd(ji,jk,nibm ,nitm) = usbnd(ji,jk,nibm ,nit)*usmsk(ji,jk) 
    … …  
    9631093  
    9641094         !.. advance in time (time filter, array swap)  
     1095#if defined key_z_first 
     1096         DO ji = 1, jpi 
     1097            DO jk = 1, jpkm1 
     1098#else 
    9651099         DO jk = 1, jpkm1 
    9661100            DO ji = 1, jpi 
     1101#endif 
    9671102         ! ... fields nitm2 <== nitm  
    9681103               vsbnd(ji,jk,nib  ,nitm2) = vsbnd(ji,jk,nib  ,nitm)*vsmsk(ji,jk) 
    … …  
    9721107 
    9731108         DO jj = fs_njs0, fs_njs1  ! Vector opt. 
     1109#if defined key_z_first 
     1110            DO ji = 1, jpi 
     1111               DO jk = 1, jpkm1 
     1112#else 
    9741113            DO jk = 1, jpkm1 
    9751114               DO ji = 1, jpi 
     1115#endif 
    9761116                  vsbnd(ji,jk,nib  ,nitm) = vsbnd(ji,jk,nib,  nit)*vsmsk(ji,jk) 
    9771117                  vsbnd(ji,jk,nibm ,nitm) = vsbnd(ji,jk,nibm ,nit)*vsmsk(ji,jk) 
    … …  
    10081148 
    10091149         ! ... advance in time (time filter, array swap) 
     1150#if defined key_z_first 
     1151         DO ji = 1, jpi 
     1152            DO jk = 1, jpkm1 
     1153#else 
    10101154         DO jk = 1, jpkm1 
    10111155            DO ji = 1, jpi 
     1156#endif 
    10121157         ! ... fields nitm <== nit  plus time filter at the boundary 
    10131158               tsbnd(ji,jk,nib,nitm) = tsbnd(ji,jk,nib,nit)*tsmsk(ji,jk) 
    … …  
    10171162 
    10181163         DO jj = fs_njs0, fs_njs1  ! Vector opt. 
     1164#if defined key_z_first 
     1165            DO ji = 1, jpi 
     1166               DO jk = 1, jpkm1 
     1167#else 
    10191168            DO jk = 1, jpkm1 
    10201169               DO ji = 1, jpi 
     1170#endif 
    10211171                  tsbnd(ji,jk,nibm ,nitm) = tsbnd(ji,jk,nibm ,nit)*tsmsk(ji,jk) 
    10221172                  ssbnd(ji,jk,nibm ,nitm) = ssbnd(ji,jk,nibm ,nit)*tsmsk(ji,jk) 
    … …  
    10751225         ! ... jpjsob,(jpisdp1, jpisfm1) 
    10761226         DO jj = fs_njs0, fs_njs1  ! Vector opt. 
     1227#if defined key_z_first 
     1228            DO ji = 2, jpim1 
     1229               DO jk = 1, jpkm1 
     1230#else 
    10771231            DO jk = 1, jpkm1 
    10781232               DO ji = 2, jpim1 
     1233#endif 
    10791234         ! ... 2* j-gradient of u (f-point i=nibm, time mean) 
    10801235                  z2dx = (- usbnd(ji,jk,nibm ,nit) - usbnd(ji,jk,nibm ,nitm2) & 
    … …  
    11321287         ! ... jpjsob,(jpisdp1,jpisfm1) 
    11331288         DO jj = fs_njs0, fs_njs1 ! Vector opt. 
     1289#if defined key_z_first 
     1290            DO ji = 2, jpim1 
     1291               DO jk = 1, jpkm1 
     1292#else 
    11341293            DO jk = 1, jpkm1 
    11351294               DO ji = 2, jpim1 
     1295#endif 
    11361296         ! ... 2* gradj(v) (T-point i=nibm, time mean) 
    11371297                  z2dx = ( - vsbnd(ji,jk,nibm ,nit) - vsbnd(ji,jk,nibm ,nitm2) & 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/OBC/obcrst.F90

    r2715 r3211  
    2020   PUBLIC   obc_rst_read    ! routine called by obc_ini 
    2121   PUBLIC   obc_rst_write   ! routine called by step 
     22 
     23   !! * Control permutation of array indices 
     24#  include "oce_ftrans.h90" 
     25#  include "dom_oce_ftrans.h90" 
     26#  include "obc_oce_ftrans.h90" 
    2227 
    2328   !!---------------------------------------------------------------------- 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/OBC/obctra.F90

    r2528 r3211  
    4343      rtauein, rtauwin, rtaunin, rtausin      ! Boundary restoring coefficient for inflow  
    4444 
     45   !! * Control permutation of array indices 
     46#  include "oce_ftrans.h90" 
     47#  include "dom_oce_ftrans.h90" 
     48#  include "obc_oce_ftrans.h90" 
     49 
    4550   !! * Substitutions 
    4651#  include "obc_vectopt_loop_substitute.h90" 
    … …  
    140145 
    141146      IF( ( kt < nit000+3 .AND. .NOT.ln_rstart ) .OR. lfbceast ) THEN 
     147#if defined key_z_first 
     148         DO jj = 1, jpj 
     149            DO ji = fs_nie0+1, fs_nie1+1 ! Vector opt. 
     150               DO jk = 1, jpkm1 
     151#else 
    142152         DO ji = fs_nie0+1, fs_nie1+1 ! Vector opt. 
    143153            DO jk = 1, jpkm1 
    144154               DO jj = 1, jpj 
     155#endif 
    145156                  ta(ji,jj,jk) = ta(ji,jj,jk) * (1. - temsk(jj,jk)) + & 
    146157                                 tfoe(jj,jk)*temsk(jj,jk) 
    … …  
    178189         !     tial velocity (here vn), which have been saved in (u_cxebnd,v_cxebnd) 
    179190         ! ... (jpjedp1, jpjefm1), jpieob+1 
     191#if defined key_z_first 
     192         DO jj = 2, jpjm1 
     193            DO ji = fs_nie0+1, fs_nie1+1 ! Vector opt. 
     194               DO jk = 1, jpkm1 
     195#else 
    180196         DO ji = fs_nie0+1, fs_nie1+1 ! Vector opt. 
    181197            DO jk = 1, jpkm1 
    182198               DO jj = 2, jpjm1 
     199#endif 
    183200         ! ... i-phase speed ratio (from averaged of v_cxebnd) 
    184201                  z05cx = ( 0.5 * ( v_cxebnd(jj,jk) + v_cxebnd(jj-1,jk) ) ) / e1t(ji-1,jj) 
    … …  
    241258      IF( ( kt < nit000+3 .AND. .NOT.ln_rstart ) .OR. lfbcwest ) THEN 
    242259 
     260#if defined key_z_first 
     261         DO jj = 1, jpj 
     262            DO ji = fs_niw0, fs_niw1 ! Vector opt. 
     263               DO jk = 1, jpkm1 
     264#else 
    243265         DO ji = fs_niw0, fs_niw1 ! Vector opt. 
    244266            DO jk = 1, jpkm1 
    245267               DO jj = 1, jpj 
     268#endif 
    246269                  ta(ji,jj,jk) = ta(ji,jj,jk) * (1. - twmsk(jj,jk)) + & 
    247270                                 tfow(jj,jk)*twmsk(jj,jk) 
    … …  
    278301         ! ... the phase velocity is taken as the phase velocity of the tangen- 
    279302         ! ... tial velocity (here vn), which have been saved in (v_cxwbnd) 
     303#if defined key_z_first 
     304         DO jj = 2, jpjm1 
     305            DO ji = fs_niw0, fs_niw1 ! Vector opt. 
     306               DO jk = 1, jpkm1 
     307#else 
    280308         DO ji = fs_niw0, fs_niw1 ! Vector opt. 
    281309            DO jk = 1, jpkm1 
    282310               DO jj = 2, jpjm1 
     311#endif 
    283312         ! ... i-phase speed ratio (from averaged of v_cxwbnd) 
    284313                  z05cx = (  0.5 * ( v_cxwbnd(jj,jk) + v_cxwbnd(jj-1,jk) ) ) / e1t(ji+1,jj) 
    … …  
    341370 
    342371         DO jj = fs_njn0+1, fs_njn1+1  ! Vector opt. 
     372#if defined key_z_first 
     373            DO ji = 1, jpi 
     374               DO jk = 1, jpkm1 
     375#else 
    343376            DO jk = 1, jpkm1 
    344377               DO ji = 1, jpi 
     378#endif 
    345379                  ta(ji,jj,jk)= ta(ji,jj,jk) * (1.-tnmsk(ji,jk)) + & 
    346380                                tnmsk(ji,jk) * tfon(ji,jk) 
    … …  
    379413         ! ... jpjnob+1,(jpindp1, jpinfm1) 
    380414         DO jj = fs_njn0+1, fs_njn1+1 ! Vector opt. 
     415#if defined key_z_first 
     416            DO ji = 2, jpim1 
     417               DO jk = 1, jpkm1 
     418#else 
    381419            DO jk = 1, jpkm1 
    382420               DO ji = 2, jpim1 
     421#endif 
    383422         ! ... j-phase speed ratio (from averaged of vtnbnd) 
    384423         !        (bounded by 1) 
    … …  
    443482 
    444483         DO jj = fs_njs0, fs_njs1  ! Vector opt. 
     484#if defined key_z_first 
     485            DO ji = 1, jpi 
     486               DO jk = 1, jpkm1 
     487#else 
    445488            DO jk = 1, jpkm1 
    446489               DO ji = 1, jpi 
     490#endif 
    447491                  ta(ji,jj,jk)= ta(ji,jj,jk) * (1.-tsmsk(ji,jk)) + & 
    448492                                tsmsk(ji,jk) * tfos(ji,jk) 
    … …  
    480524         !... jpjsob,(jpisdp1, jpisfm1) 
    481525         DO jj = fs_njs0, fs_njs1  ! Vector opt. 
     526#if defined key_z_first 
     527            DO ji = 2, jpim1 
     528               DO jk = 1, jpkm1 
     529#else 
    482530            DO jk = 1, jpkm1 
    483531               DO ji = 2, jpim1 
     532#endif 
    484533         !... j-phase speed ratio (from averaged of u_cysbnd) 
    485534         !       (bounded by 1) 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/OBC/obcvol.F90

    r2528 r3211  
    2424   PUBLIC obc_vol        ! routine called by dynspg_flt 
    2525 
     26   !! * Control permutation of array indices 
     27#  include "oce_ftrans.h90" 
     28#  include "dom_oce_ftrans.h90" 
     29#  include "sbc_oce_ftrans.h90" 
     30#  include "obc_oce_ftrans.h90" 
     31 
    2632   !! * Substitutions 
    2733#  include "domzgr_substitute.h90" 
    … …  
    108114      ! ... East open boundary 
    109115      IF( lp_obc_east ) THEN                      ! ... Total transport through the East OBC 
     116#if defined key_z_first 
     117         DO jj = 1, jpj 
     118            DO ji = fs_nie0, fs_nie1 ! Vector opt. 
     119               DO jk = 1, jpkm1 
     120#else 
    110121         DO ji = fs_nie0, fs_nie1 ! Vector opt. 
    111122            DO jk = 1, jpkm1 
    112123               DO jj = 1, jpj 
     124#endif 
    113125                  zubtpecor = zubtpecor - ua(ji,jj,jk)*e2u(ji,jj)*fse3u(ji,jj,jk) * & 
    114126             &     uemsk(jj,jk)*MAX(obctmsk(ji,jj),obctmsk(ji+1,jj) ) 
    … …  
    120132      ! ... West open boundary 
    121133      IF( lp_obc_west ) THEN                      ! ... Total transport through the West OBC 
     134#if defined key_z_first 
     135         DO jj = 1, jpj 
     136            DO ji = fs_niw0, fs_niw1 ! Vector opt. 
     137               DO jk = 1, jpkm1 
     138#else 
    122139         DO ji = fs_niw0, fs_niw1 ! Vector opt. 
    123140            DO jk = 1, jpkm1 
    124141               DO jj = 1, jpj 
     142#endif 
    125143                  zubtpecor = zubtpecor + ua(ji,jj,jk)*e2u(ji,jj)*fse3u(ji,jj,jk) * & 
    126144             &    uwmsk(jj,jk) *MAX(obctmsk(ji,jj),obctmsk(ji+1,jj) ) 
    … …  
    128146            END DO 
    129147         END DO 
    130        ENDIF 
     148      ENDIF 
    131149 
    132150      ! ... North open boundary 
    133151      IF( lp_obc_north ) THEN                     ! ... Total transport through the North OBC 
     152#if defined key_z_first 
     153         DO ji = 1, jpi 
     154            DO jj = fs_njn0, fs_njn1 ! Vector opt. 
     155               DO jk = 1, jpkm1 
     156#else 
    134157         DO jj = fs_njn0, fs_njn1 ! Vector opt. 
    135158            DO jk = 1, jpkm1 
    136159               DO ji = 1, jpi 
     160#endif 
    137161                  zubtpecor = zubtpecor - va(ji,jj,jk)*e1v(ji,jj)*fse3v(ji,jj,jk) * & 
    138162             &    vnmsk(ji,jk) * MAX(obctmsk(ji,jj),obctmsk(ji,jj+1) ) 
    … …  
    140164            END DO 
    141165         END DO 
    142        ENDIF 
     166      ENDIF 
    143167 
    144168      ! ... South open boundary 
    145169      IF( lp_obc_south ) THEN                     ! ... Total transport through the South OBC 
    146170         DO jj = fs_njs0, fs_njs1 ! Vector opt. 
     171#if defined key_z_first 
     172            DO ji = 1, jpi 
     173               DO jk = 1, jpkm1 
     174#else 
    147175            DO jk = 1, jpkm1 
    148176               DO ji = 1, jpi 
     177#endif 
    149178                  zubtpecor = zubtpecor + va(ji,jj,jk)*e1v(ji,jj)*fse3v(ji,jj,jk) * & 
    150179             &    vsmsk(ji,jk) * MAX(obctmsk(ji,jj),obctmsk(ji,jj+1) ) 
    … …  
    152181            END DO 
    153182         END DO 
    154        ENDIF 
     183      ENDIF 
    155184 
    156185      IF( lk_mpp )   CALL mpp_sum( zubtpecor )   ! sum over the global domain 
    … …  
    185214      IF( lp_obc_west ) THEN 
    186215         ! ... correction of the west velocity 
     216#if defined key_z_first 
     217         DO jj = 1, jpj 
     218            DO ji = fs_niw0, fs_niw1 ! Vector opt. 
     219               DO jk = 1, jpkm1 
     220#else 
    187221         DO ji = fs_niw0, fs_niw1 ! Vector opt. 
    188222            DO jk = 1, jpkm1 
    189223               DO jj = 1, jpj 
     224#endif 
    190225                  ua(ji,jj,jk) = ua(ji,jj,jk) - zubtpecor*uwmsk(jj,jk) 
    191226                  ztransw= ztransw + ua(ji,jj,jk)*fse3u(ji,jj,jk)*e2u(ji,jj)*uwmsk(jj,jk) * & 
    … …  
    203238 
    204239         ! ... correction of the east velocity 
     240#if defined key_z_first 
     241         DO jj = 1, jpj 
     242            DO ji = fs_nie0, fs_nie1 ! Vector opt. 
     243               DO jk = 1, jpkm1 
     244#else 
    205245         DO ji = fs_nie0, fs_nie1 ! Vector opt. 
    206246            DO jk = 1, jpkm1 
    207247               DO jj = 1, jpj 
     248#endif 
    208249                  ua(ji,jj,jk) = ua(ji,jj,jk) + zubtpecor*uemsk(jj,jk) 
    209250                  ztranse= ztranse + ua(ji,jj,jk)*fse3u(ji,jj,jk)*e2u(ji,jj)*uemsk(jj,jk) * & 
    … …  
    225266         ! ... correction of the north velocity 
    226267         DO jj = fs_njn0, fs_njn1 ! Vector opt. 
     268#if defined key_z_first 
     269            DO ji =  1, jpi 
     270               DO jk = 1, jpkm1 
     271#else 
    227272            DO jk = 1, jpkm1 
    228273               DO ji =  1, jpi 
     274#endif 
    229275                  va(ji,jj,jk) = va(ji,jj,jk) + zubtpecor*vnmsk(ji,jk) 
    230276                  ztransn= ztransn + va(ji,jj,jk)*fse3v(ji,jj,jk)*e1v(ji,jj)*vnmsk(ji,jk) * & 
    … …  
    245291         ! ... correction of the south velocity 
    246292         DO jj = fs_njs0, fs_njs1 ! Vector opt. 
     293#if defined key_z_first 
     294            DO ji =  1, jpi 
     295               DO jk = 1, jpkm1 
     296#else 
    247297            DO jk = 1, jpkm1 
    248298               DO ji =  1, jpi 
     299#endif 
    249300                  va(ji,jj,jk) = va(ji,jj,jk) - zubtpecor*vsmsk(ji,jk) 
    250301                  ztranss= ztranss + va(ji,jj,jk)*fse3v(ji,jj,jk)*e1v(ji,jj)*vsmsk(ji,jk) * & 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/OBS/diaobs.F90

    r2733 r3211  
    1919   USE in_out_manager           ! I/O manager 
    2020   USE par_oce 
    21    USE dom_oce                  ! Ocean space and time domain variables 
    2221   USE obs_read_prof            ! Reading and allocation of observations (Coriolis) 
    2322   USE obs_read_sla             ! Reading and allocation of SLA observations   
    … …  
    105104   LOGICAL, DIMENSION(:), ALLOCATABLE :: & 
    106105      & ld_velav     !: Velocity data is daily averaged 
     106 
     107   !! * Control permutation of array indices 
     108#  include "dom_oce_ftrans.h90" 
    107109 
    108110   !!---------------------------------------------------------------------- 
    … …  
    10231025      USE wrk_nemo, ONLY: frld => wrk_2d_1 
    10241026#endif 
     1027 
     1028   !! * Control permutation of array indices 
     1029!FTRANS CLEAR 
     1030#  include "dom_oce_ftrans.h90" 
     1031#  include "oce_ftrans.h90" 
     1032 
    10251033      IMPLICIT NONE 
    10261034 
    … …  
    10811089      IF ( ln_sla ) THEN 
    10821090         DO jslaset = 1, nslasets 
     1091#if defined key_z_first 
     1092            CALL obs_sla_opt( sladatqc(jslaset),            & 
     1093               &              kstp, jpi, jpj, nit000, sshn, & 
     1094               &              tmask_1(:,:), n2dint ) 
     1095#else 
    10831096            CALL obs_sla_opt( sladatqc(jslaset),            & 
    10841097               &              kstp, jpi, jpj, nit000, sshn, & 
    10851098               &              tmask(:,:,1), n2dint ) 
     1099#endif 
    10861100         END DO          
    10871101      ENDIF 
    … …  
    10901104      IF ( ln_sst ) THEN 
    10911105         DO jsstset = 1, nsstsets 
     1106#if defined key_z_first 
     1107            CALL obs_sst_opt( sstdatqc(jsstset),                 & 
     1108               &              kstp, jpi, jpj, nit000, tn(:,:,1), & 
     1109               &              tmask_1(:,:), n2dint ) 
     1110#else 
    10921111            CALL obs_sst_opt( sstdatqc(jsstset),                 & 
    10931112               &              kstp, jpi, jpj, nit000, tn(:,:,1), & 
    10941113               &              tmask(:,:,1), n2dint ) 
     1114#endif 
    10951115         END DO 
    10961116      ENDIF 
    … …  
    14271447         & rdt 
    14281448 
     1449   !! * Control permutation of array indices 
     1450!FTRANS CLEAR 
     1451 
    14291452      IMPLICIT NONE 
    14301453 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/OBS/mpp_map.F90

    r2363 r3211  
    2424 
    2525   INTEGER, DIMENSION(:,:), ALLOCATABLE ::   mppmap   ! ??? 
     26 
     27   !! * Control permutation of array indices 
     28   !! No array indices to control 
    2629 
    2730   !!---------------------------------------------------------------------- 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/OBS/obs_grid.F90

    r2715 r3211  
    8585      & grid_search_file    ! file name head for grid search lookup  
    8686 
     87   !! * Control permutation of array indices 
     88#  include "dom_oce_ftrans.h90" 
     89 
    8790   !!---------------------------------------------------------------------- 
    8891   !! NEMO/OPA 3.3 , NEMO Consortium (2010) 
    … …  
    128131         ELSE 
    129132            IF ( cdgrid == 'T' ) THEN 
    130                CALL obs_grd_bruteforce( jpi, jpj, jpiglo, jpjglo, & 
    131                   &                             nldi, nlei,nldj,  nlej,   & 
    132                   &                             nproc, jpnij,             & 
    133                   &                             glamt, gphit, tmask,      & 
    134                   &                             kobsin, plam, pphi,       & 
    135                   &                             kobsi, kobsj, kproc ) 
     133               CALL obs_grd_bruteforce( jpi, jpj, jpiglo, jpjglo,        & 
     134                  &                     nldi, nlei,nldj,  nlej,          & 
     135                  &                     nproc, jpnij,                    & 
     136#if defined key_z_first 
     137                  &                     glamt, gphit, tmask_1(:,:),      & 
     138#else 
     139                  &                     glamt, gphit, tmask(:,:,1),      & 
     140#endif 
     141                  &                     kobsin, plam, pphi,              & 
     142                  &                     kobsi, kobsj, kproc ) 
    136143            ELSEIF ( cdgrid == 'U' ) THEN 
    137                CALL obs_grd_bruteforce( jpi, jpj, jpiglo, jpjglo, & 
    138                   &                             nldi, nlei,nldj,  nlej,   & 
    139                   &                             nproc, jpnij,             & 
    140                   &                             glamu, gphiu, umask,      & 
    141                   &                             kobsin, plam, pphi,       & 
    142                   &                             kobsi, kobsj, kproc ) 
     144               CALL obs_grd_bruteforce( jpi, jpj, jpiglo, jpjglo,        & 
     145                  &                     nldi, nlei,nldj,  nlej,          & 
     146                  &                     nproc, jpnij,                    & 
     147#if defined key_z_first 
     148                  &                     glamu, gphiu, umask_1(:,:),      & 
     149#else 
     150                  &                     glamu, gphiu, umask(:,:,1),      & 
     151#endif 
     152                  &                     kobsin, plam, pphi,              & 
     153                  &                     kobsi, kobsj, kproc ) 
    143154            ELSEIF ( cdgrid == 'V' ) THEN 
    144                CALL obs_grd_bruteforce( jpi, jpj, jpiglo, jpjglo, & 
    145                   &                             nldi, nlei,nldj,  nlej,   & 
    146                   &                             nproc, jpnij,             & 
    147                   &                             glamv, gphiv, vmask,      & 
    148                   &                             kobsin, plam, pphi,       & 
    149                   &                             kobsi, kobsj, kproc ) 
     155               CALL obs_grd_bruteforce( jpi, jpj, jpiglo, jpjglo,        & 
     156                  &                     nldi, nlei,nldj,  nlej,          & 
     157                  &                     nproc, jpnij,                    & 
     158#if defined key_z_first 
     159                  &                     glamv, gphiv, vmask_1(:,:),      & 
     160#else 
     161                  &                     glamv, gphiv, vmask(:,:,1),      & 
     162#endif 
     163                  &                     kobsin, plam, pphi,              & 
     164                  &                     kobsi, kobsj, kproc ) 
    150165            ELSEIF ( cdgrid == 'F' ) THEN 
    151                CALL obs_grd_bruteforce( jpi, jpj, jpiglo, jpjglo, & 
    152                   &                             nldi, nlei,nldj,  nlej,   & 
    153                   &                             nproc, jpnij,             & 
    154                   &                             glamf, gphif, fmask,      & 
    155                   &                             kobsin, plam, pphi,       & 
    156                   &                             kobsi, kobsj, kproc ) 
     166               CALL obs_grd_bruteforce( jpi, jpj, jpiglo, jpjglo,        & 
     167                  &                     nldi, nlei,nldj,  nlej,          & 
     168                  &                     nproc, jpnij,                    & 
     169#if defined key_z_first 
     170                  &                     glamf, gphif, fmask_1(:,:),      & 
     171#else 
     172                  &                     glamf, gphif, fmask(:,:,1),      & 
     173#endif 
     174                  &                     kobsin, plam, pphi,              & 
     175                  &                     kobsi, kobsj, kproc ) 
    157176            ELSE 
    158177               CALL ctl_stop( 'Grid not supported' ) 
    … …  
    283302               zlamg(mig(ji),mjg(jj)) = glamt(ji,jj) 
    284303               zphig(mig(ji),mjg(jj)) = gphit(ji,jj) 
     304#if defined key_z_first 
     305               zmskg(mig(ji),mjg(jj)) = tmask_1(ji,jj) 
     306#else 
    285307               zmskg(mig(ji),mjg(jj)) = tmask(ji,jj,1) 
     308#endif 
    286309            END DO 
    287310         END DO 
    … …  
    295318               zlamg(ji,jj) = glamt(ji,jj) 
    296319               zphig(ji,jj) = gphit(ji,jj) 
     320#if defined key_z_first 
     321               zmskg(ji,jj) = tmask_1(ji,jj) 
     322#else 
    297323               zmskg(ji,jj) = tmask(ji,jj,1) 
     324#endif 
    298325            END DO 
    299326         END DO 
    … …  
    813840            END DO 
    814841             
    815             CALL obs_grd_bruteforce( jpi, jpj, jpiglo, jpjglo,  & 
    816                &                     nldi, nlei,nldj,  nlej,    & 
    817                &                     nproc, jpnij,              & 
    818                &                     glamt, gphit, tmask,      & 
    819                &                     nlons*nlats, lonsi, latsi, & 
     842            CALL obs_grd_bruteforce( jpi, jpj, jpiglo, jpjglo,   & 
     843               &                     nldi, nlei,nldj,  nlej,     & 
     844               &                     nproc, jpnij,               & 
     845               &                     glamt, gphit, tmask(:,:,1), & 
     846               &                     nlons*nlats, lonsi, latsi,  & 
    820847               &                     ixposi, iyposi, iproci ) 
    821848             

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/OBS/obs_inter_sup.F90

    r2715 r3211  
    2626      &   obs_int_comm_2d    ! Get 2D interpolation stencil 
    2727    
     28   !! * Control permutation of array indices 
     29#  include "dom_oce_ftrans.h90" 
     30 
    2831   !!---------------------------------------------------------------------- 
    2932   !! NEMO/OPA 3.3 , NEMO Consortium (2010) 
    … …  
    5861      INTEGER, INTENT(IN) :: kpk       ! Number of levels 
    5962      INTEGER, DIMENSION(kptsi,kptsj,kobs), INTENT(IN) :: & 
    60          & kgrdi, &         ! i,j indicies for each stencil 
     63         & kgrdi, &         ! i,j indices for each stencil 
    6164         & kgrdj 
    6265      INTEGER, OPTIONAL, DIMENSION(kptsi,kptsj,kobs), INTENT(IN) :: & 
    6366         & kproc            ! Precomputed processor for each i,j,iobs points 
    64       REAL(KIND=wp), DIMENSION(jpi,jpj,kpk), INTENT(IN) ::& 
    65          & pval             ! Local 3D array to extract data from 
     67 
     68!! DCSE_NEMO: This style defeats ftrans 
     69!      REAL(KIND=wp), DIMENSION(jpi,jpj,kpk), INTENT(IN) ::& 
     70!        & pval             ! Local 3D array to extract data from 
     71!FTRANS pval :I :I :z 
     72      REAL(KIND=wp), INTENT(IN) ::& 
     73         & pval(jpi,jpj,kpk) ! Local 3D array to extract data from 
    6674      REAL(KIND=wp), DIMENSION(kptsi,kptsj,kpk,kobs), INTENT(OUT) ::& 
    6775         & pgval            ! Stencil at each point 
    6876      !! * Local declarations 
    6977       
     78#if defined key_z_first 
     79      IF ( kpk /= jpk ) THEN 
     80         CALL ctl_stop( 'Error in obs_int_comm_3d', & 
     81            &           'index reordering requires that jpk==kpk' ) 
     82      ENDIF 
     83#endif 
     84 
    7085      IF (ln_grid_global) THEN 
    7186          
    … …  
    107122      USE wrk_nemo, ONLY: wrk_in_use, wrk_not_released 
    108123      USE wrk_nemo, ONLY: wrk_3d_1 
     124 
     125   !! * Control permutation of array indices 
     126!FTRANS CLEAR 
     127#  include "dom_oce_ftrans.h90" 
     128!FTRANS wrk_3d_1 :I :I :z 
     129!FTRANS zval :I :I :z 
     130 
    109131      !! 
    110132      !! * Arguments 
    … …  
    132154         RETURN 
    133155      END IF 
    134       zval => wrk_3d_1(:,:,1:1) 
     156 
     157      zval => wrk_3d_1 
    135158 
    136159      ! Set up local "3D" buffer 
    … …  
    139162 
    140163      ! Call the 3D version 
     164 
     165!! DCSE_NEMO: this is not going to work with index re-ordering 
     166!! Really want obs_int_comm_2d to do its own stuff, instead of calling 
     167!! obs_int_comm_3d !! 
    141168 
    142169      IF (PRESENT(kproc)) THEN 
    … …  
    184211      INTEGER, INTENT(IN) :: kpk       ! Number of levels 
    185212      INTEGER, DIMENSION(kptsi,kptsj,kobs), INTENT(IN) :: & 
    186          & kgrdi, &         ! i,j indicies for each stencil 
     213         & kgrdi, &         ! i,j indices for each stencil 
    187214         & kgrdj 
    188215      INTEGER, OPTIONAL, DIMENSION(kptsi,kptsj,kobs), INTENT(IN) :: & 
    189216         & kproc            ! Precomputed processor for each i,j,iobs points 
    190       REAL(KIND=wp), DIMENSION(jpi,jpj,kpk), INTENT(IN) ::& 
    191          & pval             ! Local 3D array to extract data from 
    192       REAL(KIND=wp), DIMENSION(kptsi,kptsj,kpk,kobs), INTENT(OUT) ::& 
    193          & pgval            ! Stencil at each point 
     217 
     218   !! * Control permutation of array indices 
     219!FTRANS CLEAR 
     220#  include "dom_oce_ftrans.h90" 
     221 
     222!! DCSE_NEMO: this style defeats ftrans 
     223!     REAL(KIND=wp), DIMENSION(jpi,jpj,kpk), INTENT(IN) ::& 
     224!        & pval             ! Local 3D array to extract data from 
     225!     REAL(KIND=wp), DIMENSION(kptsi,kptsj,kpk,kobs), INTENT(OUT) ::& 
     226!        & pgval            ! Stencil at each point 
     227 
     228!FTRANS pval :I :I :z 
     229      REAL(KIND=wp), INTENT(IN) ::& 
     230         & pval(jpi,jpj,kpk)             ! Local 3D array to extract data from 
     231 
     232!FTRANS pgval :I :I :z : 
     233      REAL(KIND=wp), INTENT(OUT) ::& 
     234         & pgval(kptsi,kptsj,kpk,kobs)   ! Stencil at each point 
     235 
    194236      !! * Local declarations 
    195237      REAL(KIND=wp), DIMENSION(:,:), ALLOCATABLE :: & 
    … …  
    281323      END DO 
    282324 
    283       ! Send and recieve buffers for list of points 
     325      ! Send and receive buffers for list of points 
    284326 
    285327      CALL mpp_alltoallv_int( igrdij_send, kptsi*kptsj*kobs*2, nplocal(:)*2, & 
    … …  
    320362      END DO 
    321363 
    322       ! Deallocate message parsing workspace 
     364      ! Deallocate message passing workspace 
    323365 
    324366      DEALLOCATE( & 
    … …  
    353395      INTEGER, INTENT(IN) :: kpk          ! Number of levels 
    354396      INTEGER, DIMENSION(kptsi,kptsj,kobs), INTENT(IN) :: & 
    355          & kgrdi, &         ! i,j indicies for each stencil 
     397         & kgrdi, &         ! i,j indices for each stencil 
    356398         & kgrdj 
    357       REAL(KIND=wp), DIMENSION(jpi,jpj,kpk), INTENT(IN) ::& 
    358          & pval             ! Local 3D array to extract data from 
    359       REAL(KIND=wp), DIMENSION(kptsi,kptsj,kpk,kobs), INTENT(OUT) ::& 
    360          & pgval            ! Stencil at each point 
     399 
     400   !! * Control permutation of array indices 
     401!FTRANS CLEAR 
     402#  include "dom_oce_ftrans.h90" 
     403 
     404!! DCSE_NEMO: this style defeats ftrans 
     405!     REAL(KIND=wp), DIMENSION(jpi,jpj,kpk), INTENT(IN) ::& 
     406!        & pval             ! Local 3D array to extract data from 
     407!     REAL(KIND=wp), DIMENSION(kptsi,kptsj,kpk,kobs), INTENT(OUT) ::& 
     408!        & pgval            ! Stencil at each point 
     409 
     410!FTRANS pval :I :I :z 
     411      REAL(KIND=wp), INTENT(IN)  ::& 
     412         & pval(jpi,jpj,kpk)             ! Local 3D array to extract data from 
     413!FTRANS pgval :I :I :z : 
     414      REAL(KIND=wp), INTENT(OUT) ::& 
     415         & pgval(kptsi,kptsj,kpk,kobs)   ! Stencil at each point 
     416 
    361417      !! * Local declarations 
    362418      INTEGER ::  ji 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/OBS/obs_oper.F90

    r2715 r3211  
    5555   INTEGER, PARAMETER, PUBLIC :: imaxavtypes = 20 ! Max number of daily avgd obs types 
    5656 
     57   !! * Control permutation of array indices 
     58   !! None required from dom_oce_ftrans.h90 
     59 
    5760   !!---------------------------------------------------------------------- 
    5861   !! NEMO/OPA 3.3 , NEMO Consortium (2010) 
    … …  
    133136      INTEGER, INTENT(IN) :: k2dint    ! Horizontal interpolation type (see header) 
    134137      INTEGER, INTENT(IN) :: kdaystp   ! Number of time steps per day                     
    135       REAL(KIND=wp), INTENT(IN), DIMENSION(kpi,kpj,kpk) :: & 
    136          & ptn,    &    ! Model temperature field 
    137          & psn,    &    ! Model salinity field 
    138          & ptmask       ! Land-sea mask 
     138!! DCSE_NEMO : this style defeats ftrans 
     139!     REAL(KIND=wp), INTENT(IN), DIMENSION(kpi,kpj,kpk) :: & 
     140!        & ptn,    &    ! Model temperature field 
     141!        & psn,    &    ! Model salinity field 
     142!        & ptmask       ! Land-sea mask 
     143 
     144!FTRANS ptn psn ptmask :I :I :z 
     145      REAL(KIND=wp), INTENT(IN) :: ptn(kpi,kpj,kpk)    ! Model temperature field 
     146      REAL(KIND=wp), INTENT(IN) :: psn(kpi,kpj,kpk)    ! Model salinity field 
     147      REAL(KIND=wp), INTENT(IN) :: ptmask(kpi,kpj,kpk) ! Land-sea mask 
     148 
    139149      REAL(KIND=wp), INTENT(IN), DIMENSION(kpk) :: & 
    140150         & pgdept       ! Model array of depth levels 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/OBS/obs_prep.F90

    r2715 r3211  
    4242      & obs_pre_vel, &     ! First level check and screening of velocity profiles 
    4343      & calc_month_len     ! Calculate the number of days in the months of a year   
     44 
     45   !! * Control permutation of array indices 
     46   !! No arrays with indices to permute. 
    4447 
    4548   !!---------------------------------------------------------------------- 
    … …  
    356359      USE domstp              ! Domain: set the time-step 
    357360      USE par_oce             ! Ocean parameters 
     361#if defined key_z_first 
     362      USE dom_oce, ONLY : &   ! Geographical information 
     363         & glamt,   & 
     364         & gphit,   & 
     365         & tmask,   & 
     366         & tmask_1, & 
     367         & nproc 
     368#else 
    358369      USE dom_oce, ONLY : &   ! Geographical information 
    359370         & glamt,   & 
    … …  
    361372         & tmask,   & 
    362373         & nproc 
     374#endif 
     375 
     376   !! * Control permutation of array indices 
     377#  include "dom_oce_ftrans.h90" 
     378 
    363379      !! * Arguments 
    364380      TYPE(obs_surf), INTENT(INOUT) :: sladata    ! Full set of SLA data 
    … …  
    440456         &                 sladata%rlam, sladata%rphi, & 
    441457         &                 glamt,        gphit,        & 
     458#if defined key_z_first 
     459         &                 tmask_1(:,:), sladata%nqc,  & 
     460#else 
    442461         &                 tmask(:,:,1), sladata%nqc,  & 
     462#endif 
    443463         &                 iosdsobs,     ilansobs,     & 
    444464         &                 inlasobs,     ld_nea        ) 
    … …  
    526546   END SUBROUTINE obs_pre_sla 
    527547 
     548   !! * Reset control of array index permutation 
     549!FTRANS CLEAR 
     550   !! No arrays with indices to permute. 
     551 
    528552   SUBROUTINE obs_pre_sst( sstdata, sstdatqc, ld_sst, ld_nea ) 
    529553      !!---------------------------------------------------------------------- 
    … …  
    544568      USE domstp              ! Domain: set the time-step 
    545569      USE par_oce             ! Ocean parameters 
     570#if defined key_z_first 
     571      USE dom_oce, ONLY : &   ! Geographical information 
     572         & glamt,   & 
     573         & gphit,   & 
     574         & tmask,   & 
     575         & tmask_1, & 
     576         & nproc 
     577#else 
    546578      USE dom_oce, ONLY : &   ! Geographical information 
    547579         & glamt,   & 
    … …  
    549581         & tmask,   & 
    550582         & nproc 
     583#endif 
     584 
     585   !! * Control permutation of array indices 
     586#  include "dom_oce_ftrans.h90" 
     587 
    551588      !! * Arguments 
    552589      TYPE(obs_surf), INTENT(INOUT) :: sstdata     ! Full set of SST data 
    … …  
    625662         &                 sstdata%rlam, sstdata%rphi, & 
    626663         &                 glamt,        gphit,        & 
     664#if defined key_z_first 
     665         &                 tmask_1(:,:), sstdata%nqc,  & 
     666#else 
    627667         &                 tmask(:,:,1), sstdata%nqc,  & 
     668#endif 
    628669         &                 iosdsobs,     ilansobs,     & 
    629670         &                 inlasobs,     ld_nea        ) 
    … …  
    711752   END SUBROUTINE obs_pre_sst 
    712753 
     754   !! * Reset control of array index permutation 
     755!FTRANS CLEAR 
     756   !! No arrays with indices to permute. 
     757 
    713758   SUBROUTINE obs_pre_seaice( seaicedata, seaicedatqc, ld_seaice, ld_nea ) 
    714759      !!---------------------------------------------------------------------- 
    … …  
    733778         & gphit,   & 
    734779         & tmask,   & 
     780#if defined key_z_first 
     781         & tmask_1, & 
     782#endif 
    735783         & nproc 
     784 
     785      !! * Control permutation of array indices 
     786#  include "dom_oce_ftrans.h90" 
     787 
    736788      !! * Arguments 
    737789      TYPE(obs_surf), INTENT(INOUT) :: seaicedata     ! Full set of Sea Ice data 
    … …  
    810862         &                 seaicedata%rlam, seaicedata%rphi, & 
    811863         &                 glamt,           gphit,           & 
     864#if defined key_z_first 
     865         &                 tmask_1(:,:),    seaicedata%nqc,  & 
     866#else 
    812867         &                 tmask(:,:,1),    seaicedata%nqc,  & 
     868#endif 
    813869         &                 iosdsobs,        ilansobs,        & 
    814870         &                 inlasobs,        ld_nea           ) 
    … …  
    896952   END SUBROUTINE obs_pre_seaice 
    897953 
     954   !! * Reset control of array index permutation 
     955!FTRANS CLEAR 
     956   !! No arrays with indices to permute. 
     957 
    898958   SUBROUTINE obs_pre_vel( profdata, prodatqc, ld_vel3d, ld_nea, ld_dailyav ) 
    899959      !!---------------------------------------------------------------------- 
    … …  
    919979         & tmask, umask, vmask,  & 
    920980         & nproc 
     981 
     982      !! * Control permutation of array indices 
     983#  include "dom_oce_ftrans.h90" 
     984 
    921985      !! * Arguments 
    922986      TYPE(obs_prof), INTENT(INOUT) :: profdata   ! Full set of profile data 
    … …  
    11881252   END SUBROUTINE obs_pre_vel 
    11891253 
     1254   !! * Reset control of array index permutation 
     1255!FTRANS CLEAR 
     1256   !! No arrays with indices to permute. 
     1257 
    11901258   SUBROUTINE obs_coo_tim( kcycle, & 
    11911259      &                    kyea0,   kmon0,   kday0,   khou0,   kmin0,     & 
    … …  
    17101778      USE dom_oce, ONLY : &       ! Geographical information 
    17111779         & gdepw_0                         
     1780 
     1781   !! * Control permutation of array indices 
     1782#  include "dom_oce_ftrans.h90" 
    17121783 
    17131784      !! * Arguments 
    … …  
    18681939   END SUBROUTINE obs_coo_spc_3d 
    18691940 
     1941   !! * Reset control of array index permutation 
     1942!FTRANS CLEAR 
     1943   !! No arrays with indices to permute. 
     1944 
    18701945   SUBROUTINE obs_pro_rej( profdata ) 
    18711946      !!---------------------------------------------------------------------- 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/OBS/obs_read_altbias.F90

    r2715 r3211  
    2424   USE dom_oce, ONLY : &        ! Domain variables 
    2525      & tmask, & 
     26#if defined key_z_first 
     27      & tmask_1, & 
     28#endif 
    2629      & tmask_i, & 
    2730      & e1t,   & 
    … …  
    4043 
    4144   PUBLIC obs_rea_altbias     ! Read the altimeter bias 
     45 
     46   !! * Control permutation of array indices 
     47#  include "dom_oce_ftrans.h90" 
    4248 
    4349   !!---------------------------------------------------------------------- 
    … …  
    175181         CALL obs_int_comm_2d( 2, 2, sladata(jslano)%nsurf, & 
    176182            &                  igrdi, igrdj, gphit, zgphi ) 
     183#if defined key_z_first 
     184         CALL obs_int_comm_2d( 2, 2, sladata(jslano)%nsurf, & 
     185            &                  igrdi, igrdj, tmask_1(:,:), zmask ) 
     186#else 
    177187         CALL obs_int_comm_2d( 2, 2, sladata(jslano)%nsurf, & 
    178188            &                  igrdi, igrdj, tmask(:,:,1), zmask ) 
     189#endif 
    179190         CALL obs_int_comm_2d( 2, 2, sladata(jslano)%nsurf, & 
    180191            &                  igrdi, igrdj, z_altbias, zbias ) 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/OBS/obs_read_prof.F90

    r2715 r3211  
    3434 
    3535   PUBLIC obs_rea_pro_dri  ! Read the profile observations  
     36 
     37   !! * Control permutation of array indices 
     38#  include "dom_oce_ftrans.h90" 
    3639 
    3740   !!---------------------------------------------------------------------- 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/OBS/obs_read_seaice.F90

    r2287 r3211  
    3232   PUBLIC obs_rea_seaice      ! Read the seaice observations from the point data 
    3333    
     34   !! * Control permutation of array indices 
     35#  include "dom_oce_ftrans.h90" 
     36 
    3437   !!---------------------------------------------------------------------- 
    3538   !! NEMO/OPA 3.3 , NEMO Consortium (2010) 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/OBS/obs_read_sla.F90

    r2287 r3211  
    3131 
    3232   PUBLIC obs_rea_sla  ! Read the SLA observations from the AVISO/SLA database 
     33 
     34   !! * Control permutation of array indices 
     35#  include "dom_oce_ftrans.h90" 
    3336 
    3437   !!---------------------------------------------------------------------- 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/OBS/obs_read_sst.F90

    r2287 r3211  
    3333   PUBLIC obs_rea_sst      ! Read the SST observations from the point data 
    3434   PUBLIC obs_rea_sst_rey  ! Read the gridded Reynolds SST  
     35 
     36   !! * Control permutation of array indices 
     37#  include "dom_oce_ftrans.h90" 
    3538    
    3639   !!---------------------------------------------------------------------- 
    … …  
    694697      DO jj = nldj, nlej 
    695698         DO ji = nldi, nlei 
     699#if defined key_z_first 
     700            IF ( tmask_1(ji,jj) == 1.0_wp ) inumobs = inumobs + 1 
     701#else 
    696702            IF ( tmask(ji,jj,1) == 1.0_wp ) inumobs = inumobs + 1 
     703#endif 
    697704         END DO 
    698705      END DO 
    … …  
    717724            DO ji = nldi, nlei 
    718725 
     726#if defined key_z_first 
     727               IF ( tmask_1(ji,jj) == 1.0_wp ) THEN 
     728#else 
    719729               IF ( tmask(ji,jj,1) == 1.0_wp ) THEN 
     730#endif 
    720731 
    721732                  inumobs = inumobs + 1 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/OBS/obs_read_vel.F90

    r2715 r3211  
    3434 
    3535   PUBLIC obs_rea_vel_dri  ! Read the profile observations  
     36 
     37   !! * Control permutation of array indices 
     38#  include "dom_oce_ftrans.h90" 
    3639 
    3740   !!---------------------------------------------------------------------- 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/OBS/obs_readmdt.F90

    r2715 r3211  
    3737   REAL(wp), PUBLIC ::   mdtcutoff = 65.0_wp   ! MDT cutoff for computed correction 
    3838 
     39   !! * Control permutation of array indices 
     40#  include "dom_oce_ftrans.h90" 
     41 
    3942   !!---------------------------------------------------------------------- 
    4043   !! NEMO/OPA 3.3 , NEMO Consortium (2010) 
    … …  
    106109      ! setup mask based on tmask and MDT mask 
    107110      ! set mask to 0 where the MDT is set to fillvalue 
     111#if defined key_z_first 
     112      WHERE(z_mdt(:,:) /= zfill)   ;   mdtmask(:,:) = tmask_1(:,:) 
     113#else 
    108114      WHERE(z_mdt(:,:) /= zfill)   ;   mdtmask(:,:) = tmask(:,:,1) 
     115#endif 
    109116      ELSE WHERE                   ;   mdtmask(:,:) = 0 
    110117      END WHERE 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/OBS/obs_rot_vel.F90

    r2715 r3211  
    2727 
    2828   PUBLIC obs_rotvel            ! Rotate the observations 
     29 
     30   !! * Control permutation of array indices 
     31#  include "dom_oce_ftrans.h90" 
    2932 
    3033   !!---------------------------------------------------------------------- 
    … …  
    148151      CALL obs_int_comm_2d( 2, 2, profdata%nprof, igrdiu, igrdju, & 
    149152         &                  gphiu, zgphiu ) 
     153#if defined key_z_first 
     154      CALL obs_int_comm_2d( 2, 2, profdata%nprof, igrdiu, igrdju, & 
     155         &                  umask_1(:,:), zmasku ) 
     156#else 
    150157      CALL obs_int_comm_2d( 2, 2, profdata%nprof, igrdiu, igrdju, & 
    151158         &                  umask(:,:,1), zmasku ) 
     159#endif 
    152160      CALL obs_int_comm_2d( 2, 2, profdata%nprof, igrdiu, igrdju, & 
    153161         &                  zsingu, zsinlu ) 
    … …  
    158166      CALL obs_int_comm_2d( 2, 2, profdata%nprof, igrdiv, igrdjv, & 
    159167         &                  gphiv, zgphiv ) 
     168#if defined key_z_first 
     169      CALL obs_int_comm_2d( 2, 2, profdata%nprof, igrdiv, igrdjv, & 
     170         &                  vmask_1(:,:), zmaskv ) 
     171#else 
    160172      CALL obs_int_comm_2d( 2, 2, profdata%nprof, igrdiv, igrdjv, & 
    161173         &                  vmask(:,:,1), zmaskv ) 
     174#endif 
    162175      CALL obs_int_comm_2d( 2, 2, profdata%nprof, igrdiv, igrdjv, & 
    163176         &                  zsingv, zsinlv ) 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/OBS/obs_write.F90

    r2287 r3211  
    5151      CHARACTER(len=ilenunit), POINTER, DIMENSION(:,:) :: cdunit 
    5252   END TYPE obswriinfo 
     53 
     54   !! * Control permutation of array indices 
     55#  include "dom_oce_ftrans.h90" 
    5356 
    5457   !!---------------------------------------------------------------------- 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/SBC/cpl_oasis3.F90

    r2715 r3211  
    6363 
    6464   REAL(wp), DIMENSION(:,:), ALLOCATABLE ::   exfld   ! Temporary buffer for receiving 
     65 
     66   !! * Control permutation of array indices 
     67#  include "dom_oce_ftrans.h90" 
    6568 
    6669   !!---------------------------------------------------------------------- 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/SBC/cpl_oasis4.F90

    r2715 r3211  
    6565   TYPE(PRISM_Time_struct), PUBLIC    :: date            ! date info for send operation 
    6666   TYPE(PRISM_Time_struct), PUBLIC    :: date_bound(2)   ! date info for send operation 
     67 
     68   !! * Control permutation of array indices 
     69#  include "dom_oce_ftrans.h90" 
    6770 
    6871   !!---------------------------------------------------------------------- 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/SBC/fldread.F90

    r2715 r3211  
    9090 
    9191   PUBLIC   fld_read, fld_fill   ! called by sbc... modules 
     92 
     93   !! * Control permutation of array indices 
     94#  include "oce_ftrans.h90" 
     95#  include "dom_oce_ftrans.h90" 
    9296 
    9397   !!---------------------------------------------------------------------- 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/SBC/geo2ocean.F90

    r2715 r3211  
    4040 
    4141   LOGICAL ::   lmust_init = .TRUE.        !: used to initialize the cos/sin variables (se above) 
     42 
     43   !! * Control permutation of array indices 
     44#  include "dom_oce_ftrans.h90" 
    4245 
    4346   !! * Substitutions 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/SBC/sbc_oce.F90

    r2715 r3211  
    4949   LOGICAL , PUBLIC ::   lhftau = .FALSE.        !: HF tau used in TKE: mean(stress module) - module(mean stress) 
    5050   !!                                   !!   now    ! before   !! 
    51    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   utau   , utau_b   !: sea surface i-stress (ocean referential)     [N/m2] 
    52    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   vtau   , vtau_b   !: sea surface j-stress (ocean referential)     [N/m2] 
    53    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   taum              !: module of sea surface stress (at T-point)    [N/m2]  
     51   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   utau, utau_b  !: sea surface i-stress (ocean referential)  [N/m2] 
     52   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   vtau, vtau_b  !: sea surface j-stress (ocean referential)  [N/m2] 
     53   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   taum          !: module of sea surface stress (at T-point) [N/m2]  
    5454   !! wndm is used onmpute surface gases exchanges in ice-free ocean or leads 
    55    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wndm              !: wind speed module at T-point (=|U10m-Uoce|) [m/s] 
    56    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   qsr               !: sea heat flux:     solar                     [W/m2] 
    57    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   qns    , qns_b    !: sea heat flux: non solar                     [W/m2] 
    58    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   qsr_tot           !: total     solar heat flux (over sea and ice) [W/m2] 
    59    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   qns_tot           !: total non solar heat flux (over sea and ice) [W/m2] 
    60    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   emp    , emp_b    !: freshwater budget: volume flux               [Kg/m2/s] 
    61    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   emps   , emps_b   !: freshwater budget: concentration/dillution  [Kg/m2/s] 
    62    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   emp_tot           !: total E-P over ocean and ice                 [Kg/m2/s] 
    63    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   rnf    , rnf_b    !: river runoff   [Kg/m2/s]   
     55   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wndm          !: wind speed module at T-point (=|U10m-Uoce|) [m/s] 
     56   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   qsr           !: sea heat flux:     solar                   [W/m2] 
     57   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   qns,  qns_b   !: sea heat flux: non solar                   [W/m2] 
     58   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   qsr_tot       !: total    solar heat flux (over sea and ice) [W/m2] 
     59   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   qns_tot       !: total non solar heat flux (over sea and ice) [W/m2] 
     60   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   emp,  emp_b   !: freshwater budget: volume flux           [Kg/m2/s] 
     61   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   emps, emps_b  !: freshwater budget: concentration/dilution [Kg/m2/s] 
     62   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   emp_tot       !: total E-P over ocean and ice              [Kg/m2/s] 
     63   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   rnf, rnf_b    !: river runoff   [Kg/m2/s]   
    6464   !! 
    65    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::  sbc_tsc, sbc_tsc_b  !: sbc content trend                      [K.m/s] jpi,jpj,jpts 
    66    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::  qsr_hc , qsr_hc_b   !: heat content trend due to qsr flux     [K.m/s] jpi,jpj,jpk 
     65   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::  sbc_tsc, sbc_tsc_b  !: sbc content trend [K.m/s] jpi,jpj,jpts 
     66   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::  qsr_hc , qsr_hc_b   !: heat content trend due to qsr flux [K.m/s] 
     67   !                                                                             ! jpi,jpj,jpk 
    6768   !! 
    68    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   tprecip           !: total precipitation                          [Kg/m2/s] 
    69    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   sprecip           !: solid precipitation                          [Kg/m2/s] 
    70    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   fr_i              !: ice fraction = 1 - lead fraction      (between 0 to 1) 
     69   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   tprecip       !: total precipitation                       [Kg/m2/s] 
     70   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   sprecip       !: solid precipitation                       [Kg/m2/s] 
     71   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   fr_i          !: ice fraction = 1 - lead fraction  (between 0 to 1) 
    7172#if defined key_cpl_carbon_cycle 
    72    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   atm_co2           !: atmospheric pCO2                             [ppm] 
     73   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   atm_co2       !: atmospheric pCO2                          [ppm] 
    7374#endif 
    7475 
    … …  
    7778   !!---------------------------------------------------------------------- 
    7879   INTEGER , PUBLIC                     ::   nn_fsbc   !: frequency of sbc computation (as well as sea-ice model) 
    79    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   ssu_m     !: mean (nn_fsbc time-step) surface sea i-current (U-point) [m/s] 
    80    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   ssv_m     !: mean (nn_fsbc time-step) surface sea j-current (V-point) [m/s] 
    81    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   sst_m     !: mean (nn_fsbc time-step) surface sea temperature     [Celsius] 
    82    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   sss_m     !: mean (nn_fsbc time-step) surface sea salinity            [psu] 
    83    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   ssh_m     !: mean (nn_fsbc time-step) sea surface height                [m] 
     80   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   ssu_m   !: mean (nn_fsbc time-step) surface sea i-current (U-point) 
     81   !                                                                !                                                 [m/s] 
     82   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   ssv_m   !: mean (nn_fsbc time-step) surface sea j-current (V-point) 
     83   !                                                                !                                                 [m/s] 
     84   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   sst_m   !: mean (nn_fsbc time-step) surface sea temp      [Celsius] 
     85   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   sss_m   !: mean (nn_fsbc time-step) surface sea salinity  [psu] 
     86   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   ssh_m   !: mean (nn_fsbc time-step) sea surface height    [m] 
     87 
     88   !! * Control permutation of array indices 
     89#  include "sbc_oce_ftrans.h90" 
    8490 
    8591   !! * Substitutions 
    … …  
    134140      !!--------------------------------------------------------------------- 
    135141      USE dom_oce         ! ocean space and time domain 
     142 
     143   !! * Control permutation of array indices 
     144#  include "dom_oce_ftrans.h90" 
     145 
    136146      USE lbclnk          ! ocean lateral boundary conditions (or mpp link) 
    137147      REAL(wp) ::   zrhoa  = 1.22         ! Air density kg/m3 
    … …  
    148158            zty = vtau(ji  ,jj-1) + vtau(ji,jj)  
    149159            ztau = SQRT( ztx * ztx + zty * zty ) 
     160#if defined key_z_first 
     161            wndm(ji,jj) = SQRT ( ztau * zcoef ) * tmask_1(ji,jj) 
     162#else 
    150163            wndm(ji,jj) = SQRT ( ztau * zcoef ) * tmask(ji,jj,1) 
     164#endif 
    151165         END DO 
    152166      END DO 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/SBC/sbcana.F90

    r2715 r3211  
    3535   REAL(wp) ::   rn_qsr0   = 0._wp   !     solar heat flux 
    3636   REAL(wp) ::   rn_emp0   = 0._wp   ! net freshwater flux 
    37     
     37 
     38   !! * Control permutation of array indices 
     39#  include "oce_ftrans.h90" 
     40#  include "dom_oce_ftrans.h90" 
     41#  include "sbc_oce_ftrans.h90" 
     42 
    3843   !! * Substitutions 
    3944#  include "domzgr_substitute.h90" 
    … …  
    210215      IF( nbench /= 1 ) THEN 
    211216         zsumemp = GLOB_SUM( emp(:,:) )  
     217#if defined key_z_first 
     218         zsurf   = GLOB_SUM( tmask_1(:,:) )  
     219#else 
    212220         zsurf   = GLOB_SUM( tmask(:,:,1) )  
     221#endif 
    213222         ! Default GYRE configuration 
    214223         zsumemp = zsumemp / zsurf 
    … …  
    219228 
    220229      !salinity terms 
     230#if defined key_z_first 
     231      emp (:,:) = emp(:,:) - zsumemp * tmask_1(:,:) 
     232#else 
    221233      emp (:,:) = emp(:,:) - zsumemp * tmask(:,:,1) 
     234#endif 
    222235      emps(:,:) = emp(:,:) 
    223236 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/SBC/sbcapr.F90

    r2715 r3211  
    4242    
    4343   TYPE(FLD), ALLOCATABLE, DIMENSION(:) ::   sf_apr   ! structure of input fields (file informations, fields read) 
     44 
     45   !! * Control permutation of array indices 
     46#  include "oce_ftrans.h90" 
     47#  include "dom_oce_ftrans.h90" 
     48#  include "sbc_oce_ftrans.h90" 
    4449 
    4550   !! * Substitutions 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/SBC/sbcblk_clio.F90

    r2715 r3211  
    7979   REAL(wp) ::   eps20  = 1.e-20   ! constant values 
    8080    
     81   !! * Control permutation of array indices 
     82#  include "oce_ftrans.h90" 
     83#  include "dom_oce_ftrans.h90" 
     84#  include "sbc_oce_ftrans.h90" 
     85 
    8186   !! * Substitutions 
    8287#  include "vectopt_loop_substitute.h90" 
    … …  
    308313            !-------------------------------------------------- 
    309314            !                                                          ! vapour pressure at saturation of ocean 
     315#if defined key_z_first 
     316            zeso =  611.0 * EXP ( 17.2693884 * ( zsst - rtt ) * tmask_1(ji,jj) / ( zsst - 35.86 ) ) 
     317#else 
    310318            zeso =  611.0 * EXP ( 17.2693884 * ( zsst - rtt ) * tmask(ji,jj,1) / ( zsst - 35.86 ) ) 
     319#endif 
    311320 
    312321            zqsato = ( 0.622 * zeso ) / ( zpatm - 0.378 * zeso )       ! humidity close to the ocean surface (at saturation) 
    … …  
    369378 
    370379!CDIR COLLAPSE 
     380#if defined key_z_first 
     381      emp (:,:) = zqla(:,:) / cevap - sf(jp_prec)%fnow(:,:,1) / rday * tmask_1(:,:) 
     382#else 
    371383      emp (:,:) = zqla(:,:) / cevap - sf(jp_prec)%fnow(:,:,1) / rday * tmask(:,:,1) 
     384#endif 
    372385      qns (:,:) = zqlw(:,:) - zqsb(:,:) - zqla(:,:)         ! Downward Non Solar flux 
    373386      emps(:,:) = emp(:,:) 
    … …  
    560573 
    561574               ! vapour pressure at saturation of ice (tmask to avoid overflow in the exponential) 
     575#if defined key_z_first 
     576               zesi =  611.0 * EXP( 21.8745587 * tmask_1(ji,jj) * ( pst(ji,jj,jl) - rtt )/ ( pst(ji,jj,jl) - 7.66 ) ) 
     577#else 
    562578               zesi =  611.0 * EXP( 21.8745587 * tmask(ji,jj,1) * ( pst(ji,jj,jl) - rtt )/ ( pst(ji,jj,jl) - 7.66 ) ) 
     579#endif 
    563580               ! humidity close to the ice surface (at saturation) 
    564581               zqsati   = ( 0.622 * zesi ) / ( zpatm - 0.378 * zesi ) 
    … …  
    619636!!gm : mask is not required on forcing 
    620637      DO jl = 1, ijpl 
     638#if defined key_z_first 
     639         p_qns (:,:,jl) = p_qns (:,:,jl) * tmask_1(:,:) 
     640         p_qla (:,:,jl) = p_qla (:,:,jl) * tmask_1(:,:) 
     641         p_dqns(:,:,jl) = p_dqns(:,:,jl) * tmask_1(:,:) 
     642         p_dqla(:,:,jl) = p_dqla(:,:,jl) * tmask_1(:,:) 
     643#else 
    621644         p_qns (:,:,jl) = p_qns (:,:,jl) * tmask(:,:,1) 
    622645         p_qla (:,:,jl) = p_qla (:,:,jl) * tmask(:,:,1) 
    623646         p_dqns(:,:,jl) = p_dqns(:,:,jl) * tmask(:,:,1) 
    624647         p_dqla(:,:,jl) = p_dqla(:,:,jl) * tmask(:,:,1) 
     648#endif 
    625649      END DO 
    626650 
    … …  
    787811            zcldcor  = MIN(  1.e0, ( 1.e0 - 0.62 * sf(jp_ccov)%fnow(ji,jj,1)   &     ! cloud correction (Reed 1977) 
    788812               &                          + 0.0019 * zlmunoon )                 ) 
     813#if defined key_z_first 
     814            pqsr_oce(ji,jj) = zcoef1 * zcldcor * pqsr_oce(ji,jj) * tmask_1(ji,jj)    ! and zcoef1: ellipsity 
     815#else 
    789816            pqsr_oce(ji,jj) = zcoef1 * zcldcor * pqsr_oce(ji,jj) * tmask(ji,jj,1)    ! and zcoef1: ellipsity 
     817#endif 
    790818         END DO 
    791819      END DO 
    … …  
    925953         ! 
    926954         ! Correction : Taking into account the ellipsity of the earth orbit 
     955#if defined key_z_first 
     956         pqsr_ice(:,:,jl) = pqsr_ice(:,:,jl) * zcoef1 * tmask_1(:,:) 
     957#else 
    927958         pqsr_ice(:,:,jl) = pqsr_ice(:,:,jl) * zcoef1 * tmask(:,:,1) 
     959#endif 
    928960         ! 
    929961         !                 !--------------------------------!  

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/SBC/sbcblk_core.F90

    r2715 r3211  
    7070   LOGICAL  ::   ln_taudif = .FALSE.   ! logical flag to use the "mean of stress module - module of mean stress" data 
    7171   REAL(wp) ::   rn_pfac   = 1.        ! multiplication factor for precipitation 
     72 
     73   !! * Control permutation of array indices 
     74#  include "oce_ftrans.h90" 
     75#  include "dom_oce_ftrans.h90" 
     76#  include "sbc_oce_ftrans.h90" 
    7277 
    7378   !! * Substitutions 
    … …  
    261266!CDIR NOVERRCHK 
    262267!CDIR COLLAPSE 
     268#if defined key_z_first 
     269      wndm(:,:) = SQRT(  zwnd_i(:,:) * zwnd_i(:,:)   & 
     270         &             + zwnd_j(:,:) * zwnd_j(:,:)  ) * tmask_1(:,:) 
     271#else 
    263272      wndm(:,:) = SQRT(  zwnd_i(:,:) * zwnd_i(:,:)   & 
    264273         &             + zwnd_j(:,:) * zwnd_j(:,:)  ) * tmask(:,:,1) 
     274#endif 
    265275 
    266276      ! ----------------------------------------------------------------------------- ! 
    … …  
    270280      ! ocean albedo assumed to be constant + modify now Qsr to include the diurnal cycle                    ! Short Wave 
    271281      zztmp = 1. - albo 
     282#if defined key_z_first 
     283      IF( ln_dm2dc ) THEN   ;   qsr(:,:) = zztmp * sbc_dcy( sf(jp_qsr)%fnow(:,:,1) ) * tmask_1(:,:) 
     284      ELSE                  ;   qsr(:,:) = zztmp *          sf(jp_qsr)%fnow(:,:,1)   * tmask_1(:,:) 
     285#else 
    272286      IF( ln_dm2dc ) THEN   ;   qsr(:,:) = zztmp * sbc_dcy( sf(jp_qsr)%fnow(:,:,1) ) * tmask(:,:,1) 
    273287      ELSE                  ;   qsr(:,:) = zztmp *          sf(jp_qsr)%fnow(:,:,1)   * tmask(:,:,1) 
    274       ENDIF 
    275 !CDIR COLLAPSE 
     288#endif 
     289      ENDIF 
     290!CDIR COLLAPSE 
     291#if defined key_z_first 
     292      zqlw(:,:) = (  sf(jp_qlw)%fnow(:,:,1) - Stef * zst(:,:)*zst(:,:)*zst(:,:)*zst(:,:)  ) * tmask_1(:,:)   ! Long  Wave 
     293#else 
    276294      zqlw(:,:) = (  sf(jp_qlw)%fnow(:,:,1) - Stef * zst(:,:)*zst(:,:)*zst(:,:)*zst(:,:)  ) * tmask(:,:,1)   ! Long  Wave 
     295#endif 
    277296      ! ----------------------------------------------------------------------------- ! 
    278297      !     II    Turbulent FLUXES                                                    ! 
    … …  
    366385      qns(:,:) = zqlw(:,:) - zqsb(:,:) - zqla(:,:)      ! Downward Non Solar flux 
    367386!CDIR COLLAPSE 
     387#if defined key_z_first 
     388      emp(:,:) = zevap(:,:) - sf(jp_prec)%fnow(:,:,1) * rn_pfac * tmask_1(:,:) 
     389#else 
    368390      emp(:,:) = zevap(:,:) - sf(jp_prec)%fnow(:,:,1) * rn_pfac * tmask(:,:,1) 
     391#endif 
    369392!CDIR COLLAPSE 
    370393      emps(:,:) = emp(:,:) 
    … …  
    495518               zwndj_t = sf(jp_wndj)%fnow(ji,jj,1) - 0.25 * (  pvi(ji,jj+1) + pvi(ji+1,jj+1)   & 
    496519                  &                                          + pvi(ji,jj  ) + pvi(ji+1,jj  )  ) 
     520#if defined key_z_first 
     521               z_wnds_t(ji,jj)  = SQRT( zwndi_t * zwndi_t + zwndj_t * zwndj_t ) * tmask_1(ji,jj) 
     522#else 
    497523               z_wnds_t(ji,jj)  = SQRT( zwndi_t * zwndi_t + zwndj_t * zwndj_t ) * tmask(ji,jj,1) 
     524#endif 
    498525            END DO 
    499526         END DO 
    … …  
    510537               zwndi_t = (  sf(jp_wndi)%fnow(ji,jj,1) - 0.5 * ( pui(ji-1,jj  ) + pui(ji,jj) )  ) 
    511538               zwndj_t = (  sf(jp_wndj)%fnow(ji,jj,1) - 0.5 * ( pvi(ji  ,jj-1) + pvi(ji,jj) )  ) 
     539#if defined key_z_first 
     540               z_wnds_t(ji,jj)  = SQRT( zwndi_t * zwndi_t + zwndj_t * zwndj_t ) * tmask_1(ji,jj) 
     541#else 
    512542               z_wnds_t(ji,jj)  = SQRT( zwndi_t * zwndi_t + zwndj_t * zwndj_t ) * tmask(ji,jj,1) 
     543#endif 
    513544            END DO 
    514545         END DO 
    … …  
    547578               p_qsr(ji,jj,jl) = zztmp * ( 1. - palb(ji,jj,jl) ) * qsr(ji,jj) 
    548579               ! Long  Wave (lw) 
     580#if defined key_z_first 
     581               z_qlw(ji,jj,jl) = 0.95 * (  sf(jp_qlw)%fnow(ji,jj,1) - Stef * pst(ji,jj,jl) * zst3  ) * tmask_1(ji,jj) 
     582#else 
    549583               z_qlw(ji,jj,jl) = 0.95 * (  sf(jp_qlw)%fnow(ji,jj,1) - Stef * pst(ji,jj,jl) * zst3  ) * tmask(ji,jj,1) 
     584#endif 
    550585               ! lw sensitivity 
    551586               z_dqlw(ji,jj,jl) = zcoef_dqlw * zst3                                                

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/SBC/sbccpl.F90

    r2715 r3211  
    162162#endif 
    163163 
     164   !! * Control permutation of array indices 
     165#  include "oce_ftrans.h90" 
     166#  include "dom_oce_ftrans.h90" 
     167#  include "sbc_oce_ftrans.h90" 
     168 
    164169   !! Substitution 
    165170#  include "vectopt_loop_substitute.h90" 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/SBC/sbcdcy.F90

    r2715 r3211  
    2828   
    2929   PUBLIC   sbc_dcy        ! routine called by sbc 
     30 
     31   !! * Control permutation of array indices 
     32#  include "oce_ftrans.h90" 
     33#  include "dom_oce_ftrans.h90" 
     34#  include "sbc_oce_ftrans.h90" 
    3035 
    3136   !!---------------------------------------------------------------------- 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/SBC/sbcflx.F90

    r2715 r3211  
    3535   INTEGER , PARAMETER ::   jp_emp  = 5   ! index of evaporation-precipation file 
    3636   TYPE(FLD), ALLOCATABLE, DIMENSION(:) ::   sf    ! structure of input fields (file informations, fields read) 
     37 
     38   !! * Control permutation of array indices 
     39#  include "oce_ftrans.h90" 
     40#  include "dom_oce_ftrans.h90" 
     41#  include "sbc_oce_ftrans.h90" 
    3742 
    3843   !! * Substitutions 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/SBC/sbcfwb.F90

    r2715 r3211  
    3434   REAL(wp) ::   fwfold    ! fwfold to be suppressed 
    3535   REAL(wp) ::   area      ! global mean ocean surface (interior domain) 
     36 
     37   !! * Control permutation of array indices 
     38#  include "oce_ftrans.h90" 
     39#  include "dom_oce_ftrans.h90" 
     40#  include "sbc_oce_ftrans.h90" 
    3641 
    3742   !! * Substitutions 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/SBC/sbcice_if.F90

    r2715 r3211  
    2727 
    2828   TYPE(FLD), ALLOCATABLE, DIMENSION(:) ::   sf_ice   ! structure of input ice-cover (file informations, fields read) 
     29 
     30   !! * Control permutation of array indices 
     31#  include "oce_ftrans.h90" 
     32#  include "dom_oce_ftrans.h90" 
     33#  include "sbc_oce_ftrans.h90" 
    2934    
    3035   !! * Substitutions 
    … …  
    96101                                 ! ( d rho / dt ) / ( d rho / ds )      ( s = 34, t = -1.8 ) 
    97102          
     103#if defined key_z_first 
     104         fr_i(:,:) = tfreez( sss_m ) * tmask_1(:,:)       ! sea surface freezing temperature [Celcius] 
     105#else 
    98106         fr_i(:,:) = tfreez( sss_m ) * tmask(:,:,1)      ! sea surface freezing temperature [Celcius] 
     107#endif 
    99108 
    100109         ! Flux and ice fraction computation 
    … …  
    119128               zqri = ztrp * ( tb(ji,jj,1) - ( zt_fzp - 1.) ) 
    120129               zqrj = ztrp * MIN( 0., tb(ji,jj,1) - zt_fzp ) 
     130#if defined key_z_first 
     131               zqrp = ( zfr_obs * ( (1. - fr_i(ji,jj) ) * zqri    & 
     132                 &                 +      fr_i(ji,jj)   * zqrj ) ) * tmask_1(ji,jj) 
     133#else 
    121134               zqrp = ( zfr_obs * ( (1. - fr_i(ji,jj) ) * zqri    & 
    122135                 &                 +      fr_i(ji,jj)   * zqrj ) ) * tmask(ji,jj,1) 
     136#endif 
    123137 
    124138               !                                            ! non-solar heat flux  
    … …  
    128142               !                                   (-2=arctic, -4=antarctic)    
    129143               zqi = -3. + SIGN( 1.e0, ff(ji,jj) ) 
     144#if defined key_z_first 
     145               qns(ji,jj) = ( ( 1.- zfr_obs ) * qns(ji,jj)                             & 
     146                  &          +      zfr_obs   * fr_i(ji,jj) * zqi ) * tmask_1(ji,jj)    & 
     147                  &       + zqrp 
     148#else 
    130149               qns(ji,jj) = ( ( 1.- zfr_obs ) * qns(ji,jj)                             & 
    131150                  &          +      zfr_obs   * fr_i(ji,jj) * zqi ) * tmask(ji,jj,1)   & 
    132151                  &       + zqrp 
     152#endif 
    133153            END DO 
    134154         END DO 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/SBC/sbcice_lim.F90

    r2715 r3211  
    5858 
    5959   PUBLIC sbc_ice_lim  ! routine called by sbcmod.F90 
     60 
     61   !! * Control permutation of array indices 
     62#  include "oce_ftrans.h90" 
     63#  include "dom_oce_ftrans.h90" 
     64#  include "sbc_oce_ftrans.h90" 
    6065    
    6166   !! * Substitutions 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/SBC/sbcice_lim_2.F90

    r2715 r3211  
    5353   PUBLIC sbc_ice_lim_2 ! routine called by sbcmod.F90 
    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 
    5560   !! * Substitutions 
    5661#  include "domzgr_substitute.h90" 
    … …  
    99104         CALL ctl_stop('sbc_ice_lim_2: requested workspace arrays are unavailable')   ;   RETURN 
    100105      ENDIF 
     106 
     107 
     108      !! DCSE_NEMO: Attention! This usage will break index re-ordering !! 
     109 
    101110      ! Use pointers to access only sub-arrays of workspaces 
    102111      zalb_ice_os => wrk_3d_1(:,:,1:1) 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/SBC/sbcmod.F90

    r2715 r3211  
    5454    
    5555   INTEGER ::   nsbc   ! type of surface boundary condition (deduced from namsbc informations) 
     56 
     57   !! * Control permutation of array indices 
     58#  include "oce_ftrans.h90" 
     59#  include "dom_oce_ftrans.h90" 
     60#  include "sbc_oce_ftrans.h90" 
    5661       
    5762   !! * Substitutions 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/SBC/sbcrnf.F90

    r2715 r3211  
    5454   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   h_rnf               !: depth of runoff in m 
    5555   INTEGER,  PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   nk_rnf              !: depth of runoff in model levels 
    56    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   rnf_tsc_b, rnf_tsc  !: before and now T & S runoff contents   [K.m/s & PSU.m/s] 
     56   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   rnf_tsc_b, rnf_tsc  !: before and now T & S runoff contents 
     57   !                                                                              !            [K.m/s & PSU.m/s] 
    5758    
    5859   REAL(wp) ::   r1_rau0   ! = 1 / rau0  
    5960 
    6061   TYPE(FLD), ALLOCATABLE, DIMENSION(:) ::   sf_rnf       ! structure: river runoff (file information, fields read) 
    61    TYPE(FLD), ALLOCATABLE, DIMENSION(:) ::   sf_s_rnf     ! structure: river runoff salinity (file information, fields read)   
    62    TYPE(FLD), ALLOCATABLE, DIMENSION(:) ::   sf_t_rnf     ! structure: river runoff temperature (file information, fields read)   
     62   TYPE(FLD), ALLOCATABLE, DIMENSION(:) ::   sf_s_rnf     ! structure: river runoff salinity (file info, fields read)   
     63   TYPE(FLD), ALLOCATABLE, DIMENSION(:) ::   sf_t_rnf     ! structure: river runoff temperature (file info, fields read)   
     64 
     65   !! * Control permutation of array indices 
     66#  include "dom_oce_ftrans.h90" 
     67#  include "sbc_oce_ftrans.h90" 
    6368  
    6469   !! * Substitutions   
    … …  
    197202      !!---------------------------------------------------------------------- 
    198203      REAL(wp), DIMENSION(:,:,:), INTENT(inout) ::   phdivn   ! horizontal divergence 
     204!FTRANS phdivn :I :I :z 
    199205      !! 
    200206      INTEGER  ::   ji, jj, jk   ! dummy loop indices 
    … …  
    238244   END SUBROUTINE sbc_rnf_div 
    239245 
     246   !! * Reset control of array index permutation 
     247#  include "dom_oce_ftrans.h90" 
     248#  include "sbc_oce_ftrans.h90" 
    240249 
    241250   SUBROUTINE sbc_rnf_init 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/SBC/sbcssm.F90

    r2715 r3211  
    1414   USE oce             ! ocean dynamics and tracers 
    1515   USE dom_oce         ! ocean space and time domain 
    16    USE sbc_oce         ! Surface boundary condition: ocean fields 
    1716   USE sbc_oce         ! surface boundary condition: ocean fields 
    1817   USE sbcapr          ! surface boundary condition: atmospheric pressure 
    … …  
    2625 
    2726   PUBLIC   sbc_ssm    ! routine called by step.F90 
     27 
     28   !! * Control permutation of array indices 
     29#  include "oce_ftrans.h90" 
     30#  include "dom_oce_ftrans.h90" 
     31#  include "sbc_oce_ftrans.h90" 
    2832    
    2933   !! * Substitutions 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/SBC/sbcssr.F90

    r2715 r3211  
    4141   TYPE(FLD), ALLOCATABLE, DIMENSION(:) ::   sf_sst   ! structure of input SST (file informations, fields read) 
    4242   TYPE(FLD), ALLOCATABLE, DIMENSION(:) ::   sf_sss   ! structure of input SSS (file informations, fields read) 
     43 
     44   !! * Control permutation of array indices 
     45#  include "oce_ftrans.h90" 
     46#  include "dom_oce_ftrans.h90" 
     47#  include "sbc_oce_ftrans.h90" 
    4348 
    4449   !! * Substitutions 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/SOL/solmat.F90

    r2715 r3211  
    3737   PUBLIC   sol_mat    ! routine called by inisol.F90 
    3838 
     39   !! * Control permutation of array indices 
     40#  include "oce_ftrans.h90" 
     41#  include "dom_oce_ftrans.h90" 
     42#  include "obc_oce_ftrans.h90" 
     43 
    3944   !!---------------------------------------------------------------------- 
    4045   !! NEMO/OPA 3.3 , NEMO Consortium (2010) 
    … …  
    207212               !  south coefficient 
    208213               IF( ( nbondj == -1 .OR. nbondj == 2 ) .AND. ( jj == 3 ) ) THEN 
     214#if defined key_z_first 
     215                  zcoefs = -zcoef * hv(ji,jj-1) * e1v(ji,jj-1)/e2v(ji,jj-1)*(1.-vmask_1(ji,jj-1)) 
     216#else 
    209217                  zcoefs = -zcoef * hv(ji,jj-1) * e1v(ji,jj-1)/e2v(ji,jj-1)*(1.-vmask(ji,jj-1,1)) 
     218#endif 
    210219               ELSE 
    211220                  zcoefs = -zcoef * hv(ji,jj-1) * e1v(ji,jj-1)/e2v(ji,jj-1) 
    … …  
    223232               !   east coefficient 
    224233               IF( ( nbondi == 1 .OR. nbondi == 2 ) .AND. ( ji == nlci-2 ) ) THEN 
     234#if defined key_z_first 
     235                  zcoefe = -zcoef * hu(ji,jj) * e2u(ji,jj)/e1u(ji,jj)*(1.-umask_1(ji,jj)) 
     236#else 
    225237                  zcoefe = -zcoef * hu(ji,jj) * e2u(ji,jj)/e1u(ji,jj)*(1.-umask(ji,jj,1)) 
     238#endif 
    226239               ELSE 
    227240                  zcoefe = -zcoef * hu(ji,jj) * e2u(ji,jj)/e1u(ji,jj) 
    … …  
    231244               !   north coefficient 
    232245               IF( ( nbondj == 1 .OR. nbondj == 2 ) .AND. ( jj == nlcj-2 ) ) THEN 
     246#if defined key_z_first 
     247                  zcoefn = -zcoef * hv(ji,jj) * e1v(ji,jj)/e2v(ji,jj)*(1.-vmask_1(ji,jj)) 
     248#else 
    233249                  zcoefn = -zcoef * hv(ji,jj) * e1v(ji,jj)/e2v(ji,jj)*(1.-vmask(ji,jj,1)) 
     250#endif 
    234251               ELSE 
    235252                  zcoefn = -zcoef * hv(ji,jj) * e1v(ji,jj)/e2v(ji,jj) 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/SOL/solpcg.F90

    r2715 r3211  
    2020 
    2121   PUBLIC   sol_pcg    !  
     22 
     23   !! * Control permutation of array indices 
     24#  include "oce_ftrans.h90" 
     25#  include "dom_oce_ftrans.h90" 
    2226 
    2327   !! * Substitutions 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/SOL/solsor.F90

    r2715 r3211  
    2828 
    2929   PUBLIC   sol_sor    !  
     30 
     31   !! * Control permutation of array indices 
     32#  include "oce_ftrans.h90" 
     33#  include "dom_oce_ftrans.h90" 
     34#  include "zdf_oce_ftrans.h90" 
    3035 
    3136   !!---------------------------------------------------------------------- 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/SOL/solver.F90

    r2715 r3211  
    2929 
    3030   IMPLICIT NONE 
     31 
     32   !! * Control permutation of array indices 
     33#  include "oce_ftrans.h90" 
     34#  include "dom_oce_ftrans.h90" 
     35#  include "zdf_oce_ftrans.h90" 
     36#  include "obc_oce_ftrans.h90" 
    3137 
    3238   !!---------------------------------------------------------------------- 

  • 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 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/TRD/trdicp.F90

    r2715 r3211  
    3939   PUBLIC   trd_icp_init  ! called by opa.F90 
    4040 
     41   !! * Control permutation of array indices 
     42#  include "oce_ftrans.h90" 
     43#  include "dom_oce_ftrans.h90" 
     44#  include "trdmld_oce_ftrans.h90" 
     45#  include "ldftra_oce_ftrans.h90" 
     46#  include "ldfdyn_oce_ftrans.h90" 
     47#  include "zdf_oce_ftrans.h90" 
     48 
    4149   !! * Substitutions 
    4250#  include "domzgr_substitute.h90" 
    … …  
    121129      !!              momentum equations at every time step frequency nn_trd. 
    122130      !!---------------------------------------------------------------------- 
    123       REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   ptrd3dx   ! Temperature or U trend  
    124       REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   ptrd3dy   ! Salinity    or V trend 
     131 
     132      !! DCSE_NEMO: This style defeats ftrans 
     133!     REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   ptrd3dx   ! Temperature or U trend  
     134!     REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   ptrd3dy   ! Salinity    or V trend 
     135 
     136!FTRANS ptrd3dx ptrd3dy :I :I :z 
     137      REAL(wp), INTENT(inout) ::   ptrd3dx(jpi,jpj,jpk)   ! Temperature or U trend  
     138      REAL(wp), INTENT(inout) ::   ptrd3dy(jpi,jpj,jpk)   ! Salinity    or V trend 
     139 
    125140      INTEGER,                          INTENT(in   ) ::   ktrd      ! momentum or tracer trend index 
    126141      CHARACTER(len=3),                 INTENT(in   ) ::   ctype     ! momentum ('DYN') or tracers ('TRA') trends 
    … …  
    132147      ! 
    133148      CASE( 'DYN' )              ! Momentum         
     149#if defined key_z_first 
     150         DO jj = 1, jpjm1 
     151            DO ji = 1, jpim1 
     152               DO jk = 1, jpkm1 
     153#else 
    134154         DO jk = 1, jpkm1 
    135155            DO jj = 1, jpjm1 
    136156               DO ji = 1, jpim1 
     157#endif 
    137158                  ptrd3dx(ji,jj,jk) = ptrd3dx(ji,jj,jk) * tmask_i(ji+1,jj  ) * tmask_i(ji,jj) * umask(ji,jj,jk) 
    138159                  ptrd3dy(ji,jj,jk) = ptrd3dy(ji,jj,jk) * tmask_i(ji  ,jj+1) * tmask_i(ji,jj) * vmask(ji,jj,jk) 
    … …  
    144165         ! 
    145166      CASE( 'TRA' )              ! Tracers 
     167#if defined key_z_first 
     168         DO jj = 1, jpj 
     169            DO ji = 1, jpi 
     170               DO jk = 1, jpkm1 
     171                  ptrd3dx(ji,jj,jk) = ptrd3dx(ji,jj,jk) * tmask(ji,jj,jk) * tmask_i(ji,jj) 
     172                  ptrd3dy(ji,jj,jk) = ptrd3dy(ji,jj,jk) * tmask(ji,jj,jk) * tmask_i(ji,jj) 
     173               END DO 
     174            END DO 
     175         END DO 
     176#else 
    146177         DO jk = 1, jpkm1 
    147178            ptrd3dx(:,:,jk) = ptrd3dx(:,:,jk) * tmask(:,:,jk) * tmask_i(:,:) 
    148179            ptrd3dy(:,:,jk) = ptrd3dy(:,:,jk) * tmask(:,:,jk) * tmask_i(:,:) 
    149180         END DO 
     181#endif 
    150182         ! 
    151183      END SELECT    
    … …  
    156188         umo(ktrd) = 0._wp 
    157189         vmo(ktrd) = 0._wp 
     190#if defined key_z_first 
     191         !! DCSE_NEMO: this changes the order of summation 
     192         DO jj = 1, jpj 
     193            DO ji = 1, jpi 
     194               DO jk = 1, jpkm1 
     195                  umo(ktrd) = umo(ktrd) + ptrd3dx(ji,jj,jk) * e1u(ji,jj) * e2u(ji,jj) * fse3u(ji,jj,jk) 
     196                  vmo(ktrd) = vmo(ktrd) + ptrd3dy(ji,jj,jk) * e1v(ji,jj) * e2v(ji,jj) * fse3v(ji,jj,jk) 
     197               END DO 
     198            END DO 
     199         END DO 
     200#else 
    158201         DO jk = 1, jpkm1 
    159202            umo(ktrd) = umo(ktrd) + SUM( ptrd3dx(:,:,jk) * e1u(:,:) * e2u(:,:) * fse3u(:,:,jk) ) 
    160203            vmo(ktrd) = vmo(ktrd) + SUM( ptrd3dy(:,:,jk) * e1v(:,:) * e2v(:,:) * fse3v(:,:,jk) ) 
    161204         END DO 
     205#endif 
    162206         ! 
    163207      CASE( 'TRA' )              ! Tracers 
    164208         tmo(ktrd) = 0._wp 
    165209         smo(ktrd) = 0._wp 
     210#if defined key_z_first 
     211         !! DCSE_NEMO: this changes the order of summation 
     212         DO jj = 1, jpj 
     213            DO ji = 1, jpi 
     214               DO jk = 1, jpkm1 
     215                  tmo(ktrd) = tmo(ktrd) + ptrd3dx(ji,jj,jk) * e1e2t(ji,jj) * fse3t(ji,jj,jk) ) 
     216                  smo(ktrd) = smo(ktrd) + ptrd3dy(ji,jj,jk) * e1e2t(ji,jj) * fse3t(ji,jj,jk) ) 
     217               END DO 
     218            END DO 
     219         END DO 
     220#else 
    166221         DO jk = 1, jpkm1 
    167222            tmo(ktrd) = tmo(ktrd) + SUM( ptrd3dx(:,:,jk) * e1e2t(:,:) * fse3t(:,:,jk) ) 
    168223            smo(ktrd) = smo(ktrd) + SUM( ptrd3dy(:,:,jk) * e1e2t(:,:) * fse3t(:,:,jk) ) 
    169224         END DO 
     225#endif 
    170226         ! 
    171227      END SELECT 
    … …  
    175231      CASE( 'DYN' )              ! Momentum 
    176232         hke(ktrd) = 0._wp 
     233#if defined key_z_first 
     234         !! DCSE_NEMO: this changes the order of summation 
     235         DO jj = 1, jpj 
     236            DO ji = 1, jpi 
     237               DO jk = 1, jpkm1 
     238                  hke(ktrd) = hke(ktrd) + un(ji,jj,jk) * ptrd3dx(ji,jj,jk) * e1u(ji,jj) * e2u(ji,jj) * fse3u(ji,jj,jk)   & 
     239                     &                  + vn(ji,jj,jk) * ptrd3dy(ji,jj,jk) * e1v(ji,jj) * e2v(ji,jj) * fse3v(ji,jj,jk)   
     240               END DO 
     241            END DO 
     242         END DO 
     243#else 
    177244         DO jk = 1, jpkm1 
    178245            hke(ktrd) = hke(ktrd) + SUM(   un(:,:,jk) * ptrd3dx(:,:,jk) * e1u(:,:) * e2u(:,:) * fse3u(:,:,jk)   & 
    179246               &                         + vn(:,:,jk) * ptrd3dy(:,:,jk) * e1v(:,:) * e2v(:,:) * fse3v(:,:,jk)   ) 
    180247         END DO 
     248#endif 
    181249         ! 
    182250      CASE( 'TRA' )              ! Tracers 
    183251         t2(ktrd) = 0._wp 
    184252         s2(ktrd) = 0._wp 
     253#if defined key_z_first 
     254         !! DCSE_NEMO: this changes the order of summation 
     255         DO jj = 1, jpj 
     256            DO ji = 1, jpi 
     257               DO jk = 1, jpkm1 
     258                  t2(ktrd) = t2(ktrd) + ptrd3dx(ji,jj,jk) * tn(ji,jj,jk) * e1e2t(ji,jj) * fse3t(ji,jj,jk) 
     259                  s2(ktrd) = s2(ktrd) + ptrd3dy(ji,jj,jk) * sn(ji,jj,jk) * e1e2t(ji,jj) * fse3t(ji,jj,jk) 
     260               END DO 
     261            END DO 
     262         END DO 
     263#else 
    185264         DO jk = 1, jpkm1 
    186             t2(ktrd) = t2(ktrd) + SUM( ptrd3dx(ji,jj,jk) * tn(ji,jj,jk) * e1e2t(:,:) * fse3t(:,:,jk) ) 
    187             s2(ktrd) = s2(ktrd) + SUM( ptrd3dy(ji,jj,jk) * sn(ji,jj,jk) * e1e2t(:,:) * fse3t(:,:,jk) ) 
    188          END DO 
     265         !! DCSE_NEMO: This looks plain wrong! 
     266!           t2(ktrd) = t2(ktrd) + SUM( ptrd3dx(ji,jj,jk) * tn(ji,jj,jk) * e1e2t(:,:) * fse3t(:,:,jk) ) 
     267!           s2(ktrd) = s2(ktrd) + SUM( ptrd3dy(ji,jj,jk) * sn(ji,jj,jk) * e1e2t(:,:) * fse3t(:,:,jk) ) 
     268            t2(ktrd) = t2(ktrd) + SUM( ptrd3dx(:,:,jk) * tn(:,:,jk) * e1e2t(:,:) * fse3t(:,:,jk) ) 
     269            s2(ktrd) = s2(ktrd) + SUM( ptrd3dy(:,:,jk) * sn(:,:,jk) * e1e2t(:,:) * fse3t(:,:,jk) ) 
     270         END DO 
     271#endif 
    189272         ! 
    190273      END SELECT 
    … …  
    210293      ! Total volume at t-points: 
    211294      tvolt = 0._wp 
     295#if defined key_z_first 
     296      DO jj = 1, jpj 
     297         DO ji = 1, jpi 
     298            DO jk = 1, jpkm1 
     299               tvolt = tvolt + e1e2t(ji,jj) * fse3t(ji,jj,jk) * tmask(ji,jj,jk) * tmask_i(ji,jj) 
     300            END DO 
     301         END DO 
     302      END DO 
     303#else 
    212304      DO jk = 1, jpkm1 
    213          tvolt = SUM( e1e2t(:,:) * fse3t(:,:,jk) * tmask(:,:,jk) * tmask_i(:,:) ) 
     305      !! DCSE_NEMO: This looks plain wrong 
     306!        tvolt = SUM( e1e2t(:,:) * fse3t(:,:,jk) * tmask(:,:,jk) * tmask_i(:,:) ) 
     307         tvolt = tvolt + SUM( e1e2t(:,:) * fse3t(:,:,jk) * tmask(:,:,jk) * tmask_i(:,:) ) 
    214308      END DO 
     309#endif 
    215310      IF( lk_mpp )   CALL mpp_sum( tvolt )   ! sum over the global domain 
    216311 
    … …  
    225320      tvolv = 0._wp 
    226321 
     322#if defined key_z_first 
     323      DO jj = 2, jpjm1 
     324         DO ji = 2, jpim1 
     325            DO jk = 1, jpk 
     326#else 
    227327      DO jk = 1, jpk 
    228328         DO jj = 2, jpjm1 
    229329            DO ji = fs_2, fs_jpim1   ! vector opt. 
     330#endif 
    230331               tvolu = tvolu + e1u(ji,jj) * e2u(ji,jj) * fse3u(ji,jj,jk) * tmask_i(ji+1,jj  ) * tmask_i(ji,jj) * umask(ji,jj,jk) 
    231332               tvolv = tvolv + e1v(ji,jj) * e2v(ji,jj) * fse3v(ji,jj,jk) * tmask_i(ji  ,jj+1) * tmask_i(ji,jj) * vmask(ji,jj,jk) 
    … …  
    254355      USE wrk_nemo, ONLY:   zkepe => wrk_3d_1 , zkx => wrk_3d_2   ! 3D workspace 
    255356      USE wrk_nemo, ONLY:   zky   => wrk_3d_3 , zkz => wrk_3d_4   !  -      - 
     357 
     358      !! DCSE_NEMO: need additional directives for renamed module variables 
     359!FTRANS zkepe zkx zky zkz :I :I :z 
     360 
    256361      ! 
    257362      INTEGER, INTENT(in) ::   kt   ! ocean time-step index 
    … …  
    281386 
    282387         zcof = 0.5_wp / rau0             ! Density flux at w-point 
     388#if defined key_z_first 
     389         DO jj = 1, jpj 
     390            DO ji = 1, jpi 
     391               zkz(ji,jj,1) = 0._wp 
     392               DO jk = 2, jpk 
     393                  zkz(ji,jj,jk) = e1e2t(ji,jj) * wn(ji,jj,jk) * ( rhop(ji,jj,jk) + rhop(ji,jj,jk-1) ) * tmask_i(ji,jj) 
     394               END DO 
     395            END DO 
     396         END DO 
     397#else 
    283398         zkz(:,:,1) = 0._wp 
    284399         DO jk = 2, jpk 
    285400            zkz(:,:,jk) = e1e2t(:,:) * wn(:,:,jk) * ( rhop(:,:,jk) + rhop(:,:,jk-1) ) * tmask_i(:,:) 
    286401         END DO 
     402#endif 
    287403          
    288404         zcof   = 0.5_wp / rau0           ! Density flux at u and v-points 
     405#if defined key_z_first 
     406         DO jj = 1, jpjm1 
     407            DO ji = 1, jpim1 
     408               DO jk = 1, jpkm1 
     409#else 
    289410         DO jk = 1, jpkm1 
    290411            DO jj = 1, jpjm1 
    291412               DO ji = 1, jpim1 
     413#endif 
    292414                  zkx(ji,jj,jk) = zcof * e2u(ji,jj) * fse3u(ji,jj,jk) * un(ji,jj,jk) * ( rhop(ji,jj,jk) + rhop(ji+1,jj,jk) ) 
    293415                  zky(ji,jj,jk) = zcof * e1v(ji,jj) * fse3v(ji,jj,jk) * vn(ji,jj,jk) * ( rhop(ji,jj,jk) + rhop(ji,jj+1,jk) ) 
    … …  
    296418         END DO 
    297419          
     420#if defined key_z_first 
     421         DO jj = 2, jpjm1                 ! Density flux divergence at t-point 
     422            DO ji = 2, jpim1 
     423               DO jk = 1, jpkm1 
     424#else 
    298425         DO jk = 1, jpkm1                 ! Density flux divergence at t-point 
    299426            DO jj = 2, jpjm1 
    300427               DO ji = 2, jpim1 
     428#endif 
    301429                  zkepe(ji,jj,jk) = - (  zkz(ji,jj,jk) - zkz(ji  ,jj  ,jk+1)               & 
    302430                     &                 + zkx(ji,jj,jk) - zkx(ji-1,jj  ,jk  )               & 
    … …  
    310438         ! ---------------------------------------- 
    311439         peke = 0._wp 
     440#if defined key_z_first 
     441         DO jj = 1, jpj 
     442            DO ji = 1, jpi 
     443               DO jk = 1, jpkm1 
     444                  peke = peke + zkepe(ji,jj,jk) * fsdept(ji,jj,jk) * e1e2t(ji,jj) * fse3t(ji,jj,jk) 
     445               END DO 
     446            END DO 
     447         END DO 
     448#else 
    312449         DO jk = 1, jpkm1 
    313450            peke = peke + SUM( zkepe(:,:,jk) * fsdept(:,:,jk) * e1e2t(:,:) * fse3t(:,:,jk) ) 
    314451         END DO 
     452#endif 
    315453         peke = grav * peke 
    316454 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/TRD/trdmld.F90

    r2715 r3211  
    5353   INTEGER ::   ionce, icount                    
    5454 
     55   !! * Control permutation of array indices 
     56#  include "oce_ftrans.h90" 
     57#  include "dom_oce_ftrans.h90" 
     58#  include "trdmld_oce_ftrans.h90" 
     59#  include "ldftra_oce_ftrans.h90" 
     60#  include "zdf_oce_ftrans.h90" 
     61#  include "ldfslp_ftrans.h90" 
     62#  include "zdfddm_ftrans.h90" 
     63 
    5564   !! * Substitutions 
    5665#  include "domzgr_substitute.h90" 
    … …  
    98107      INTEGER                         , INTENT( in ) ::   ktrd       ! ocean trend index 
    99108      CHARACTER(len=2)                , INTENT( in ) ::   ctype      ! 2D surface/bottom or 3D interior physics 
    100       REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT( in ) ::   pttrdmld   ! temperature trend  
    101       REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT( in ) ::   pstrdmld   ! salinity trend  
     109 
     110      !! DCSE_NEMO: This style defeats ftrans 
     111!     REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT( in ) ::   pttrdmld   ! temperature trend  
     112!     REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT( in ) ::   pstrdmld   ! salinity trend  
     113 
     114!FTRANS pttrdmld pstrdmld :I :I :z 
     115      REAL(wp), INTENT( in ) ::   pttrdmld(jpi,jpj,jpk)   ! temperature trend  
     116      REAL(wp), INTENT( in ) ::   pstrdmld(jpi,jpj,jpk)   ! salinity trend  
    102117      ! 
    103118      INTEGER ::   ji, jj, jk, isum 
    … …  
    160175         ! ... Weights for vertical averaging 
    161176         wkx(:,:,:) = 0.e0 
     177#if defined key_z_first 
     178         DO jj = 1,jpj                 ! initialize wkx with vertical scale factor in mixed-layer 
     179            DO ji = 1,jpi 
     180               DO jk = 1, jpktrd 
     181                  IF( jk < nmld(ji,jj) )          wkx(ji,jj,jk) = fse3t(ji,jj,jk) * tmask(ji,jj,jk) 
     182#else 
    162183         DO jk = 1, jpktrd             ! initialize wkx with vertical scale factor in mixed-layer 
    163184            DO jj = 1,jpj 
    164185               DO ji = 1,jpi 
    165186                  IF( jk - nmld(ji,jj) < 0.e0 )   wkx(ji,jj,jk) = fse3t(ji,jj,jk) * tmask(ji,jj,jk) 
     187#endif 
    166188               END DO 
    167189            END DO 
    … …  
    169191          
    170192         rmld(:,:) = 0.e0                ! compute mixed-layer depth : rmld 
     193#if defined key_z_first 
     194         DO jj = 1, jpj 
     195            DO ji = 1, jpi 
     196               DO jk = 1, jpktrd 
     197                  rmld(ji,jj) = rmld(ji,jj) + wkx(ji,jj,jk) 
     198               END DO 
     199            END DO 
     200         END DO 
     201#else 
    171202         DO jk = 1, jpktrd 
    172203            rmld(:,:) = rmld(:,:) + wkx(:,:,jk) 
    173204         END DO 
    174           
     205#endif 
     206          
     207#if defined key_z_first 
     208         DO jj = 1, jpj 
     209            DO ji = 1, jpi 
     210               DO jk = 1, jpktrd             ! compute integration weights 
     211                  wkx(ji,jj,jk) = wkx(ji,jj,jk) / MAX( 1., rmld(ji,jj) ) 
     212               END DO 
     213            END DO 
     214         END DO 
     215#else 
    175216         DO jk = 1, jpktrd             ! compute integration weights 
    176217            wkx(:,:,jk) = wkx(:,:,jk) / MAX( 1., rmld(:,:) ) 
    177218         END DO 
     219#endif 
    178220 
    179221         icount = 0                    ! <<< flag = off : control surface & integr. weights 
    … …  
    186228      SELECT CASE (ctype) 
    187229      CASE ( '3D' )   ! mean T/S trends in the mixed-layer 
     230#if defined key_z_first 
     231         DO jj = 1, jpj 
     232            DO ji = 1, jpi 
     233               DO jk = 1, jpktrd 
     234                  tmltrd(ji,jj,ktrd) = tmltrd(ji,jj,ktrd) + pttrdmld(ji,jj,jk) * wkx(ji,jj,jk)   ! temperature 
     235                  smltrd(ji,jj,ktrd) = smltrd(ji,jj,ktrd) + pstrdmld(ji,jj,jk) * wkx(ji,jj,jk)   ! salinity 
     236               END DO 
     237            END DO 
     238         END DO 
     239#else 
    188240         DO jk = 1, jpktrd 
    189241            tmltrd(:,:,ktrd) = tmltrd(:,:,ktrd) + pttrdmld(:,:,jk) * wkx(:,:,jk)   ! temperature 
    190242            smltrd(:,:,ktrd) = smltrd(:,:,ktrd) + pstrdmld(:,:,jk) * wkx(:,:,jk)   ! salinity 
    191243         END DO 
     244#endif 
    192245      CASE ( '2D' )   ! forcing at upper boundary of the mixed-layer 
    193246         tmltrd(:,:,ktrd) = tmltrd(:,:,ktrd) + pttrdmld(:,:,1) * wkx(:,:,1)        ! non penetrative 
    … …  
    198251      ! 
    199252   END SUBROUTINE trd_mld_zint 
    200      
     253 
     254   !! * Reset control of array index permutation 
     255!FTRANS CLEAR 
     256#  include "oce_ftrans.h90" 
     257#  include "dom_oce_ftrans.h90" 
     258#  include "trdmld_oce_ftrans.h90" 
     259#  include "ldftra_oce_ftrans.h90" 
     260#  include "zdf_oce_ftrans.h90" 
     261#  include "ldfslp_ftrans.h90" 
     262#  include "zdfddm_ftrans.h90" 
     263 
    201264 
    202265   SUBROUTINE trd_mld( kt ) 
    … …  
    261324      LOGICAL :: lldebug = .TRUE. 
    262325      REAL(wp) :: zavt, zfn, zfn2 
     326 
     327#if defined key_z_first 
     328      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::  ztmltrd2, zsmltrd2   ! only needed for mean diagnostics 
     329#else 
    263330      REAL(wp), POINTER, DIMENSION(:,:,:) ::  ztmltrd2, zsmltrd2   ! only needed for mean diagnostics 
     331#endif 
     332 
    264333#if defined key_dimgout 
    265334      INTEGER ::  iyear,imon,iday 
    … …  
    269338       
    270339      ! Check that the workspace arrays are all OK to be used 
     340#if defined key_z_first 
     341      IF( wrk_in_use(2, 1,2,3,4,5,6,7,8,9,10,11,12,13,14) ) THEN 
     342         CALL ctl_stop('trd_mld : requested workspace arrays unavailable')   ;   RETURN 
     343      END IF 
     344      ALLOCATE( ztmltrd2(jpi,jpj,jpltrd) ) 
     345      ALLOCATE( zsmltrd2(jpi,jpj,jpltrd) ) 
     346#else 
    271347      IF( wrk_in_use(2, 1,2,3,4,5,6,7,8,9,10,11,12,13,14)  .OR. & 
    272348          wrk_in_use(3, 1,2)                                 ) THEN 
    … …  
    280356      ztmltrd2 => wrk_3d_1(1:,:,1:jpltrd) 
    281357      zsmltrd2 => wrk_3d_2(1:,:,1:jpltrd) 
     358#endif 
    282359 
    283360      ! ====================================================================== 
    … …  
    333410      ! -------------------------------- 
    334411      tml(:,:) = 0.e0   ;   sml(:,:) = 0.e0 
     412#if defined key_z_first 
     413      DO jj = 1, jpj 
     414         DO ji = 1, jpi 
     415            DO jk = 1, jpktrd - 1 
     416               tml(ji,jj) = tml(ji,jj) + wkx(ji,jj,jk) * tn(ji,jj,jk) 
     417               sml(ji,jj) = sml(ji,jj) + wkx(ji,jj,jk) * sn(ji,jj,jk)  
     418            END DO 
     419         END DO 
     420      END DO 
     421#else 
    335422      DO jk = 1, jpktrd - 1 
    336423         tml(:,:) = tml(:,:) + wkx(:,:,jk) * tn(:,:,jk) 
    337424         sml(:,:) = sml(:,:) + wkx(:,:,jk) * sn(:,:,jk)  
    338425      END DO 
     426#endif 
    339427 
    340428      ! II.3 Initialize mixed-layer "before" arrays for the 1rst analysis window     
    … …  
    740828      IF( lrst_oce )   CALL trd_mld_rst_write( kt )  
    741829 
     830#if defined key_z_first 
     831      IF( wrk_not_released(2, 1,2,3,4,5,6,7,8,9,10,11,12,13,14) )   & 
     832          CALL ctl_stop('trd_mld : failed to release workspace arrays.') 
     833      DEALLOCATE( ztmltrd2, zsmltrd2 ) 
     834#else 
    742835      IF( wrk_not_released(2, 1,2,3,4,5,6,7,8,9,10,11,12,13,14)  .OR. & 
    743836          wrk_not_released(3, 1,2)                                )   & 
    744837          CALL ctl_stop('trd_mld : failed to release workspace arrays.') 
     838#endif 
    745839      ! 
    746840   END SUBROUTINE trd_mld 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/TRD/trdmld_oce.F90

    r2715 r3211  
    7979      smltrd_csum_ln,               & !:    ( idem for salinity ) 
    8080      smltrd_csum_ub                  !:  
     81 
     82   !! * Control permutation of array indices 
     83#  include "trdmld_oce_ftrans.h90" 
     84 
    8185#endif 
    8286   !!---------------------------------------------------------------------- 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/TRD/trdmld_rst.F90

    r2528 r3211  
    2121   
    2222   INTEGER ::   nummldw         ! logical unit for mld restart 
     23 
     24   !! * Control permutation of array indices 
     25#  include "dom_oce_ftrans.h90" 
    2326 
    2427   !!--------------------------------------------------------------------------------- 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/TRD/trdmod.F90

    r2715 r3211  
    3434   PUBLIC trd_mod_init         ! called by opa.F90 module 
    3535 
     36   !! * Control permutation of array indices 
     37#  include "oce_ftrans.h90" 
     38#  include "dom_oce_ftrans.h90" 
     39#  include "zdf_oce_ftrans.h90" 
     40#  include "ldftra_oce_ftrans.h90" 
     41#  include "sbc_oce_ftrans.h90" 
     42 
    3643   !! * Substitutions 
    3744#  include "domzgr_substitute.h90" 
    … …  
    6269      REAL(wp), DIMENSION(:,:,:), INTENT(inout) ::   ptrdx   ! Temperature or U trend  
    6370      REAL(wp), DIMENSION(:,:,:), INTENT(inout) ::   ptrdy   ! Salinity    or V trend 
     71!FTRANS ptrdx ptrdy :I :I :z 
     72 
    6473      CHARACTER(len=3)          , INTENT(in   ) ::   ctype   ! momentum or tracers trends type 'DYN'/'TRA' 
    6574      INTEGER                   , INTENT(in   ) ::   kt      ! time step 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/TRD/trdmod_oce.F90

    r2715 r3211  
    7272   INTEGER, PUBLIC, PARAMETER ::   jpdyn_trd_bfr = 12     !: bottom friction  
    7373 
     74   !! * Control permutation of array indices 
     75   ! DCSE_NEMO: Nothing needed in this module, but beware those that use it 
     76   ! for trdmld_oce variables 
     77 
    7478   !!---------------------------------------------------------------------- 
    7579   !! NEMO/OPA 3.3 , NEMO Consortium (2010) 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/TRD/trdtra.F90

    r2715 r3211  
    2525  
    2626   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: trdtx, trdty, trdt  !: 
     27 
     28   !! * Control permutation of array indices 
     29#  include "dom_oce_ftrans.h90" 
     30   !! These are all private to the module, 
     31   !! so we do not need a separate file of ftrans directives 
     32!FTRANS trdtx trdty trdt :I :I :z 
    2733 
    2834   !! * Substitutions 
    … …  
    6369      USE wrk_nemo, ONLY:   wrk_in_use, wrk_not_released 
    6470      USE wrk_nemo, ONLY:   ztrds => wrk_3d_10   ! 3D workspace 
     71      !! DCSE_NEMO: Need additional directives for renamed module variables 
     72!FTRANS ztrds :I :I :z 
     73 
    6574      ! 
    6675      INTEGER                         , INTENT(in)           ::  kt      ! time step 
    … …  
    6877      INTEGER                         , INTENT(in)           ::  ktra    ! tracer index 
    6978      INTEGER                         , INTENT(in)           ::  ktrd    ! tracer trend index 
    70       REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in)           ::  ptrd    ! tracer trend  or flux 
    71       REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in), OPTIONAL ::  pun     ! velocity  
    72       REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in), OPTIONAL ::  ptra    ! Tracer variable  
     79 
     80      !! DCSE_NEMO: This style defeats ftrans 
     81!     REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in)           ::  ptrd    ! tracer trend  or flux 
     82!     REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in), OPTIONAL ::  pun     ! velocity  
     83!     REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in), OPTIONAL ::  ptra    ! Tracer variable  
     84 
     85!FTRANS ptrd pun ptra :I :I :z 
     86      REAL(wp), INTENT(in)           ::  ptrd(jpi,jpj,jpk)    ! tracer trend  or flux 
     87      REAL(wp), INTENT(in), OPTIONAL ::  pun(jpi,jpj,jpk)     ! velocity  
     88      REAL(wp), INTENT(in), OPTIONAL ::  ptra(jpi,jpj,jpk)    ! Tracer variable  
    7389      !!---------------------------------------------------------------------- 
    7490 
    … …  
    142158   END SUBROUTINE trd_tra 
    143159 
     160   !! * Reset control of array index permutation 
     161!FTRANS CLEAR 
     162#  include "dom_oce_ftrans.h90" 
     163!FTRANS trdtx trdty trdt :I :I :z 
    144164 
    145165   SUBROUTINE trd_tra_adv( pf, pun, ptn, cdir, ptrd ) 
    … …  
    153173      !!                k-advective trends = -un. di+1[T] = -( dk+1[fi] - tn dk+1[un] ) 
    154174      !!---------------------------------------------------------------------- 
    155       REAL(wp)        , INTENT(in ), DIMENSION(jpi,jpj,jpk) ::   pf      ! advective flux in one direction 
    156       REAL(wp)        , INTENT(in ), DIMENSION(jpi,jpj,jpk) ::   pun     ! now velocity  in one direction 
    157       REAL(wp)        , INTENT(in ), DIMENSION(jpi,jpj,jpk) ::   ptn     ! now or before tracer  
     175 
     176      !! DCSE_NEMO: This style defeats ftrans 
     177!     REAL(wp)        , INTENT(in ), DIMENSION(jpi,jpj,jpk) ::   pf      ! advective flux in one direction 
     178!     REAL(wp)        , INTENT(in ), DIMENSION(jpi,jpj,jpk) ::   pun     ! now velocity  in one direction 
     179!     REAL(wp)        , INTENT(in ), DIMENSION(jpi,jpj,jpk) ::   ptn     ! now or before tracer  
     180 
     181!FTRANS pf pun ptn :I :I :z 
     182      REAL(wp)        , INTENT(in )            ::   pf(jpi,jpj,jpk)      ! advective flux in one direction 
     183      REAL(wp)        , INTENT(in )            ::   pun(jpi,jpj,jpk)     ! now velocity  in one direction 
     184      REAL(wp)        , INTENT(in )            ::   ptn(jpi,jpj,jpk)     ! now or before tracer  
    158185      CHARACTER(len=1), INTENT(in )                         ::   cdir    ! X/Y/Z direction 
    159       REAL(wp)        , INTENT(out), DIMENSION(jpi,jpj,jpk) ::   ptrd    ! advective trend in one direction 
     186 
     187!     REAL(wp)        , INTENT(out), DIMENSION(jpi,jpj,jpk) ::   ptrd    ! advective trend in one direction 
     188!FTRANS ptrd :I :I :z 
     189      REAL(wp)        , INTENT(out)            ::   ptrd(jpi,jpj,jpk)    ! advective trend in one direction 
    160190      ! 
    161191      INTEGER  ::   ji, jj, jk   ! dummy loop indices 
    … …  
    176206      ! 
    177207      ! 
     208#if defined key_z_first 
     209      DO jj = 2, jpjm1 
     210         DO ji = 2, jpim1 
     211            DO jk = 1, jpkm1 
     212#else 
    178213      DO jk = 1, jpkm1 
    179214         DO jj = 2, jpjm1 
    180215            DO ji = fs_2, fs_jpim1   ! vector opt. 
     216#endif 
    181217               zbtr    = 1.e0/ ( e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) ) 
    182218               ptrd(ji,jj,jk) = - zbtr * (      pf (ji,jj,jk) - pf (ji-ii,jj-ij,jk-ik)                    & 
    … …  
    200236      INTEGER                         , INTENT(in)           ::  ktra    ! tracer index 
    201237      INTEGER                         , INTENT(in)           ::  ktrd    ! tracer trend index 
    202       REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in)           ::  ptrd    ! tracer trend  
    203       REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in), OPTIONAL ::  pu      ! velocity  
    204       REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in), OPTIONAL ::  ptra    ! Tracer variable  
     238      !! DCSE_NEMO: This style defeats ftrans 
     239!     REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in)           ::  ptrd    ! tracer trend  or flux 
     240!     REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in), OPTIONAL ::  pu      ! velocity  
     241!     REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in), OPTIONAL ::  ptra    ! Tracer variable  
     242 
     243!FTRANS ptrd pu ptra :I :I :z 
     244      REAL(wp), INTENT(in)           ::  ptrd(jpi,jpj,jpk)    ! tracer trend  or flux 
     245      REAL(wp), INTENT(in), OPTIONAL ::  pu(jpi,jpj,jpk)      ! velocity  
     246      REAL(wp), INTENT(in), OPTIONAL ::  ptra(jpi,jpj,jpk)    ! Tracer variable  
     247 
    205248      WRITE(*,*) 'trd_3d: You should not have seen this print! error ?', ptrd(1,1,1), ptra(1,1,1), pu(1,1,1),   & 
    206249         &                                                               ktrd, ktra, ctype, kt 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/TRD/trdvor.F90

    r2715 r3211  
    5454          
    5555   CHARACTER(len=12) ::   cvort 
     56 
     57   !! * Control permutation of array indices 
     58#  include "oce_ftrans.h90" 
     59#  include "dom_oce_ftrans.h90" 
     60#  include "zdf_oce_ftrans.h90" 
     61#  include "ldfdyn_oce_ftrans.h90" 
    5662 
    5763   !! * Substitutions 
    … …  
    204210      ! 
    205211      INTEGER                         , INTENT(in   ) ::   ktrd       ! ocean trend index 
    206       REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   putrdvor   ! u vorticity trend  
    207       REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   pvtrdvor   ! v vorticity trend 
     212 
     213      !! DCSE_NEMO: This style defeats ftrans 
     214!     REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   putrdvor   ! u vorticity trend  
     215!     REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   pvtrdvor   ! v vorticity trend 
     216 
     217!FTRANS putrdvor pvtrdvor :I :I :z 
     218      REAL(wp), INTENT(inout) ::   putrdvor(jpi,jpj,jpk)   ! u vorticity trend  
     219      REAL(wp), INTENT(inout) ::   pvtrdvor(jpi,jpj,jpk)   ! v vorticity trend 
    208220      ! 
    209221      INTEGER ::   ji, jj, jk   ! dummy loop indices 
    … …  
    227239      !  ===================================== 
    228240      ! putrdvor and pvtrdvor terms 
     241#if defined key_z_first 
     242      DO jj = 1, jpj 
     243         DO ji = 1, jpi 
     244            DO jk = 1, jpk 
     245               zudpvor(ji,jj) = zudpvor(ji,jj) + putrdvor(ji,jj,jk) * fse3u(ji,jj,jk) * e1u(ji,jj) * umask(ji,jj,jk) 
     246               zvdpvor(ji,jj) = zvdpvor(ji,jj) + pvtrdvor(ji,jj,jk) * fse3v(ji,jj,jk) * e2v(ji,jj) * vmask(ji,jj,jk) 
     247            END DO 
     248         END DO 
     249      END DO 
     250#else 
    229251      DO jk = 1,jpk 
    230252        zudpvor(:,:) = zudpvor(:,:) + putrdvor(:,:,jk) * fse3u(:,:,jk) * e1u(:,:) * umask(:,:,jk) 
    231253        zvdpvor(:,:) = zvdpvor(:,:) + pvtrdvor(:,:,jk) * fse3v(:,:,jk) * e2v(:,:) * vmask(:,:,jk) 
    232254      END DO 
     255#endif 
    233256 
    234257      ! Save Beta.V term to avoid average before Curl 
    … …  
    280303   END SUBROUTINE trd_vor_zint_3d 
    281304 
     305   !! * Reset control of array index permutation 
     306!FTRANS CLEAR 
     307#  include "oce_ftrans.h90" 
     308#  include "dom_oce_ftrans.h90" 
     309#  include "zdf_oce_ftrans.h90" 
     310#  include "ldfdyn_oce_ftrans.h90" 
    282311 
    283312   SUBROUTINE trd_vor( kt ) 
    … …  
    327356       
    328357      ! Vertically averaged velocity 
     358#if defined key_z_first 
     359      DO jj = 1, jpj 
     360         DO ji = 1, jpi 
     361            DO jk = 1, jpk - 1 
     362               zun(ji,jj) = zun(ji,jj) + e1u(ji,jj) * un(ji,jj,jk) * fse3u(ji,jj,jk) 
     363               zvn(ji,jj) = zvn(ji,jj) + e2v(ji,jj) * vn(ji,jj,jk) * fse3v(ji,jj,jk) 
     364            END DO 
     365         END DO 
     366      END DO 
     367#else 
    329368      DO jk = 1, jpk - 1 
    330369         zun(:,:) = zun(:,:) + e1u(:,:) * un(:,:,jk) * fse3u(:,:,jk) 
    331370         zvn(:,:) = zvn(:,:) + e2v(:,:) * vn(:,:,jk) * fse3v(:,:,jk) 
    332371      END DO 
     372#endif 
    333373  
    334374      zun(:,:) = zun(:,:) * hur(:,:) 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/ZDF/zdf_oce.F90

    r2715 r3211  
    4040   REAL(wp), PUBLIC, SAVE, ALLOCATABLE, DIMENSION(:,:)   ::   avtb_2d        !: horizontal shape of background Kz profile 
    4141   REAL(wp), PUBLIC, SAVE, ALLOCATABLE, DIMENSION(:,:)   ::   bfrua, bfrva   !: Bottom friction coefficients set in zdfbfr 
    42    REAL(wp), PUBLIC, SAVE, ALLOCATABLE, DIMENSION(:,:,:) ::   avmu , avmv    !: vertical viscosity coef at uw- & vw-pts       [m2/s] 
    43    REAL(wp), PUBLIC, SAVE, ALLOCATABLE, DIMENSION(:,:,:) ::   avm  , avt     !: vertical viscosity & diffusivity coef at w-pt [m2/s] 
     42   REAL(wp), PUBLIC, SAVE, ALLOCATABLE, DIMENSION(:,:,:) ::   avmu , avmv    !: vertical viscosity coef at uw- & vw-pts 
     43   !                                                                         !       [m2/s] 
     44   REAL(wp), PUBLIC, SAVE, ALLOCATABLE, DIMENSION(:,:,:) ::   avm  , avt     !: vertical viscosity & diffusivity coef at w-pt 
     45   !                                                                         !       [m2/s] 
    4446  
     47   !! * Control permutation of array indices 
     48#  include "zdf_oce_ftrans.h90" 
     49 
    4550   !!---------------------------------------------------------------------- 
    4651   !! NEMO/OPA 4.0 , NEMO Consortium (2011) 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/ZDF/zdfbfr.F90

    r2715 r3211  
    3838    
    3939   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) ::  bfrcoef2d   ! 2D bottom drag coefficient 
     40 
     41   !! * Control permutation of array indices 
     42#  include "oce_ftrans.h90" 
     43#  include "dom_oce_ftrans.h90" 
     44#  include "zdf_oce_ftrans.h90" 
    4045 
    4146   !! * Substitutions 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/ZDF/zdfddm.F90

    r2715 r3211  
    3838   REAL(wp) ::   rn_avts  = 1.e-4_wp   ! maximum value of avs for salt fingering 
    3939   REAL(wp) ::   rn_hsbfr = 1.6_wp     ! heat/salt buoyancy flux ratio 
     40 
     41   !! * Control permutation of array indices 
     42#  include "zdfddm_ftrans.h90" 
     43#  include "oce_ftrans.h90" 
     44#  include "dom_oce_ftrans.h90" 
     45#  include "zdf_oce_ftrans.h90" 
    4046 
    4147   !! * Substitutions 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/ZDF/zdfevd.F90

    r2715 r3211  
    2828   PUBLIC   zdf_evd    ! called by step.F90 
    2929 
     30   !! * Control permutation of array indices 
     31#  include "oce_ftrans.h90" 
     32#  include "dom_oce_ftrans.h90" 
     33#  include "zdf_oce_ftrans.h90" 
     34 
    3035   !! * Substitutions 
    3136#  include "domzgr_substitute.h90" 
    … …  
    5358      !!---------------------------------------------------------------------- 
    5459      USE oce,   zavt_evd => ua , zavm_evd => va  ! (ua,va) used ua workspace 
     60 
     61      !! DCSE_NEMO: need additional directives for renamed module variables 
     62!FTRANS ua va :I :I :z 
     63 
    5564      ! 
    5665      INTEGER, INTENT( in ) ::   kt   ! ocean time-step indexocean time step 
    … …  
    7483         zavm_evd(:,:,:) = avm(:,:,:)           ! set avm prior to evd application 
    7584         ! 
     85#if defined key_z_first 
     86         DO jj = 2, jpj 
     87            DO ji = 2, jpi 
     88               DO jk = 1, jpkm1 
     89#else 
    7690         DO jk = 1, jpkm1  
    7791#if defined key_vectopt_loop 
    … …  
    8296               DO ji = 2, jpi 
    8397#endif 
     98#endif 
     99 
    84100#if defined key_zdfkpp 
    85101                  ! no evd mixing in the boundary layer with KPP 
    … …  
    105121         ! 
    106122      CASE DEFAULT         ! enhance vertical eddy diffusivity only (if rn2<-1.e-12)  
     123#if defined key_z_first 
     124         DO jj = 1, jpj 
     125            DO ji = 1, jpi 
     126               DO jk = 1, jpkm1 
     127#else 
    107128         DO jk = 1, jpkm1 
    108129!!!         WHERE( rn2(:,:,jk) <= -1.e-12 ) avt(:,:,jk) = tmask(:,:,jk) * avevd   ! agissant sur T SEUL!  
    … …  
    114135               DO ji = 1, jpi 
    115136#endif 
     137#endif 
     138 
    116139#if defined key_zdfkpp 
    117140                  ! no evd mixing in the boundary layer with KPP 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/ZDF/zdfgls.F90

    r2715 r3211  
    3939   LOGICAL , PUBLIC, PARAMETER ::   lk_zdfgls = .TRUE.   !: TKE vertical mixing flag 
    4040   ! 
    41    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   en      !: now turbulent kinetic energy 
    42    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   mxln    !: now mixing length 
    43    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   zwall   !: wall function 
    44    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   ustars2 !: Squared surface velocity scale at T-points 
    45    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   ustarb2 !: Squared bottom  velocity scale at T-points 
     41   !! DCSE_NEMO: does not need to be public 
     42!  REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   en      !: now turbulent kinetic energy 
     43   REAL(wp),         ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   en      !: now turbulent kinetic energy 
     44 
     45   !! DCSE_NEMO: does not need to be public 
     46!  REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   mxln    !: now mixing length 
     47   REAL(wp),         ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   mxln    !: now mixing length 
     48 
     49   !! DCSE_NEMO: does not need to be public 
     50!  REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   zwall   !: wall function 
     51   REAL(wp),         ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   zwall   !: wall function 
     52 
     53   !! DCSE_NEMO: does not need to be public 
     54!  REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   ustars2 !: Squared surface velocity scale at T-points 
     55   REAL(wp),         ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   ustars2 !: Squared surface velocity scale at T-points 
     56 
     57   !! DCSE_NEMO: does not need to be public 
     58!  REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   ustarb2 !: Squared bottom  velocity scale at T-points 
     59   REAL(wp),         ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   ustarb2 !: Squared bottom  velocity scale at T-points 
    4660 
    4761   !                                         !!! ** Namelist  namzdf_gls  ** 
    … …  
    102116   REAL(wp) ::   rpsi3m, rpsi3p, rpp, rmm, rnn                    !     -           -           -        - 
    103117 
     118   !! * Control permutation of array indices 
     119#  include "oce_ftrans.h90" 
     120#  include "dom_oce_ftrans.h90" 
     121#  include "domvvl_ftrans.h90" 
     122#  include "zdf_oce_ftrans.h90" 
     123#  include "sbc_oce_ftrans.h90" 
     124!! DCSE_NEMO: private module variables do not need their own directives file 
     125!FTRANS en mxln zwall :I :I :z 
     126 
    104127   !! * Substitutions 
    105128#  include "domzgr_substitute.h90" 
    … …  
    144167      USE wrk_nemo, ONLY: eps       => wrk_3d_4   ! dissipation rate 
    145168      USE wrk_nemo, ONLY: zwall_psi => wrk_3d_5   ! Wall function use in the wb case (ln_sigpsi.AND.ln_crban=T) 
     169 
     170      !! DCSE_NEMO: need additional directives for renamed module variables 
     171!FTRANS z_elem_a z_elem_b z_elem_c psi :I :I :z 
     172!FTRANS eb mxlb shear eps zwall_psi :I :I :z 
    146173      ! 
    147174      INTEGER, INTENT(in) ::   kt ! ocean time step 
    … …  
    169196            !  
    170197            ! surface friction  
     198#if defined key_z_first 
     199            ustars2(ji,jj) = rau0r * taum(ji,jj) * tmask_1(ji,jj) 
     200#else 
    171201            ustars2(ji,jj) = rau0r * taum(ji,jj) * tmask(ji,jj,1) 
     202#endif 
    172203            ! 
    173204            ! bottom friction (explicit before friction) 
    174205            ! Note that we chose here not to bound the friction as in dynbfr) 
     206#if defined key_z_first 
     207            ztx2 = (  bfrua(ji,jj)  * ub(ji,jj,mbku(ji,jj)) + bfrua(ji-1,jj) * ub(ji-1,jj,mbku(ji-1,jj))  )   & 
     208               & * ( 1._wp - 0.5_wp * umask_1(ji,jj) * umask_1(ji-1,jj)  ) 
     209            zty2 = (  bfrva(ji,jj)  * vb(ji,jj,mbkv(ji,jj)) + bfrva(ji,jj-1) * vb(ji,jj-1,mbkv(ji,jj-1))  )   & 
     210               & * ( 1._wp - 0.5_wp * vmask_1(ji,jj) * vmask_1(ji,jj-1)  ) 
     211            ustarb2(ji,jj) = SQRT( ztx2 * ztx2 + zty2 * zty2 ) * tmask_1(ji,jj) 
     212#else 
    175213            ztx2 = (  bfrua(ji,jj)  * ub(ji,jj,mbku(ji,jj)) + bfrua(ji-1,jj) * ub(ji-1,jj,mbku(ji-1,jj))  )   & 
    176214               & * ( 1._wp - 0.5_wp * umask(ji,jj,1) * umask(ji-1,jj,1)  ) 
    … …  
    178216               & * ( 1._wp - 0.5_wp * vmask(ji,jj,1) * vmask(ji,jj-1,1)  ) 
    179217            ustarb2(ji,jj) = SQRT( ztx2 * ztx2 + zty2 * zty2 ) * tmask(ji,jj,1) 
     218#endif 
    180219         END DO 
    181220      END DO   
    … …  
    188227 
    189228      ! Compute shear and dissipation rate 
     229#if defined key_z_first 
     230      DO jj = 2, jpjm1 
     231         DO ji = 2, jpim1 
     232            DO jk = 2, jpkm1 
     233#else 
    190234      DO jk = 2, jpkm1 
    191235         DO jj = 2, jpjm1 
    192236            DO ji = fs_2, fs_jpim1   ! vector opt. 
     237#endif 
    193238               avmu(ji,jj,jk) = avmu(ji,jj,jk) * ( un(ji,jj,jk-1) - un(ji,jj,jk) )   & 
    194239                  &                            * ( ub(ji,jj,jk-1) - ub(ji,jj,jk) )   & 
    … …  
    212257 
    213258      IF( nn_clos == 0 ) THEN    ! Mellor-Yamada 
     259#if defined key_z_first 
     260         DO jj = 2, jpjm1  
     261            DO ji = 2, jpim1 
     262               DO jk = 2, jpkm1 
     263#else 
    214264         DO jk = 2, jpkm1 
    215265            DO jj = 2, jpjm1  
    216266               DO ji = fs_2, fs_jpim1   ! vector opt. 
     267#endif 
    217268                  zup   = mxln(ji,jj,jk) * fsdepw(ji,jj,mbkt(ji,jj)+1) 
    218269                  zdown = vkarmn * fsdepw(ji,jj,jk) * ( -fsdepw(ji,jj,jk) + fsdepw(ji,jj,mbkt(ji,jj)+1) ) 
    … …  
    237288      ! Warning : after this step, en : right hand side of the matrix 
    238289 
     290#if defined key_z_first 
     291      DO jj = 2, jpjm1 
     292         DO ji = 2, jpim1 
     293            DO jk = 2, jpkm1 
     294#else 
    239295      DO jk = 2, jpkm1 
    240296         DO jj = 2, jpjm1 
    241297            DO ji = fs_2, fs_jpim1   ! vector opt. 
     298#endif 
    242299               ! 
    243300               ! shear prod. at w-point weightened by mask 
    … …  
    422479      ! ---------------------------------------------------------- 
    423480      ! 
     481#if defined key_z_first 
     482      DO jj = 2, jpjm1 
     483         DO ji = 2, jpim1 
     484            DO jk = 2, jpkm1                       ! First recurrence : Dk = Dk - Lk * Uk-1 / Dk-1 
     485#else 
    424486      DO jk = 2, jpkm1                             ! First recurrence : Dk = Dk - Lk * Uk-1 / Dk-1 
    425487         DO jj = 2, jpjm1 
    426488            DO ji = fs_2, fs_jpim1    ! vector opt. 
     489#endif 
    427490               z_elem_b(ji,jj,jk) = z_elem_b(ji,jj,jk) - z_elem_a(ji,jj,jk) * z_elem_c(ji,jj,jk-1) / z_elem_b(ji,jj,jk-1) 
    428491            END DO 
    429492         END DO 
    430493      END DO 
     494#if defined key_z_first 
     495      DO jj = 2, jpjm1 
     496         DO ji = 2, jpim1 
     497            DO jk = 2, jpk                         ! Second recurrence : Lk = RHSk - Lk / Dk-1 * Lk-1 
     498#else 
    431499      DO jk = 2, jpk                               ! Second recurrence : Lk = RHSk - Lk / Dk-1 * Lk-1 
    432500         DO jj = 2, jpjm1 
    433501            DO ji = fs_2, fs_jpim1    ! vector opt. 
     502#endif 
    434503               z_elem_a(ji,jj,jk) = en(ji,jj,jk) - z_elem_a(ji,jj,jk) / z_elem_b(ji,jj,jk-1) * z_elem_a(ji,jj,jk-1) 
    435504            END DO 
    436505         END DO 
    437506      END DO 
    438       DO jk = jpk-1, 2, -1                         ! thrid recurrence : Ek = ( Lk - Uk * Ek+1 ) / Dk 
     507#if defined key_z_first 
     508      DO jj = 2, jpjm1 
     509         DO ji = 2, jpim1 
     510            DO jk = jpk-1, 2, -1                   ! Third recurrence : Ek = ( Lk - Uk * Ek+1 ) / Dk 
     511#else 
     512      DO jk = jpk-1, 2, -1                         ! Third recurrence : Ek = ( Lk - Uk * Ek+1 ) / Dk 
    439513         DO jj = 2, jpjm1 
    440514            DO ji = fs_2, fs_jpim1    ! vector opt. 
     515#endif 
    441516               en(ji,jj,jk) = ( z_elem_a(ji,jj,jk) - z_elem_c(ji,jj,jk) * en(ji,jj,jk+1) ) / z_elem_b(ji,jj,jk) 
    442517            END DO 
    … …  
    455530      ! 
    456531      CASE( 0 )               ! k-kl  (Mellor-Yamada) 
     532#if defined key_z_first 
     533         DO jj = 2, jpjm1 
     534            DO ji = 2, jpim1 
     535               DO jk = 2, jpkm1 
     536#else 
    457537         DO jk = 2, jpkm1 
    458538            DO jj = 2, jpjm1 
    459539               DO ji = fs_2, fs_jpim1   ! vector opt. 
     540#endif 
    460541                  psi(ji,jj,jk)  = en(ji,jj,jk) * mxln(ji,jj,jk) 
    461542               END DO 
    … …  
    464545         ! 
    465546      CASE( 1 )               ! k-eps 
     547#if defined key_z_first 
     548         DO jj = 2, jpjm1 
     549            DO ji = 2, jpim1 
     550               DO jk = 2, jpkm1 
     551#else 
    466552         DO jk = 2, jpkm1 
    467553            DO jj = 2, jpjm1 
    468554               DO ji = fs_2, fs_jpim1   ! vector opt. 
     555#endif 
    469556                  psi(ji,jj,jk)  = eps(ji,jj,jk) 
    470557               END DO 
    … …  
    473560         ! 
    474561      CASE( 2 )               ! k-w 
     562#if defined key_z_first 
     563         DO jj = 2, jpjm1 
     564            DO ji = 2, jpim1 
     565               DO jk = 2, jpkm1 
     566#else 
    475567         DO jk = 2, jpkm1 
    476568            DO jj = 2, jpjm1 
    477569               DO ji = fs_2, fs_jpim1   ! vector opt. 
     570#endif 
    478571                  psi(ji,jj,jk)  = SQRT( en(ji,jj,jk) ) / ( rc0 * mxln(ji,jj,jk) ) 
    479572               END DO 
    … …  
    482575         ! 
    483576      CASE( 3 )               ! generic 
     577#if defined key_z_first 
     578         DO jj = 2, jpjm1 
     579            DO ji = 2, jpim1 
     580               DO jk = 2, jpkm1 
     581#else 
    484582         DO jk = 2, jpkm1 
    485583            DO jj = 2, jpjm1 
    486584               DO ji = fs_2, fs_jpim1   ! vector opt. 
     585#endif 
    487586                  psi(ji,jj,jk)  = rc02 * en(ji,jj,jk) * mxln(ji,jj,jk)**rnn  
    488587               END DO 
    … …  
    499598      ! Warning : after this step, en : right hand side of the matrix 
    500599 
     600#if defined key_z_first 
     601      DO jj = 2, jpjm1 
     602         DO ji = 2, jpim1 
     603            DO jk = 2, jpkm1 
     604#else 
    501605      DO jk = 2, jpkm1 
    502606         DO jj = 2, jpjm1 
    503607            DO ji = fs_2, fs_jpim1   ! vector opt. 
     608#endif 
    504609               ! 
    505610               ! psi / k 
    … …  
    556661            !                      ! balance between the production and the dissipation terms including the wave effect 
    557662            zdep(:,:) = rl_sf * zhsro(:,:) 
     663#if defined key_z_first 
     664            psi (:,:,1) = rc0**rpp * en(:,:,1)**rmm * zdep(:,:)**rnn * tmask_1(:,:) 
     665#else 
    558666            psi (:,:,1) = rc0**rpp * en(:,:,1)**rmm * zdep(:,:)**rnn * tmask(:,:,1) 
     667#endif 
    559668            z_elem_a(:,:,1) = psi(:,:,1) 
    560669            z_elem_c(:,:,1) = 0._wp 
    … …  
    565674            zex2 = (rmm*ra_sf) 
    566675            zdep(:,:) = ( (zhsro(:,:) + fsdepw(:,:,2))**zex1 ) / zhsro(:,:)**zex2 
     676#if defined key_z_first 
     677            psi (:,:,2) = rsbc_psi1 * ustars2(:,:)**rmm * zdep(:,:) * tmask_1(:,:) 
     678#else 
    567679            psi (:,:,2) = rsbc_psi1 * ustars2(:,:)**rmm * zdep(:,:) * tmask(:,:,1) 
     680#endif 
    568681            z_elem_a(:,:,2) = 0._wp 
    569682            z_elem_c(:,:,2) = 0._wp 
    … …  
    575688            ! 
    576689            zdep(:,:) = vkarmn * zhsro(:,:) 
     690#if defined key_z_first 
     691            psi (:,:,1) = rc0**rpp * en(:,:,1)**rmm * zdep(:,:)**rnn * tmask_1(:,:) 
     692#else 
    577693            psi (:,:,1) = rc0**rpp * en(:,:,1)**rmm * zdep(:,:)**rnn * tmask(:,:,1) 
     694#endif 
    578695            z_elem_a(:,:,1) = psi(:,:,1) 
    579696            z_elem_c(:,:,1) = 0._wp 
    … …  
    582699            ! one level below 
    583700            zdep(:,:) = vkarmn * ( zhsro(:,:) + fsdepw(:,:,2) ) 
     701#if defined key_z_first 
     702            psi (:,:,2) = rc0**rpp * en(:,:,1)**rmm * zdep(:,:)**rnn * tmask_1(:,:) 
     703#else 
    584704            psi (:,:,2) = rc0**rpp * en(:,:,1)**rmm * zdep(:,:)**rnn * tmask(:,:,1) 
     705#endif 
    585706            z_elem_a(:,:,2) = 0._wp 
    586707            z_elem_c(:,:,2) = 0._wp 
    … …  
    594715            ! 
    595716            zdep(:,:) = rl_sf * zhsro(:,:) 
     717#if defined key_z_first 
     718            psi (:,:,1) = rc0**rpp * en(:,:,1)**rmm * zdep(:,:)**rnn * tmask_1(:,:) 
     719#else 
    596720            psi (:,:,1) = rc0**rpp * en(:,:,1)**rmm * zdep(:,:)**rnn * tmask(:,:,1) 
     721#endif 
    597722            z_elem_a(:,:,1) = psi(:,:,1) 
    598723            z_elem_c(:,:,1) = 0._wp 
    … …  
    612737            ! 
    613738            zdep(:,:) = vkarmn * zhsro(:,:) 
     739#if defined key_z_first 
     740            psi (:,:,1) = rc0**rpp * en(:,:,1)**rmm * zdep(:,:)**rnn * tmask_1(:,:) 
     741#else 
    614742            psi (:,:,1) = rc0**rpp * en(:,:,1)**rmm * zdep(:,:)**rnn * tmask(:,:,1) 
     743#endif 
    615744            z_elem_a(:,:,1) = psi(:,:,1) 
    616745            z_elem_c(:,:,1) = 0._wp 
    … …  
    693822      ! ---------------- 
    694823      ! 
     824#if defined key_z_first 
     825      DO jj = 2, jpjm1 
     826         DO ji = 2, jpim1 
     827            DO jk = 2, jpkm1                       ! First recurrence : Dk = Dk - Lk * Uk-1 / Dk-1 
     828#else 
    695829      DO jk = 2, jpkm1                             ! First recurrence : Dk = Dk - Lk * Uk-1 / Dk-1 
    696830         DO jj = 2, jpjm1 
    697831            DO ji = fs_2, fs_jpim1    ! vector opt. 
     832#endif 
    698833               z_elem_b(ji,jj,jk) = z_elem_b(ji,jj,jk) - z_elem_a(ji,jj,jk) * z_elem_c(ji,jj,jk-1) / z_elem_b(ji,jj,jk-1) 
    699834            END DO 
    700835         END DO 
    701836      END DO 
     837#if defined key_z_first 
     838      DO jj = 2, jpjm1 
     839         DO ji = 2, jpim1 
     840            DO jk = 2, jpk                         ! Second recurrence : Lk = RHSk - Lk / Dk-1 * Lk-1 
     841#else 
    702842      DO jk = 2, jpk                               ! Second recurrence : Lk = RHSk - Lk / Dk-1 * Lk-1 
    703843         DO jj = 2, jpjm1 
    704844            DO ji = fs_2, fs_jpim1    ! vector opt. 
     845#endif 
    705846               z_elem_a(ji,jj,jk) = psi(ji,jj,jk) - z_elem_a(ji,jj,jk) / z_elem_b(ji,jj,jk-1) * z_elem_a(ji,jj,jk-1) 
    706847            END DO 
    707848         END DO 
    708849      END DO 
     850#if defined key_z_first 
     851      DO jj = 2, jpjm1 
     852         DO ji = 2, jpim1 
     853            DO jk = jpk-1, 2, -1                   ! Third recurrence : Ek = ( Lk - Uk * Ek+1 ) / Dk 
     854#else 
    709855      DO jk = jpk-1, 2, -1                         ! Third recurrence : Ek = ( Lk - Uk * Ek+1 ) / Dk 
    710856         DO jj = 2, jpjm1 
    711857            DO ji = fs_2, fs_jpim1    ! vector opt. 
     858#endif 
    712859               psi(ji,jj,jk) = ( z_elem_a(ji,jj,jk) - z_elem_c(ji,jj,jk) * psi(ji,jj,jk+1) ) / z_elem_b(ji,jj,jk) 
    713860            END DO 
    … …  
    721868      ! 
    722869      CASE( 0 )               ! k-kl  (Mellor-Yamada) 
     870#if defined key_z_first 
     871         DO jj = 2, jpjm1 
     872            DO ji = 2, jpim1 
     873               DO jk = 1, jpkm1 
     874#else 
    723875         DO jk = 1, jpkm1 
    724876            DO jj = 2, jpjm1 
    725877               DO ji = fs_2, fs_jpim1   ! vector opt. 
     878#endif 
    726879                  eps(ji,jj,jk) = rc03 * en(ji,jj,jk) * en(ji,jj,jk) * SQRT( en(ji,jj,jk) ) / psi(ji,jj,jk) 
    727880               END DO 
    … …  
    730883         ! 
    731884      CASE( 1 )               ! k-eps 
     885#if defined key_z_first 
     886         DO jj = 2, jpjm1 
     887            DO ji = 2, jpim1 
     888               DO jk = 1, jpkm1 
     889#else 
    732890         DO jk = 1, jpkm1 
    733891            DO jj = 2, jpjm1 
    734892               DO ji = fs_2, fs_jpim1   ! vector opt. 
     893#endif 
    735894                  eps(ji,jj,jk) = psi(ji,jj,jk) 
    736895               END DO 
    … …  
    739898         ! 
    740899      CASE( 2 )               ! k-w 
     900#if defined key_z_first 
     901         DO jj = 2, jpjm1 
     902            DO ji = 2, jpim1 
     903               DO jk = 1, jpkm1 
     904#else 
    741905         DO jk = 1, jpkm1 
    742906            DO jj = 2, jpjm1 
    743907               DO ji = fs_2, fs_jpim1   ! vector opt. 
     908#endif 
    744909                  eps(ji,jj,jk) = rc04 * en(ji,jj,jk) * psi(ji,jj,jk)  
    745910               END DO 
    … …  
    751916         zex1  =      ( 1.5_wp + rmm/rnn ) 
    752917         zex2  = -1._wp / rnn 
     918#if defined key_z_first 
     919         DO jj = 2, jpjm1 
     920            DO ji = 2, jpim1 
     921                DO jk = 1, jpkm1 
     922#else 
    753923         DO jk = 1, jpkm1 
    754924            DO jj = 2, jpjm1 
    755925               DO ji = fs_2, fs_jpim1   ! vector opt. 
     926#endif 
    756927                  eps(ji,jj,jk) = zcoef * en(ji,jj,jk)**zex1 * psi(ji,jj,jk)**zex2 
    757928               END DO 
    … …  
    763934      ! Limit dissipation rate under stable stratification 
    764935      ! -------------------------------------------------- 
     936#if defined key_z_first 
     937      DO jj = 2, jpjm1 
     938         DO ji = 2, jpim1 
     939            DO jk = 1, jpkm1 ! Note that this set boundary conditions on mxln at the same time 
     940#else 
    765941      DO jk = 1, jpkm1 ! Note that this set boundary conditions on mxln at the same time 
    766942         DO jj = 2, jpjm1 
    767943            DO ji = fs_2, fs_jpim1    ! vector opt. 
     944#endif 
    768945               ! limitation 
    769946               eps(ji,jj,jk)  = MAX( eps(ji,jj,jk), rn_epsmin ) 
    … …  
    783960      ! 
    784961      CASE ( 0 , 1 )             ! Galperin or Kantha-Clayson stability functions 
     962#if defined key_z_first 
     963         DO jj = 2, jpjm1 
     964            DO ji = 2, jpim1 
     965               DO jk = 2, jpkm1 
     966#else 
    785967         DO jk = 2, jpkm1 
    786968            DO jj = 2, jpjm1 
    787969               DO ji = fs_2, fs_jpim1   ! vector opt. 
     970#endif 
    788971                  ! zcof =  l²/q² 
    789972                  zcof = mxlb(ji,jj,jk) * mxlb(ji,jj,jk) / ( 2._wp*eb(ji,jj,jk) ) 
    … …  
    804987         ! 
    805988      CASE ( 2, 3 )               ! Canuto stability functions 
     989#if defined key_z_first 
     990         DO jj = 2, jpjm1 
     991            DO ji = 2, jpim1 
     992               DO jk = 2, jpkm1 
     993#else 
    806994         DO jk = 2, jpkm1 
    807995            DO jj = 2, jpjm1 
    808996               DO ji = fs_2, fs_jpim1   ! vector opt. 
     997#endif 
    809998                  ! zcof =  l²/q² 
    810999                  zcof = mxlb(ji,jj,jk)*mxlb(ji,jj,jk) / ( 2._wp * eb(ji,jj,jk) ) 
    … …  
    8501039      ! Compute diffusivities/viscosities 
    8511040      ! The computation below could be restrained to jk=2 to jpkm1 if GOTM style Dirichlet conditions are used 
     1041#if defined key_z_first 
     1042      DO jj = 2, jpjm1 
     1043         DO ji = 2, jpim1 
     1044            DO jk = 1, jpk 
     1045#else 
     1046      DO jk = 1, jpk 
     1047         DO jj = 2, jpjm1 
     1048            DO ji = fs_2, fs_jpim1   ! vector opt. 
     1049#endif 
    8521050      DO jk = 1, jpk 
    8531051         DO jj = 2, jpjm1 
    … …  
    8661064      CALL lbc_lnk( avm, 'W', 1. )   ;   CALL lbc_lnk( avt, 'W', 1. ) 
    8671065 
     1066#if defined key_z_first 
     1067      DO jj = 2, jpjm1 
     1068         DO ji = 2, jpim1 
     1069            DO jk = 2, jpkm1      !* vertical eddy viscosity at u- and v-points 
     1070#else 
    8681071      DO jk = 2, jpkm1            !* vertical eddy viscosity at u- and v-points 
    8691072         DO jj = 2, jpjm1 
    8701073            DO ji = fs_2, fs_jpim1   ! vector opt. 
     1074#endif 
    8711075               avmu(ji,jj,jk) = 0.5 * ( avm(ji,jj,jk) + avm(ji+1,jj  ,jk) ) * umask(ji,jj,jk) 
    8721076               avmv(ji,jj,jk) = 0.5 * ( avm(ji,jj,jk) + avm(ji  ,jj+1,jk) ) * vmask(ji,jj,jk) 
    … …  
    8871091      ! 
    8881092   END SUBROUTINE zdf_gls 
    889  
     1093       
     1094   !! * Reset control of array index permutation 
     1095!FTRANS CLEAR 
     1096#  include "oce_ftrans.h90" 
     1097#  include "dom_oce_ftrans.h90" 
     1098#  include "domvvl_ftrans.h90" 
     1099#  include "zdf_oce_ftrans.h90" 
     1100#  include "sbc_oce_ftrans.h90" 
     1101!! DCSE_NEMO: private module variables do not need their own directives file 
     1102!FTRANS en mxln zwall :I :I :z 
    8901103 
    8911104   SUBROUTINE zdf_gls_init 
    … …  
    9071120      USE trazdf_exp 
    9081121      ! 
    909       INTEGER ::   jk    ! dummy loop indices 
    910       REAL(wp)::   zcr   ! local scalar 
     1122      INTEGER ::   ji, jj, jk    ! dummy loop indices 
     1123      REAL(wp)::   zcr           ! local scalar 
    9111124      !! 
    9121125      NAMELIST/namzdf_gls/rn_emin, rn_epsmin, ln_length_lim, & 
    … …  
    11751388 
    11761389      !                                !* set vertical eddy coef. to the background value 
     1390#if defined key_z_first 
     1391      DO jj = 1, jpj 
     1392         DO ji = 1, jpi 
     1393            DO jk = 1, jpk 
     1394               avt (ji,jj,jk) = avtb(jk) * tmask(ji,jj,jk) 
     1395               avm (ji,jj,jk) = avmb(jk) * tmask(ji,jj,jk) 
     1396               avmu(ji,jj,jk) = avmb(jk) * umask(ji,jj,jk) 
     1397               avmv(ji,jj,jk) = avmb(jk) * vmask(ji,jj,jk) 
     1398            END DO 
     1399         END DO 
     1400      END DO 
     1401#else 
    11771402      DO jk = 1, jpk 
    11781403         avt (:,:,jk) = avtb(jk) * tmask(:,:,jk) 
    … …  
    11811406         avmv(:,:,jk) = avmb(jk) * vmask(:,:,jk) 
    11821407      END DO 
     1408#endif 
    11831409      !                               
    11841410      CALL gls_rst( nit000, 'READ' )   !* read or initialize all required files 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/ZDF/zdfini.F90

    r2715 r3211  
    3636   PUBLIC   zdf_init   ! routine called by opa.F90 
    3737    
     38   !! * Control permutation of array indices 
     39#  include "ldftra_oce_ftrans.h90" 
     40#  include "ldfdyn_oce_ftrans.h90" 
     41#  include "zdf_oce_ftrans.h90" 
     42#  include "zdftke_ftrans.h90" 
     43#  include "zdfddm_ftrans.h90" 
     44#  include "ldfslp_ftrans.h90" 
     45 
    3846   !!---------------------------------------------------------------------- 
    3947   !! NEMO/OPA 4.0 , NEMO Consortium (2011) 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/ZDF/zdfkpp.F90

    r2715 r3211  
    4444   LOGICAL , PUBLIC, PARAMETER ::   lk_zdfkpp = .TRUE.    !: KPP vertical mixing flag 
    4545 
    46    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   ghats    !: non-local scalar mixing term (gamma/<ws>o) 
     46   !! DCSE_NEMO: ghats does not need to be public 
     47!  REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   ghats    !: non-local scalar mixing term (gamma/<ws>o) 
     48   REAL(wp),         ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   ghats    !: non-local scalar mixing term (gamma/<ws>o) 
     49 
    4750   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   wt0      !: surface temperature flux for non local flux 
    4851   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   ws0      !: surface salinity flux for non local flux 
    … …  
    130133         
    131134#if defined key_c1d 
    132    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   rig    !: gradient Richardson number 
    133    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   rib    !: bulk Richardson number 
    134    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   buof   !: buoyancy forcing 
    135    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   mols   !: moning-Obukhov length scale  
    136    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   ekdp   !: Ekman depth 
     135!! DCSE_NEMO: these arrays do not need to be public 
     136!  REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   rig    !: gradient Richardson number 
     137!  REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   rib    !: bulk Richardson number 
     138!  REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   buof   !: buoyancy forcing 
     139!  REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   mols   !: moning-Obukhov length scale  
     140!  REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   ekdp   !: Ekman depth 
     141   REAL(wp),         ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   rig    !: gradient Richardson number 
     142   REAL(wp),         ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   rib    !: bulk Richardson number 
     143   REAL(wp),         ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   buof   !: buoyancy forcing 
     144   REAL(wp),         ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   mols   !: moning-Obukhov length scale  
     145   REAL(wp),         ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   ekdp   !: Ekman depth 
    137146#endif 
    138147 
    139148   INTEGER  ::   jip = 62 , jjp = 111 
     149 
     150   !! * Control permutation of array indices 
     151#  include "oce_ftrans.h90" 
     152#  include "dom_oce_ftrans.h90" 
     153#  include "zdf_oce_ftrans.h90" 
     154#  include "sbc_oce_ftrans.h90" 
     155#  include "zdfddm_ftrans.h90" 
     156!FTRANS ghats :I :I :z 
     157!FTRANS etmean eumean evmean :I :I :z 
     158#if defined key_c1d 
     159!FTRANS rig rib buof mols :I :I :z 
     160#endif 
    140161 
    141162   !! * Substitutions 
    142163#  include "domzgr_substitute.h90" 
    143164#  include "vectopt_loop_substitute.h90" 
    144 #  include  "zdfddm_substitute.h90" 
     165#  include "zdfddm_substitute.h90" 
    145166   !!---------------------------------------------------------------------- 
    146167   !! NEMO/OPA 4.0 , NEMO Consortium (2011) 
    … …  
    210231      USE oce     , zdiffut => ta   ! temp. array for diffusivities use sa as workspace 
    211232      USE oce     , zdiffus => sa   ! temp. array for diffusivities use sa as workspace 
     233!FTRANS zviscos zdiffut zdiffus :I :I :z 
    212234#else 
    213235      USE oce     , zviscos => ua   ! temp. array for viscosities use ua as workspace 
    214236      USE oce     , zdiffut => ta   ! temp. array for diffusivities use sa as workspace 
     237!FTRANS zviscos zdiffut :I :I :z 
    215238#endif 
    216239      USE wrk_nemo, ONLY: wrk_in_use, wrk_not_released, wrk_in_use_xz, wrk_not_released_xz 
    … …  
    228251      USE wrk_nemo, ONLY: zblcm => wrk_xz_1, &   ! Boundary layer  
    229252                          zblct => wrk_xz_2      !  diffusivities/viscosities 
     253 
     254      !! DCSE_NEMO: check that wrk_xz_* arrays are being used consistently 
     255!FTRANS zblcm zblct :I :z 
    230256#if defined key_zdfddm 
    231257      USE wrk_nemo, ONLY: zblcs => wrk_xz_3 
     258!FTRANS zblcs :I :z 
    232259#endif 
    233260      !! 
    … …  
    323350      ! I. Interior diffusivity and viscosity at w points ( T interfaces) 
    324351      !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<   
     352#if defined key_z_first 
     353      DO jj = 2, jpjm1 
     354         DO ji = 2, jpim1  
     355            DO jk = 2, jpkm1 
     356#else 
    325357      DO jk = 2, jpkm1 
    326358         DO jj = 2, jpjm1 
    327359            DO ji = fs_2, fs_jpim1  
     360#endif 
    328361               ! Mixing due to internal waves breaking 
    329362               ! ------------------------------------- 
    … …  
    523556         ! Compute the pipe 
    524557         ! --------------------- 
     558 
     559         !! DCSE_NEMO: is it safe to change the order of these loops? 
    525560         DO jk = 2, jpkm1 
    526561            DO ji = fs_2, fs_jpim1 
    … …  
    11351170         CASE ( 0 )             ! no viscosity and diffusivity smoothing 
    11361171 
     1172#if defined key_z_first 
     1173            DO jj = 2, jpjm1 
     1174               DO ji = 2, jpim1 
     1175                  DO jk = 2, jpkm1 
     1176#else 
    11371177            DO jk = 2, jpkm1 
    11381178               DO jj = 2, jpjm1 
    11391179                  DO ji = fs_2, fs_jpim1 
     1180#endif 
    11401181                     avmu(ji,jj,jk) = ( zviscos(ji,jj,jk) + zviscos(ji+1,jj,jk) ) & 
    11411182                        &  / MAX( 1., tmask(ji,jj,jk) + tmask (ji + 1,jj,jk) ) * umask(ji,jj,jk) 
    … …  
    11581199            !           ( 1/2  1  1/2 )              ( 1/2  1/2 ) 
    11591200   
     1201#if defined key_z_first 
     1202            DO jj = 2, jpjm1 
     1203               DO ji = 2, jpim1 
     1204                  DO jk = 2, jpkm1 
     1205#else 
    11601206            DO jk = 2, jpkm1 
    11611207               DO jj = 2, jpjm1 
    11621208                  DO ji = fs_2, fs_jpim1 
     1209#endif 
    11631210 
    11641211                     avmu(ji,jj,jk) = (      zviscos(ji  ,jj  ,jk) + zviscos(ji+1,jj  ,jk)   & 
    … …  
    11881235         END SELECT 
    11891236 
     1237#if defined key_z_first 
     1238         ! 
     1239         !  Minimum value on the eddy diffusivity 
     1240         ! ---------------------------------------- 
     1241         DO jj = 2, jpjm1 
     1242            DO ji = 2, jpim1 
     1243               DO jk = 2, jpkm1 
     1244                  avt(ji,jj,jk) = MAX( avt(ji,jj,jk), avtb(jk) ) * tmask(ji,jj,jk) 
     1245#if defined key_zdfddm   
     1246                  avs(ji,jj,jk) = MAX( avs(ji,jj,jk), avtb(jk) ) * tmask(ji,jj,jk) 
     1247#endif 
     1248               END DO 
     1249            END DO 
     1250         END DO 
     1251         ! 
     1252         ! Minimum value on the eddy viscosity 
     1253         ! ---------------------------------------- 
     1254         DO jj = 1, jpj 
     1255            DO ji = 1, jpi 
     1256               DO jk = 2, jpkm1 
     1257                  avmu(ji,jj,jk) = MAX( avmu(ji,jj,jk), avmb(jk) ) * umask(ji,jj,jk) 
     1258                  avmv(ji,jj,jk) = MAX( avmv(ji,jj,jk), avmb(jk) ) * vmask(ji,jj,jk) 
     1259               END DO 
     1260            END DO 
     1261         END DO 
     1262#else 
    11901263         DO jk = 2, jpkm1                       ! vertical slab 
    11911264            ! 
    … …  
    12121285            ! 
    12131286         END DO 
     1287#endif 
    12141288 
    12151289         ! Lateral boundary conditions on avt  (sign unchanged) 
    … …  
    12411315   END SUBROUTINE zdf_kpp 
    12421316 
     1317   !! * Reset control of array index permutation 
     1318#  include "oce_ftrans.h90" 
     1319#  include "dom_oce_ftrans.h90" 
     1320#  include "zdf_oce_ftrans.h90" 
     1321#  include "sbc_oce_ftrans.h90" 
     1322#  include "zdfddm_ftrans.h90" 
     1323!FTRANS ghats :I :I :z 
     1324!FTRANS etmean eumean evmean :I :I :z 
     1325#if defined key_c1d 
     1326!FTRANS rig rib buof mols :I :I :z 
     1327#endif 
    12431328 
    12441329   SUBROUTINE tra_kpp( kt ) 
    … …  
    12521337      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::   ztrdt, ztrds   ! 3D workspace 
    12531338      !!---------------------------------------------------------------------- 
     1339!FTRANS ztrdt ztrds :I :I :z 
    12541340      INTEGER, INTENT(in) :: kt 
    12551341      INTEGER :: ji, jj, jk 
    … …  
    12671353 
    12681354      ! add non-local temperature and salinity flux ( in convective case only) 
     1355#if defined key_z_first 
     1356      DO jj = 2, jpjm1  
     1357         DO ji = 2, jpim1 
     1358            DO jk = 1, jpkm1 
     1359#else 
    12691360      DO jk = 1, jpkm1 
    12701361         DO jj = 2, jpjm1  
    12711362            DO ji = fs_2, fs_jpim1 
     1363#endif 
    12721364               tsa(ji,jj,jk,jp_tem) =  tsa(ji,jj,jk,jp_tem)                      & 
    12731365                  &                 - (  ghats(ji,jj,jk  ) * avt  (ji,jj,jk  )   &  
    … …  
    12981390 
    12991391#if defined key_top 
     1392 
     1393   !! * Reset control of array index permutation 
     1394#  include "oce_ftrans.h90" 
     1395#  include "dom_oce_ftrans.h90" 
     1396#  include "zdf_oce_ftrans.h90" 
     1397#  include "sbc_oce_ftrans.h90" 
     1398#  include "zdfddm_ftrans.h90" 
     1399!FTRANS ghats :I :I :z 
     1400!FTRANS etmean eumean evmean :I :I :z 
     1401#if defined key_c1d 
     1402!FTRANS rig rib buof mols :I :I :z 
     1403#endif 
     1404 
    13001405   !!---------------------------------------------------------------------- 
    13011406   !!   'key_top'                                                TOP models 
    … …  
    13221427      REAL(wp) ::   ztra, zflx 
    13231428      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::   ztrtrd 
     1429!FTRANS ztrtrd :I :I :z 
    13241430      !!---------------------------------------------------------------------- 
    13251431 
    … …  
    13361442         IF( l_trdtrc )  ztrtrd(:,:,:)  = tra(:,:,:,jn) 
    13371443         ! add non-local on passive tracer flux ( in convective case only) 
     1444#if defined key_z_first 
     1445         DO jj = 2, jpjm1  
     1446            DO ji = 2, jpim1 
     1447               DO jk = 1, jpkm1 
     1448#else 
    13381449         DO jk = 1, jpkm1 
    13391450            DO jj = 2, jpjm1  
    13401451               DO ji = fs_2, fs_jpim1 
     1452#endif 
    13411453                  ! Surface tracer flux for non-local term  
    13421454                  zflx = - ( emps(ji,jj) * tra(ji,jj,1,jn) * rcs ) * tmask(ji,jj,1) 
    … …  
    13721484#endif 
    13731485 
     1486   !! * Reset control of array index permutation 
     1487#  include "oce_ftrans.h90" 
     1488#  include "dom_oce_ftrans.h90" 
     1489#  include "zdf_oce_ftrans.h90" 
     1490#  include "sbc_oce_ftrans.h90" 
     1491#  include "zdfddm_ftrans.h90" 
     1492!FTRANS ghats :I :I :z 
     1493!FTRANS etmean eumean evmean :I :I :z 
     1494#if defined key_c1d 
     1495!FTRANS rig rib buof mols :I :I :z 
     1496#endif 
     1497 
     1498 
    13741499   SUBROUTINE zdf_kpp_init 
    13751500      !!---------------------------------------------------------------------- 
    … …  
    14771602         evmean(:,:,:) = 0.e0 
    14781603          
     1604#if defined key_z_first 
     1605         DO jj = 2, jpjm1 
     1606            DO ji = 2, jpim1 
     1607               DO jk = 1, jpkm1 
     1608#else 
    14791609         DO jk = 1, jpkm1 
    14801610            DO jj = 2, jpjm1 
    1481                DO ji = 2, jpim1   ! vector opt. 
     1611               DO ji = 2, jpim1 
     1612#endif 
    14821613                  etmean(ji,jj,jk) = tmask(ji,jj,jk)                     & 
    14831614                  &  / MAX( 1.,  umask(ji-1,jj  ,jk) + umask(ji,jj,jk)   & 
    … …  
    15031634         evmean(:,:,:) = 0.e0 
    15041635          
     1636#if defined key_z_first 
     1637         DO jj = 2, jpjm1 
     1638            DO ji = 2, jpim1 
     1639               DO jk = 1, jpkm1 
     1640#else 
    15051641         DO jk = 1, jpkm1 
    15061642            DO jj = 2, jpjm1 
    15071643               DO ji = fs_2, fs_jpim1   ! vector opt. 
     1644#endif 
    15081645                  etmean(ji,jj,jk) = tmask(ji, jj,jk)                           & 
    15091646                     & / MAX( 1., 2.* tmask(ji,jj,jk)                           & 
    … …  
    15341671      ! Initialization of vertical eddy coef. to the background value 
    15351672      ! ------------------------------------------------------------- 
     1673#if defined key_z_first 
     1674      DO jj = 1, jpj 
     1675         DO ji = 1, jpi 
     1676            avt (ji,jj,:) = avtb(:) * tmask(ji,jj,:) 
     1677            avmu(ji,jj,:) = avmb(:) * umask(ji,jj,:) 
     1678            avmv(ji,jj,:) = avmb(:) * vmask(ji,jj,:) 
     1679         END DO 
     1680      END DO 
     1681#else 
    15361682      DO jk = 1, jpk 
    15371683         avt (:,:,jk) = avtb(jk) * tmask(:,:,jk) 
    … …  
    15391685         avmv(:,:,jk) = avmb(jk) * vmask(:,:,jk) 
    15401686      END DO 
     1687#endif 
    15411688 
    15421689      ! zero the surface flux for non local term and kpp mixed layer depth 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/ZDF/zdfmxl.F90

    r2715 r3211  
    2626   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hmlp    !: mixed layer depth  (rho=rho0+zdcrit) [m] 
    2727   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hmlpt   !: mixed layer depth at t-points        [m] 
     28 
     29   !! * Control permutation of array indices 
     30#  include "oce_ftrans.h90" 
     31#  include "dom_oce_ftrans.h90" 
     32#  include "zdf_oce_ftrans.h90" 
    2833 
    2934   !! * Substitutions 
    … …  
    9095      nmln(:,:) = mbkt(:,:) + 1        ! Initialization to the number of w ocean point 
    9196      imld(:,:) = mbkt(:,:) + 1 
     97#if defined key_z_first 
     98      DO jj = 1, jpj 
     99         DO ji = 1, jpi 
     100            DO jk = jpkm1, nlb10, -1   ! from the bottom to nlb10 
     101#else 
    92102      DO jk = jpkm1, nlb10, -1         ! from the bottom to nlb10 
    93103         DO jj = 1, jpj 
    94104            DO ji = 1, jpi 
     105#endif 
    95106               IF( rhop(ji,jj,jk) > rhop(ji,jj,nla10) + zrho_c )   nmln(ji,jj) = jk      ! Mixed layer 
    96107               IF( avt (ji,jj,jk) < zavt_c                     )   imld(ji,jj) = jk      ! Turbocline  
    … …  
    103114            iiki = imld(ji,jj) 
    104115            iikn = nmln(ji,jj) 
     116#if defined key_z_first 
     117            hmld (ji,jj) = fsdepw(ji,jj,iiki  ) * tmask_1(ji,jj)    ! Turbocline depth  
     118            hmlp (ji,jj) = fsdepw(ji,jj,iikn  ) * tmask_1(ji,jj)    ! Mixed layer depth 
     119#else 
    105120            hmld (ji,jj) = fsdepw(ji,jj,iiki  ) * tmask(ji,jj,1)    ! Turbocline depth  
    106121            hmlp (ji,jj) = fsdepw(ji,jj,iikn  ) * tmask(ji,jj,1)    ! Mixed layer depth 
     122#endif 
    107123            hmlpt(ji,jj) = fsdept(ji,jj,iikn-1)                     ! depth of the last T-point inside the mixed layer 
    108124         END DO 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/ZDF/zdfric.F90

    r2715 r3211  
    4141 
    4242   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   tmric   !: coef. for the horizontal mean at t-point 
     43 
     44   !! * Control permutation of array indices 
     45#  include "oce_ftrans.h90" 
     46#  include "dom_oce_ftrans.h90" 
     47#  include "zdf_oce_ftrans.h90" 
     48!FTRANS tmric :I :I :z 
    4349 
    4450   !! * Substitutions 
    … …  
    101107         CALL ctl_stop('zdf_ric : requested workspace array unavailable')   ;   RETURN 
    102108      ENDIF 
     109 
     110      !! DCSE_NEMO: To optimise this loop for z_first indexing, make zwx 3-dimensional 
     111 
    103112      !                                                ! =============== 
    104113      DO jk = 2, jpkm1                                 ! Horizontal slab 
    … …  
    187196      IF( zdf_ric_alloc() /= 0 )   CALL ctl_stop( 'STOP', 'zdf_ric_init : unable to allocate arrays' ) 
    188197      ! 
     198#if defined key_z_first 
     199      DO jj = 2, jpj  
     200         DO ji = 2, jpi 
     201            DO jk = 1, jpk 
     202#else 
    189203      DO jk = 1, jpk                 ! weighting mean array tmric for 4 T-points 
    190204         DO jj = 2, jpj              ! which accounts for coastal boundary conditions             
    191205            DO ji = 2, jpi 
     206#endif 
    192207               tmric(ji,jj,jk) =  tmask(ji,jj,jk)                                  & 
    193208                  &            / MAX( 1.,  umask(ji-1,jj  ,jk) + umask(ji,jj,jk)   & 
    … …  
    198213      tmric(:,1,:) = 0._wp 
    199214      ! 
     215#if defined key_z_first 
     216      DO jj = 1, jpj 
     217         DO ji = 1, jpi 
     218            DO jk = 1, jpk           ! Initialization of vertical eddy coef. to the background value 
     219               avt (ji,jj,jk) = avtb(jk) * tmask(ji,jj,jk) 
     220               avmu(ji,jj,jk) = avmb(jk) * umask(ji,jj,jk) 
     221               avmv(ji,jj,jk) = avmb(jk) * vmask(ji,jj,jk) 
     222            END DO 
     223         END DO 
     224      END DO 
     225#else 
    200226      DO jk = 1, jpk                 ! Initialization of vertical eddy coef. to the background value 
    201227         avt (:,:,jk) = avtb(jk) * tmask(:,:,jk) 
    … …  
    203229         avmv(:,:,jk) = avmb(jk) * vmask(:,:,jk) 
    204230      END DO 
     231#endif 
    205232      ! 
    206233   END SUBROUTINE zdf_ric_init 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/ZDF/zdftke.F90

    r2715 r3211  
    8282   REAL(wp) ::   rhftau_scl = 1.0_wp       ! scale factor applied to HF part of taum  (nn_etau=3) 
    8383 
     84   !! DCSE_NEMO: en is public because it is used by asmtrj 
    8485   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   en             !: now turbulent kinetic energy   [m2/s2] 
    8586   REAL(wp)        , ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   htau           ! depth of tke penetration (nn_htau) 
    86    REAL(wp)        , ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   dissl          ! now mixing lenght of dissipation 
     87   REAL(wp)        , ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   dissl          ! now mixing length of dissipation 
    8788#if defined key_c1d 
    8889   !                                                                        !!** 1D cfg only  **   ('key_c1d') 
    89    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   e_dis, e_mix   !: dissipation and mixing turbulent lengh scales 
    90    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   e_pdl, e_ric   !: prandl and local Richardson numbers 
    91 #endif 
     90   !! DCSE_NEMO: these arrays do not need to be public 
     91!  REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   e_dis, e_mix   !: dissipation and mixing turbulent length scales 
     92!  REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   e_pdl, e_ric   !: prandl and local Richardson numbers 
     93   REAL(wp),         ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   e_dis, e_mix   !: dissipation and mixing turbulent length scales 
     94   REAL(wp),         ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   e_pdl, e_ric   !: prandl and local Richardson numbers 
     95#endif 
     96 
     97   !! * Control permutation of array indices 
     98#  include "zdftke_ftrans.h90" 
     99#  include "oce_ftrans.h90" 
     100#  include "dom_oce_ftrans.h90" 
     101#  include "domvvl_ftrans.h90" 
     102#  include "sbc_oce_ftrans.h90" 
     103#  include "zdf_oce_ftrans.h90" 
     104!FTRANS dissl e_dis e_mix e_pdl e_ric :I :I :z 
    92105 
    93106   !! * Substitutions 
    … …  
    195208      USE wrk_nemo, ONLY:   zhlc  =>  wrk_2d_1   ! 2D REAL workspace 
    196209      USE wrk_nemo, ONLY:   zpelc =>  wrk_3d_1   ! 3D REAL workspace 
     210 
     211      !! DCSE_NEMO: need additional directives for renamed module variables 
     212!FTRANS zdiag zd_up zd_lw :I :I :z 
     213!FTRANS zpelc :I :I :z 
    197214      ! 
    198215      INTEGER  ::   ji, jj, jk                      ! dummy loop arguments 
    … …  
    226243      DO jj = 2, jpjm1            ! en(1)   = rn_ebb taum / rau0  (min value rn_emin0) 
    227244         DO ji = fs_2, fs_jpim1   ! vector opt. 
     245#if defined key_z_first 
     246            en(ji,jj,1) = MAX( rn_emin0, zbbrau * taum(ji,jj) ) * tmask_1(ji,jj) 
     247#else 
    228248            en(ji,jj,1) = MAX( rn_emin0, zbbrau * taum(ji,jj) ) * tmask(ji,jj,1) 
     249#endif 
    229250         END DO 
    230251      END DO 
    … …  
    260281         ! 
    261282         !                        !* total energy produce by LC : cumulative sum over jk 
     283#if defined key_z_first 
     284         DO jj = 1, jpj 
     285            DO ji = 1, jpi 
     286               zpelc(ji,jj,1) =  MAX( rn2b(ji,jj,1), 0._wp ) * fsdepw(ji,jj,1) * fse3w(ji,jj,1) 
     287               DO jk = 2, jpk 
     288                  zpelc(ji,jj,jk)  = zpelc(ji,jj,jk-1) + MAX( rn2b(ji,jj,jk), 0._wp ) * fsdepw(ji,jj,jk) * fse3w(ji,jj,jk) 
     289               END DO 
     290            END DO 
     291         END DO 
     292#else 
    262293         zpelc(:,:,1) =  MAX( rn2b(:,:,1), 0._wp ) * fsdepw(:,:,1) * fse3w(:,:,1) 
    263294         DO jk = 2, jpk 
    264295            zpelc(:,:,jk)  = zpelc(:,:,jk-1) + MAX( rn2b(:,:,jk), 0._wp ) * fsdepw(:,:,jk) * fse3w(:,:,jk) 
    265296         END DO 
     297#endif 
    266298         !                        !* finite Langmuir Circulation depth 
    267299         zcof = 0.5 * 0.016 * 0.016 / ( zrhoa * zcdrag ) 
    268300         imlc(:,:) = mbkt(:,:) + 1       ! Initialization to the number of w ocean point (=2 over land) 
     301#if defined key_z_first 
     302         DO jj = 1, jpj                  ! Last w-level at which zpelc>=0.5*us*us  
     303            DO ji = 1, jpi               !      with us=0.016*wind(starting from jpk-1) 
     304               zus  = zcof * taum(ji,jj) 
     305               DO jk = jpkm1, 2, -1 
     306#else 
    269307         DO jk = jpkm1, 2, -1 
    270308            DO jj = 1, jpj               ! Last w-level at which zpelc>=0.5*us*us  
    271309               DO ji = 1, jpi            !      with us=0.016*wind(starting from jpk-1) 
    272310                  zus  = zcof * taum(ji,jj) 
     311#endif 
    273312                  IF( zpelc(ji,jj,jk) > zus )   imlc(ji,jj) = jk 
    274313               END DO 
    … …  
    287326         END DO 
    288327         zcof = 0.016 / SQRT( zrhoa * zcdrag ) 
     328#if defined key_z_first 
     329         DO jj = 2, jpjm1         !* TKE Langmuir circulation source term added to en 
     330            DO ji = 2, jpim1 
     331               zus  = zcof * SQRT( taum(ji,jj) )           ! Stokes drift 
     332               DO jk = 2, jpkm1 
     333#else 
    289334!CDIR NOVERRCHK 
    290335         DO jk = 2, jpkm1         !* TKE Langmuir circulation source term added to en 
    … …  
    294339               DO ji = fs_2, fs_jpim1   ! vector opt. 
    295340                  zus  = zcof * SQRT( taum(ji,jj) )           ! Stokes drift 
     341#endif 
    296342                  !                                           ! vertical velocity due to LC 
    297343                  zind = 0.5 - SIGN( 0.5, fsdepw(ji,jj,jk) - zhlc(ji,jj) ) 
    … …  
    312358      !                     ! zdiag : diagonal zd_up : upper diagonal zd_lw : lower diagonal 
    313359      ! 
     360#if defined key_z_first 
     361      !* Shear production at uw- and vw-points (energy conserving form) 
     362             ! here avmu, avmv used as workspace 
     363      DO jj = 1, jpj 
     364         DO ji = 1, jpi 
     365            DO jk = 2, jpkm1 
     366#else 
    314367      DO jk = 2, jpkm1           !* Shear production at uw- and vw-points (energy conserving form) 
    315368         DO jj = 1, jpj                 ! here avmu, avmv used as workspace 
    316369            DO ji = 1, jpi 
     370#endif 
    317371               avmu(ji,jj,jk) = avmu(ji,jj,jk) * ( un(ji,jj,jk-1) - un(ji,jj,jk) )   & 
    318372                  &                            * ( ub(ji,jj,jk-1) - ub(ji,jj,jk) )   &  
    … …  
    326380         END DO 
    327381      END DO 
    328       ! 
     382 
     383      ! 
     384#if defined key_z_first 
     385      DO jj = 2, jpjm1 
     386         DO ji = 2, jpim1 
     387            DO jk = 2, jpkm1     !* Matrix and right hand side in en 
     388#else 
    329389      DO jk = 2, jpkm1           !* Matrix and right hand side in en 
    330390         DO jj = 2, jpjm1 
    331391            DO ji = fs_2, fs_jpim1   ! vector opt. 
     392#endif 
    332393               zcof   = zfact1 * tmask(ji,jj,jk) 
    333394               zzd_up = zcof * ( avm  (ji,jj,jk+1) + avm  (ji,jj,jk  ) )   &  ! upper diagonal 
    … …  
    350411      END DO 
    351412      !                          !* Matrix inversion from level 2 (tke prescribed at level 1) 
     413#if defined key_z_first 
     414      DO jj = 2, jpjm1 
     415         DO ji = 2, jpim1 
     416            ! First recurrence : Dk = Dk - Lk * Uk-1 / Dk-1 
     417            DO jk = 3, jpkm1 
     418               zdiag(ji,jj,jk) = zdiag(ji,jj,jk) - zd_lw(ji,jj,jk) * zd_up(ji,jj,jk-1) / zdiag(ji,jj,jk-1) 
     419            END DO 
     420            ! Second recurrence : Lk = RHSk - Lk / Dk-1 * Lk-1 
     421            zd_lw(ji,jj,2) = en(ji,jj,2) - zd_lw(ji,jj,2) * en(ji,jj,1)    ! Surface boudary conditions on tke 
     422            DO jk = 3, jpkm1 
     423               zd_lw(ji,jj,jk) = en(ji,jj,jk) - zd_lw(ji,jj,jk) / zdiag(ji,jj,jk-1) *zd_lw(ji,jj,jk-1) 
     424            END DO 
     425            ! Third recurrence : Ek = ( Lk - Uk * Ek+1 ) / Dk 
     426            en(ji,jj,jpkm1) = zd_lw(ji,jj,jpkm1) / zdiag(ji,jj,jpkm1) 
     427            DO jk = jpk-2, 2, -1 
     428               en(ji,jj,jk) = ( zd_lw(ji,jj,jk) - zd_up(ji,jj,jk) * en(ji,jj,jk+1) ) / zdiag(ji,jj,jk) 
     429            END DO 
     430            DO jk = 2, jpkm1                       ! set the minimum value of tke 
     431               en(ji,jj,jk) = MAX( en(ji,jj,jk), rn_emin ) * tmask(ji,jj,jk) 
     432            END DO 
     433         END DO 
     434      END DO 
     435#else 
    352436      DO jk = 3, jpkm1                             ! First recurrence : Dk = Dk - Lk * Uk-1 / Dk-1 
    353437         DO jj = 2, jpjm1 
    … …  
    388472         END DO 
    389473      END DO 
     474#endif 
    390475 
    391476      !                            !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 
    … …  
    393478      !                            !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 
    394479      IF( nn_etau == 1 ) THEN           !* penetration below the mixed layer (rn_efr fraction) 
     480#if defined key_z_first 
     481         DO jj = 2, jpjm1 
     482            DO ji = 2, jpim1 
     483               DO jk = 2, jpkm1 
     484#else 
    395485         DO jk = 2, jpkm1 
    396486            DO jj = 2, jpjm1 
    397487               DO ji = fs_2, fs_jpim1   ! vector opt. 
     488#endif 
    398489                  en(ji,jj,jk) = en(ji,jj,jk) + rn_efr * en(ji,jj,1) * EXP( -fsdepw(ji,jj,jk) / htau(ji,jj) )   & 
    399490                     &                                               * ( 1._wp - fr_i(ji,jj) )  * tmask(ji,jj,jk) 
    … …  
    410501         END DO 
    411502      ELSEIF( nn_etau == 3 ) THEN       !* penetration belox the mixed layer (HF variability) 
     503 
     504         !! DCSE_NEMO: its probably not worth changing the order of these loops for level first indexing, 
     505         !!            unless we also make zdif a 2-d (jpi,jpj) array 
    412506!CDIR NOVERRCHK 
    413507         DO jk = 2, jpkm1 
    … …  
    435529   END SUBROUTINE tke_tke 
    436530 
     531   !! * Reset control of array index permutation 
     532#  include "zdftke_ftrans.h90" 
     533#  include "oce_ftrans.h90" 
     534#  include "dom_oce_ftrans.h90" 
     535#  include "domvvl_ftrans.h90" 
     536#  include "sbc_oce_ftrans.h90" 
     537#  include "zdf_oce_ftrans.h90" 
     538!FTRANS dissl e_dis e_mix e_pdl e_ric :I :I :z 
    437539 
    438540   SUBROUTINE tke_avn 
    … …  
    472574      !!---------------------------------------------------------------------- 
    473575      USE oce, ONLY:   zmpdl => ua , zmxlm => va , zmxld => ta   ! (ua,va,ta) used as workspace 
     576      !! DCSE_NEMO: need additional directives for renamed module variables 
     577!FTRANS zmpdl zmxlm zmxld :I :I :z 
    474578      !! 
    475579      INTEGER  ::   ji, jj, jk   ! dummy loop indices 
    … …  
    491595         zmxlm(:,:,1) = rn_mxl0 
    492596      ENDIF 
    493       zmxlm(:,:,jpk)  = rmxl_min     ! last level set to the interior minium value 
     597 
     598#if defined key_z_first 
     599      DO jj = 2, jpjm1 
     600         DO ji = 2, jpim1 
     601            zmxlm(ji,jj,jpk) = rmxl_min     ! last level set to the interior minium value 
     602            DO jk = 2, jpkm1        ! interior value : l=sqrt(2*e/n^2) 
     603#else 
     604      zmxlm(:,:,jpk)  = rmxl_min    ! last level set to the interior minium value 
    494605      ! 
    495606!CDIR NOVERRCHK 
    … …  
    499610!CDIR NOVERRCHK 
    500611            DO ji = fs_2, fs_jpim1   ! vector opt. 
     612#endif 
    501613               zrn2 = MAX( rn2(ji,jj,jk), rsmall ) 
    502614               zmxlm(ji,jj,jk) = MAX(  rmxl_min,  SQRT( 2._wp * en(ji,jj,jk) / zrn2 )  ) 
    … …  
    513625      ! 
    514626      CASE ( 0 )           ! bounded by the distance to surface and bottom 
     627#if defined key_z_first 
     628         DO jj = 2, jpjm1 
     629            DO ji = 2, jpim1 
     630               DO jk = 2, jpkm1 
     631#else 
    515632         DO jk = 2, jpkm1 
    516633            DO jj = 2, jpjm1 
    517634               DO ji = fs_2, fs_jpim1   ! vector opt. 
     635#endif 
    518636                  zemxl = MIN( fsdepw(ji,jj,jk), zmxlm(ji,jj,jk),   & 
    519637                  &            fsdepw(ji,jj,mbkt(ji,jj)+1) - fsdepw(ji,jj,jk) ) 
    … …  
    525643         ! 
    526644      CASE ( 1 )           ! bounded by the vertical scale factor 
     645#if defined key_z_first 
     646         DO jj = 2, jpjm1 
     647            DO ji = 2, jpim1 
     648               DO jk = 2, jpkm1 
     649#else 
    527650         DO jk = 2, jpkm1 
    528651            DO jj = 2, jpjm1 
    529652               DO ji = fs_2, fs_jpim1   ! vector opt. 
     653#endif 
    530654                  zemxl = MIN( fse3w(ji,jj,jk), zmxlm(ji,jj,jk) ) 
    531655                  zmxlm(ji,jj,jk) = zemxl 
    … …  
    536660         ! 
    537661      CASE ( 2 )           ! |dk[xml]| bounded by e3t : 
     662#if defined key_z_first 
     663         DO jj = 2, jpjm1 
     664            DO ji = 2, jpim1 
     665               DO jk = 2, jpkm1   ! from the surface to the bottom : 
     666                  zmxlm(ji,jj,jk) = MIN( zmxlm(ji,jj,jk-1) + fse3t(ji,jj,jk-1), zmxlm(ji,jj,jk) ) 
     667               END DO 
     668               DO jk = jpkm1, 2, -1     ! from the bottom to the surface : 
     669                  zemxl = MIN( zmxlm(ji,jj,jk+1) + fse3t(ji,jj,jk+1), zmxlm(ji,jj,jk) ) 
     670                  zmxlm(ji,jj,jk) = zemxl 
     671                  zmxld(ji,jj,jk) = zemxl 
     672               END DO 
     673            END DO 
     674         END DO 
     675#else 
    538676         DO jk = 2, jpkm1         ! from the surface to the bottom : 
    539677            DO jj = 2, jpjm1 
    … …  
    552690            END DO 
    553691         END DO 
     692#endif 
    554693         ! 
    555694      CASE ( 3 )           ! lup and ldown, |dk[xml]| bounded by e3t : 
     695#if defined key_z_first 
     696         DO jj = 2, jpjm1 
     697            DO ji = 2, jpim1 
     698               DO jk = 2, jpkm1         ! from the surface to the bottom : lup 
     699                  zmxld(ji,jj,jk) = MIN( zmxld(ji,jj,jk-1) + fse3t(ji,jj,jk-1), zmxlm(ji,jj,jk) ) 
     700               END DO 
     701               DO jk = jpkm1, 2, -1     ! from the bottom to the surface : ldown 
     702                  zmxlm(ji,jj,jk) = MIN( zmxlm(ji,jj,jk+1) + fse3t(ji,jj,jk+1), zmxlm(ji,jj,jk) ) 
     703               END DO 
     704               DO jk = 2, jpkm1 
     705                  zemlm = MIN ( zmxld(ji,jj,jk),  zmxlm(ji,jj,jk) ) 
     706                  zemlp = SQRT( zmxld(ji,jj,jk) * zmxlm(ji,jj,jk) ) 
     707                  zmxlm(ji,jj,jk) = zemlm 
     708                  zmxld(ji,jj,jk) = zemlp 
     709               END DO 
     710            END DO 
     711         END DO 
     712#else 
    556713         DO jk = 2, jpkm1         ! from the surface to the bottom : lup 
    557714            DO jj = 2, jpjm1 
    … …  
    581738            END DO 
    582739         END DO 
     740#endif 
    583741         ! 
    584742      END SELECT 
    … …  
    592750      !                     !  Vertical eddy viscosity and diffusivity  (avmu, avmv, avt) 
    593751      !                     !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 
     752#if defined key_z_first 
     753      DO jj = 2, jpjm1 
     754         DO ji = 2, jpim1 
     755            DO jk = 1, jpkm1      !* vertical eddy viscosity & diffivity at w-points 
     756#else 
    594757!CDIR NOVERRCHK 
    595758      DO jk = 1, jpkm1            !* vertical eddy viscosity & diffivity at w-points 
    … …  
    598761!CDIR NOVERRCHK 
    599762            DO ji = fs_2, fs_jpim1   ! vector opt. 
     763#endif 
    600764               zsqen = SQRT( en(ji,jj,jk) ) 
    601765               zav   = rn_ediff * zmxlm(ji,jj,jk) * zsqen 
    … …  
    608772      CALL lbc_lnk( avm, 'W', 1. )      ! Lateral boundary conditions (sign unchanged) 
    609773      ! 
     774#if defined key_z_first 
     775      DO jj = 2, jpjm1 
     776         DO ji = 2, jpim1 
     777            DO jk = 2, jpkm1      !* vertical eddy viscosity at u- and v-points 
     778#else 
    610779      DO jk = 2, jpkm1            !* vertical eddy viscosity at u- and v-points 
    611780         DO jj = 2, jpjm1 
    612781            DO ji = fs_2, fs_jpim1   ! vector opt. 
     782#endif 
    613783               avmu(ji,jj,jk) = 0.5 * ( avm(ji,jj,jk) + avm(ji+1,jj  ,jk) ) * umask(ji,jj,jk) 
    614784               avmv(ji,jj,jk) = 0.5 * ( avm(ji,jj,jk) + avm(ji  ,jj+1,jk) ) * vmask(ji,jj,jk) 
    … …  
    619789      ! 
    620790      IF( nn_pdl == 1 ) THEN      !* Prandtl number case: update avt 
     791#if defined key_z_first 
     792         DO jj = 2, jpjm1 
     793            DO ji = 2, jpim1 
     794               DO jk = 2, jpkm1 
     795#else 
    621796         DO jk = 2, jpkm1 
    622797            DO jj = 2, jpjm1 
    623798               DO ji = fs_2, fs_jpim1   ! vector opt. 
     799#endif 
    624800                  zcoef = avm(ji,jj,jk) * 2._wp * fse3w(ji,jj,jk) * fse3w(ji,jj,jk) 
    625801                  !                                          ! shear 
    … …  
    652828   END SUBROUTINE tke_avn 
    653829 
     830   !! * Reset control of array index permutation 
     831#  include "zdftke_ftrans.h90" 
     832#  include "oce_ftrans.h90" 
     833#  include "dom_oce_ftrans.h90" 
     834#  include "domvvl_ftrans.h90" 
     835#  include "sbc_oce_ftrans.h90" 
     836#  include "zdf_oce_ftrans.h90" 
     837!FTRANS dissl e_dis e_mix e_pdl e_ric :I :I :z 
    654838 
    655839   SUBROUTINE zdf_tke_init 
    … …  
    733917      ENDIF 
    734918      !                               !* set vertical eddy coef. to the background value 
     919#if defined key_z_first 
     920      DO jj = 1, jpj 
     921         DO ji = 1, jpi 
     922             avt (ji,jj,:) = avtb(:) * tmask(ji,jj,:) 
     923             avm (ji,jj,:) = avmb(:) * tmask(ji,jj,:) 
     924             avmu(ji,jj,:) = avmb(:) * umask(ji,jj,:) 
     925             avmv(ji,jj,:) = avmb(:) * vmask(ji,jj,:) 
     926         END DO 
     927      END DO 
     928#else 
    735929      DO jk = 1, jpk 
    736930         avt (:,:,jk) = avtb(jk) * tmask(:,:,jk) 
    … …  
    739933         avmv(:,:,jk) = avmb(jk) * vmask(:,:,jk) 
    740934      END DO 
     935#endif 
    741936      dissl(:,:,:) = 1.e-12_wp 
    742937      !                               
    … …  
    759954     CHARACTER(len=*), INTENT(in) ::   cdrw   ! "READ"/"WRITE" flag 
    760955     ! 
    761      INTEGER ::   jit, jk   ! dummy loop indices 
     956     INTEGER ::   jit, ji, jj, jk   ! dummy loop indices 
    762957     INTEGER ::   id1, id2, id3, id4, id5, id6   ! local integers 
    763958     !!---------------------------------------------------------------------- 
    … …  
    792987        ELSE                                   !* Start from rest 
    793988           en(:,:,:) = rn_emin * tmask(:,:,:) 
     989#if defined key_z_first 
     990           DO jj = 1, jpj                           ! set the Kz to the background value 
     991              DO ji = 1, jpi 
     992                  avt (ji,jj,:) = avtb(:) * tmask(ji,jj,:) 
     993                  avm (ji,jj,:) = avmb(:) * tmask(ji,jj,:) 
     994                  avmu(ji,jj,:) = avmb(:) * umask(ji,jj,:) 
     995                  avmv(ji,jj,:) = avmb(:) * vmask(ji,jj,:) 
     996              END DO 
     997           END DO 
     998#else 
    794999           DO jk = 1, jpk                           ! set the Kz to the background value 
    7951000              avt (:,:,jk) = avtb(jk) * tmask(:,:,jk) 
    … …  
    7981003              avmv(:,:,jk) = avmb(jk) * vmask(:,:,jk) 
    7991004           END DO 
     1005#endif 
     1006 
    8001007        ENDIF 
    8011008        ! 

  • branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/ZDF/zdftmx.F90

    r2715 r3211  
    4848   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   az_tmx     ! coefficient used to evaluate the tidal induced Kz 
    4949 
     50   !! * Control permutation of array indices 
     51#  include "oce_ftrans.h90" 
     52#  include "dom_oce_ftrans.h90" 
     53#  include "zdf_oce_ftrans.h90" 
     54!FTRANS az_tmx :I :I :z 
     55 
    5056   !! * Substitutions 
    5157#  include "domzgr_substitute.h90" 
    … …  
    110116      INTEGER  ::   ji, jj, jk   ! dummy loop indices 
    111117      REAL(wp) ::   ztpc         ! scalar workspace 
     118#if defined key_z_first 
     119      REAL(wp) ::   ztpc         ! scalar workspace 
     120#endif 
    112121      !!---------------------------------------------------------------------- 
    113122 
    … …  
    132141      END DO 
    133142 
     143#if defined key_z_first 
     144      DO jj = 1, jpj 
     145         DO ji = 1, jpi 
     146            zscal = MIN( zkz(ji,jj), 30./6. )   !kz max = 300 cm2/s 
     147            DO jk = 2, jpkm1        !* Mutiply by zkz to recover en_tmx, BUT bound by 30/6 ==> zav_tide bound by 300 cm2/s 
     148               zav_tide(ji,jj,jk) = zav_tide(ji,jj,jk) * zscal 
     149            END DO 
     150         END DO 
     151      END DO 
     152#else 
    134153      DO jk = 2, jpkm1              !* Mutiply by zkz to recover en_tmx, BUT bound by 30/6 ==> zav_tide bound by 300 cm2/s 
    135154         zav_tide(:,:,jk) = zav_tide(:,:,jk) * MIN( zkz(:,:), 30./6. )   !kz max = 300 cm2/s 
    136155      END DO 
     156#endif 
    137157 
    138158      IF( kt == nit000 ) THEN       !* check at first time-step: diagnose the energy consumed by zav_tide 
    139159         ztpc = 0.e0 
     160#if defined key_z_first 
     161         DO jj = 1, jpj 
     162            DO ji = 1, jpi 
     163               DO jk = 1, jpk 
     164#else 
    140165         DO jk= 1, jpk 
    141166            DO jj= 1, jpj 
    142167               DO ji= 1, jpi 
     168#endif 
    143169                  ztpc = ztpc + fse3w(ji,jj,jk) * e1t(ji,jj) * e2t(ji,jj)   & 
    144170                     &         * MAX( 0.e0, rn2(ji,jj,jk) ) * zav_tide(ji,jj,jk) * tmask(ji,jj,jk) * tmask_i(ji,jj) 
    … …  
    159185      !                          !   Update  mixing coefs  !                           
    160186      !                          ! ----------------------- ! 
     187#if defined key_z_first 
     188      !* update momentum & tracer diffusivity with tidal mixing 
     189      DO jj = 1, jpj 
     190         DO ji = 1, jpi 
     191            DO jk = 2, jpkm1  
     192               avt(ji,jj,jk) = avt(ji,jj,jk) + zav_tide(ji,jj,jk) 
     193               avm(ji,jj,jk) = avm(ji,jj,jk) + zav_tide(ji,jj,jk) 
     194            END DO 
     195         END DO 
     196      END DO 
     197      DO jj = 2, jpjm1 
     198         DO ji = 2, fpim1 
     199            DO jk = 2, jpkm1 
     200               avmu(ji,jj,jk) = avmu(ji,jj,jk) + 0.5 * ( zav_tide(ji,jj,jk) + zav_tide(ji+1,jj  ,jk) ) * umask(ji,jj,jk) 
     201               avmv(ji,jj,jk) = avmv(ji,jj,jk) + 0.5 * ( zav_tide(ji,jj,jk) + zav_tide(ji  ,jj+1,jk) ) * vmask(ji,jj,jk) 
     202            END DO 
     203         END DO 
     204      END DO 
     205#else 
    161206      DO jk = 2, jpkm1              !* update momentum & tracer diffusivity with tidal mixing 
    162207         avt(:,:,jk) = avt(:,:,jk) + zav_tide(:,:,jk) 
    … …  
    169214         END DO 
    170215      END DO 
     216#endif 
    171217      CALL lbc_lnk( avmu, 'U', 1. )   ;   CALL lbc_lnk( avmv, 'V', 1. )      ! lateral boundary condition 
    172218 
    … …  
    208254      USE wrk_nemo, ONLY: zempba_3d   => wrk_3d_3, zdn2dz      => wrk_3d_4 
    209255      USE wrk_nemo, ONLY: zavt_itf    => wrk_3d_5 
     256      !! DCSE_NEMO: need additional directives for renamed module variables 
     257!FTRANS zempba_3d_1 zempba_3d_2 zempba_3d zdn2dz zavt_itf :I :I :z 
    210258      !! 
    211259      INTEGER , INTENT(in   )                         ::   kt   ! ocean time-step 
    212       REAL(wp), INTENT(inout), DIMENSION(jpi,jpj,jpk) ::   pav  ! Tidal mixing coef. 
     260 
     261      !! DCSE_NEMO: This style defeats ftrans 
     262!     REAL(wp), INTENT(inout), DIMENSION(jpi,jpj,jpk) ::   pav  ! Tidal mixing coef. 
     263!FTRANS pav :I :I :z 
     264      REAL(wp), INTENT(inout)            ::   pav(jpi,jpj,jpk)  ! Tidal mixing coef. 
    213265      !!  
    214266      INTEGER  ::   ji, jj, jk    ! dummy loop indices 
    … …  
    221273      END IF 
    222274      !                             ! compute the form function using N2 at each time step 
     275#if defined key_z_first 
     276      DO jj = 1, jpj 
     277         DO ji = 1, jpi 
     278            DO jk = 1, jpkm1              
     279               zdn2dz     (ji,jj,jk) = rn2(ji,jj,jk) - rn2(ji,jj,jk+1)         ! Vertical profile of dN2/dz 
     280               zempba_3d_1(ji,jj,jk) = SQRT(  MAX( 0.e0, rn2(ji,jj,jk) )  )    !    -        -    of N 
     281               zempba_3d_2(ji,jj,jk) =        MAX( 0.e0, rn2(ji,jj,jk) )       !    -        -    of N^2 
     282            END DO 
     283            zempba_3d_1(ji,jj,jpk) = 0.e0 
     284            zempba_3d_2(ji,jj,jpk) = 0.e0 
     285         END DO 
     286      END DO 
     287#else 
    223288      zempba_3d_1(:,:,jpk) = 0.e0 
    224289      zempba_3d_2(:,:,jpk) = 0.e0 
    … …  
    229294         zempba_3d_2(:,:,jk) =        MAX( 0.e0, rn2(:,:,jk) )       !    -        -    of N^2 
    230295      END DO 
    231       ! 
    232       zsum (:,:) = 0.e0 
     296#endif 
     297      ! 
     298#if defined key_z_first 
     299      DO jj = 1, jpj 
     300         DO ji = 1, jpj 
     301            zsum1(ji,jj) = 0.e0 
     302            zsum2(ji,jj) = 0.e0 
     303            DO jk= 2, jpk 
     304               zsum1(ji,jj) = zsum1(ji,jj) + zempba_3d_1(ji,jj,jk) * fse3w(ji,jj,jk) 
     305               zsum2(ji,jj) = zsum2(ji,jj) + zempba_3d_2(ji,jj,jk) * fse3w(ji,jj,jk)                 
     306            END DO 
     307            IF( zsum1(ji,jj) /= 0.e0 )   zsum1(ji,jj) = 1.e0 / zsum1(ji,jj) 
     308            IF( zsum2(ji,jj) /= 0.e0 )   zsum2(ji,jj) = 1.e0 / zsum2(ji,jj)                 
     309         END DO 
     310      END DO 
     311#else 
    233312      zsum1(:,:) = 0.e0 
    234313      zsum2(:,:) = 0.e0 
    … …  
    243322         END DO 
    244323      END DO 
    245  
    246       DO jk= 1, jpk 
    247          DO jj = 1, jpj 
    248             DO ji = 1, jpi 
     324#endif 
     325 
     326      zsum (:,:) = 0.e0 
     327 
     328#if defined key_z_first 
     329      DO jj = 1, jpj 
     330         DO ji = 1, jpi 
     331            DO jk = 1, jpk 
     332#else 
     333      DO jk = 1, jpk 
     334         DO jj = 1, jpj 
     335            DO ji = 1, jpi 
     336#endif 
    249337               zcoef = 0.5 - SIGN( 0.5, zdn2dz(ji,jj,jk) )       ! =0 if dN2/dz > 0, =1 otherwise  
    250338               ztpc  = zempba_3d_1(ji,jj,jk) * zsum1(ji,jj) *        zcoef     & 
    … …  
    254342               zsum     (ji,jj)    = zsum(ji,jj) + ztpc * fse3w(ji,jj,jk) 
    255343            END DO 
     344#if !defined key_z_first 
    256345         END DO 
    257346       END DO 
    258347       DO jj = 1, jpj 
    259348          DO ji = 1, jpi 
     349#endif 
    260350             IF( zsum(ji,jj) > 0.e0 )   zsum(ji,jj) = 1.e0 / zsum(ji,jj)                 
    261351          END DO 
    … …  
    264354      !                             ! first estimation bounded by 10 cm2/s (with n2 bounded by rn_n2min)  
    265355      zcoef = rn_tfe_itf / ( rn_tfe * rau0 ) 
     356#if defined key_z_first 
     357      DO jj = 1, jpj 
     358         DO ji = 1, jpi 
     359            DO jk = 1, jpk 
     360                zavt_itf(ji,jj,jk) = MIN(  10.e-4, zcoef * en_tmx(ji,jj) * zsum(ji,jj) * zempba_3d(ji,jj,jk)   & 
     361            &                                             / MAX( rn_n2min, rn2(ji,jj,jk) ) * tmask(ji,jj,jk)  ) 
     362             END DO 
     363         END DO 
     364      END DO            
     365#else 
    266366      DO jk = 1, jpk 
    267367         zavt_itf(:,:,jk) = MIN(  10.e-4, zcoef * en_tmx(:,:) * zsum(:,:) * zempba_3d(:,:,jk)   & 
    268368            &                                      / MAX( rn_n2min, rn2(:,:,jk) ) * tmask(:,:,jk)  ) 
    269369      END DO            
    270  
     370#endif 
     371 
     372#if defined key_z_first 
     373      DO jj = 1, jpj 
     374         DO ji = 1, jpi 
     375            zkz(ji,jj) = 0.e0       ! Associated potential energy consummed over the whole water column 
     376            DO jk = 2, jpkm1 
     377               zkz(ji,jj) = zkz(ji,jj) + fse3w(ji,jj,jk)   & 
     378                  &                     * MAX( 0.e0, rn2(ji,jj,jk) ) * rau0 * zavt_itf(ji,jj,jk) * tmask(ji,jj,jk) 
     379            END DO 
     380         END DO 
     381      END DO 
     382#else 
    271383      zkz(:,:) = 0.e0               ! Associated potential energy consummed over the whole water column 
    272384      DO jk = 2, jpkm1 
    273385         zkz(:,:) = zkz(:,:) + fse3w(:,:,jk) * MAX( 0.e0, rn2(:,:,jk) ) * rau0 * zavt_itf(:,:,jk) * tmask(:,:,jk) 
    274386      END DO 
     387#endif 
    275388 
    276389      DO jj = 1, jpj                ! Here zkz should be equal to en_tmx ==> multiply by en_tmx/zkz to recover en_tmx 
    … …  
    280393      END DO 
    281394 
     395#if defined key_z_first 
     396      DO jj = 1, jpj 
     397         DO ji = 1, jpi 
     398            zcoef = MIN( zkz(:,:), 120./10. )                              ! kz max = 120 cm2/s 
     399            DO jk = 2, jpkm1        ! Mutiply by zkz to recover en_tmx, BUT bound by 30/6 ==> zavt_itf bound by 300 cm2/s 
     400               zavt_itf(ji,jj,jk) = zavt_itf(ji,jj,jk) * zcoef 
     401            END DO 
     402         END DO 
     403      END DO 
     404#else 
    282405      DO jk = 2, jpkm1              ! Mutiply by zkz to recover en_tmx, BUT bound by 30/6 ==> zavt_itf bound by 300 cm2/s 
    283406         zavt_itf(:,:,jk) = zavt_itf(:,:,jk) * MIN( zkz(:,:), 120./10. )   ! kz max = 120 cm2/s 
    284407      END DO 
    285  
    286       IF( kt == nit000 ) THEN       ! diagnose the nergy consumed by zavt_itf 
     408#endif 
     409 
     410      IF( kt == nit000 ) THEN       ! diagnose the energy consumed by zavt_itf 
    287411         ztpc = 0.e0 
    288          DO jk= 1, jpk 
    289             DO jj= 1, jpj 
    290                DO ji= 1, jpi 
     412#if defined key_z_first 
     413         DO jj = 1, jpj 
     414            DO ji = 1, jpi 
     415               DO jk = 1, jpk 
     416#else 
     417         DO jk = 1, jpk 
     418            DO jj = 1, jpj 
     419               DO ji = 1, jpi 
     420#endif 
    291421                  ztpc = ztpc + e1t(ji,jj) * e2t(ji,jj) * fse3w(ji,jj,jk) * MAX( 0.e0, rn2(ji,jj,jk) )   & 
    292422                     &                     * zavt_itf(ji,jj,jk) * tmask(ji,jj,jk) * tmask_i(ji,jj) 
    … …  
    299429 
    300430      !                             ! Update pav with the ITF mixing coefficient 
     431#if defined key_z_first 
     432      DO jj = 1, jpj 
     433         DO ji = 1, jpi 
     434            DO jk = 2, jpkm1 
     435               pav(ji,jj,jk) = pav     (ji,jj,jk) * ( 1.e0 - mask_itf(ji,jj) )   & 
     436            &                + zavt_itf(ji,jj,jk) *          mask_itf(ji,jj)  
     437            END DO 
     438         END DO 
     439      END DO 
     440#else 
    301441      DO jk = 2, jpkm1 
    302442         pav(:,:,jk) = pav     (:,:,jk) * ( 1.e0 - mask_itf(:,:) )   & 
    303443            &        + zavt_itf(:,:,jk) *          mask_itf(:,:)  
    304444      END DO 
     445#endif 
    305446      ! 
    306447      IF( wrk_not_released(2, 2,3,4,5) .OR. & 
    … …  
    311452   END SUBROUTINE tmx_itf 
    312453 
     454   !! * Reset control of array index permutation 
     455#  include "oce_ftrans.h90" 
     456#  include "dom_oce_ftrans.h90" 
     457#  include "zdf_oce_ftrans.h90" 
     458!FTRANS az_tmx :I :I :z 
    313459 
    314460   SUBROUTINE zdf_tmx_init 
    … …  
    354500      USE wrk_nemo, ONLY:   zhdep    =>  wrk_2d_5   ! Ocean depth  
    355501      USE wrk_nemo, ONLY:   zpc      =>  wrk_3d_1   ! power consumption 
     502 
     503      !! DCSE_NEMO: need additional directives for renamed module variables 
     504!FTRANS zpc :I :I :z 
     505 
    356506      !! 
    357507      INTEGER  ::   ji, jj, jk   ! dummy loop indices 
    358508      INTEGER  ::   inum         ! local integer 
    359509      REAL(wp) ::   ztpc, ze_z   ! local scalars 
     510#if defined key_z_first 
     511      REAL(wp) ::   zcoef        ! local scalar 
     512#endif 
     513 
    360514      !! 
    361515      NAMELIST/namzdf_tmx/ rn_htmx, rn_n2min, rn_tfe, rn_me, ln_tmx_itf, rn_tfe_itf 
    … …  
    414568         END DO 
    415569      END DO 
     570#if defined key_z_first 
     571      DO jj = 1, jpj 
     572         DO ji = 1, jpi 
     573            DO jk= 1, jpk           ! complete with the level-dependent part 
     574#else 
    416575      DO jk= 1, jpk                 ! complete with the level-dependent part 
    417576         DO jj = 1, jpj 
    418577            DO ji = 1, jpi 
     578#endif 
    419579               az_tmx(ji,jj,jk) = zfact(ji,jj) * EXP( -( zhdep(ji,jj)-fsdepw(ji,jj,jk) ) / rn_htmx ) * tmask(ji,jj,jk) 
    420580            END DO 
    … …  
    426586         ! Total power consumption due to vertical mixing 
    427587         ! zpc = rau0 * 1/rn_me * rn2 * zav_tide 
     588#if defined key_z_first 
     589         DO jj = 1, jpj 
     590            DO ji = 1, jpi 
     591               zav_tide(ji,jj,1) = 0.e0 
     592               DO jk = 2, jpkm1 
     593                  zav_tide(:,:,jk) = az_tmx(:,:,jk) / MAX( rn_n2min, rn2(:,:,jk) ) 
     594               END DO 
     595               zav_tide(ji,jj,jpk) = 0.e0 
     596            END DO 
     597         END DO 
     598#else 
    428599         zav_tide(:,:,:) = 0.e0 
    429600         DO jk = 2, jpkm1 
    430601            zav_tide(:,:,jk) = az_tmx(:,:,jk) / MAX( rn_n2min, rn2(:,:,jk) ) 
    431602         END DO 
     603#endif 
    432604 
    433605         ztpc = 0.e0 
    434606         zpc(:,:,:) = MAX(rn_n2min,rn2(:,:,:)) * zav_tide(:,:,:) 
     607#if defined key_z_first 
     608         DO jj = 1, jpj 
     609            DO ji = 1, jpi 
     610               DO jk= 2, jpkm1 
     611#else 
    435612         DO jk= 2, jpkm1 
    436613            DO jj = 1, jpj 
    437614               DO ji = 1, jpi 
     615#endif 
    438616                  ztpc = ztpc + fse3w(ji,jj,jk) * e1t(ji,jj) * e2t(ji,jj) * zpc(ji,jj,jk) * tmask(ji,jj,jk) * tmask_i(ji,jj) 
    439617               END DO 
    … …  
    448626         ! control print 2 
    449627         zav_tide(:,:,:) = MIN( zav_tide(:,:,:), 60.e-4 )    
     628#if defined key_z_first 
     629         DO jj = 1, jpj 
     630            DO ji = 1, jpi 
     631               zkz(ji,jj) = 0.e0 
     632               DO jk = 2, jpkm1 
     633#else 
    450634         zkz(:,:) = 0.e0 
    451635         DO jk = 2, jpkm1 
    452          DO jj = 1, jpj 
    453             DO ji = 1, jpi 
    454                zkz(ji,jj) = zkz(ji,jj) + fse3w(ji,jj,jk) * MAX( 0.e0, rn2(ji,jj,jk) ) * rau0 * zav_tide(ji,jj,jk)* tmask(ji,jj,jk) 
    455             END DO 
    456          END DO 
     636            DO jj = 1, jpj 
     637               DO ji = 1, jpi 
     638#endif 
     639                  zkz(ji,jj) = zkz(ji,jj) + fse3w(ji,jj,jk)   & 
     640                     &                     * MAX( 0.e0, rn2(ji,jj,jk) ) * rau0 * zav_tide(ji,jj,jk)* tmask(ji,jj,jk) 
     641               END DO 
     642            END DO 
    457643         END DO 
    458644         ! Here zkz should be equal to en_tmx ==> multiply by en_tmx/zkz 
    … …  
    468654            DO ji = 1, jpi 
    469655               IF( zkz(ji,jj) /= 0.e0 )   THEN 
    470                    ztpc = Min( zkz(ji,jj), ztpc) 
     656                   ztpc = MIN( zkz(ji,jj), ztpc) 
    471657               ENDIF 
    472658            END DO 
    473659         END DO 
    474          WRITE(numout,*) '          Min de zkz ', ztpc, ' Max = ', maxval(zkz(:,:) ) 
    475  
     660         WRITE(numout,*) '          Min de zkz ', ztpc, ' Max = ', MAXVAL(zkz(:,:) ) 
     661 
     662#if defined key_z_first 
     663         DO jj = 1, jpj 
     664            DO ji = 1, jpi 
     665               zcoef = MIN( zkz(ji,jj), 30./6. )                            !kz max = 300 cm2/s 
     666               DO jk = 2, jpkm1 
     667                  zav_tide(ji,jj,jk) = zav_tide(ji,jj,jk) * zcoef 
     668               END DO 
     669            END DO 
     670         END DO 
     671#else 
    476672         DO jk = 2, jpkm1 
    477673            zav_tide(:,:,jk) = zav_tide(:,:,jk) * MIN( zkz(:,:), 30./6. )   !kz max = 300 cm2/s 
    478674         END DO 
     675#endif 
    479676         ztpc = 0.e0 
    480          zpc(:,:,:) = Max(0.e0,rn2(:,:,:)) * zav_tide(:,:,:) 
     677         zpc(:,:,:) = MAX(0.e0,rn2(:,:,:)) * zav_tide(:,:,:) 
     678#if defined key_z_first 
     679         DO jj = 1, jpj 
     680            DO ji = 1, jpi 
     681               DO jk= 1, jpk 
     682#else 
    481683         DO jk= 1, jpk 
    482684            DO jj = 1, jpj 
    483685               DO ji = 1, jpi 
     686#endif 
    484687                  ztpc = ztpc + fse3w(ji,jj,jk) * e1t(ji,jj) * e2t(ji,jj) * zpc(ji,jj,jk) * tmask(ji,jj,jk) * tmask_i(ji,jj) 
    485688               END DO 
Note: See TracChangeset for help on using the changeset viewer.