Changeset 3211 for branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/DOM/istate.F90

Timestamp:

2011-12-11T16:00:26+01:00 (13 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/.

File:

• branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/DOM/istate.F90 (modified) (10 diffs)

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

@@ -50 +50 @@
    PUBLIC   istate_init   ! routine called by step.F90
 
+   !! * Control permutation of array indices
+#  include "oce_ftrans.h90"
+#  include "dom_oce_ftrans.h90"
+#  include "ldftra_oce_ftrans.h90"
+#  include "zdf_oce_ftrans.h90"
+#  include "dtatem_ftrans.h90"
+#  include "dtasal_ftrans.h90"
+#  include "domvvl_ftrans.h90"
+
    !! * Substitutions
 #  include "domzgr_substitute.h90"
@@ -67 +76 @@
       !!----------------------------------------------------------------------
       ! - ML - needed for initialization of e3t_b
-      INTEGER  ::  jk     ! dummy loop indice
+      INTEGER  ::  ji, jj, jk     ! dummy loop indices
 
       IF(lwp) WRITE(numout,*)
@@ -134 +143 @@
          ! - ML - sshn could be modified by istate_eel, so that initialization of fse3t_b is done here
          IF( lk_vvl ) THEN
+#if defined key_z_first
+            fse3t_b(:,:,:) = fse3t_n(:,:,:)
+#else
             DO jk = 1, jpk
                fse3t_b(:,:,jk) = fse3t_n(:,:,jk)
             ENDDO
+#endif
          ENDIF
          ! 
@@ -169 +182 @@
       IF(lwp) WRITE(numout,*) '~~~~~~~~~~'
       !
+#if defined key_z_first
+      DO jj = 1, jpj
+         DO ji = 1, jpi
+            DO jk = 1, jpk
+#else
       DO jk = 1, jpk
          DO jj = 1, jpj
             DO ji = 1, jpi
+#endif
                tn(ji,jj,jk) = (  ( ( 7.5 - 0.*ABS(gphit(ji,jj))/30. )   &
                   &               *( 1.-TANH((fsdept(ji,jj,jk)-80.)/30.) )   &
@@ -253 +272 @@
             zcst   = ( zt1 * ( zh1 - zh2) - ( zt1 - zt2 ) * zh1 ) / ( zh1 - zh2 )
             !
+#if defined key_z_first
+            DO jj = 1, jpj
+               DO ji = 1, jpi
+                  DO jk = 1, jpk
+                     tn(ji,jj,jk) = ( zt2 + zt1 * exp( - fsdept(ji,jj,jk) / 1000 ) ) * tmask(ji,jj,jk)
+                     tb(ji,jj,jk) = tn(ji,jj,jk)
+                  END DO
+               END DO
+            END DO
+#else
             DO jk = 1, jpk
                tn(:,:,jk) = ( zt2 + zt1 * exp( - fsdept(:,:,jk) / 1000 ) ) * tmask(:,:,jk)
                tb(:,:,jk) = tn(:,:,jk)
             END DO
+#endif
             !
             IF(lwp) CALL prizre( tn    , jpi   , jpj   , jpk   , jpj/2 ,   &
@@ -294 +324 @@
             DO jj = 1, nlcj
                DO ji = 1, nlci
+#if defined key_z_first
+                  sshb(ji,jj) = zssh( mig(ji) , mjg(jj) ) * tmask_1(ji,jj)
+#else
                   sshb(ji,jj) = zssh( mig(ji) , mjg(jj) ) * tmask(ji,jj,1)
+#endif
                END DO
             END DO
@@ -374 +408 @@
          IF(lwp) WRITE(numout,*) '~~~~~~~~~~~'
 
+#if defined key_z_first
+         DO jj = 1, jpj
+            DO ji = 1, jpi
+               DO jk = 1, jpk
+#else
          DO jk = 1, jpk
             DO jj = 1, jpj
                DO ji = 1, jpi
+#endif
                   tn(ji,jj,jk) = (  16. - 12. * TANH( (fsdept(ji,jj,jk) - 400) / 700 )         )   &
                        &           * (-TANH( (500-fsdept(ji,jj,jk)) / 150 ) + 1) / 2               &
@@ -448 +488 @@
       USE wrk_nemo, ONLY:   wrk_in_use, wrk_not_released
       USE wrk_nemo, ONLY:   zprn => wrk_3d_1    ! 3D workspace
+      !! DCSE_NEMO: wrk_3d_1 renamed, need additional directive
+!FTRANS zprn :I :I :z
 
       USE dynspg          ! surface pressure gradient             (dyn_spg routine)
@@ -473 +515 @@
       zprn(:,:,1) = zalfg * fse3w(:,:,1) * ( 1 + rhd(:,:,1) )       ! Surface value
 
+#if defined key_z_first
+      DO jj = 1, jpj
+         DO ji = 1, jpi
+            DO jk = 2, jpkm1                                        ! Vertical integration from the surface
+               zprn(ji,jj,jk) = zprn(ji,jj,jk-1)   &
+                  &           + zalfg * fse3w(ji,jj,jk) * ( 2. + rhd(ji,jj,jk) + rhd(ji,jj,jk-1) )
+            END DO  
+         END DO  
+      END DO  
+#else
       DO jk = 2, jpkm1                                              ! Vertical integration from the surface
          zprn(:,:,jk) = zprn(:,:,jk-1)   &
             &         + zalfg * fse3w(:,:,jk) * ( 2. + rhd(:,:,jk) + rhd(:,:,jk-1) )
       END DO  
+#endif
 
       ! Compute geostrophic balance
       ! ---------------------------
+#if defined key_z_first
+      DO jj = 2, jpjm1
+         DO ji = 2, jpim1
+            DO jk = 1, jpkm1
+#else
       DO jk = 1, jpkm1
          DO jj = 2, jpjm1
-            DO ji = fs_2, fs_jpim1   ! vertor opt.
+            DO ji = fs_2, fs_jpim1   ! vector opt.
+#endif
                zmsv = 1. / MAX(  umask(ji-1,jj+1,jk) + umask(ji  ,jj+1,jk)   &
                                + umask(ji-1,jj  ,jk) + umask(ji  ,jj  ,jk) , 1.  )
@@ -511 +570 @@
       ! to have a zero bottom velocity
 
+#if defined key_z_first
+      DO jj = 1, jpj
+         DO ji = 1, jpi
+            DO jk = 1, jpkm1
+               un(ji,jj,jk) = ( un(ji,jj,jk) - un(ji,jj,jpkm1) ) * umask(ji,jj,jk)
+               vn(ji,jj,jk) = ( vn(ji,jj,jk) - vn(ji,jj,jpkm1) ) * vmask(ji,jj,jk)
+            END DO
+         END DO
+      END DO
+#else
       DO jk = 1, jpkm1
          un(:,:,jk) = ( un(:,:,jk) - un(:,:,jpkm1) ) * umask(:,:,jk)
          vn(:,:,jk) = ( vn(:,:,jk) - vn(:,:,jpkm1) ) * vmask(:,:,jk)
       END DO
+#endif
 
       CALL lbc_lnk( un, 'U', -1. )