Changeset 2715 for trunk/NEMOGCM/NEMO/OPA_SRC/DYN/dynspg_ts.F90

Timestamp:

2011-03-30T17:58:35+02:00 (13 years ago)

Author:

rblod

Message:

First attempt to put dynamic allocation on the trunk

File:

• trunk/NEMOGCM/NEMO/OPA_SRC/DYN/dynspg_ts.F90 (modified) (7 diffs)

trunk/NEMOGCM/NEMO/OPA_SRC/DYN/dynspg_ts.F90

@@ -38 +38 @@
    USE prtctl          ! Print control
    USE in_out_manager  ! I/O manager
-   USE iom
+   USE iom             ! IOM library
    USE restart         ! only for lrst_oce
    USE zdf_oce
@@ -45 +45 @@
    PRIVATE
 
-   PUBLIC dyn_spg_ts  ! routine called by step.F90
-   PUBLIC ts_rst      ! routine called by istate.F90
-
-
-   REAL(wp), DIMENSION(jpi,jpj) ::  ftnw, ftne   ! triad of coriolis parameter
-   REAL(wp), DIMENSION(jpi,jpj) ::  ftsw, ftse   ! (only used with een vorticity scheme)
-
-   REAL(wp), PUBLIC, DIMENSION(jpi,jpj) ::   un_b, vn_b   ! now    averaged velocity
-   REAL(wp), PUBLIC, DIMENSION(jpi,jpj) ::   ub_b, vb_b   ! before averaged velocity
-
+   PUBLIC dyn_spg_ts        ! routine called by step.F90
+   PUBLIC ts_rst            ! routine called by istate.F90
+   PUBLIC dyn_spg_ts_alloc  ! routine called by dynspg.F90
+
+
+   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) ::  ftnw, ftne   ! triad of coriolis parameter
+   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) ::  ftsw, ftse   ! (only used with een vorticity scheme)
+
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   un_b, vn_b   ! now    averaged velocity
+   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   ub_b, vb_b   ! before averaged velocity
 
    !! * Substitutions
 #  include "domzgr_substitute.h90"
 #  include "vectopt_loop_substitute.h90"
-   !!-------------------------------------------------------------------------
-   !! NEMO/OPA 3.3 , NEMO Consortium (2010)
+   !!----------------------------------------------------------------------
+   !! NEMO/OPA 4.0 , NEMO Consortium (2011)
    !! $Id$
-   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
-   !!-------------------------------------------------------------------------
-
+   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
+   !!----------------------------------------------------------------------
 CONTAINS
+
+   INTEGER FUNCTION dyn_spg_ts_alloc()
+      !!----------------------------------------------------------------------
+      !!                  ***  routine dyn_spg_ts_alloc  ***
+      !!----------------------------------------------------------------------
+      ALLOCATE( ftnw  (jpi,jpj) , ftne(jpi,jpj) , un_b(jpi,jpj) , vn_b(jpi,jpj) ,     &
+         &      ftsw  (jpi,jpj) , ftse(jpi,jpj) , ub_b(jpi,jpj) , vb_b(jpi,jpj) , STAT= dyn_spg_ts_alloc )
+         !
+      IF( lk_mpp                )   CALL mpp_sum( dyn_spg_ts_alloc )
+      IF( dyn_spg_ts_alloc /= 0 )   CALL ctl_warn('dynspg_oce_alloc: failed to allocate arrays')
+      !
+   END FUNCTION dyn_spg_ts_alloc
+
 
    SUBROUTINE dyn_spg_ts( kt )
@@ -94 +106 @@
       !! References : Griffies et al., (2003): A technical guide to MOM4. NOAA/GFDL
       !!---------------------------------------------------------------------
+      USE wrk_nemo, ONLY:   wrk_in_use, wrk_not_released
+      USE wrk_nemo, ONLY:   zsshun_e => wrk_2d_1 , zsshb_e  => wrk_2d_2  , zhdiv => wrk_2d_3
+      USE wrk_nemo, ONLY:   zsshvn_e => wrk_2d_4 , zssh_sum => wrk_2d_5
+      USE wrk_nemo, ONLY:   zcu => wrk_2d_6  , zwx   => wrk_2d_7  , zua   => wrk_2d_8  , zbfru  => wrk_2d_9
+      USE wrk_nemo, ONLY:   zcv => wrk_2d_10 , zwy   => wrk_2d_11 , zva   => wrk_2d_12 , zbfrv  => wrk_2d_13
+      USE wrk_nemo, ONLY:   zun => wrk_2d_14 , zun_e => wrk_2d_15 , zub_e => wrk_2d_16 , zu_sum => wrk_2d_17
+      USE wrk_nemo, ONLY:   zvn => wrk_2d_18 , zvn_e => wrk_2d_19 , zvb_e => wrk_2d_20 , zv_sum => wrk_2d_21
+      !
       INTEGER, INTENT(in)  ::   kt   ! ocean time-step index
-      !!
+      !
       INTEGER  ::   ji, jj, jk, jn   ! dummy loop indices
-      INTEGER  ::   icycle           ! temporary scalar
-
-      REAL(wp) ::   zraur, zcoef, z2dt_e, z2dt_b     ! temporary scalars
-      REAL(wp) ::   z1_8, zx1, zy1                   !    -         -
-      REAL(wp) ::   z1_4, zx2, zy2                   !     -         -
-      REAL(wp) ::   zu_spg, zu_cor, zu_sld, zu_asp   !     -         -
-      REAL(wp) ::   zv_spg, zv_cor, zv_sld, zv_asp   !     -         -
-      !!
-      REAL(wp), DIMENSION(jpi,jpj) ::   zhdiv, zsshb_e
-      !!
-      REAL(wp), DIMENSION(jpi,jpj) ::   zbfru  , zbfrv     ! 2D workspace
-      !!
-      REAL(wp), DIMENSION(jpi,jpj) ::   zsshun_e, zsshvn_e   ! 2D workspace
-      !!
-      REAL(wp), DIMENSION(jpi,jpj) ::   zcu, zwx, zua, zun   ! 2D workspace
-      REAL(wp), DIMENSION(jpi,jpj) ::   zcv, zwy, zva, zvn   !  -      -
-      REAL(wp), DIMENSION(jpi,jpj) ::   zun_e, zub_e, zu_sum      ! 2D workspace
-      REAL(wp), DIMENSION(jpi,jpj) ::   zvn_e, zvb_e, zv_sum      !  -      -
-      REAL(wp), DIMENSION(jpi,jpj) ::   zssh_sum                  !  -      -
+      INTEGER  ::   icycle           ! local scalar
+      REAL(wp) ::   zraur, zcoef, z2dt_e, z2dt_b     ! local scalars
+      REAL(wp) ::   z1_8, zx1, zy1                   !   -      -
+      REAL(wp) ::   z1_4, zx2, zy2                   !   -      -
+      REAL(wp) ::   zu_spg, zu_cor, zu_sld, zu_asp   !   -      -
+      REAL(wp) ::   zv_spg, zv_cor, zv_sld, zv_asp   !   -      -
       !!----------------------------------------------------------------------
+
+      IF( wrk_in_use(2,  1, 2, 3, 4, 5, 6, 7, 8, 9,10,     &
+         &              11,12,13,14,15,16,17,18,19,20,21 ) ) THEN
+         CALL ctl_stop( 'dyn_spg_ts: requested workspace arrays unavailable' )   ;   RETURN
+      ENDIF
 
       IF( kt == nit000 ) THEN             !* initialisation
@@ -465 +477 @@
          !                                                      !         - Correct the velocity
 
-         IF( lk_obc               )   CALL obc_fla_ts
+         IF( lk_obc               )   CALL obc_fla_ts ( ua_e, va_e, sshn_e, ssha_e )
          IF( lk_bdy .OR. ln_tides )   CALL bdy_dyn_fla( sshn_e ) 
          !
@@ -550 +562 @@
       !
       !
+      IF( wrk_not_released(2,  1, 2, 3, 4, 5, 6, 7, 8, 9,10,         &
+         &                    11,12,13,14,15,16,17,18,19,20,21) )    &
+         CALL ctl_stop('dyn_spg_ts: failed to release workspace arrays')
+      !
    END SUBROUTINE dyn_spg_ts
 
@@ -623 +639 @@
 
          IF( iom_varid( numror, 'sshn_b', ldstop = .FALSE. ) > 0 ) THEN
-            CALL iom_get( numror, jpdom_autoglo, 'sshn_b' , sshn_b (:,:) )   ! filtered extrenal ssh
+            CALL iom_get( numror, jpdom_autoglo, 'sshn_b' , sshn_b (:,:) )   ! filtered ssh
          ELSE
-            sshn_b(:,:)=sshb(:,:)   ! if not in restart set previous time mean to current baroclinic before value   
+            sshn_b(:,:) = sshb(:,:)   ! if not in restart set previous time mean to current baroclinic before value   
          ENDIF 
       ELSEIF( TRIM(cdrw) == 'WRITE' ) THEN
@@ -640 +656 @@
    !!----------------------------------------------------------------------
 CONTAINS
-   SUBROUTINE dyn_spg_ts( kt )       ! Empty routine
+   INTEGER FUNCTION dyn_spg_ts_alloc()    ! Dummy function
+      dyn_spg_ts_alloc = 0
+   END FUNCTION dyn_spg_ts_alloc
+   SUBROUTINE dyn_spg_ts( kt )            ! Empty routine
+      INTEGER, INTENT(in) :: kt
       WRITE(*,*) 'dyn_spg_ts: You should not have seen this print! error?', kt
    END SUBROUTINE dyn_spg_ts
-   SUBROUTINE ts_rst( kt, cdrw )     ! Empty routine
+   SUBROUTINE ts_rst( kt, cdrw )          ! Empty routine
       INTEGER         , INTENT(in) ::   kt         ! ocean time-step
       CHARACTER(len=*), INTENT(in) ::   cdrw       ! "READ"/"WRITE" flag