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

Changeset 2618


Ignore:
Timestamp:
2011-02-26T13:31:38+01:00 (13 years ago)
Author:
gm
Message:

dynamic mem: #785 ; move dyn allocation from nemogcm to module when possible (continuation)

Location:
branches/dev_r2586_dynamic_mem/NEMOGCM/NEMO/OPA_SRC
Files:
28 edited

Legend:

Unmodified
Added
Removed

  • branches/dev_r2586_dynamic_mem/NEMOGCM/NEMO/OPA_SRC/DIA/diahth.F90

    r2613 r2618  
    5757      ! 
    5858   END FUNCTION dia_hth_alloc 
     59 
    5960 
    6061   SUBROUTINE dia_hth( kt ) 
    … …  
    104105 
    105106      IF( kt == nit000 ) THEN 
     107         !                                      ! allocate dia_hth array 
     108         IF( dia_hth_alloc() /= 0 )   CALL ctl_stop( 'STOP', 'lim_sbc_init : unable to allocate standard arrays' ) 
    106109 
    107110         IF(.not. ALLOCATED(ik20))THEN 
    108111            ALLOCATE(ik20(jpi,jpj), ik28(jpi,jpj), & 
    109                      zabs2(jpi,jpj),   & 
    110                      ztm2(jpi,jpj),    & 
    111                      zrho10_3(jpi,jpj),& 
    112                      zpycn(jpi,jpj),   & 
    113                      ztinv(jpi,jpj),   & 
    114                      zdepinv(jpi,jpj), & 
    115                      zrho0_3(jpi,jpj), & 
    116                      zrho0_1(jpi,jpj), & 
    117                      zmaxdzT(jpi,jpj), & 
    118                      zthick(jpi,jpj),  & 
    119                      zdelr(jpi,jpj), STAT=ji) 
     112               &      zabs2(jpi,jpj),   & 
     113               &      ztm2(jpi,jpj),    & 
     114               &      zrho10_3(jpi,jpj),& 
     115               &      zpycn(jpi,jpj),   & 
     116               &      ztinv(jpi,jpj),   & 
     117               &      zdepinv(jpi,jpj), & 
     118               &      zrho0_3(jpi,jpj), & 
     119               &      zrho0_1(jpi,jpj), & 
     120               &      zmaxdzT(jpi,jpj), & 
     121               &      zthick(jpi,jpj),  & 
     122               &      zdelr(jpi,jpj), STAT=ji) 
    120123            IF( lk_mpp  )   CALL mpp_sum(ji) 
    121124            IF( ji /= 0 )   CALL ctl_stop( 'STOP', 'dia_hth : unable to allocate standard ocean arrays' ) 

  • branches/dev_r2586_dynamic_mem/NEMOGCM/NEMO/OPA_SRC/DIA/diaptr.F90

    r2590 r2618  
    4141   PUBLIC   ptr_vj         ! call by tra_ldf & tra_adv routines 
    4242   PUBLIC   ptr_vjk        ! call by tra_ldf & tra_adv routines 
    43    PUBLIC   dia_ptr_alloc  ! call in nemogcm module 
    4443 
    4544   !                                           !!** namelist  namptr  ** 
    … …  
    5150   INTEGER , PUBLIC ::   nn_fwri    = 15        !: frequency of ptr outputs      [time step] 
    5251 
    53    REAL(wp), PUBLIC, DIMENSION(:), ALLOCATABLE ::   htr_adv, htr_ldf, htr_ove   !: Heat TRansports (adv, diff, overturn.) 
    54    REAL(wp), PUBLIC, DIMENSION(:), ALLOCATABLE ::   str_adv, str_ldf, str_ove   !: Salt TRansports (adv, diff, overturn.) 
     52   REAL(wp), ALLOCATABLE, SAVE, PUBLIC, DIMENSION(:) ::   htr_adv, htr_ldf, htr_ove   !: Heat TRansports (adv, diff, overturn.) 
     53   REAL(wp), ALLOCATABLE, SAVE, PUBLIC, DIMENSION(:) ::   str_adv, str_ldf, str_ove   !: Salt TRansports (adv, diff, overturn.) 
    5554    
    56    REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::   btmsk                  ! T-point basin interior masks 
    57    REAL(wp), DIMENSION(:,:)  , ALLOCATABLE ::   btm30                  ! mask out Southern Ocean (=0 south of 30°S) 
    58    REAL(wp), DIMENSION(:,:)  , ALLOCATABLE ::   htr  , str             ! adv heat and salt transports (approx) 
    59    REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::   tn_jk, sn_jk , v_msf   ! i-mean T and S, j-Stream-Function 
    60    REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::   sjk  , r1_sjk          ! i-mean i-k-surface and its inverse         
    61 #if defined key_diaeiv 
    62    REAL(wp), DIMENSION(:,:)  , ALLOCATABLE ::   htr_eiv, str_eiv   ! bolus adv heat ans salt transports    ('key_diaeiv') 
    63    REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::   v_msf_eiv          ! bolus j-streamfuction                 ('key_diaeiv') 
    64 #endif 
     55   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   btmsk                  ! T-point basin interior masks 
     56   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   btm30                  ! mask out Southern Ocean (=0 south of 30°S) 
     57   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   htr  , str             ! adv heat and salt transports (approx) 
     58   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   tn_jk, sn_jk , v_msf   ! i-mean T and S, j-Stream-Function 
     59   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   sjk  , r1_sjk          ! i-mean i-k-surface and its inverse         
     60   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   htr_eiv, str_eiv       ! bolus adv heat ans salt transports ('key_diaeiv') 
     61   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   v_msf_eiv              ! bolus j-streamfuction              ('key_diaeiv') 
     62 
    6563 
    6664   INTEGER ::   niter       ! 
    … …  
    7876   !! Integer, 1D workspace arrays. Not common enough to be implemented in  
    7977   !! wrk_nemo module. 
    80    INTEGER, ALLOCATABLE, SAVE, DIMENSION (:) :: ndex  , ndex_atl     , ndex_pac     , ndex_ind     , ndex_ipc 
    81    INTEGER, ALLOCATABLE, SAVE, DIMENSION (:) ::         ndex_atl_30  , ndex_pac_30  , ndex_ind_30  , ndex_ipc_30 
    82    INTEGER, ALLOCATABLE, SAVE, DIMENSION (:) :: ndex_h, ndex_h_atl_30, ndex_h_pac_30, ndex_h_ind_30, ndex_h_ipc_30 
     78   INTEGER, ALLOCATABLE, SAVE, DIMENSION(:) :: ndex  , ndex_atl     , ndex_pac     , ndex_ind     , ndex_ipc 
     79   INTEGER, ALLOCATABLE, SAVE, DIMENSION(:) ::         ndex_atl_30  , ndex_pac_30  , ndex_ind_30  , ndex_ipc_30 
     80   INTEGER, ALLOCATABLE, SAVE, DIMENSION(:) :: ndex_h, ndex_h_atl_30, ndex_h_pac_30, ndex_h_ind_30, ndex_h_ipc_30 
    8381 
    8482   !! * Substitutions 
    … …  
    9290CONTAINS 
    9391 
    94     FUNCTION dia_ptr_alloc() 
     92   FUNCTION dia_ptr_alloc() 
    9593      !!---------------------------------------------------------------------- 
    9694      !!                    ***  ROUTINE dia_ptr_alloc  *** 
    9795      !!---------------------------------------------------------------------- 
    98       INTEGER               :: dia_ptr_alloc 
    99       INTEGER, DIMENSION(5) :: ierr 
     96      INTEGER               ::   dia_ptr_alloc   ! return value 
     97      INTEGER, DIMENSION(5) ::   ierr 
    10098      !!---------------------------------------------------------------------- 
    10199 
    … …  
    103101 
    104102      ALLOCATE( btmsk(jpi,jpj,nptr) ,           & 
    105                 htr_adv(jpj) , str_adv(jpj) ,   & 
    106                 htr_ldf(jpj) , str_ldf(jpj) ,   & 
    107                 htr_ove(jpj) , str_ove(jpj),    & 
    108                 htr(jpj,nptr) , str(jpj,nptr) , & 
    109                 tn_jk(jpj,jpk,nptr) , sn_jk (jpj,jpk,nptr) , v_msf(jpj,jpk,nptr) , & 
    110                 sjk  (jpj,jpk,nptr) , r1_sjk(jpj,jpk,nptr) , STAT=ierr(1)  ) 
     103         &       htr_adv(jpj) , str_adv(jpj) ,   & 
     104         &       htr_ldf(jpj) , str_ldf(jpj) ,   & 
     105         &       htr_ove(jpj) , str_ove(jpj),    & 
     106         &       htr(jpj,nptr) , str(jpj,nptr) , & 
     107         &       tn_jk(jpj,jpk,nptr) , sn_jk (jpj,jpk,nptr) , v_msf(jpj,jpk,nptr) , & 
     108         &       sjk  (jpj,jpk,nptr) , r1_sjk(jpj,jpk,nptr) , STAT=ierr(1)  ) 
    111109         ! 
    112110#if defined key_diaeiv 
    113111      ALLOCATE( htr_eiv(jpj,nptr) , str_eiv(jpj,nptr) , & 
    114                 v_msf_eiv(jpj,jpk,nptr) , STAT=ierr(2) ) 
     112         &      v_msf_eiv(jpj,jpk,nptr) , STAT=ierr(2) ) 
    115113#endif 
    116114 
    … …  
    118116 
    119117      ALLOCATE(ndex(jpj*jpk),        ndex_atl(jpj*jpk), ndex_pac(jpj*jpk), & 
    120                ndex_ind(jpj*jpk),    ndex_ipc(jpj*jpk),                    & 
    121                ndex_atl_30(jpj*jpk), ndex_pac_30(jpj*jpk), Stat=ierr(4)) 
     118         &     ndex_ind(jpj*jpk),    ndex_ipc(jpj*jpk),                    & 
     119         &     ndex_atl_30(jpj*jpk), ndex_pac_30(jpj*jpk), Stat=ierr(4)) 
    122120 
    123121      ALLOCATE(ndex_ind_30(jpj*jpk), ndex_ipc_30(jpj*jpk),                   & 
    124                ndex_h(jpj),          ndex_h_atl_30(jpj), ndex_h_pac_30(jpj), & 
    125                ndex_h_ind_30(jpj),   ndex_h_ipc_30(jpj), Stat=ierr(5)) 
    126  
    127       dia_ptr_alloc = MAXVAL(ierr) 
    128  
     122         &     ndex_h(jpj),          ndex_h_atl_30(jpj), ndex_h_pac_30(jpj), & 
     123         &     ndex_h_ind_30(jpj),   ndex_h_ipc_30(jpj), Stat=ierr(5) ) 
     124         ! 
     125      dia_ptr_alloc = MAXVAL( ierr ) 
     126      IF(lk_mpp)   CALL mpp_sum( dia_ptr_alloc ) 
     127      ! 
    129128   END FUNCTION dia_ptr_alloc 
    130129 
    … …  
    141140      !! ** Action  : - p_fval: i-k-mean poleward flux of pva 
    142141      !!---------------------------------------------------------------------- 
    143       IMPLICIT none 
    144142      REAL(wp) , INTENT(in), DIMENSION(jpi,jpj,jpk) ::   pva   ! mask flux array at V-point 
    145143      !! 
    … …  
    160158         END DO 
    161159      END DO 
    162       ! 
    163 #if defined key_mpp_mpi 
    164       CALL mpp_sum( p_fval, ijpj, ncomm_znl) 
     160#if defined key_mpp_mpi 
     161      IF(lk_mpp)   CALL mpp_sum( p_fval, ijpj, ncomm_znl) 
    165162#endif 
    166163      ! 
    … …  
    196193         END DO 
    197194      END DO 
    198       ! 
    199195#if defined key_mpp_mpi 
    200196      CALL mpp_sum( p_fval, ijpj, ncomm_znl ) 
    … …  
    234230      ! 
    235231#if defined key_mpp_mpi 
    236       IF(.not. wrk_use(1, 1))THEN 
    237          CALL ctl_stop('ptr_vjk: ERROR - requested workspace array is unavailable') 
    238          RETURN 
     232      IF( .not. wrk_use(1, 1) ) THEN 
     233         CALL ctl_stop('ptr_vjk: ERROR - requested workspace array is unavailable')   ;   RETURN 
    239234      END IF 
    240235#endif 
    … …  
    272267      ! 
    273268#if defined key_mpp_mpi 
    274       IF(.not. wrk_release(1, 1))THEN 
    275          CALL ctl_stop('ptr_vjk: ERROR - failed to release workspace array') 
    276       END IF 
     269      IF(.NOT. wrk_release(1, 1) )   CALL ctl_stop('ptr_vjk: ERROR - failed to release workspace array') 
    277270#endif 
    278271      ! 
    … …  
    333326      ! 
    334327#if defined key_mpp_mpi 
    335       IF(.NOT. wrk_release(1, 1))THEN 
    336          CALL ctl_stop('ptr_tjk: failed to release workspace array.') 
    337       END IF 
     328      IF( .NOT. wrk_release(1, 1) )   CALL ctl_stop('ptr_tjk: failed to release workspace array.') 
    338329#endif 
    339330      !     
    … …  
    461452      NAMELIST/namptr/ ln_diaptr, ln_diaznl, ln_subbas, ln_ptrcomp, nn_fptr, nn_fwri 
    462453      !!---------------------------------------------------------------------- 
     454 
     455      !                                      ! allocate dia_ptr arrays 
     456      IF( dia_ptr_alloc() /= 0 )   CALL ctl_stop( 'STOP', 'lim_sbc_init : unable to allocate arrays' ) 
    463457 
    464458      REWIND( numnam )                 ! Read Namelist namptr : poleward transport parameters 
    … …  
    547541      !! 
    548542      INTEGER, SAVE ::   nhoridz, ndepidzt, ndepidzw 
    549       INTEGER, SAVE :: ndim  , ndim_atl     , ndim_pac     , ndim_ind     , ndim_ipc 
    550       INTEGER, SAVE ::         ndim_atl_30  , ndim_pac_30  , ndim_ind_30  , ndim_ipc_30 
    551       INTEGER, SAVE :: ndim_h, ndim_h_atl_30, ndim_h_pac_30, ndim_h_ind_30, ndim_h_ipc_30 
    552       !! 
    553       CHARACTER (len=40)       ::   clhstnam, clop, clop_once, cl_comment   ! temporary names 
    554       INTEGER                  ::   iline, it, itmod, ji, jj, jk            ! 
     543      INTEGER, SAVE ::   ndim  , ndim_atl     , ndim_pac     , ndim_ind     , ndim_ipc 
     544      INTEGER, SAVE ::           ndim_atl_30  , ndim_pac_30  , ndim_ind_30  , ndim_ipc_30 
     545      INTEGER, SAVE ::   ndim_h, ndim_h_atl_30, ndim_h_pac_30, ndim_h_ind_30, ndim_h_ipc_30 
     546      !! 
     547      CHARACTER (len=40) ::   clhstnam, clop, clop_once, cl_comment   ! temporary names 
     548      INTEGER            ::   iline, it, itmod, ji, jj, jk            ! 
    555549#if defined key_iomput 
    556       INTEGER                  ::   inum                                    ! temporary logical unit 
    557 #endif 
    558       REAL(wp)                 ::   zsto, zout, zdt, zjulian                ! temporary scalars 
     550      INTEGER            ::   inum                                    ! temporary logical unit 
     551#endif 
     552      REAL(wp)           ::   zsto, zout, zdt, zjulian                ! temporary scalars 
    559553      !!---------------------------------------------------------------------- 
    560554 
    561555      IF( (.not. wrk_use(1, 1,2)) .OR. (.not. wrk_use(2, 1)) )THEN 
    562          CALL ctl_stop('dia_ptr_wri: ERROR: requested workspace arrays unavailable') 
    563          RETURN 
     556         CALL ctl_stop('dia_ptr_wri: ERROR: requested workspace arrays unavailable')   ;   RETURN 
    564557      END IF 
    565558 
    … …  
    641634            zfoo(1:jpj) = 0._wp 
    642635 
    643             ! Compute julian date from starting date of the run 
    644  
    645             CALL ymds2ju( nyear, nmonth, nday, rdt, zjulian ) 
    646             zjulian = zjulian - adatrj   !   set calendar origin to the beginning of the experiment 
     636            CALL ymds2ju( nyear, nmonth, nday, rdt, zjulian )  ! Compute julian date from starting date of the run 
     637            zjulian = zjulian - adatrj                         ! set calendar origin to the beginning of the experiment 
    647638 
    648639#if defined key_iomput 
    … …  
    667658            CALL histvert( numptr, "depthw", "Vertical W levels",   & 
    668659               &                   "m", jpk, gdepw_0, ndepidzw, "down" ) 
    669  
    670660            ! 
    671661            CALL wheneq ( jpj*jpk, MIN(sjk(:,:,1), 1._wp), 1, 1., ndex  , ndim  )      ! Lat-Depth 
    … …  
    701691            cl_comment = '                      ' 
    702692#endif 
    703             !  Zonal mean T and S 
    704  
    705             IF( ln_diaznl ) THEN  
     693            IF( ln_diaznl ) THEN             !  Zonal mean T and S 
    706694               CALL histdef( numptr, "zotemglo", "Zonal Mean Temperature","C" ,   & 
    707695                  1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop, zsto, zout ) 
    … …  
    711699               CALL histdef( numptr, "zosrfglo", "Zonal Mean Surface","m^2"   ,   & 
    712700                  1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop_once, zsto, zout ) 
    713  
     701               ! 
    714702               IF (ln_subbas) THEN  
    715703                  CALL histdef( numptr, "zotematl", "Zonal Mean Temperature: Atlantic","C" ,   & 
    … …  
    741729                     1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop_once, zsto, zout ) 
    742730               ENDIF 
    743  
    744731            ENDIF 
    745  
     732            ! 
    746733            !  Meridional Stream-Function (Eulerian and Bolus) 
    747  
    748734            CALL histdef( numptr, "zomsfglo", "Meridional Stream-Function: Global"//TRIM(cl_comment),"Sv" ,   & 
    749735               1, jpj, nhoridz, jpk, 1, jpk, ndepidzw, 32, clop, zsto, zout ) 
    … …  
    758744                  1, jpj, nhoridz, jpk, 1, jpk, ndepidzw, 32, clop, zsto, zout ) 
    759745            ENDIF 
    760  
     746            ! 
    761747            !  Heat transport  
    762  
    763748            CALL histdef( numptr, "sophtadv", "Advective Heat Transport"      ,   & 
    764749               "PW", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout ) 
    … …  
    779764                  "PW", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout ) 
    780765            ENDIF 
    781  
    782  
     766            ! 
    783767            !  Salt transport  
    784  
    785768            CALL histdef( numptr, "sopstadv", "Advective Salt Transport"      ,   & 
    786769               "Giga g/s", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout ) 
    … …  
    810793                  "Giga g/s", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout ) 
    811794            ENDIF 
    812  
     795            ! 
    813796            CALL histend( numptr ) 
    814  
     797            ! 
    815798         END IF 
    816799#if defined key_mpp_mpi 
    … …  
    886869      ENDIF 
    887870      ! 
    888       IF( (.not. wrk_release(1, 1,2)) .OR. (.not. wrk_release(2, 1)) )THEN 
    889          CALL ctl_stop('dia_ptr_wri: ERROR: failed to release workspace arrays') 
    890       END IF 
     871      IF( .not. wrk_release(1, 1,2) .OR. (.not. wrk_release(2, 1)) )   & 
     872         CALL ctl_stop('dia_ptr_wri: failed to release workspace arrays') 
    891873      ! 
    892874  END SUBROUTINE dia_ptr_wri 

  • branches/dev_r2586_dynamic_mem/NEMOGCM/NEMO/OPA_SRC/DOM/dom_oce.F90

    r2590 r2618  
    77   !! History :  1.0  ! 2005-10  (A. Beckmann, G. Madec)  reactivate s-coordinate  
    88   !!            3.3  ! 2010-11  (G. Madec) add mbk. arrays associated to the deepest ocean level 
    9    !!---------------------------------------------------------------------- 
    10    USE par_oce      ! ocean parameters 
     9   !!            4.0  ! 2011-01  (A. R. Porter, STFC Daresbury) dynamical allocation 
     10   !!---------------------------------------------------------------------- 
     11 
     12   !!---------------------------------------------------------------------- 
     13   !!   Agrif_Root    : dummy function used when lk_agrif=F 
     14   !!   Agrif_CFixed  : dummy function used when lk_agrif=F 
     15   !!   dom_oce_alloc : dynamical allocation of dom_oce arrays 
     16   !!---------------------------------------------------------------------- 
     17   USE par_oce        ! ocean parameters 
    1118 
    1219   IMPLICIT NONE 
    13    PUBLIC           ! allows the acces to par_oce when dom_oce is used 
    14    !                ! exception to coding rules... to be suppressed ??? 
     20   PUBLIC             ! allows the acces to par_oce when dom_oce is used 
     21   !                  ! exception to coding rules... to be suppressed ??? 
     22 
     23   PUBLIC dom_oce_alloc  ! Called from nemogcm.F90 
    1524 
    1625   !!---------------------------------------------------------------------- 
    … …  
    4453   REAL(wp), PUBLIC ::   rdth            !: depth variation of tracer step 
    4554   INTEGER , PUBLIC ::   nclosea         !: =0 suppress closed sea/lake from the ORCA domain or not (=1) 
    46  
    4755 
    4856   !                                                  !!! associated variables 
    … …  
    216224#endif 
    217225 
    218    PUBLIC dom_oce_alloc  ! Called from nemogcm.F90 
    219  
    220226   !!---------------------------------------------------------------------- 
    221227   !! agrif domain 
    … …  
    227233#endif 
    228234 
     235   !!---------------------------------------------------------------------- 
     236   !! NEMO/OPA 4.0 , NEMO Consortium (2011) 
     237   !! $Id$  
     238   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt) 
     239   !!---------------------------------------------------------------------- 
    229240CONTAINS 
    230241 
    231242#if ! defined key_agrif 
     243   !!---------------------------------------------------------------------- 
     244   !! NOT 'key_agrif'      dummy function                     No AGRIF zoom 
     245   !!---------------------------------------------------------------------- 
    232246   LOGICAL FUNCTION Agrif_Root() 
    233247      Agrif_Root = .TRUE. 
    … …  
    235249 
    236250   CHARACTER(len=3) FUNCTION Agrif_CFixed() 
    237      Agrif_CFixed = '0'  
     251      Agrif_CFixed = '0'  
    238252   END FUNCTION Agrif_CFixed 
    239253#endif 
    240254 
    241    FUNCTION dom_oce_alloc() 
    242      !!---------------------------------------------------------------------- 
    243      USE par_oce, Only: jpi, jpj, jpk, jpnij 
    244      IMPLICIT none 
    245      INTEGER :: dom_oce_alloc 
    246      INTEGER, DIMENSION(11) :: ierr 
    247      
    248      ierr(:) = 0 
    249  
    250      ALLOCATE(rdttra(jpk), mig(jpi), mjg(jpj), Stat=ierr(1)) 
    251  
    252      ALLOCATE(nimppt(jpnij), njmppt(jpnij), & 
    253               ibonit(jpnij), ibonjt(jpnij), & 
    254               nlcit(jpnij), nlcjt(jpnij),   & 
    255               nldit(jpnij), nldjt(jpnij),   & 
    256               nleit(jpnij), nlejt(jpnij), Stat=ierr(2)) 
    257  
    258      ALLOCATE(glamt(jpi,jpj), glamu(jpi,jpj), &  
    259               glamv(jpi,jpj), glamf(jpi,jpj), &   
    260               gphit(jpi,jpj), gphiu(jpi,jpj), &   
    261               gphiv(jpi,jpj), gphif(jpi,jpj), &   
    262               e1t(jpi,jpj), e2t(jpi,jpj),     &   
    263               e1u(jpi,jpj), e2u(jpi,jpj),     &   
    264               e1v(jpi,jpj), e2v(jpi,jpj),     &   
    265               e1f(jpi,jpj), e2f(jpi,jpj),     &   
    266               ff(jpi,jpj), Stat=ierr(3))      
    267  
    268     !IF( .not. lk_zco )THEN 
    269      ALLOCATE(gdep3w(jpi,jpj,jpk),                        & 
    270               gdept(jpi,jpj,jpk) , gdepw(jpi,jpj,jpk),    & 
    271               e3v(jpi,jpj,jpk)   , e3f(jpi,jpj,jpk)  ,    & 
    272               e3t(jpi,jpj,jpk)   , e3u(jpi,jpj,jpk)  ,    & 
    273               e3vw(jpi,jpj,jpk)  ,                        & 
    274               e3w(jpi,jpj,jpk)   , e3uw(jpi,jpj,jpk) , Stat=ierr(4)) 
    275     !END IF 
     255   INTEGER FUNCTION dom_oce_alloc() 
     256      !!---------------------------------------------------------------------- 
     257      INTEGER, DIMENSION(11) :: ierr 
     258      !!---------------------------------------------------------------------- 
     259 
     260      ierr(:) = 0 
     261 
     262      ALLOCATE( rdttra(jpk), mig(jpi), mjg(jpj), STAT=ierr(1) ) 
     263 
     264      ALLOCATE( nimppt(jpnij) , ibonit(jpnij) , nlcit(jpnij) , nlcjt(jpnij) ,     & 
     265         &      njmppt(jpnij) , ibonjt(jpnij) , nldit(jpnij) , nldjt(jpnij) ,     & 
     266         &                                      nleit(jpnij) , nlejt(jpnij) , STAT=ierr(2) ) 
     267 
     268      ALLOCATE( glamt(jpi,jpj), gphit(jpi,jpj), e1t(jpi,jpj), e2t(jpi,jpj),                  &  
     269         &      glamu(jpi,jpj), gphiu(jpi,jpj), e1u(jpi,jpj), e2u(jpi,jpj),                  &   
     270         &      glamv(jpi,jpj), gphiv(jpi,jpj), e1v(jpi,jpj), e2v(jpi,jpj),                  &   
     271         &      glamf(jpi,jpj), gphif(jpi,jpj), e1f(jpi,jpj), e2f(jpi,jpj), ff(jpi,jpj), STAT=ierr(3) )      
     272 
     273      ALLOCATE( gdep3w(jpi,jpj,jpk) , e3v(jpi,jpj,jpk) , e3f (jpi,jpj,jpk) ,                         & 
     274         &      gdept (jpi,jpj,jpk) , e3t(jpi,jpj,jpk) , e3u (jpi,jpj,jpk) ,                         & 
     275         &      gdepw (jpi,jpj,jpk) , e3w(jpi,jpj,jpk) , e3vw(jpi,jpj,jpk) , e3uw(jpi,jpj,jpk) , STAT=ierr(4) ) 
    276276 
    277277#if defined key_vvl 
    278      ALLOCATE(gdep3w_1(jpi,jpj,jpk)       ,  & 
    279               gdept_1(jpi,jpj,jpk), gdepw_1(jpi,jpj,jpk),  & 
    280               e3v_1(jpi,jpj,jpk)  , e3f_1(jpi,jpj,jpk)  ,  & 
    281               e3t_1(jpi,jpj,jpk)  , e3u_1(jpi,jpj,jpk)  ,  & 
    282               e3vw_1(jpi,jpj,jpk) ,                        &  
    283               e3w_1(jpi,jpj,jpk)  , e3uw_1(jpi,jpj,jpk),   & 
    284               e3t_b(jpi,jpj,jpk)  ,                        & 
    285               e3u_b(jpi,jpj,jpk)  , e3v_b(jpi,jpj,jpk),    & 
    286               Stat=ierr(5)) 
    287 #endif 
    288  
    289     ALLOCATE(hur(jpi,jpj), hvr(jpi,jpj),  & 
    290              hu(jpi,jpj),  hv(jpi,jpj),   & 
    291              hu_0(jpi,jpj), hv_0(jpi,jpj),& 
    292              Stat=ierr(6)) 
     278      ALLOCATE( gdep3w_1(jpi,jpj,jpk) , e3v_1(jpi,jpj,jpk) , e3f_1 (jpi,jpj,jpk) ,                           & 
     279         &      gdept_1 (jpi,jpj,jpk) , e3t_1(jpi,jpj,jpk) , e3u_1 (jpi,jpj,jpk) ,                           & 
     280         &      gdepw_1 (jpi,jpj,jpk) , e3w_1(jpi,jpj,jpk) , e3vw_1(jpi,jpj,jpk) , e3uw_1(jpi,jpj,jpk) ,     & 
     281         &      e3t_b   (jpi,jpj,jpk) , e3u_b(jpi,jpj,jpk) , e3v_b(jpi,jpj,jpk)                        , STAT=ierr(5) ) 
     282#endif 
     283 
     284      ALLOCATE( hu(jpi,jpj) , hur(jpi,jpj) , hu_0(jpi,jpj) ,     & 
     285         &      hv(jpi,jpj) , hvr(jpi,jpj) , hv_0(jpi,jpj) , STAT=ierr(6) ) 
     286 
     287      ALLOCATE( gdept_0(jpk) , gdepw_0(jpk) ,                                     & 
     288         &      e3t_0  (jpk) , e3w_0  (jpk) , e3tp (jpi,jpj), e3wp(jpi,jpj) ,     & 
     289         &      gsigt  (jpk) , gsigw  (jpk) , gsi3w(jpk)    ,                     & 
     290         &      esigt  (jpk) , esigw  (jpk)                                 , STAT=ierr(7) ) 
    293291    ! 
    294     ALLOCATE(gdept_0(jpk), gdepw_0(jpk),  e3t_0(jpk),    & 
    295              e3w_0(jpk)  , e3tp(jpi,jpj), e3wp(jpi,jpj), & 
    296              gsigt(jpk)  , gsigw(jpk)   , gsi3w(jpk),    & 
    297              esigt(jpk)  , esigw(jpk)   , Stat=ierr(7)) 
    298     ! 
    299     ALLOCATE(hbatv(jpi,jpj) , hbatf(jpi,jpj) ,   & 
    300              hbatt(jpi,jpj) , hbatu(jpi,jpj) ,   & 
    301              scosrf(jpi,jpj), scobot(jpi,jpj),   & 
    302              hifv(jpi,jpj)  , hiff(jpi,jpj)  ,   & 
    303              hift(jpi,jpj)  , hifu(jpi,jpj)  ,   & 
    304              Stat=ierr(8)) 
    305     ! 
    306     ALLOCATE(mbathy(jpi,jpj),                             & 
    307              mbkt(jpi,jpj), mbku(jpi,jpj), mbkv(jpi,jpj), & 
    308              bathy(jpi,jpj),                              & 
    309              tmask_i(jpi,jpj),bmask(jpi,jpj),             & 
    310              Stat=ierr(9)) 
    311  
    312     ALLOCATE(tmask(jpi,jpj,jpk), umask(jpi,jpj,jpk),    &  
    313              vmask(jpi,jpj,jpk), fmask(jpi,jpj,jpk),    & 
    314              Stat=ierr(10)) 
     292      ALLOCATE( hbatv (jpi,jpj) , hbatf (jpi,jpj) ,     & 
     293         &      hbatt (jpi,jpj) , hbatu (jpi,jpj) ,     & 
     294         &      scosrf(jpi,jpj) , scobot(jpi,jpj) ,     & 
     295         &      hifv  (jpi,jpj) , hiff  (jpi,jpj) ,     & 
     296         &      hift  (jpi,jpj) , hifu  (jpi,jpj) , STAT=ierr(8) ) 
     297 
     298      ALLOCATE( mbathy(jpi,jpj) , bathy(jpi,jpj) ,                     & 
     299         &     tmask_i(jpi,jpj) , bmask(jpi,jpj) ,                     & 
     300         &     mbkt   (jpi,jpj) , mbku (jpi,jpj) , mbkv(jpi,jpj) , STAT=ierr(9) ) 
     301 
     302      ALLOCATE( tmask(jpi,jpj,jpk), umask(jpi,jpj,jpk),     &  
     303         &      vmask(jpi,jpj,jpk), fmask(jpi,jpj,jpk), STAT=ierr(10) ) 
    315304 
    316305#if defined key_noslip_accurate 
    317     ALLOCATE(npcoa(4,jpk), nicoa(2*(jpi+jpj),4,jpk), njcoa(2*(jpi+jpj),4,jpk), & 
    318              Stat=ierr(11)) 
    319 #endif 
    320  
    321     dom_oce_alloc = MAXVAL(ierr) 
    322  
    323   END FUNCTION dom_oce_alloc 
    324  
    325    !!---------------------------------------------------------------------- 
    326    !! NEMO/OPA 3.3 , NEMO Consortium (2010) 
    327    !! $Id$  
    328    !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt) 
     306      ALLOCATE( npcoa(4,jpk), nicoa(2*(jpi+jpj),4,jpk), njcoa(2*(jpi+jpj),4,jpk), STAT=ierr(11) ) 
     307#endif 
     308      ! 
     309      dom_oce_alloc = MAXVAL(ierr) 
     310      ! 
     311   END FUNCTION dom_oce_alloc 
     312 
    329313   !!====================================================================== 
    330314END MODULE dom_oce 

  • branches/dev_r2586_dynamic_mem/NEMOGCM/NEMO/OPA_SRC/DOM/domvvl.F90

    r2590 r2618  
    2727   PUBLIC   dom_vvl_alloc ! called by nemogcm.F90 
    2828 
    29    REAL(wp), PUBLIC, ALLOCATABLE, SAVE,   DIMENSION(:,:) ::   ee_t, ee_u, ee_v, ee_f   !: ??? 
    30    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   mut, muu, muv, muf       !: ???  
    31  
    32    REAL(wp),         ALLOCATABLE, SAVE,     DIMENSION(:) ::   r2dt   ! vertical profile time-step, = 2 rdttra  
    33       !                                 ! except at nit000 (=rdttra) if neuler=0 
     29   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)  ::   ee_t, ee_u, ee_v, ee_f   !: ??? 
     30   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   mut , muu , muv , muf    !: ???  
     31 
     32   REAL(wp),         ALLOCATABLE, SAVE, DIMENSION(:)    ::   r2dt   ! vertical profile time-step, = 2 rdttra  
     33      !                                                              ! except at nit000 (=rdttra) if neuler=0 
    3434 
    3535   !! * Substitutions 
    … …  
    3737#  include "vectopt_loop_substitute.h90" 
    3838   !!---------------------------------------------------------------------- 
    39    !! NEMO/OPA 3.3 , NEMO Consortium (2010) 
     39   !! NEMO/OPA 4.0 , NEMO Consortium (2011) 
    4040   !! $Id$ 
    41    !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 
    42    !!---------------------------------------------------------------------- 
    43  
     41   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt) 
     42   !!---------------------------------------------------------------------- 
    4443CONTAINS        
    4544 
    46    FUNCTION dom_vvl_alloc() 
     45   INTEGER FUNCTION dom_vvl_alloc() 
    4746      !!---------------------------------------------------------------------- 
    4847      !!                ***  ROUTINE dom_vvl_alloc  *** 
    4948      !!---------------------------------------------------------------------- 
    50       IMPLICIT none 
    51       INTEGER :: dom_vvl_alloc 
    52       !!---------------------------------------------------------------------- 
    53  
    54       ALLOCATE(mut(jpi,jpj,jpk), muu(jpi,jpj,jpk), muv(jpi,jpj,jpk),       & 
    55                muf(jpi,jpj,jpk),                                           & 
    56                ee_t(jpi,jpj), ee_u(jpi,jpj), ee_v(jpi,jpj), ee_f(jpi,jpj), & 
    57                r2dt(jpk), Stat=dom_vvl_alloc) 
    58  
    59       IF(dom_vvl_alloc /= 0)THEN 
    60          CALL ctl_warn('dom_vvl_alloc: failed to allocate arrays') 
    61       END IF 
    62  
     49      ! 
     50      ALLOCATE( mut (jpi,jpj,jpk) , muu (jpi,jpj,jpk) , muv (jpi,jpj,jpk) , muf (jpi,jpj,jpk) ,    & 
     51         &      ee_t(jpi,jpj)     , ee_u(jpi,jpj)     , ee_v(jpi,jpj)     , ee_f(jpi,jpj)     ,    & 
     52         &      r2dt(jpk)                                                                     , STAT=dom_vvl_alloc) 
     53         ! 
     54      IF( lk_mpp             )   CALL mpp_sum ( dom_vvl_alloc ) 
     55      IF( dom_vvl_alloc /= 0 )   CALL ctl_warn('dom_vvl_alloc: failed to allocate arrays') 
     56      ! 
    6357   END FUNCTION dom_vvl_alloc 
    6458 
    … …  
    7165      !!               ssh over the whole water column (scale factors) 
    7266      !!---------------------------------------------------------------------- 
    73       USE wrk_nemo, ONLY: wrk_use, wrk_release 
    74       USE wrk_nemo, ONLY: zs_t   => wrk_2d_1, zs_u_1 => wrk_2d_2, & 
    75                           zs_v_1 => wrk_2d_3 
     67      USE wrk_nemo, ONLY:   wrk_use, wrk_release 
     68      USE wrk_nemo, ONLY:   zs_t   => wrk_2d_1, zs_u_1 => wrk_2d_2 
     69      USE wrk_nemo, ONLY:   zs_v_1 => wrk_2d_3 
    7670      !! 
    7771      INTEGER  ::   ji, jj, jk 
    78       REAL(wp) ::   zcoefu , zcoefv   , zcoeff                   ! temporary scalars 
    79       REAL(wp) ::   zv_t_ij, zv_t_ip1j, zv_t_ijp1, zv_t_ip1jp1   !     -        - 
     72      REAL(wp) ::   zcoefu , zcoefv   , zcoeff                   ! local scalars 
     73      REAL(wp) ::   zv_t_ij, zv_t_ip1j, zv_t_ijp1, zv_t_ip1jp1   !   -      - 
    8074      !!---------------------------------------------------------------------- 
    8175 
    8276      IF(.not. wrk_use(2, 1,2,3))THEN 
    83          CALL ctl_stop('dom_vvl: ERROR - requested workspace arrays unavailable.') 
    84          RETURN 
     77         CALL ctl_stop('dom_vvl: ERROR - requested workspace arrays unavailable.')   ;   RETURN 
    8578      END IF 
    8679 
    87       IF(lwp)   THEN 
     80      IF(lwp) THEN 
    8881         WRITE(numout,*) 
    89          WRITE(numout,*) 'dom_vvl : Variable volume activated' 
     82         WRITE(numout,*) 'dom_vvl : Variable volume initialization' 
    9083         WRITE(numout,*) '~~~~~~~~  compute coef. used to spread ssh over each layers' 
    9184      ENDIF 
    92  
     85       
     86      IF( dom_vvl_alloc /= 0 )   CALL ctl_stop( 'STOP', 'dom_vvl : unable to allocate arrays' ) 
    9387 
    9488      fsdept(:,:,:) = gdept (:,:,:) 

  • branches/dev_r2586_dynamic_mem/NEMOGCM/NEMO/OPA_SRC/DOM/domwri.F90

    r2590 r2618  
    22   !!====================================================================== 
    33   !!                       ***  MODULE domwri  *** 
    4    !! Ocean initialization : write the ocean domain mesh ask file(s) 
     4   !! Ocean initialization : write the ocean domain mesh file(s) 
    55   !!====================================================================== 
    66   !! History :  OPA  ! 1997-02  (G. Madec)  Original code 
    77   !!            8.1  ! 1999-11  (M. Imbard)  NetCDF FORMAT with IOIPSL 
    88   !!   NEMO     1.0  ! 2002-08  (G. Madec)  F90 and several file 
     9   !!            3.0  ! 2008-01  (S. Masson) add dom_uniq  
     10   !!            4.0  ! 2011-01  (A. R. Porter, STFC Daresbury) dynamical allocation 
    911   !!---------------------------------------------------------------------- 
    1012 
    1113   !!---------------------------------------------------------------------- 
    1214   !!   dom_wri        : create and write mesh and mask file(s) 
    13    !!                    nmsh = 1  :   mesh_mask file 
    14    !!                         = 2  :   mesh and mask file 
    15    !!                         = 3  :   mesh_hgr, mesh_zgr and mask 
     15   !!   dom_uniq       : 
    1616   !!---------------------------------------------------------------------- 
    1717   USE dom_oce         ! ocean space and time domain 
    … …  
    2525 
    2626   PUBLIC dom_wri        ! routine called by inidom.F90 
    27    PUBLIC dom_wri_alloc  ! routine called by nemogcm.F90 
    28  
    29    LOGICAL, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::  lldbl  ! Used in dom_uniq to store whether each point is unique or not 
    3027 
    3128   !! * Substitutions 
    … …  
    3734   !!---------------------------------------------------------------------- 
    3835CONTAINS 
    39  
    40    FUNCTION dom_wri_alloc() 
    41       !!---------------------------------------------------------------------- 
    42       !!                  ***  ROUTINE dom_wri_alloc  *** 
    43       !!---------------------------------------------------------------------- 
    44       INTEGER :: dom_wri_alloc 
    45       !!---------------------------------------------------------------------- 
    46  
    47       ALLOCATE(lldbl(jpi,jpj,1), Stat = dom_wri_alloc) 
    48  
    49    END FUNCTION dom_wri_alloc 
    50  
    5136 
    5237   SUBROUTINE dom_wri 
    … …  
    144129      CALL iom_rstput( 0, 0, inum2, 'fmask', fmask, ktype = jp_i1 ) 
    145130       
    146       CALL dom_uniq(zprw, 'T') 
     131      CALL dom_uniq( zprw, 'T' ) 
    147132      zprt = tmask(:,:,1) * zprw                               !    ! unique point mask 
    148133      CALL iom_rstput( 0, 0, inum2, 'tmaskutil', zprt, ktype = jp_i1 )   
    149       CALL dom_uniq(zprw, 'U') 
     134      CALL dom_uniq( zprw, 'U' ) 
    150135      zprt = umask(:,:,1) * zprw 
    151136      CALL iom_rstput( 0, 0, inum2, 'umaskutil', zprt, ktype = jp_i1 )   
    152       CALL dom_uniq(zprw, 'V') 
     137      CALL dom_uniq( zprw, 'V' ) 
    153138      zprt = vmask(:,:,1) * zprw 
    154139      CALL iom_rstput( 0, 0, inum2, 'vmaskutil', zprt, ktype = jp_i1 )   
    155       CALL dom_uniq(zprw, 'F') 
     140      CALL dom_uniq( zprw, 'F' ) 
    156141      zprt = fmask(:,:,1) * zprw 
    157142      CALL iom_rstput( 0, 0, inum2, 'fmaskutil', zprt, ktype = jp_i1 )   
    … …  
    283268 
    284269 
    285    SUBROUTINE dom_uniq(puniq, cdgrd ) 
     270   SUBROUTINE dom_uniq( puniq, cdgrd ) 
    286271      !!---------------------------------------------------------------------- 
    287272      !!                  ***  ROUTINE dom_uniq  *** 
    … …  
    296281      USE wrk_nemo, ONLY: ztstref => wrk_2d_1      ! array with different values for each element 
    297282     !! 
    298       CHARACTER(len=1)            , INTENT(in   ) ::  cdgrd   !  
    299       REAL(wp), DIMENSION(:,:)    , INTENT(inout) ::  puniq   !  
    300       ! 
    301       REAL(wp)                       ::  zshift    ! shift value link to the process number 
    302       INTEGER                        ::  ji        ! dummy loop indices 
    303       !!---------------------------------------------------------------------- 
    304  
    305       IF(.not. wrk_use(2, 1))THEN 
    306          CALL ctl_stop('dom_uniq: ERROR - requested workspace array unavailable.') 
    307          RETURN 
     283      CHARACTER(len=1)        , INTENT(in   ) ::   cdgrd   !  
     284      REAL(wp), DIMENSION(:,:), INTENT(inout) ::   puniq   !  
     285      ! 
     286      REAL(wp) ::  zshift   ! shift value link to the process number 
     287      INTEGER  ::  ji       ! dummy loop indices 
     288      LOGICAL, DIMENSION(SIZE(puniq,1),SIZE(puniq,2),1) ::  lldbl  ! store whether each point is unique or not 
     289      !!---------------------------------------------------------------------- 
     290 
     291      IF( .not. wrk_use(2, 1) ) THEN 
     292         CALL ctl_stop('dom_uniq: ERROR - requested workspace array unavailable.')   ;   RETURN 
    308293      END IF 
    309294 

  • branches/dev_r2586_dynamic_mem/NEMOGCM/NEMO/OPA_SRC/DTA/dtasal.F90

    r2590 r2618  
    2525   PRIVATE 
    2626 
    27    PUBLIC   dta_sal        ! called by step.F90 and inidta.F90 
    28    PUBLIC   dta_sal_alloc  ! Called by nemogcm.F90 
    29  
    30    LOGICAL , PUBLIC, PARAMETER              :: lk_dtasal = .TRUE. !: salinity data flag 
    31    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: s_dta !: salinity data at given time-step 
    32  
    33    TYPE(FLD), ALLOCATABLE, DIMENSION(:) ::   sf_sal       ! structure of input SST (file informations, fields read) 
     27   PUBLIC   dta_sal    ! called by step.F90 and inidta.F90 
     28 
     29   LOGICAL , PUBLIC, PARAMETER                     ::   lk_dtasal = .TRUE. !: salinity data flag 
     30   REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:,:) ::   s_dta              !: salinity data at given time-step 
     31 
     32   TYPE(FLD), ALLOCATABLE, DIMENSION(:) ::   sf_sal   ! structure of input SST (file informations, fields read) 
    3433 
    3534   !! * Substitutions 
    3635#  include "domzgr_substitute.h90" 
    3736   !!---------------------------------------------------------------------- 
    38    !! NEMO/OPA 3.3 , NEMO Consortium (2010) 
     37   !! NEMO/OPA 4.0 , NEMO Consortium (2011) 
    3938   !! $Id$  
    4039   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt) 
    4140   !!---------------------------------------------------------------------- 
    4241CONTAINS 
    43  
    44    FUNCTION dta_sal_alloc() 
    45      IMPLICIT none 
    46      INTEGER :: dta_sal_alloc 
    47      INTEGER :: ierr 
    48  
    49      ALLOCATE(s_dta(jpi,jpj,jpk),  & 
    50               sf_sal(1),           & 
    51               Stat=ierr) 
    52      IF(ierr <= 0)THEN 
    53         ALLOCATE( sf_sal(1)%fnow(jpi,jpj,jpk)   ) 
    54      END IF 
    55  
    56      dta_sal_alloc = ierr 
    57  
    58    END FUNCTION dta_sal_alloc 
    5942 
    6043   SUBROUTINE dta_sal( kt ) 
    … …  
    6952      !!                between two monthly values. 
    7053      !!---------------------------------------------------------------------- 
    71       INTEGER, INTENT(in) ::   kt             ! ocean time step 
     54      INTEGER, INTENT(in) ::   kt   ! ocean time step 
    7255      ! 
    73       INTEGER ::   ji, jj, jk, jl, jkk            ! dummy loop indicies 
    74       INTEGER ::   ik, ierror                     ! temporary integers 
     56      INTEGER ::   ji, jj, jk, jl, jkk       ! local loop indicies 
     57      INTEGER ::   ik, ierr0, ierr1, ierr2   ! local integers 
    7558#if defined key_tradmp 
    76       INTEGER ::   il0, il1, ii0, ii1, ij0, ij1   ! temporary integers 
     59      INTEGER ::   il0, il1, ii0, ii1, ij0, ij1   ! local integers 
    7760#endif 
    7861      REAL(wp)::   zl 
    … …  
    10588            WRITE(numout,*) '~~~~~~~ ' 
    10689         ENDIF 
    107 ! ARPDBG moved first two allocate's into dta_sal_alloc() 
    108 !!$         ALLOCATE( sf_sal(1), STAT=ierror ) 
    109 !!$         IF( ierror > 0 ) THEN 
    110 !!$             CALL ctl_stop( 'dta_sal: unable to allocate sf_sal structure' )   ;   RETURN 
    111 !!$         ENDIF 
    112 !!$                                ALLOCATE( sf_sal(1)%fnow(jpi,jpj,jpk)   ) 
    113          IF( sn_sal%ln_tint )   ALLOCATE( sf_sal(1)%fdta(jpi,jpj,jpk,2) ) 
     90                                ALLOCATE( sf_sal(1)                    , STAT=ierr0 ) 
     91                                ALLOCATE( sf_sal(1)%fnow(jpi,jpj,jpk)  , STAT=ierr1 ) 
     92         IF( sn_sal%ln_tint )   ALLOCATE( sf_sal(1)%fdta(jpi,jpj,jpk,2), STAT=ierr2 ) 
     93         IF( ierr0+ierr1+ierr2 > 0 )   CALL ctl_stop( 'STOP', 'dta_sal: unable to allocate sf_sal structure' ) 
    11494         !                         ! fill sf_sal with sn_sal and control print 
    11595         CALL fld_fill( sf_sal, (/ sn_sal /), cn_dir, 'dta_sal', 'Salinity data', 'namdta_sal' ) 

  • branches/dev_r2586_dynamic_mem/NEMOGCM/NEMO/OPA_SRC/DTA/dtatem.F90

    r2590 r2618  
    2525   PRIVATE 
    2626 
    27    PUBLIC   dta_tem        ! called by step.F90 and inidta.F90 
    28    PUBLIC   dta_tem_alloc  ! called by nemo_init in nemogcm.F90 
    29  
    30    LOGICAL , PUBLIC, PARAMETER ::   lk_dtatem = .TRUE.   !: temperature data flag 
    31    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: t_dta !: temperature data at given time-step 
     27   PUBLIC   dta_tem    ! called by step.F90 and inidta.F90 
     28 
     29   LOGICAL , PUBLIC, PARAMETER                     ::   lk_dtatem = .TRUE. !: temperature data flag 
     30   REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:,:) ::   t_dta              !: temperature data at given time-step 
    3231 
    3332   TYPE(FLD), ALLOCATABLE, DIMENSION(:) ::   sf_tem      ! structure of input SST (file informations, fields read) 
    … …  
    3635#  include "domzgr_substitute.h90" 
    3736   !!---------------------------------------------------------------------- 
    38    !! NEMO/OPA 3.3 , NEMO Consortium (2010) 
     37   !! NEMO/OPA 4.0 , NEMO Consortium (2011) 
    3938   !! $Id$  
    4039   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt) 
    4140   !!---------------------------------------------------------------------- 
    4241CONTAINS 
    43  
    44    FUNCTION dta_tem_alloc() 
    45      IMPLICIT none 
    46      INTEGER :: dta_tem_alloc 
    47      INTEGER :: ierror 
    48      ALLOCATE(t_dta(jpi,jpj,jpk), & 
    49               sf_tem(1),          & 
    50               STAT=ierror ) 
    51      IF( ierror <= 0 ) THEN 
    52         ALLOCATE( sf_tem(1)%fnow(jpi,jpj,jpk), STAT=ierror   ) 
    53      END IF 
    54  
    55      dta_tem_alloc = ierror 
    56  
    57    END FUNCTION dta_tem_alloc 
    58  
    5942 
    6043   SUBROUTINE dta_tem( kt ) 
    … …  
    7558      !! ** Action  :   define t_dta array at time-step kt 
    7659      !!---------------------------------------------------------------------- 
    77       INTEGER, INTENT( in ) ::   kt     ! ocean time-step 
     60      INTEGER, INTENT( in ) ::   kt   ! ocean time-step 
    7861      ! 
    79       INTEGER ::   ji, jj, jk, jl, jkk            ! dummy loop indicies 
    80       INTEGER ::   ik, ierror                     ! temporary integers 
     62      INTEGER ::   ji, jj, jk, jl, jkk       ! dummy loop indicies 
     63      INTEGER ::   ik, ierr0, ierr1, ierr2   ! local integers 
    8164#if defined key_tradmp 
    82       INTEGER ::   il0, il1, ii0, ii1, ij0, ij1   ! temporary integers 
     65      INTEGER ::   il0, il1, ii0, ii1, ij0, ij1   ! local integers 
    8366#endif 
    8467      REAL(wp)::   zl 
    … …  
    11295            WRITE(numout,*) '~~~~~~~ ' 
    11396         ENDIF 
    114 ! ARPDBG - moved into dta_tem_alloc() 
    115 !!$         ALLOCATE( sf_tem(1), STAT=ierror ) 
    116 !!$         IF( ierror > 0 ) THEN 
    117 !!$             CALL ctl_stop( 'dta_tem: unable to allocate sf_tem structure' )   ;   RETURN 
    118 !!$         ENDIF 
    119 !!$                                ALLOCATE( sf_tem(1)%fnow(jpi,jpj,jpk)   ) 
    120          IF( sn_tem%ln_tint )   ALLOCATE( sf_tem(1)%fdta(jpi,jpj,jpk,2) ) 
     97                                ALLOCATE( sf_tem(1)                    , STAT=ierr0 ) 
     98                                ALLOCATE( sf_tem(1)%fnow(jpi,jpj,jpk)  , STAT=ierr1 ) 
     99         IF( sn_tem%ln_tint )   ALLOCATE( sf_tem(1)%fdta(jpi,jpj,jpk,2), STAT=ierr2 ) 
     100         IF( ierr0+ierr1+ierr2 > 0 )   CALL ctl_stop( 'STOP', 'dta_sal: unable to allocate sf_sal structure' ) 
    121101         !                         ! fill sf_tem with sn_tem and control print 
    122102         CALL fld_fill( sf_tem, (/ sn_tem /), cn_dir, 'dta_tem', 'Temperature data', 'namdta_tem' ) 

  • branches/dev_r2586_dynamic_mem/NEMOGCM/NEMO/OPA_SRC/DYN/divcur.F90

    r2592 r2618  
    3535   PRIVATE 
    3636 
    37    PUBLIC   div_cur       ! routine called by step.F90 and istate.F90 
    38    PUBLIC   div_cur_alloc ! routine called by nemogcm.F90 
    39  
    40    ! These workspace arrays are not replaced by wrk_nemo because they  
    41    ! have extents greater than (jpi,jpj) 
    42    REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) ::   zwu   ! workspace 
    43    REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) ::   zwv   ! workspace 
     37   PUBLIC   div_cur    ! routine called by step.F90 and istate.F90 
    4438 
    4539   !! * Substitutions 
    … …  
    5347CONTAINS 
    5448 
    55    FUNCTION div_cur_alloc() 
    56       !!---------------------------------------------------------------------- 
    57       !!               ***  ROUTINE div_cur_alloc  *** 
    58       !!---------------------------------------------------------------------- 
    59       INTEGER :: div_cur_alloc 
    60       !!---------------------------------------------------------------------- 
    61  
    62       div_cur_alloc = 0 
    63  
    6449#if defined key_noslip_accurate 
    65       ALLOCATE(zwu( jpi, 1:jpj+2), zwv(-1:jpi+2, jpj), Stat=div_cur_alloc) 
    66 #endif 
    67  
    68       IF(div_cur_alloc /= 0)THEN 
    69          CALL ctl_warn('div_cur_alloc: failed to allocate arrays.') 
    70       END IF 
    71  
    72    END FUNCTION div_cur_alloc 
    73  
    74 #if defined key_noslip_accurate 
    75    !!---------------------------------------------------------------------- 
    76    !!   'key_noslip_accurate'                     2nd order centered scheme 
    77    !!                                                4th order at the coast 
     50   !!---------------------------------------------------------------------- 
     51   !!   'key_noslip_accurate'   2nd order interior + 4th order at the coast 
    7852   !!---------------------------------------------------------------------- 
    7953 
    … …  
    8357      !! 
    8458      !! ** Purpose :   compute the horizontal divergence and the relative 
    85       !!      vorticity at before and now time-step 
     59      !!              vorticity at before and now time-step 
    8660      !! 
    8761      !! ** Method  : I.  divergence : 
    … …  
    10781      !!              - update rotb , rotn , the before & now rel. vorticity 
    10882      !!---------------------------------------------------------------------- 
    109       INTEGER, INTENT( in ) ::   kt      ! ocean time-step index 
    110       ! 
    111       INTEGER ::   ji, jj, jk     ! dummy loop indices 
    112       INTEGER ::   ii, ij, jl     ! temporary integer 
    113       INTEGER ::   ijt, iju       ! temporary integer 
    114       REAL(wp) ::  zraur, zdep 
     83      INTEGER, INTENT(in) ::   kt   ! ocean time-step index 
     84      ! 
     85      REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) ::   zwu   ! specific 2D workspace 
     86      REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) ::   zwv   ! specific 2D workspace 
     87      ! 
     88      INTEGER ::   ji, jj, jk, jl           ! dummy loop indices 
     89      INTEGER ::   ii, ij, ijt, iju, ierr   ! local integer 
     90      REAL(wp) ::  zraur, zdep              ! local scalar 
    11591      !!---------------------------------------------------------------------- 
    11692 
    … …  
    11995         IF(lwp) WRITE(numout,*) 'div_cur : horizontal velocity divergence and relative vorticity' 
    12096         IF(lwp) WRITE(numout,*) '~~~~~~~   NOT optimal for auto-tasking case' 
     97         ! 
     98         ALLOCATE( zwu( jpi, 1:jpj+2) , zwv(-1:jpi+2, jpj) , Stat=ierr ) 
     99         IF( lk_mpp    )   CALL mpp_sum( ierr ) 
     100         IF( ierr /= 0 )   CALL ctl_stop( 'STOP', 'div_cur : unable to allocate arrays' ) 
    121101      ENDIF 
    122102 

  • branches/dev_r2586_dynamic_mem/NEMOGCM/NEMO/OPA_SRC/DYN/dynldf_bilapg.F90

    r2590 r2618  
    44   !! Ocean dynamics:  lateral viscosity trend 
    55   !!====================================================================== 
     6   !! History :  OPA  !  1997-07  (G. Madec)  Original code 
     7   !!  NEMO      1.0  !  2002-08  (G. Madec)  F90: Free form and module 
     8   !!            2.0  !  2004-08  (C. Talandier) New trends organization 
     9   !!---------------------------------------------------------------------- 
    610#if defined key_ldfslp   ||   defined key_esopa 
    711   !!---------------------------------------------------------------------- 
    … …  
    1216   !!   ldfguv         :  
    1317   !!---------------------------------------------------------------------- 
    14    !! * Modules used 
    1518   USE oce             ! ocean dynamics and tracers 
    1619   USE dom_oce         ! ocean space and time domain 
    … …  
    2730   PRIVATE 
    2831 
    29    !! * Routine accessibility 
    30    PUBLIC dyn_ldf_bilapg       ! called by step.F90 
    31    PUBLIC dyn_ldf_bilapg_alloc ! called by nemogcm.F90 
    32  
    33    ! These are just workspace arrays but since they're (jpi,jpk) it's not 
    34    ! worth putting them in the wrk_nemo module. 
    35    REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) ::  zfuw, zfvw, zdiu, zdiv 
    36    REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) ::  zdju, zdj1u, zdjv, zdj1v  
     32   PUBLIC   dyn_ldf_bilapg       ! called by step.F90 
     33 
     34   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) ::  zfuw, zfvw , zdiu, zdiv   ! 2D workspace (ldfguv) 
     35   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) ::  zdju, zdj1u, zdjv, zdj1v  ! 2D workspace (ldfguv) 
    3736 
    3837   !! * Substitutions 
    … …  
    4746CONTAINS 
    4847 
    49    FUNCTION dyn_ldf_bilapg_alloc() 
     48   INTEGER FUNCTION dyn_ldf_bilapg_alloc() 
    5049      !!---------------------------------------------------------------------- 
    5150      !!               ***  ROUTINE dyn_ldf_bilapg_alloc  *** 
    5251      !!---------------------------------------------------------------------- 
    53       INTEGER :: dyn_ldf_bilapg_alloc 
    54  
    55       ALLOCATE(zfuw(jpi,jpk), zfvw(jpi,jpk),  zdiu(jpi,jpk), zdiv(jpi,jpk), & 
    56                zdju(jpi,jpk), zdj1u(jpi,jpk), zdjv(jpi,jpk), zdj1v(jpi,jpk),& 
    57                Stat = dyn_ldf_bilapg_alloc) 
    58  
    59       IF(dyn_ldf_bilapg_alloc /= 0)THEN 
    60          CALL ctl_warn('dyn_ldf_bilapg_alloc: failed to allocate arrays') 
    61       END IF 
    62  
     52      ! 
     53      ALLOCATE( zfuw(jpi,jpk) , zfvw (jpi,jpk) , zdiu(jpi,jpk) , zdiv (jpi,jpk) ,     & 
     54         &      zdju(jpi,jpk) , zdj1u(jpi,jpk) , zdjv(jpi,jpk) , zdj1v(jpi,jpk) , STAT=dyn_ldf_bilapg_alloc) 
     55         ! 
     56      IF( dyn_ldf_bilapg_alloc /= 0 )   CALL ctl_warn('dyn_ldf_bilapg_alloc: failed to allocate arrays') 
     57      ! 
    6358   END FUNCTION dyn_ldf_bilapg_alloc 
    6459 
    … …  
    9085      !!                biharmonic mixing trend. 
    9186      !!              - save the trend in (zwk3,zwk4) ('key_trddyn') 
    92       !! 
    93       !! History : 
    94       !!   8.0  !  97-07  (G. Madec)  Original code 
    95       !!   8.5  !  02-08  (G. Madec)  F90: Free form and module 
    96       !!   9.0  !  04-08  (C. Talandier) New trends organization 
    97       !!---------------------------------------------------------------------- 
    98       !! * Modules used      
    99       USE oce, ONLY :    zwk3 => ta,   & ! use ta as 3D workspace    
    100                          zwk4 => sa      ! use sa as 3D workspace    
    101       USE wrk_nemo, ONLY: wrk_use, wrk_release 
    102       ! work array used for rotated biharmonic operator on  
    103       ! tracers and/or momentum 
    104       USE wrk_nemo, ONLY: zwk1 => wrk_3d_1, &  
    105                           zwk2 => wrk_3d_2 
    106       !! * Arguments 
     87      !!---------------------------------------------------------------------- 
     88      USE wrk_nemo, ONLY:   wrk_use, wrk_release 
     89      USE wrk_nemo, ONLY:   zwk1 => wrk_3d_1 , zwk2 => wrk_3d_2   ! 3D workspace 
     90      USE oce     , ONLY:   zwk3 => ta       , zwk4 => sa         ! ta, sa used as 3D workspace    
     91      ! 
    10792      INTEGER, INTENT( in ) ::   kt           ! ocean time-step index 
    108  
    109       !! * Local declarations 
     93      ! 
    11094      INTEGER ::   ji, jj, jk                 ! dummy loop indices 
    11195      !!---------------------------------------------------------------------- 
    11296 
    113       IF(.NOT. wrk_use(3, 1,2))THEN 
    114          CALL ctl_stop('dyn_ldf_bilapg: requested workspace arrays unavailable.') 
    115          RETURN 
     97      IF( .NOT. wrk_use(3, 1,2) ) THEN 
     98         CALL ctl_stop('dyn_ldf_bilapg: requested workspace arrays unavailable.')   ;   RETURN 
    11699      END IF 
    117100 
    … …  
    122105         zwk1(:,:,:) = 0.e0   ;   zwk3(:,:,:) = 0.e0 
    123106         zwk2(:,:,:) = 0.e0   ;   zwk4(:,:,:) = 0.e0 
     107         !                                      ! allocate dyn_ldf_bilapg arrays 
     108         IF( dyn_ldf_bilapg_alloc() /= 0 )   CALL ctl_stop('STOP', 'dyn_ldf_bilapg: failed to allocate arrays') 
    124109      ENDIF 
    125110 
    126111      ! Laplacian of (ub,vb) multiplied by ahm 
    127112      ! --------------------------------------   
    128       ! rotated harmonic operator applied to (ub,vb) 
    129       !     and multiply by ahmu, ahmv (output in (zwk1,zwk2) ) 
    130  
    131       CALL ldfguv ( ub, vb, zwk1, zwk2, 1 ) 
    132  
    133  
    134       ! Lateral boundary conditions on (zwk1,zwk2) 
    135       CALL lbc_lnk( zwk1, 'U', -1. ) 
    136       CALL lbc_lnk( zwk2, 'V', -1. ) 
    137  
     113      CALL ldfguv( ub, vb, zwk1, zwk2, 1 )      ! rotated harmonic operator applied to (ub,vb) 
     114      !                                         ! and multiply by ahmu, ahmv (output in (zwk1,zwk2) ) 
     115      CALL lbc_lnk( zwk1, 'U', -1. )   ;   CALL lbc_lnk( zwk2, 'V', -1. )     ! Lateral boundary conditions 
    138116 
    139117      ! Bilaplacian of (ub,vb) 
    140118      ! ----------------------  
    141       ! rotated harmonic operator applied to (zwk1,zwk2) (output in (zwk3,zwk4) ) 
    142  
    143       CALL ldfguv ( zwk1, zwk2, zwk3, zwk4, 2 ) 
    144  
    145  
    146       ! Update the momentum trends           (j-slab :   2, jpj-1) 
     119      CALL ldfguv( zwk1, zwk2, zwk3, zwk4, 2 )  ! rotated harmonic operator applied to (zwk1,zwk2)  
     120      !                                         ! (output in (zwk3,zwk4) ) 
     121 
     122      ! Update the momentum trends 
    147123      ! -------------------------- 
    148       !                                                ! =============== 
    149       DO jj = 2, jpjm1                                 !  Vertical slab 
    150          !                                             ! =============== 
     124      DO jj = 2, jpjm1               ! add the diffusive trend to the general momentum trends 
    151125         DO jk = 1, jpkm1 
    152126            DO ji = 2, jpim1 
    153                ! add the diffusive trend to the general momentum trends 
    154127               ua(ji,jj,jk) = ua(ji,jj,jk) + zwk3(ji,jj,jk) 
    155128               va(ji,jj,jk) = va(ji,jj,jk) + zwk4(ji,jj,jk) 
    156129            END DO 
    157130         END DO 
    158          !                                             ! =============== 
    159       END DO                                           !   End of slab 
    160       !                                                ! =============== 
    161       IF(.NOT. wrk_release(3, 1,2))THEN 
    162          CALL ctl_stop('dyn_ldf_bilapg: failed to release workspace arrays.') 
    163       END IF 
     131      END DO 
     132      ! 
     133      IF( .NOT. wrk_release(3, 1,2) )   CALL ctl_stop('dyn_ldf_bilapg: failed to release workspace arrays') 
    164134      ! 
    165135   END SUBROUTINE dyn_ldf_bilapg 
    … …  
    206176      !!                          second order vertical derivative term) 
    207177      !!      'key_trddyn' defined: the trend is saved for diagnostics. 
    208       !! 
    209       !! History : 
    210       !!   8.0  !  97-07  (G. Madec)  Original code 
    211       !!   8.5  !  02-08  (G. Madec)  F90: Free form and module 
    212178      !!---------------------------------------------------------------------- 
    213179      USE wrk_nemo, ONLY: wrk_use, wrk_release 
    … …  
    216182      USE wrk_nemo, ONLY: zdkv => wrk_2d_7, zdk1v => wrk_2d_8 
    217183      !! 
    218       !! * Arguments 
    219       REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT( in ) ::   & 
    220          pu, pv     ! momentum fields (before u and v for the 1st call, and 
    221       !             ! laplacian of these fields multiplied by ahm for the 2nd 
    222       REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT( out ) ::   & 
    223          plu, plv   ! partial harmonic operator applied to 
    224       !             ! pu and pv (all the components except 
    225       !             ! second order vertical derivative term) 
    226       INTEGER, INTENT( in ) ::   & 
    227          kahm       ! =1 the laplacian is multiplied by the eddy diffusivity coef. 
    228       !             ! =2 no multiplication 
    229  
    230       !! * Local declarations 
    231       INTEGER  ::   ji, jj, jk       ! dummy loop indices 
    232       REAL(wp) ::   & 
    233          zabe1, zabe2, zcof1, zcof2,    &  ! temporary scalars 
    234          zcoef0, zcoef3, zcoef4 
    235       REAL(wp) ::   & 
    236          zbur, zbvr, zmkt, zmkf, zuav, zvav,    & 
    237          zuwslpi, zuwslpj, zvwslpi, zvwslpj 
    238       !!---------------------------------------------------------------------- 
    239  
    240       IF(.NOT. wrk_use(2, 1,2,3,4,5,6,7,8))THEN 
    241          CALL ctl_stop('dyn:ldfguv : requested workspace arrays unavailable.') 
    242          RETURN 
     184      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in   ) ::   pu , pv    ! 1st call: before horizontal velocity  
     185      !                                                               ! 2nd call: ahm x these fields 
     186      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(  out) ::   plu, plv   ! partial harmonic operator applied to 
     187      !                                                               ! pu and pv (all the components except 
     188      !                                                               ! second order vertical derivative term) 
     189      INTEGER                         , INTENT(in   ) ::   kahm       ! =1 1st call ; =2 2nd call 
     190      ! 
     191      INTEGER  ::   ji, jj, jk   ! dummy loop indices 
     192      REAL(wp) ::   zabe1 , zabe2 , zcof1 , zcof2        ! local scalar 
     193      REAL(wp) ::   zcoef0, zcoef3, zcoef4               !   -      - 
     194      REAL(wp) ::   zbur, zbvr, zmkt, zmkf, zuav, zvav   !   -      - 
     195      REAL(wp) ::   zuwslpi, zuwslpj, zvwslpi, zvwslpj   !   -      - 
     196      !!---------------------------------------------------------------------- 
     197 
     198      IF( .NOT. wrk_use(2, 1,2,3,4,5,6,7,8) ) THEN 
     199         CALL ctl_stop('dyn:ldfguv : requested workspace arrays unavailable.')   ;   RETURN 
    243200      END IF 
    244201      !                               ! ********** !   ! =============== 

  • branches/dev_r2586_dynamic_mem/NEMOGCM/NEMO/OPA_SRC/DYN/dynldf_iso.F90

    r2590 r2618  
    44   !! Ocean dynamics:  lateral viscosity trend 
    55   !!====================================================================== 
     6   !! History :  OPA  !  97-07  (G. Madec)  Original code 
     7   !!  NEMO      1.0  !  2002-08  (G. Madec)  F90: Free form and module 
     8   !!             -   !  2004-08  (C. Talandier) New trends organization 
     9   !!            2.0  !  2005-11  (G. Madec)  s-coordinate: horizontal diffusion 
     10   !!---------------------------------------------------------------------- 
    611#if defined key_ldfslp   ||   defined key_esopa 
    712   !!---------------------------------------------------------------------- 
    … …  
    1217   !!                  tal s-coordinate laplacian operator. 
    1318   !!---------------------------------------------------------------------- 
    14    !! * Modules used 
    1519   USE oce             ! ocean dynamics and tracers 
    1620   USE dom_oce         ! ocean space and time domain 
    … …  
    2832   PRIVATE 
    2933 
    30    !! * Routine accessibility 
    31    PUBLIC dyn_ldf_iso           ! called by step.F90 
    32    PUBLIC dyn_ldf_iso_alloc     ! called by nemogcm.F90 
    33  
    34    ! These are just workspace arrays but because they are (jpi,jpk) in extent 
    35    ! we can't use the arrays in wrk_nemo for them 
    36    REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: zfuw, zdiu, zdju, zdj1u 
    37    REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: zfvw, zdiv, zdjv, zdj1v 
     34   PUBLIC   dyn_ldf_iso           ! called by step.F90 
     35   PUBLIC   dyn_ldf_iso_alloc     ! called by nemogcm.F90 
     36 
     37   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: zfuw, zdiu, zdju, zdj1u   ! 2D workspace (dyn_ldf_iso)  
     38   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: zfvw, zdiv, zdjv, zdj1v   !  -      - 
    3839 
    3940   !! * Substitutions 
    … …  
    4243#  include "vectopt_loop_substitute.h90" 
    4344   !!---------------------------------------------------------------------- 
    44    !! NEMO/OPA 3.3 , NEMO Consortium (2010) 
     45   !! NEMO/OPA 3.3 , NEMO Consortium (2011) 
    4546   !! $Id$ 
    46    !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 
    47    !!---------------------------------------------------------------------- 
    48  
     47   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt) 
     48   !!---------------------------------------------------------------------- 
    4949CONTAINS 
    5050 
    51    FUNCTION dyn_ldf_iso_alloc() 
     51   INTEGER FUNCTION dyn_ldf_iso_alloc() 
    5252      !!---------------------------------------------------------------------- 
    5353      !!                  ***  ROUTINE dyn_ldf_iso_alloc  *** 
    5454      !!---------------------------------------------------------------------- 
    55       INTEGER :: dyn_ldf_iso_alloc 
    56       !!---------------------------------------------------------------------- 
    57  
    58       ALLOCATE(zfuw(jpi,jpk), zdiu(jpi,jpk), zdju(jpi,jpk), zdj1u(jpi,jpk), &  
    59                zfvw(jpi,jpk), zdiv(jpi,jpk), zdjv(jpi,jpk), zdj1v(jpi,jpk), & 
    60                Stat=dyn_ldf_iso_alloc) 
    61  
    62       IF(dyn_ldf_iso_alloc /= 0)THEN 
    63          CALL ctl_warn('dyn_ldf_iso_alloc: array allocate failed.') 
    64       END IF 
    65  
     55      ! 
     56      ALLOCATE( zfuw(jpi,jpk) , zdiu(jpi,jpk) , zdju(jpi,jpk) , zdj1u(jpi,jpk) ,     &  
     57         &      zfvw(jpi,jpk) , zdiv(jpi,jpk) , zdjv(jpi,jpk) , zdj1v(jpi,jpk) , STAT=dyn_ldf_iso_alloc) 
     58         ! 
     59      IF( dyn_ldf_iso_alloc /= 0 )   CALL ctl_warn('dyn_ldf_iso_alloc: array allocate failed.') 
     60      ! 
    6661   END FUNCTION dyn_ldf_iso_alloc 
    6762 
    … …  
    110105      !!        Update (avmu,avmv) to accompt for the diagonal vertical component 
    111106      !!      of the rotated operator in dynzdf module 
    112       !! 
    113       !! History : 
    114       !!   8.0  !  97-07  (G. Madec)  Original code 
    115       !!   8.5  !  02-08  (G. Madec)  F90: Free form and module 
    116       !!   9.0  !  04-08  (C. Talandier) New trends organization 
    117       !!        !  05-11  (G. Madec)  s-coordinate: horizontal diffusion 
    118107      !!---------------------------------------------------------------------- 
    119       USE wrk_nemo, ONLY: wrk_use, wrk_release 
    120       USE wrk_nemo, ONLY: ziut => wrk_2d_1, zjuf  => wrk_2d_2, & ! temporary workspace 
    121                           zjvt => wrk_2d_3, zivf  => wrk_2d_4, &  
    122                           zdku => wrk_2d_5, zdk1u => wrk_2d_6, & 
    123                           zdkv => wrk_2d_7, zdk1v => wrk_2d_8 
    124       !! 
    125       !! * Arguments 
    126       INTEGER, INTENT( in ) ::   kt       ! ocean time-step index 
    127  
    128       !! * Local declarations 
    129       INTEGER  ::   ji, jj, jk            ! dummy loop indices 
    130       REAL(wp) ::   & 
    131          zabe1, zabe2, zcof1, zcof2,   &  ! temporary scalars 
    132          zmskt, zmskf, zbu, zbv,       & 
    133          zuah, zvah 
    134  
    135       REAL(wp) ::   & 
    136          zcoef0, zcoef3, zcoef4, zmkt, zmkf,   & 
    137          zuav, zvav, zuwslpi, zuwslpj, zvwslpi, zvwslpj 
    138  
     108      USE wrk_nemo, ONLY:   wrk_use, wrk_release 
     109      USE wrk_nemo, ONLY:   ziut  => wrk_2d_1 , zjuf  => wrk_2d_2 , zjvt => wrk_2d_3    ! 2D workspace 
     110      USE wrk_nemo, ONLY:   zivf  => wrk_2d_4 , zdku  => wrk_2d_5 , zdkv => wrk_2d_6    ! 2D workspace 
     111      USE wrk_nemo, ONLY:   zdk1u => wrk_2d_7 , zdk1v => wrk_2d_8 
     112      ! 
     113      INTEGER, INTENT( in ) ::   kt   ! ocean time-step index 
     114      ! 
     115      INTEGER  ::   ji, jj, jk   ! dummy loop indices 
     116      REAL(wp) ::   zabe1, zabe2, zcof1, zcof2                       ! local scalars 
     117      REAL(wp) ::   zmskt, zmskf, zbu, zbv, zuah, zvah               !   -      - 
     118      REAL(wp) ::   zcoef0, zcoef3, zcoef4, zmkt, zmkf               !   -      - 
     119      REAL(wp) ::   zuav, zvav, zuwslpi, zuwslpj, zvwslpi, zvwslpj   !   -      - 
    139120      !!---------------------------------------------------------------------- 
    140121 
    141       IF( .NOT. wrk_use(2, 1,2,3,4,5,6,7,8))THEN 
    142          CALL ctl_stop('dyn_ldf_iso: requested workspace arrays unavailable.') 
    143          RETURN 
     122      IF( .NOT. wrk_use(2, 1,2,3,4,5,6,7,8) ) THEN 
     123         CALL ctl_stop('dyn_ldf_iso: requested workspace arrays unavailable.')   ;   RETURN 
    144124      END IF 
    145125 
    … …  
    148128         IF(lwp) WRITE(numout,*) 'dyn_ldf_iso : iso-neutral laplacian diffusive operator or ' 
    149129         IF(lwp) WRITE(numout,*) '~~~~~~~~~~~   s-coordinate horizontal diffusive operator' 
     130         !                                      ! allocate dyn_ldf_bilap arrays 
     131         IF( dyn_ldf_iso_alloc() /= 0 )   CALL ctl_stop('STOP', 'dyn_ldf_iso: failed to allocate arrays') 
    150132      ENDIF 
    151133 
    152 !     ! s-coordinate: Iso-level diffusion on momentum but not on tracer 
     134      ! s-coordinate: Iso-level diffusion on momentum but not on tracer 
    153135      IF( ln_dynldf_hor .AND. ln_traldf_iso ) THEN 
    154   
    155          ! set the slopes of iso-level 
    156          DO jk = 1, jpk 
     136         ! 
     137         DO jk = 1, jpk         ! set the slopes of iso-level 
    157138            DO jj = 2, jpjm1 
    158139               DO ji = fs_2, fs_jpim1   ! vector opt. 
    … …  
    164145            END DO 
    165146         END DO 
    166   
    167147         ! Lateral boundary conditions on the slopes 
    168148         CALL lbc_lnk( uslp , 'U', -1. )      ;      CALL lbc_lnk( vslp , 'V', -1. ) 
    … …  
    170150  
    171151!!bug 
    172          if( kt == nit000 ) then 
    173             IF(lwp) WRITE(numout,*) ' max slop: u',SQRT( MAXVAL(uslp*uslp)), ' v ', SQRT(MAXVAL(vslp)),  & 
    174                &                             ' wi', sqrt(MAXVAL(wslpi)), ' wj', sqrt(MAXVAL(wslpj)) 
     152         IF( kt == nit000 ) then 
     153            IF(lwp) WRITE(numout,*) ' max slop: u', SQRT( MAXVAL(uslp*uslp)), ' v ', SQRT(MAXVAL(vslp)),  & 
     154               &                             ' wi', sqrt(MAXVAL(wslpi))     , ' wj', sqrt(MAXVAL(wslpj)) 
    175155         endif 
    176156!!end 

  • branches/dev_r2586_dynamic_mem/NEMOGCM/NEMO/OPA_SRC/DYN/dynspg.F90

    r2590 r2618  
    9191!!gm             they return the after velocity, not the trends (as in trazdf_imp...) 
    9292!!gm             In this case, change/simplify dynnxt 
    93  
    9493 
    9594 
    … …  
    181180      ENDIF 
    182181 
     182      !                        ! allocate dyn_spg arrays 
     183      IF( lk_dynspg_ts  .AND. dyn_spg_ts_alloc () /= 0 )   CALL ctl_stop('STOP', 'dyn_spg_init: failed to allocate ts  arrays') 
     184 
    183185      !                        ! Control of surface pressure gradient scheme options 
    184186      ioptio = 0 

  • branches/dev_r2586_dynamic_mem/NEMOGCM/NEMO/OPA_SRC/DYN/dynspg_exp.F90

    r2528 r2618  
    4242   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 
    4343   !!---------------------------------------------------------------------- 
    44  
    4544CONTAINS 
    4645 

  • branches/dev_r2586_dynamic_mem/NEMOGCM/NEMO/OPA_SRC/DYN/dynspg_flt.F90

    r2528 r2618  
    6565   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 
    6666   !!---------------------------------------------------------------------- 
    67  
    6867CONTAINS 
    6968 

  • branches/dev_r2586_dynamic_mem/NEMOGCM/NEMO/OPA_SRC/DYN/dynspg_oce.F90

    r2590 r2618  
    55   !! Ocean dynamics: Define in memory surface pressure gradient variables 
    66   !!====================================================================== 
    7    !! History :  1.0  !  05-12  (C. Talandier, G. Madec)  Original code 
     7   !! History :  1.0  ! 2005-12  (C. Talandier, G. Madec)  Original code 
    88   !!            3.2  ! 2009-07  (R. Benshila) Suppression of rigid-lid option 
    99   !!---------------------------------------------------------------------- 
    … …  
    3030#endif 
    3131 
    32 !!gm BUG : always required in _ts, only  some of them in vvl 
    33 !    #if   defined key_dynspg_ts   ||   defined key_esopa 
    34 !!gm end 
    35 #if   defined key_dynspg_ts   ||   defined key_vvl   ||   defined key_esopa 
    36   !                                                                !!! Time splitting scheme (sub-time step variables) 
    37    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ua_e  , va_e             ! barotropic velocities (after) 
    38    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sshn_e, ssha_e, sshn_b   ! sea surface heigth (now, after, average) 
    39    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hu_e  , hv_e             ! now ocean depth ( = Ho+sshn_e ) 
    40    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hur_e , hvr_e            ! inverse of the now depth ( = 1/(Ho+sshn_e) ) 
    41 #endif 
    42  
    4332   !!---------------------------------------------------------------------- 
    44    !! NEMO/OPA 3.2 , LODYC-IPSL  (2009) 
     33   !! NEMO/OPA 4.0 , LODYC-IPSL  (2011) 
    4534   !! $Id$  
    46    !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 
     35   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt) 
    4736   !!====================================================================== 
    48 CONTAINS 
    49  
    50   FUNCTION dynspg_oce_alloc() 
    51     IMPLICIT none 
    52     INTEGER :: dynspg_oce_alloc 
    53  
    54     dynspg_oce_alloc = 0 
    55  
    56 #if   defined key_dynspg_ts   ||   defined key_vvl   ||   defined key_esopa 
    57     ALLOCATE(ua_e(jpi,jpj),   va_e(jpi,jpj)  ,                  & 
    58              sshn_e(jpi,jpj), ssha_e(jpi,jpj), sshn_b(jpi,jpj), & 
    59              hu_e(jpi,jpj),   hv_e(jpi,jpj)  ,                  & 
    60              hur_e(jpi,jpj),  hvr_e(jpi,jpj) ,                  & 
    61              Stat=dynspg_oce_alloc) 
    62 #endif 
    63  
    64   END FUNCTION dynspg_oce_alloc 
    65  
    6637END MODULE dynspg_oce 

  • branches/dev_r2586_dynamic_mem/NEMOGCM/NEMO/OPA_SRC/DYN/dynspg_ts.F90

    r2613 r2618  
    3838   USE prtctl          ! Print control 
    3939   USE in_out_manager  ! I/O manager 
    40    USE iom 
     40   USE iom             ! IOM library 
    4141   USE restart         ! only for lrst_oce 
    4242   USE zdf_oce 
    … …  
    5353   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) ::  ftsw, ftse   ! (only used with een vorticity scheme) 
    5454 
    55    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   un_b, vn_b   ! now    averaged velocity 
    56    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   ub_b, vb_b   ! before averaged velocity 
    57  
     55   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   un_b, vn_b       ! now    averaged velocity 
     56   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   ub_b, vb_b       ! before averaged velocity 
     57   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   ua_e  , va_e     ! barotropic velocities (after) 
     58   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   sshn_e, ssha_e   ! sea surface heigth (now, after, average) 
     59   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hu_e  , hv_e     ! now ocean depth ( = Ho+sshn_e ) 
     60   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hur_e , hvr_e    ! inverse of the now depth ( = 1/(Ho+sshn_e) ) 
    5861 
    5962   !! * Substitutions 
    6063#  include "domzgr_substitute.h90" 
    6164#  include "vectopt_loop_substitute.h90" 
    62    !!------------------------------------------------------------------------- 
    63    !! NEMO/OPA 3.3 , NEMO Consortium (2010) 
     65   !!---------------------------------------------------------------------- 
     66   !! NEMO/OPA 4.0 , NEMO Consortium (2011) 
    6467   !! $Id$ 
    65    !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 
    66    !!------------------------------------------------------------------------- 
    67  
     68   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt) 
     69   !!---------------------------------------------------------------------- 
    6870CONTAINS 
    6971 
    70    FUNCTION dyn_spg_ts_alloc() 
     72   INTEGER FUNCTION dyn_spg_ts_alloc() 
    7173      !!---------------------------------------------------------------------- 
    7274      !!                  ***  routine dyn_spg_ts_alloc  *** 
    7375      !!---------------------------------------------------------------------- 
    74       INTEGER ::   dyn_spg_ts_alloc   ! return value 
    75       !!---------------------------------------------------------------------- 
    76       ! 
    77       ALLOCATE(ftnw(jpi,jpj), ftne(jpi,jpj), ftsw(jpi,jpj), ftse(jpi,jpj), & 
    78          &      un_b(jpi,jpj), vn_b(jpi,jpj), ub_b(jpi,jpj), vb_b(jpi,jpj), & 
    79          &      STAT=dyn_spg_ts_alloc) 
    80          ! 
     76      ! 
     77      ALLOCATE( ftnw  (jpi,jpj) , ftne  (jpi,jpj) , ftsw  (jpi,jpj) , ftse (jpi,jpj) ,                                       & 
     78         &      un_b  (jpi,jpj) , vn_b  (jpi,jpj) , ub_b  (jpi,jpj) , vb_b (jpi,jpj) , ua_e  (jpi,jpj) , va_e  (jpi,jpj) ,   & 
     79         &      sshn_e(jpi,jpj) , ssha_e(jpi,jpj) , sshn_b(jpi,jpj) ,                                                        & 
     80         &      hu_e  (jpi,jpj) , hv_e  (jpi,jpj) , hur_e (jpi,jpj) , hvr_e(jpi,jpj) , STAT=dyn_spg_ts_alloc ) 
     81      IF(lk_mpp)   CALL mpp_sum( dyn_spg_ts_alloc ) 
     82      ! 
    8183   END FUNCTION dyn_spg_ts_alloc 
    8284 
    … …  
    122124      !! 
    123125      INTEGER  ::   ji, jj, jk, jn   ! dummy loop indices 
    124       INTEGER  ::   icycle           ! temporary scalar 
    125  
    126       REAL(wp) ::   zraur, zcoef, z2dt_e, z2dt_b     ! temporary scalars 
    127       REAL(wp) ::   z1_8, zx1, zy1                   !    -         - 
    128       REAL(wp) ::   z1_4, zx2, zy2                   !     -         - 
    129       REAL(wp) ::   zu_spg, zu_cor, zu_sld, zu_asp   !     -         - 
    130       REAL(wp) ::   zv_spg, zv_cor, zv_sld, zv_asp   !     -         - 
     126      INTEGER  ::   icycle           ! local scalar 
     127      REAL(wp) ::   zraur, zcoef, z2dt_e, z2dt_b     ! local scalars 
     128      REAL(wp) ::   z1_8, zx1, zy1                   !   -      - 
     129      REAL(wp) ::   z1_4, zx2, zy2                   !   -      - 
     130      REAL(wp) ::   zu_spg, zu_cor, zu_sld, zu_asp   !   -      - 
     131      REAL(wp) ::   zv_spg, zv_cor, zv_sld, zv_asp   !   -      - 
    131132      !!---------------------------------------------------------------------- 
    132133 
    133134      IF(.NOT. wrk_use(2,  1, 2, 3, 4, 5, 6, 7, 8, 9,10,         & 
    134                           11,12,13,14,15,16,17,18,19,20,21))THEN 
    135          CALL ctl_stop('dyn_spg_ts: requested workspace arrays unavailable.') 
    136          RETURN 
     135                          11,12,13,14,15,16,17,18,19,20,21 ) ) THEN 
     136         CALL ctl_stop( 'dyn_spg_ts: requested workspace arrays unavailable.' )   ;   RETURN 
    137137      END IF 
    138138 
    … …  
    143143         IF(lwp) WRITE(numout,*) '~~~~~~~~~~   free surface with time splitting' 
    144144         IF(lwp) WRITE(numout,*) ' Number of sub cycle in 1 time-step (2 rdt) : icycle = ',  2*nn_baro 
     145         ! 
     146         !                                      ! allocate dyn_spg_ts arrays 
     147         IF( dyn_spg_ts_alloc() /= 0 )   CALL ctl_stop('STOP', 'dyn_spg_ts_alloc: failed to allocate arrays') 
    145148         ! 
    146149         CALL ts_rst( nit000, 'READ' )   ! read or initialize the following fields: un_b, vn_b   
    … …  
    484487         !                                                      !         - Correct the velocity 
    485488 
    486          IF( lk_obc               )   CALL obc_fla_ts 
     489         IF( lk_obc               )   CALL obc_fla_ts ( ua_e, va_e, sshn_e, ssha_e ) 
    487490         IF( lk_bdy .OR. ln_tides )   CALL bdy_dyn_fla( sshn_e )  
    488491         ! 

  • branches/dev_r2586_dynamic_mem/NEMOGCM/NEMO/OPA_SRC/DYN/dynvor.F90

    r2590 r2618  
    3939   PUBLIC   dyn_vor        ! routine called by step.F90 
    4040   PUBLIC   dyn_vor_init   ! routine called by opa.F90 
    41    PUBLIC   dyn_vor_alloc  ! routine called by nemogcm.F90 
    4241 
    4342   !                                             !!* Namelist namdyn_vor: vorticity term 
    … …  
    5150   INTEGER ::   nrvm = 2   ! =2 relative vorticity ; =3 metric term 
    5251   INTEGER ::   ntot = 4   ! =4 total vorticity (relative + planetary) ; =5 coriolis + metric term 
    53  
    54 !!$#if defined key_vvl 
    55 !!$   REAL(wp), DIMENSION(jpi,jpj,jpk)       ::   ze3f  
    56 !!$#else 
    57 !!$   REAL(wp), ALLOCATABLE, DIMENSION(jpi,jpj,jpk), SAVE ::   ze3f 
    58 !!$#endif 
    59    REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   ze3f 
    6052 
    6153   !! * Substitutions 
    … …  
    6759   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 
    6860   !!---------------------------------------------------------------------- 
    69  
    7061CONTAINS 
    71  
    72    FUNCTION dyn_vor_alloc() 
    73       !!---------------------------------------------------------------------- 
    74       !!              *** Routine dyn_vor_alloc *** 
    75       !!---------------------------------------------------------------------- 
    76       IMPLICIT none 
    77       INTEGER :: dyn_vor_alloc 
    78       !!---------------------------------------------------------------------- 
    79  
    80       ALLOCATE(ze3f(jpi,jpj,jpk), Stat=dyn_vor_alloc) 
    81  
    82       IF(dyn_vor_alloc /= 0 )THEN 
    83          CALL ctl_warn('dyn_vor_alloc: failed to allocate array ze3f.') 
    84       END IF 
    85  
    86    END FUNCTION dyn_vor_alloc 
    87  
    8862 
    8963   SUBROUTINE dyn_vor( kt ) 
    … …  
    584558      !! References : Arakawa and Lamb 1980, Mon. Wea. Rev., 109, 18-36 
    585559      !!---------------------------------------------------------------------- 
    586       USE wrk_nemo, ONLY: wrk_use, wrk_release 
    587       USE wrk_nemo, ONLY: zwx => wrk_2d_1,  zwy => wrk_2d_2,  zwz => wrk_2d_3  
    588       USE wrk_nemo, ONLY: ztnw => wrk_2d_4, ztne => wrk_2d_5, & 
    589                           ztsw => wrk_2d_6, ztse => wrk_2d_7 
    590       !! 
     560      USE wrk_nemo, ONLY:   wrk_use, wrk_release 
     561      USE wrk_nemo, ONLY:   zwx  => wrk_2d_1 , zwy  => wrk_2d_2 ,  zwz => wrk_2d_3  
     562      USE wrk_nemo, ONLY:   ztnw => wrk_2d_4 , ztne => wrk_2d_5  
     563      USE wrk_nemo, ONLY:   ztsw => wrk_2d_6 , ztse => wrk_2d_7 
     564#if defined key_vvl 
     565      USE wrk_nemo, ONLY:   ze3f => wrk_3d_1 
     566#endif 
     567      ! 
    591568      INTEGER , INTENT(in   )                         ::   kt     ! ocean time-step index 
    592569      INTEGER , INTENT(in   )                         ::   kvor   ! =ncor (planetary) ; =ntot (total) ; 
    … …  
    596573      !! 
    597574      INTEGER  ::   ji, jj, jk         ! dummy loop indices 
    598       REAL(wp) ::   zfac12, zua, zva   ! temporary scalars 
    599       !!---------------------------------------------------------------------- 
    600  
    601       IF(.NOT. wrk_use(2, 1,2,3,4,5,6,7))THEN 
    602          CALL ctl_stop('dyn:vor_een : requested workspace arrays unavailable.') 
    603          RETURN 
     575      INTEGER  ::   ierr               ! local integer 
     576      REAL(wp) ::   zfac12, zua, zva   ! local scalars 
     577#if ! defined key_vvl 
     578      REAL(wp), ALLOCATABLE, DIMENSION(:,:,:), SAVE ::   ze3f 
     579#endif 
     580      !!---------------------------------------------------------------------- 
     581 
     582      IF(.NOT. wrk_use(2, 1,2,3,4,5,6,7) .AND. .NOT. wrk_use(3, 1) ) THEN 
     583         CALL ctl_stop('dyn:vor_een : requested workspace arrays unavailable.')   ;   RETURN 
    604584      END IF 
    605585 
    … …  
    608588         IF(lwp) WRITE(numout,*) 'dyn:vor_een : vorticity term: energy and enstrophy conserving scheme' 
    609589         IF(lwp) WRITE(numout,*) '~~~~~~~~~~~' 
     590         IF( .NOT.lk_vvl ) THEN 
     591            ALLOCATE( ze3f(jpi,jpj,jpk) , STAT=ierr ) 
     592            IF( lk_mpp    )   CALL mpp_sum ( ierr ) 
     593            IF( ierr /= 0 )   CALL ctl_stop( 'STOP', 'dyn:vor_een : unable to allocate arrays' ) 
     594         ENDIF 
    610595      ENDIF 
    611596 
    … …  
    696681      END DO                                           !   End of slab 
    697682      !                                                ! =============== 
    698       IF(.NOT. wrk_release(2, 1,2,3,4,5,6,7))THEN 
    699          CALL ctl_stop('dyn:vor_een : failed to release workspace arrays.') 
    700       END IF 
     683      IF(.NOT. wrk_release(2, 1,2,3,4,5,6,7) .AND.   & 
     684         .NOT. wrk_release(3, 1)  )   CALL ctl_stop('dyn:vor_een : failed to release workspace arrays') 
    701685      ! 
    702686   END SUBROUTINE vor_een 

  • branches/dev_r2586_dynamic_mem/NEMOGCM/NEMO/OPA_SRC/FLO/flo_oce.F90

    r2613 r2618  
    1212   !!---------------------------------------------------------------------- 
    1313   USE par_oce         ! ocean parameters 
     14   USE in_out_manager  ! I/O manager 
     15   USE lib_mpp         ! MPP library 
    1416 
    1517   IMPLICIT NONE 
    1618   PUBLIC 
    1719 
    18    PUBLIC   flo_oce_alloc   ! Routine called in nemogcm.F90 
     20   PUBLIC   flo_oce_alloc   ! Routine called in floats.F90 
    1921 
    2022   LOGICAL, PUBLIC, PARAMETER ::   lk_floats = .TRUE.    !: float flag 
    … …  
    4446 
    4547   !!---------------------------------------------------------------------- 
     48   !! NEMO/OPA 4.0 , NEMO Consortium (2011) 
     49   !! $Id$  
     50   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt) 
     51   !!---------------------------------------------------------------------- 
    4652CONTAINS 
    4753 
    48    FUNCTION flo_oce_alloc() 
     54   INTEGER FUNCTION flo_oce_alloc() 
    4955      !!---------------------------------------------------------------------- 
    50       INTEGER :: flo_oce_alloc 
     56      !!                 ***  FUNCTION flo_oce_alloc  *** 
    5157      !!---------------------------------------------------------------------- 
     58      ALLOCATE( wb(jpi,jpj,jpk), Stat=flo_oce_alloc ) 
    5259      ! 
    53       ALLOCATE(wb(jpi,jpj,jpk), Stat=flo_oce_alloc) 
    54       ! 
     60      IF( lk_mpp             )   CALL mpp_sum ( flo_oce_alloc ) 
     61      IF( flo_oce_alloc /= 0 )   CALL ctl_warn('flo_oce_alloc: failed to allocate arrays.') 
    5562   END FUNCTION flo_oce_alloc 
    5663 
    … …  
    6269#endif 
    6370 
    64    !!---------------------------------------------------------------------- 
    65    !! NEMO/OPA 3.3 , NEMO Consortium (2010) 
    66    !! $Id$  
    67    !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt) 
    6871   !!====================================================================== 
    6972END MODULE flo_oce 

  • branches/dev_r2586_dynamic_mem/NEMOGCM/NEMO/OPA_SRC/FLO/floats.F90

    r2528 r2618  
    5050      !!---------------------------------------------------------------------- 
    5151      ! 
    52       IF( kt == nit000 ) THEN 
    53          IF(lwp) WRITE(numout,*) 
    54          IF(lwp) WRITE(numout,*) 'flo_stp : call floats routine ' 
    55          IF(lwp) WRITE(numout,*) '~~~~~~~' 
    56  
    57          CALL flo_dom            ! compute/read initial position of floats 
    58  
    59          wb(:,:,:) = wn(:,:,:)   ! set wb for computation of floats trajectories at the first time step 
    60       ENDIF 
    61       ! 
    6252      IF( ln_flork4 ) THEN   ;   CALL flo_4rk( kt )        ! Trajectories using a 4th order Runge Kutta scheme 
    6353      ELSE                   ;   CALL flo_blk( kt )        ! Trajectories using Blanke' algorithme 
    … …  
    8373      !!--------------------------------------------------------------------- 
    8474      ! 
     75      IF(lwp) WRITE(numout,*) 
     76      IF(lwp) WRITE(numout,*) 'flo_stp : call floats routine ' 
     77      IF(lwp) WRITE(numout,*) '~~~~~~~' 
     78 
    8579      REWIND( numnam )              ! Namelist namflo : floats 
    8680      READ  ( numnam, namflo ) 
    … …  
    9589         WRITE(numout,*) '            Computation of T trajectories    ln_flork4  = ', ln_flork4 
    9690      ENDIF 
     91      ! 
     92      !                             ! allocate floats arrays 
     93      IF( flo_oce_alloc() /= 0 )   CALL ctl_stop( 'STOP', 'flo_init : unable to allocate arrays' ) 
     94      ! 
     95      !                             ! allocate flowri arrays 
     96      IF( flo_wri_alloc() /= 0 )   CALL ctl_stop( 'STOP', 'flo_wri : unable to allocate arrays' ) 
     97      ! 
     98      CALL flo_dom                  ! compute/read initial position of floats 
     99 
     100      wb(:,:,:) = wn(:,:,:)         ! set wb for computation of floats trajectories at the first time step 
    97101      ! 
    98102   END SUBROUTINE flo_init 

  • branches/dev_r2586_dynamic_mem/NEMOGCM/NEMO/OPA_SRC/FLO/floblk.F90

    r2528 r2618  
    1414   USE dom_oce         ! ocean space and time domain 
    1515   USE phycst          ! physical constants 
     16   USE obc_par         ! open boundary condition parameters 
    1617   USE in_out_manager  ! I/O manager 
    1718   USE lib_mpp         ! distribued memory computing library 

  • branches/dev_r2586_dynamic_mem/NEMOGCM/NEMO/OPA_SRC/FLO/flowri.F90

    r2613 r2618  
    2323   PRIVATE 
    2424 
    25    PUBLIC   flo_wri          ! routine called by floats.F90 
    26    PUBLIC   flo_wri_alloc   ! routine called by nemogcm.F90 
     25   PUBLIC   flo_wri         ! routine called by floats.F90 
     26   PUBLIC   flo_wri_alloc   ! routine called by floats.F90 
    2727 
    2828   INTEGER ::   jfl      ! number of floats 
    … …  
    4343CONTAINS 
    4444 
    45    FUNCTION flo_wri_alloc 
     45   INTEGER FUNCTION flo_wri_alloc 
    4646      !!------------------------------------------------------------------- 
    47       !!                ***  ROUTINE flo_wri_alloc  *** 
     47      !!                ***  FUNCTION flo_wri_alloc  *** 
    4848      !!------------------------------------------------------------------- 
    49       INTEGER :: flo_wri_alloc 
    50       !!------------------------------------------------------------------- 
    51       ! 
    52       ALLOCATE(ztemp(jpk,jpnfl), zsal(jpk,jpnfl), Stat=flo_wri_alloc) 
     49      ALLOCATE( ztemp(jpk,jpnfl) , zsal(jpk,jpnfl) , STAT=flo_wri_alloc) 
    5350      ! 
    5451      IF( lk_mpp             )   CALL mpp_sum ( flo_wri_alloc ) 
    5552      IF( flo_wri_alloc /= 0 )   CALL ctl_warn('flo_wri_alloc: failed to allocate arrays.') 
    56       ! 
    5753   END FUNCTION flo_wri_alloc 
    5854 
    … …  
    7571      INTEGER  ::    ic, jc , jpn 
    7672      INTEGER, DIMENSION ( jpnij )  ::   iproc 
    77       REAL(wp) ::   zafl,zbfl,zcfl,zdtj 
     73      REAL(wp) ::   zafl, zbfl, zcfl, zdtj 
    7874      REAL(wp) ::   zxxu, zxxu_01,zxxu_10, zxxu_11 
    7975      !!--------------------------------------------------------------------- 
    8076       
    81       IF( kt == nit000 .OR. MOD( kt,nn_writefl)== 0 ) THEN  
     77      IF( kt == nit000 .OR. MOD( kt,nn_writefl) == 0 ) THEN  
    8278 
    8379         ! header of output floats file 

  • branches/dev_r2586_dynamic_mem/NEMOGCM/NEMO/OPA_SRC/LDF/ldfdyn_oce.F90

    r2590 r2618  
    66   !! History :  1.0  ! 2002-11  (G. Madec)  F90: Free form and module 
    77   !!---------------------------------------------------------------------- 
    8    USE par_oce      ! ocean parameters 
     8   USE par_oce        ! ocean parameters 
     9   USE in_out_manager ! I/O manager 
    910 
    1011   IMPLICIT NONE 
    … …  
    2021   REAL(wp), PUBLIC ::   rn_ahmb_0       =     0._wp   !: lateral laplacian background eddy viscosity (m2/s) 
    2122   REAL(wp), PUBLIC ::   rn_ahm_0_blp    =     0._wp   !: lateral bilaplacian eddy viscosity (m4/s) 
    22    REAL(wp), PUBLIC ::   ahm0, ahmb0, ahm0_blp         ! OLD namelist names 
     23   REAL(wp), PUBLIC ::   ahm0, ahmb0, ahm0_blp         !: OLD namelist names 
    2324 
     25   !                                                                                  !!! eddy coeff. at U-,V-,W-pts [m2/s] 
    2426#if defined key_dynldf_c3d 
    25    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   ahm1, ahm2, ahm3, ahm4  ! ** 3D coefficients ** 
     27   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   ahm1, ahm2, ahm3, ahm4   !: ** 3D coefficients ** 
    2628#elif defined key_dynldf_c2d 
    27    REAL(wp), PUBLIC, ALLOCATABLE, SAVE,   DIMENSION(:,:) ::   ahm1, ahm2, ahm3, ahm4  ! ** 2D coefficients ** 
     29   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   ahm1, ahm2, ahm3, ahm4   !: ** 2D coefficients ** 
    2830#elif defined key_dynldf_c1d 
    29    REAL(wp), PUBLIC, DIMENSION(jpk)         ::   ahm1, ahm2, ahm3, ahm4  ! ** 2D coefficients ** 
     31   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:)     ::   ahm1, ahm2, ahm3, ahm4   !: ** 2D coefficients ** 
    3032#else 
    31    REAL(wp), PUBLIC                         ::   ahm1, ahm2, ahm3, ahm4  ! ** 0D coefficients ** 
     33   REAL(wp), PUBLIC                                      ::   ahm1, ahm2, ahm3, ahm4   !: ** 0D coefficients ** 
    3234#endif 
    3335 
    3436   !!---------------------------------------------------------------------- 
    35    !! NEMO/OPA 3.3 , NEMO Consortium (2010) 
     37   !! NEMO/OPA 4.0 , NEMO Consortium (2011) 
    3638   !! $Id$  
    37    !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 
    38    !!====================================================================== 
     39   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt) 
     40   !!---------------------------------------------------------------------- 
    3941CONTAINS 
    4042 
    41   FUNCTION ldfdyn_oce_alloc() 
    42     !!---------------------------------------------------------------------- 
    43     !!---------------------------------------------------------------------- 
    44     IMPLICIT none 
    45     INTEGER :: ldfdyn_oce_alloc 
     43   INTEGER FUNCTION ldfdyn_oce_alloc() 
     44      !!---------------------------------------------------------------------- 
     45      !!                 ***  FUNCTION ldfdyn_oce_alloc  *** 
     46      !!---------------------------------------------------------------------- 
     47#if defined key_dynldf_c3d 
     48      ALLOCATE( ahm1(jpi,jpj,jpk) , ahm2(jpi,jpj,jpk) , ahm3(jpi,jpj,jpk) , ahm4(jpi,jpj,jpk) , STAT=ldfdyn_oce_alloc ) 
     49#elif defined key_dynldf_c2d 
     50      ALLOCATE( ahm1(jpi,jpj    ) , ahm2(jpi,jpj    ) , ahm3(jpi,jpj    ) , ahm4(jpi,jpj    ) , STAT=ldfdyn_oce_alloc ) 
     51#elif defined key_dynldf_c1d 
     52      ALLOCATE( ahm1(        jpk) , ahm2(        jpk) , ahm3(        jpk) , ahm4(        jpk) , STAT=ldfdyn_oce_alloc ) 
     53#endif 
     54      IF( ldfdyn_oce_alloc /= 0 )   CALL ctl_warn('ldfdyn_oce_alloc: failed to allocate arrays') 
     55      ! 
     56   END FUNCTION ldfdyn_oce_alloc 
    4657 
    47     ldfdyn_oce_alloc = 0 
    48  
    49 #if defined key_dynldf_c3d 
    50     ALLOCATE(ahm1(jpi,jpj,jpk), ahm2(jpi,jpj,jpk), ahm3(jpi,jpj,jpk), & 
    51              ahm4(jpi,jpj,jpk), Stat=ldfdyn_oce_alloc) 
    52 #elif defined key_dynldf_c2d 
    53     ALLOCATE(ahm1(jpi,jpj), ahm2(jpi,jpj), ahm3(jpi,jpj),             & 
    54              ahm4(jpi,jpj),     Stat=ldfdyn_oce_alloc) 
    55 #elif defined key_dynldf_c1d 
    56     ALLOCATE(ahm1(jpk), ahm2(jpk), ahm3(jpk),                         & 
    57              ahm4(jpk),         Stat=ldfdyn_oce_alloc) 
    58 #endif 
    59  
    60   END FUNCTION ldfdyn_oce_alloc 
    61  
    62   !!---------------------------------------------------------------------- 
    63  
     58   !!====================================================================== 
    6459END MODULE ldfdyn_oce 

  • branches/dev_r2586_dynamic_mem/NEMOGCM/NEMO/OPA_SRC/LDF/ldfslp.F90

    r2611 r2618  
    3838   PUBLIC   ldf_slp_grif   ! routine called by step.F90 
    3939   PUBLIC   ldf_slp_init   ! routine called by opa.F90 
    40    PUBLIC   ldf_slp_alloc  ! routine called by nemo_init->nemo_alloc 
    4140 
    4241   LOGICAL , PUBLIC, PARAMETER ::   lk_ldfslp = .TRUE.     !: slopes flag 
    … …  
    6160   ! arrays from the wrk_nemo module with a bit of code re-writing. The 4D workspace  
    6261   ! arrays can't be used here because of the zero-indexing of some of the ranks. ARPDBG. 
    63    REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) ::   zdzrho, zdyrho, zdxrho     ! Horizontal and vertical density gradients 
    64    REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) ::   zti_mlb, ztj_mlb 
     62   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) ::   zdzrho , zdyrho, zdxrho     ! Horizontal and vertical density gradients 
     63   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) ::   zti_mlb, ztj_mlb            ! for Griffies operator only 
    6564 
    6665   !! * Substitutions 
    … …  
    7069#  include "vectopt_loop_substitute.h90" 
    7170   !!---------------------------------------------------------------------- 
    72    !! NEMO/OPA 3.3 , NEMO Consortium (2010) 
     71   !! NEMO/OPA 4.0 , NEMO Consortium (2011) 
    7372   !! $Id$ 
    7473   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt) 
    … …  
    7675CONTAINS 
    7776 
    78    FUNCTION ldf_slp_alloc() 
    79       !!---------------------------------------------------------------------- 
    80       !!              ***  ROUTINE ldf_slp_alloc  *** 
    81       !!---------------------------------------------------------------------- 
    82       INTEGER :: ldf_slp_alloc 
    83       !!---------------------------------------------------------------------- 
    84       ! 
    85       ALLOCATE(zdzrho(jpi,jpj,jpk,0:1),  zdyrho(jpi,jpj,jpk,0:1),  & 
    86                zdxrho(jpi,jpj,jpk,0:1),  zti_mlb(jpi,jpj,0:1,0:1), & 
    87                ztj_mlb(jpi,jpj,0:1,0:1), Stat=ldf_slp_alloc) 
    88  
    89       IF(ldf_slp_alloc /= 0)THEN 
    90          CALL ctl_warn('ldf_slp_alloc : failed to allocate arrays.') 
    91       END IF 
    92  
     77   INTEGER FUNCTION ldf_slp_alloc() 
     78      !!---------------------------------------------------------------------- 
     79      !!              ***  FUNCTION ldf_slp_alloc  *** 
     80      !!---------------------------------------------------------------------- 
     81      ! 
     82      ALLOCATE( zdxrho (jpi,jpj,jpk,0:1) , zti_mlb(jpi,jpj,0:1,0:1) ,     & 
     83         &      zdyrho (jpi,jpj,jpk,0:1) , ztj_mlb(jpi,jpj,0:1,0:1) ,     & 
     84         &      zdzrho (jpi,jpj,jpk,0:1)                            , STAT=ldf_slp_alloc ) 
     85         ! 
     86      IF( lk_mpp             )   CALL mpp_sum ( ldf_slp_alloc ) 
     87      IF( ldf_slp_alloc /= 0 )   CALL ctl_warn('ldf_slp_alloc : failed to allocate arrays.') 
     88      ! 
    9389   END FUNCTION ldf_slp_alloc 
    9490 
    … …  
    139135      !!---------------------------------------------------------------------- 
    140136 
    141       IF(.not. wrk_use(3, 1))THEN 
    142          CALL ctl_stop('ldf_slp: ERROR: requested workspace arrays are unavailable.') 
    143          RETURN 
     137      IF(.NOT. wrk_use(3, 1) ) THEN 
     138         CALL ctl_stop('ldf_slp: requested workspace arrays are unavailable')   ;   RETURN 
    144139      END IF 
    145140 
    … …  
    429424 
    430425      IF( (.not. wrk_use(3, 2,3,4,5)) .OR. (.not. wrk_use(2, 1)) )THEN 
    431          CALL ctl_stop('ldf_slp_grif: ERROR: requested workspace arrays are unavailable.') 
    432          RETURN 
     426         CALL ctl_stop('ldf_slp_grif: ERROR: requested workspace arrays are unavailable.')   ;   RETURN 
    433427      END IF 
    434428 
    … …  
    613607      CALL lbc_lnk( wslp2, 'W', 1. )      ! lateral boundary confition on wslp2 only   ==>>> gm : necessary ? to be checked 
    614608      ! 
    615       IF( (.not. wrk_release(3, 2,3,4,5)) .OR. (.not. wrk_release(2, 1)) )THEN 
    616          CALL ctl_stop('ldf_slp_grif: ERROR: failed to release workspace arrays.') 
    617       END IF 
     609      IF(.NOT. wrk_release(3, 2,3,4,5) .OR.   & 
     610         .NOT. wrk_release(2, 1)        )   CALL ctl_stop('ldf_slp_grif: ERROR: failed to release workspace arrays.') 
    618611      ! 
    619612   END SUBROUTINE ldf_slp_grif 
    … …  
    749742      !! 
    750743      !! ** Method  :   read the nammbf namelist and check the parameter  
    751       !!      values called by tra_dmp at the first timestep (nit000) 
     744      !!              values called by tra_dmp at the first timestep (nit000) 
    752745      !!---------------------------------------------------------------------- 
    753746      INTEGER ::   ji, jj, jk   ! dummy loop indices 
    … …  
    764757         ALLOCATE( triadi_g(jpi,jpj,jpk,0:1,0:1) , triadj_g(jpi,jpj,jpk,0:1,0:1) , wslp2(jpi,jpj,jpk) , STAT=ierr ) 
    765758         ALLOCATE( triadi  (jpi,jpj,jpk,0:1,0:1) , triadj  (jpi,jpj,jpk,0:1,0:1)                      , STAT=ierr ) 
    766          IF( ierr > 0 ) THEN 
    767             CALL ctl_stop( 'ldf_slp_init : unable to allocate Griffies operator slope ' )   ;   RETURN 
    768          ENDIF 
     759         IF( ierr > 0             )   CALL ctl_stop( 'STOP', 'ldf_slp_init : unable to allocate Griffies operator slope' ) 
     760         IF( ldf_slp_alloc() /= 0 )   CALL ctl_stop( 'STOP', 'ldf_slp_init : unable to allocate workspace arrays' ) 
    769761         ! 
    770762         IF( ln_dynldf_iso )   CALL ctl_stop( 'ldf_slp_init: Griffies operator on momentum not supported' ) 
    771763         ! 
    772          IF( ( ln_traldf_hor .AND. ln_dynldf_hor ) .AND. ln_sco )   & 
    773             &     CALL ctl_stop( 'ldf_slp_init: horizontal Griffies operator ',   & 
    774             &                                              'in s-coordinate not supported' ) 
     764         IF( ( ln_traldf_hor .OR. ln_dynldf_hor ) .AND. ln_sco )   & 
     765            CALL ctl_stop( 'ldf_slp_init: horizontal Griffies operator in s-coordinate not supported' ) 
    775766         ! 
    776767      ELSE                             ! Madec operator : slopes at u-, v-, and w-points 
    777768         ALLOCATE( uslp(jpi,jpj,jpk) , vslp(jpi,jpj,jpk) , wslpi(jpi,jpj,jpk) , wslpj(jpi,jpj,jpk) ,                & 
    778769            &   omlmask(jpi,jpj,jpk) , uslpml(jpi,jpj)   , vslpml(jpi,jpj)    , wslpiml(jpi,jpj)   , wslpjml(jpi,jpj) , STAT=ierr ) 
    779          IF( ierr > 0 ) THEN 
    780             CALL ctl_stop( 'ldf_slp_init : unable to allocate Madec operator slope ' )   ;   RETURN 
    781          ENDIF 
     770         IF( ierr > 0 )   CALL ctl_stop( 'STOP', 'ldf_slp_init : unable to allocate Madec operator slope ' ) 
    782771 
    783772         ! Direction of lateral diffusion (tracers and/or momentum) 
    … …  
    790779!!gm I no longer understand this..... 
    791780         IF( (ln_traldf_hor .OR. ln_dynldf_hor) .AND. .NOT. (lk_vvl .AND. ln_rstart) ) THEN 
    792             IF(lwp) THEN 
    793                WRITE(numout,*) '          Horizontal mixing in s-coordinate: slope = slope of s-surfaces' 
    794             ENDIF 
     781            IF(lwp)   WRITE(numout,*) '          Horizontal mixing in s-coordinate: slope = slope of s-surfaces' 
    795782 
    796783            ! geopotential diffusion in s-coordinates on tracers and/or momentum 
    … …  
    810797               END DO 
    811798            END DO 
    812             ! Lateral boundary conditions on the slopes 
    813             CALL lbc_lnk( uslp , 'U', -1. )      ;      CALL lbc_lnk( vslp , 'V', -1. ) 
    814             CALL lbc_lnk( wslpi, 'W', -1. )      ;      CALL lbc_lnk( wslpj, 'W', -1. ) 
     799            CALL lbc_lnk( uslp , 'U', -1. )   ;   CALL lbc_lnk( vslp , 'V', -1. )      ! Lateral boundary conditions 
     800            CALL lbc_lnk( wslpi, 'W', -1. )   ;   CALL lbc_lnk( wslpj, 'W', -1. ) 
    815801         ENDIF 
    816       ENDIF      ! 
     802      ENDIF 
     803      ! 
    817804   END SUBROUTINE ldf_slp_init 
    818805 

  • branches/dev_r2586_dynamic_mem/NEMOGCM/NEMO/OPA_SRC/LDF/ldftra_oce.F90

    r2590 r2618  
    44   !! Ocean physics :  lateral tracer mixing coefficient defined in memory  
    55   !!===================================================================== 
    6    !! History :  9.0  !  02-11  (G. Madec)  Original code 
     6   !! History :  9.0  !  2002-11  (G. Madec)  Original code 
    77   !!---------------------------------------------------------------------- 
    8    USE par_oce         ! ocean parameters 
     8   USE par_oce        ! ocean parameters 
     9   USE in_out_manager ! I/O manager 
    910 
    1011   IMPLICIT NONE 
    … …  
    3435 
    3536#if defined key_traldf_c3d 
    36    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   ahtt, ahtu, ahtv, ahtw   !: ** 3D coefficients ** at T-, U-, V-, W-points 
     37   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   ahtt, ahtu, ahtv, ahtw   !: ** 3D coefficients ** at T-,U-,V-,W-points 
    3738#elif defined key_traldf_c2d 
    38    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   ahtt, ahtu, ahtv, ahtw   !: ** 2D coefficients ** at T-, U-, V-, W-points 
     39   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   ahtt, ahtu, ahtv, ahtw   !: ** 2D coefficients ** at T-,U-,V-,W-points 
    3940#elif defined key_traldf_c1d 
    40    REAL(wp), PUBLIC, DIMENSION(jpk)         ::   ahtt, ahtu, ahtv, ahtw   !: ** 1D coefficients ** at T-, U-, V-, W-points ARPDBGjpk 
     41   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:)     ::   ahtt, ahtu, ahtv, ahtw   !: ** 1D coefficients ** at T-,U-,V-,W-points 
    4142#else 
    42    REAL(wp), PUBLIC                         ::   ahtt, ahtu, ahtv, ahtw   !: ** 0D coefficients ** at T-, U-, V-, W-points 
     43   REAL(wp), PUBLIC                                      ::   ahtt, ahtu, ahtv, ahtw   !: ** 0D coefficients ** at T-,U-,V-,W-points 
    4344#endif 
    44  
    4545 
    4646#if defined key_traldf_eiv 
    … …  
    4949   !!---------------------------------------------------------------------- 
    5050   LOGICAL, PUBLIC, PARAMETER               ::   lk_traldf_eiv   = .TRUE.   !: eddy induced velocity flag 
    51        
     51    
     52   !                                                                              !!! eddy coefficients at U-, V-, W-points  [m2/s] 
    5253# if defined key_traldf_c3d 
    53    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   aeiu, aeiv, aeiw  !: ** 3D coefficients ** at U-, V-, W-points  [m2/s] 
     54   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   aeiu , aeiv , aeiw   !: ** 3D coefficients ** 
    5455# elif defined key_traldf_c2d 
    55    REAL(wp), PUBLIC, ALLOCATABLE, SAVE,   DIMENSION(:,:) ::   aeiu, aeiv, aeiw  !: ** 2D coefficients ** at U-, V-, W-points  [m2/s] 
     56   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   aeiu , aeiv , aeiw   !: ** 2D coefficients ** 
    5657# elif defined key_traldf_c1d 
    57    REAL(wp), PUBLIC, ALLOCATABLE, SAVE,     DIMENSION(:) ::   aeiu, aeiv, aeiw  !: ** 1D coefficients ** at U-, V-, W-points  [m2/s] 
     58   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:)     ::   aeiu , aeiv , aeiw   !: ** 1D coefficients ** 
    5859# else 
    59    REAL(wp), PUBLIC                         ::   aeiu, aeiv, aeiw  !: ** 0D coefficients ** at U-, V-, W-points  [m2/s] 
     60   REAL(wp), PUBLIC                                      ::   aeiu , aeiv , aeiw   !: ** 0D coefficients ** 
    6061# endif 
    6162# if defined key_diaeiv 
    … …  
    7576   !! $Id$  
    7677   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 
    77    !!===================================================================== 
     78   !!---------------------------------------------------------------------- 
    7879CONTAINS 
    7980 
    80    FUNCTION ldftra_oce_alloc() 
     81   INTEGER FUNCTION ldftra_oce_alloc() 
    8182     !!---------------------------------------------------------------------- 
     83      !!                 ***  FUNCTION ldftra_oce_alloc  *** 
    8284     !!---------------------------------------------------------------------- 
    83      IMPLICIT None 
    84      INTEGER               :: ldftra_oce_alloc 
    8585     INTEGER, DIMENSION(3) :: ierr 
    8686     !!---------------------------------------------------------------------- 
    … …  
    8888 
    8989#if defined key_traldf_c3d 
    90      ALLOCATE(ahtt(jpi,jpj,jpk), ahtu(jpi,jpj,jpk), ahtv(jpi,jpj,jpk), & 
    91               ahtw(jpi,jpj,jpk), Stat=ierr(1)) 
     90      ALLOCATE( ahtt(jpi,jpj,jpk) , ahtu(jpi,jpj,jpk) , ahtv(jpi,jpj,jpk) , ahtw(jpi,jpj,jpk) , STAT=ierr(1) ) 
    9291#elif defined key_traldf_c2d 
    93      ALLOCATE(ahtt(jpi,jpj), ahtu(jpi,jpj), ahtv(jpi,jpj), & 
    94               ahtw(jpi,jpj), Stat=ierr(1)) 
     92      ALLOCATE( ahtt(jpi,jpj     ), ahtu(jpi,jpj)     , ahtv(jpi,jpj    ) , ahtw(jpi,jpj    ) , STAT=ierr(1) ) 
    9593#elif defined key_traldf_c1d 
    96      ! No need to allocate arrays where extent only depends on jpk ARPDBGjpk 
     94      ALLOCATE( ahtt(         jpk) , ahtu(       jpk) , ahtv(        jpk) , ahtw(        jpk) , STAT=ierr(1) ) 
    9795#endif 
    98  
     96      ! 
    9997#if defined key_traldf_eiv 
    100  
    101 #if defined key_traldf_c3d 
    102      ALLOCATE(aeiu(jpi,jpj,jpk), aeiv(jpi,jpj,jpk), aeiw(jpi,jpj,jpk), &  
    103               Stat=ierr(2)) 
    104 #elif defined key_traldf_c2d 
    105      ALLOCATE(aeiu(jpi,jpj), aeiv(jpi,jpj), aeiw(jpi,jpj), Stat=ierr(2)) 
    106 #elif defined key_traldf_c1d 
    107      ALLOCATE(aeiu(jpk), aeiv(jpk), aeiw(jpk), Stat=ierr(2)) 
     98# if defined key_traldf_c3d 
     99      ALLOCATE( aeiu(jpi,jpj,jpk) , aeiv(jpi,jpj,jpk) , aeiw(jpi,jpj,jpk) , STAT=ierr(2) ) 
     100# elif defined key_traldf_c2d 
     101      ALLOCATE( aeiu(jpi,jpj    ) , aeiv(jpi,jpj    ) , aeiw(jpi,jpj    ) , STAT=ierr(2) ) 
     102# elif defined key_traldf_c1d 
     103      ALLOCATE( aeiu(        jpk) , aeiv(        jpk) , aeiw(        jpk) , STAT=ierr(2) ) 
     104# endif 
     105# if defined key_diaeiv 
     106      ALLOCATE( u_eiv(jpi,jpj,jpk), v_eiv(jpi,jpj,jpk), w_eiv(jpi,jpj,jpk), STAT=ierr(3)) 
     107# endif 
    108108#endif 
    109  
    110 # if defined key_diaeiv 
    111      ALLOCATE(u_eiv(jpi,jpj,jpk), v_eiv(jpi,jpj,jpk), w_eiv(jpi,jpj,jpk), & 
    112               Stat=ierr(3)) 
    113 # endif 
    114  
    115 #endif 
    116       
    117      ldftra_oce_alloc = MAXVAL(ierr) 
    118  
     109      ldftra_oce_alloc = MAXVAL( ierr ) 
     110      IF( ldftra_oce_alloc /= 0 )   CALL ctl_warn('ldftra_oce_alloc: failed to allocate arrays') 
     111      ! 
    119112   END FUNCTION ldftra_oce_alloc 
    120113 
    121    !!---------------------------------------------------------------------- 
    122  
     114   !!===================================================================== 
    123115END MODULE ldftra_oce 

  • branches/dev_r2586_dynamic_mem/NEMOGCM/NEMO/OPA_SRC/OBC/obcdyn_bt.F90

    r2528 r2618  
    1616 
    1717   !!---------------------------------------------------------------------------------- 
    18    !! * Modules used 
    1918   USE oce             ! ocean dynamics and tracers  
    2019   USE dom_oce         ! ocean space and time domain 
    … …  
    4140CONTAINS 
    4241 
    43    SUBROUTINE obc_dyn_bt ( kt ) 
     42   SUBROUTINE obc_dyn_bt( kt ) 
    4443      !!------------------------------------------------------------------------------ 
    4544      !!                      SUBROUTINE obc_dyn_bt 
    … …  
    5554      !!      open one (must be done in the param_obc.h90 file). 
    5655      !! 
    57       !! ** Reference :  
    58       !!         Flather, R. A., 1976, Mem. Soc. R. Sci. Liege, Ser. 6, 10, 141-164 
    59       !! 
    60       !! History : 
    61       !!   9.0  !  05-12  (V. Garnier) original  
     56      !! ** Reference :   Flather, R. A., 1976, Mem. Soc. R. Sci. Liege, Ser. 6, 10, 141-164 
     57      !! 
     58      !! History :  9.0  !  05-12  (V. Garnier) original  
    6259      !!---------------------------------------------------------------------- 
    6360      !! * Arguments 
    … …  
    321318      !!   9.0  !  05-12  (V. Garnier) original 
    322319      !!------------------------------------------------------------------------------ 
    323       !! * Local declaration 
    324       INTEGER ::   ji, jj, jk ! dummy loop indices 
    325  
     320      INTEGER ::   ji, jj, jk ! dummy loop indices 
    326321      !!------------------------------------------------------------------------------ 
    327322 

  • branches/dev_r2586_dynamic_mem/NEMOGCM/NEMO/OPA_SRC/OBC/obcfla.F90

    r2528 r2618  
    55   !!====================================================================== 
    66   !! History :  2.0  ! 2005-12  (V. Garnier) original code 
    7    !!            3.3  ! 2010-11  (G. Madec) 
     7   !!            3.3  ! 2010-11  (G. Madec)  
     8   !!            4.0  ! 2011-02  (G. Madec) velocity & ssh passed in argument 
    89   !!---------------------------------------------------------------------- 
    910#if defined key_obc && defined key_dynspg_ts 
    … …  
    3132 
    3233   !!---------------------------------------------------------------------- 
    33    !! NEMO/OPA 3.3 , NEMO Consortium (2010) 
     34   !! NEMO/OPA 4.0 , NEMO Consortium (2011) 
    3435   !! $Id$ 
    3536   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt) 
    … …  
    3738CONTAINS 
    3839 
    39    SUBROUTINE obc_fla_ts 
     40   SUBROUTINE obc_fla_ts( pua, pva, p_sshn, p_ssha ) 
    4041      !!---------------------------------------------------------------------- 
    4142      !!                      SUBROUTINE obc_fla_ts 
    … …  
    5253      !! ** Reference : Flather, R. A., 1976, Mem. Soc. R. Sci. Liege, Ser. 6, 10, 141-164 
    5354      !!---------------------------------------------------------------------- 
     55      REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) ::   pua   , pva      ! after barotropic velocities 
     56      REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) ::   p_sshn, p_ssha   ! before, now, after sea surface height 
     57      !!---------------------------------------------------------------------- 
    5458      ! 
    55       IF( lp_obc_east  )   CALL obc_fla_ts_east  
    56       IF( lp_obc_west  )   CALL obc_fla_ts_west  
    57       IF( lp_obc_north )   CALL obc_fla_ts_north 
    58       IF( lp_obc_south )   CALL obc_fla_ts_south 
     59      IF( lp_obc_east  )   CALL obc_fla_ts_east ( pua, pva, p_sshn, p_ssha )  
     60      IF( lp_obc_west  )   CALL obc_fla_ts_west ( pua, pva, p_sshn, p_ssha ) 
     61      IF( lp_obc_north )   CALL obc_fla_ts_north( pua, pva, p_sshn, p_ssha ) 
     62      IF( lp_obc_south )   CALL obc_fla_ts_south( pua, pva, p_sshn, p_ssha )  
    5963      ! 
    6064   END SUBROUTINE obc_fla_ts 
    6165 
    6266 
    63    SUBROUTINE obc_fla_ts_east 
     67   SUBROUTINE obc_fla_ts_east( pua, pva, p_sshn, p_ssha )  
    6468      !!---------------------------------------------------------------------- 
    6569      !!                  ***  SUBROUTINE obc_fla_ts_east  *** 
    6670      !! 
    6771      !! ** Purpose :   Apply Flather's algorithm on east OBC velocities ua, va 
    68       !!              Fix sea surface height (sshn_e) on east open boundary 
     72      !!              Fix sea surface height (p_sshn) on east open boundary 
    6973      !!---------------------------------------------------------------------- 
     74      REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) ::   pua   , pva      ! after barotropic velocities 
     75      REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) ::   p_sshn, p_ssha   ! before, now, after sea surface height 
     76      ! 
    7077      INTEGER ::   ji, jj ! dummy loop indices 
    7178      !!---------------------------------------------------------------------- 
    … …  
    7380      DO ji = nie0, nie1 
    7481         DO jj = 1, jpj 
    75             ua_e    (ji,jj) = (  ubtfoe(jj) * hur(ji,jj) + SQRT( grav*hur(ji,jj) )          & 
    76                &            * ( ( sshn_e(ji,jj) + sshn_e(ji+1,jj) ) * 0.5 - sshfoe(jj) )  ) * uemsk(jj,1) 
     82            pua     (ji,jj) = (  ubtfoe(jj) * hur(ji,jj) + SQRT( grav*hur(ji,jj) )          & 
     83               &            * ( ( p_sshn(ji,jj) + p_sshn(ji+1,jj) ) * 0.5 - sshfoe(jj) )  ) * uemsk(jj,1) 
    7784            sshfoe_b(ji,jj) =    sshfoe_b(ji,jj)         + SQRT( grav*hur(ji,jj) )          & 
    78                &            * ( ( sshn_e(ji,jj) + sshn_e(ji+1,jj) ) * 0.5 - sshfoe(jj) )    * uemsk(jj,1) 
     85               &            * ( ( p_sshn(ji,jj) + p_sshn(ji+1,jj) ) * 0.5 - sshfoe(jj) )    * uemsk(jj,1) 
    7986         END DO 
    8087      END DO 
    8188      DO ji = nie0p1, nie1p1 
    8289         DO jj = 1, jpj 
    83             ssha_e(ji,jj) = ssha_e(ji,jj) * ( 1. - temsk(jj,1) ) + temsk(jj,1) * sshfoe(jj) 
    84             va_e  (ji,jj) = vbtfoe(jj) * hvr(ji,jj) * uemsk(jj,1) 
     90            p_ssha(ji,jj) = p_ssha(ji,jj) * ( 1. - temsk(jj,1) ) + temsk(jj,1) * sshfoe(jj) 
     91            pva   (ji,jj) = vbtfoe(jj) * hvr(ji,jj) * uemsk(jj,1) 
    8592         END DO 
    8693      END DO 
    … …  
    8996 
    9097 
    91    SUBROUTINE obc_fla_ts_west 
     98   SUBROUTINE obc_fla_ts_west( pua, pva, p_sshn, p_ssha ) 
    9299      !!---------------------------------------------------------------------- 
    93100      !!                  ***  SUBROUTINE obc_fla_ts_west  *** 
    94101      !!  
    95102      !! ** Purpose :   Apply Flather's algorithm on west OBC velocities ua, va 
    96       !!              Fix sea surface height (sshn_e) on west open boundary 
     103      !!              Fix sea surface height (p_sshn) on west open boundary 
    97104      !!---------------------------------------------------------------------- 
     105      REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) ::   pua   , pva      ! after barotropic velocities 
     106      REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) ::   p_sshn, p_ssha   ! before, now, after sea surface height 
     107      ! 
    98108      INTEGER ::   ji, jj ! dummy loop indices 
    99109      !!---------------------------------------------------------------------- 
    … …  
    101111      DO ji = niw0, niw1 
    102112         DO jj = 1, jpj 
    103             ua_e    (ji,jj) = ( ubtfow(jj) * hur(ji,jj) - sqrt( grav * hur(ji,jj) )            & 
    104                &                * ( ( sshn_e(ji,jj) + sshn_e(ji+1,jj) ) * 0.5 - sshfow(jj) ) ) * uwmsk(jj,1) 
    105             va_e    (ji,jj) =   vbtfow(jj) * hvr(ji,jj) * uwmsk(jj,1) 
     113            pua     (ji,jj) = ( ubtfow(jj) * hur(ji,jj) - sqrt( grav * hur(ji,jj) )            & 
     114               &            * ( ( p_sshn(ji,jj) + p_sshn(ji+1,jj) ) * 0.5 - sshfow(jj) ) ) * uwmsk(jj,1) 
     115            pva     (ji,jj) =   vbtfow(jj) * hvr(ji,jj) * uwmsk(jj,1) 
    106116            sshfow_b(ji,jj) =   sshfow_b(ji,jj) - SQRT( grav * hur(ji,jj) )                    & 
    107                &                * ( ( sshn_e(ji,jj) + sshn_e(ji+1,jj) ) * 0.5 - sshfow(jj) )   * uwmsk(jj,1) 
    108             ssha_e  (ji,jj) = ssha_e(ji,jj) * ( 1. - twmsk(jj,1) ) + twmsk(jj,1)*sshfow(jj) 
     117               &            * ( ( p_sshn(ji,jj) + p_sshn(ji+1,jj) ) * 0.5 - sshfow(jj) )   * uwmsk(jj,1) 
     118            p_ssha  (ji,jj) = p_ssha(ji,jj) * ( 1. - twmsk(jj,1) ) + twmsk(jj,1)*sshfow(jj) 
    109119         END DO 
    110120      END DO 
    … …  
    113123 
    114124 
    115    SUBROUTINE obc_fla_ts_north 
     125   SUBROUTINE obc_fla_ts_north( pua, pva, p_sshn, p_ssha ) 
    116126      !!---------------------------------------------------------------------- 
    117127      !!                     SUBROUTINE obc_fla_ts_north 
    118128      !! 
    119129      !! ** Purpose :   Apply Flather's algorithm on north OBC velocities ua, va 
    120       !!              Fix sea surface height (sshn_e) on north open boundary 
     130      !!              Fix sea surface height (p_sshn) on north open boundary 
    121131      !!---------------------------------------------------------------------- 
     132      REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) ::   pua   , pva      ! after barotropic velocities 
     133      REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) ::   p_sshn, p_ssha   ! before, now, after sea surface height 
     134      ! 
    122135      INTEGER ::   ji, jj ! dummy loop indices 
    123136      !!---------------------------------------------------------------------- 
    … …  
    125138      DO jj = njn0, njn1 
    126139         DO ji = 1, jpi 
    127             va_e    (ji,jj) = ( vbtfon(ji) * hvr(ji,jj) + sqrt( grav * hvr(ji,jj) )            & 
    128                &                * ( ( sshn_e(ji,jj) + sshn_e(ji,jj+1) ) * 0.5 - sshfon(ji) ) ) * vnmsk(ji,1) 
     140            pva     (ji,jj) = ( vbtfon(ji) * hvr(ji,jj) + sqrt( grav * hvr(ji,jj) )            & 
     141               &                * ( ( p_sshn(ji,jj) + p_sshn(ji,jj+1) ) * 0.5 - sshfon(ji) ) ) * vnmsk(ji,1) 
    129142            sshfon_b(ji,jj) =   sshfon_b(ji,jj) + sqrt( grav * hvr(ji,jj) )                    & 
    130                &                * ( ( sshn_e(ji,jj) + sshn_e(ji,jj+1) ) * 0.5 - sshfon(ji) )   * vnmsk(ji,1) 
     143               &                * ( ( p_sshn(ji,jj) + p_sshn(ji,jj+1) ) * 0.5 - sshfon(ji) )   * vnmsk(ji,1) 
    131144         END DO 
    132145      END DO 
    133146      DO jj = njn0p1, njn1p1 
    134147         DO ji = 1, jpi 
    135             ssha_e(ji,jj) = ssha_e(ji,jj) * ( 1. - tnmsk(ji,1) ) + sshfon(ji) * tnmsk(ji,1) 
    136             ua_e  (ji,jj) = ubtfon(ji) * hur(ji,jj) * vnmsk(ji,1) 
     148            p_ssha(ji,jj) = p_ssha(ji,jj) * ( 1. - tnmsk(ji,1) ) + sshfon(ji) * tnmsk(ji,1) 
     149            pua   (ji,jj) = ubtfon(ji) * hur(ji,jj) * vnmsk(ji,1) 
    137150         END DO 
    138151      END DO 
    … …  
    141154 
    142155 
    143    SUBROUTINE obc_fla_ts_south 
     156   SUBROUTINE obc_fla_ts_south( pua, pva, p_sshn, p_ssha ) 
    144157      !!---------------------------------------------------------------------- 
    145158      !!                     SUBROUTINE obc_fla_ts_south 
    146159      !! 
    147160      !! ** Purpose :   Apply Flather's algorithm on south OBC velocities ua, va 
    148       !!              Fix sea surface height (sshn_e) on south open boundary 
     161      !!              Fix sea surface height (p_sshn) on south open boundary 
    149162      !!---------------------------------------------------------------------- 
     163      REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) ::   pua   , pva      ! after barotropic velocities 
     164      REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) ::   p_sshn, p_ssha   ! before, now, after sea surface height 
     165      ! 
    150166      INTEGER ::   ji, jj ! dummy loop indices 
    151167      !!---------------------------------------------------------------------- 
    … …  
    153169      DO jj = njs0, njs1 
    154170         DO ji = 1, jpi 
    155             va_e    (ji,jj) = ( vbtfos(ji) * hvr(ji,jj) - sqrt( grav * hvr(ji,jj) )            & 
    156                &                * ( ( sshn_e(ji,jj) + sshn_e(ji,jj+1) ) * 0.5 - sshfos(ji) ) ) * vsmsk(ji,1) 
    157             ua_e    (ji,jj) =   ubtfos(ji) * hur(ji,jj) * vsmsk(ji,1) 
     171            pva     (ji,jj) = ( vbtfos(ji) * hvr(ji,jj) - sqrt( grav * hvr(ji,jj) )            & 
     172               &                * ( ( p_sshn(ji,jj) + p_sshn(ji,jj+1) ) * 0.5 - sshfos(ji) ) ) * vsmsk(ji,1) 
     173            pua     (ji,jj) =   ubtfos(ji) * hur(ji,jj) * vsmsk(ji,1) 
    158174            sshfos_b(ji,jj) =   sshfos_b(ji,jj) - sqrt( grav * hvr(ji,jj) )                    & 
    159                &                * ( ( sshn_e(ji,jj) + sshn_e(ji,jj+1) ) * 0.5 - sshfos(ji) )   * vsmsk(ji,1) 
    160             ssha_e  (ji,jj) = ssha_e(ji,jj) * (1. - tsmsk(ji,1) ) + tsmsk(ji,1) * sshfos(ji) 
     175               &                * ( ( p_sshn(ji,jj) + p_sshn(ji,jj+1) ) * 0.5 - sshfos(ji) )   * vsmsk(ji,1) 
     176            p_ssha  (ji,jj) = p_ssha(ji,jj) * (1. - tsmsk(ji,1) ) + tsmsk(ji,1) * sshfos(ji) 
    161177         END DO 
    162178      END DO 
    … …  
    170186CONTAINS 
    171187 
    172    SUBROUTINE obc_fla_ts 
    173       WRITE(*,*) 'obc_fla_ts: You should not have seen this print! error?' 
     188   SUBROUTINE obc_fla_ts( pua, pva, p_sshn, p_ssha ) 
     189      REAL, DIMENSION(:,:)::   pua, pva, p_sshn, p_ssha 
     190      WRITE(*,*) 'obc_fla_ts: You should not have seen this print! error?', pua(1,1), pva(1,1), p_sshn(1,1), p_ssha(1,1) 
    174191   END SUBROUTINE obc_fla_ts 
    175192#endif 

  • branches/dev_r2586_dynamic_mem/NEMOGCM/NEMO/OPA_SRC/ZDF/zdfkpp.F90

    r2616 r2618  
    13151315      USE trc 
    13161316      USE prtctl_trc          ! Print control 
    1317       !! * Arguments 
    1318       INTEGER ,                         INTENT( in    )  :: kt     ! ocean time-step index 
    1319       !! * Local declarations 
     1317      ! 
     1318      INTEGER, INTENT(in) ::   kt   ! ocean time-step index 
     1319      ! 
    13201320      INTEGER  ::   ji, jj, jk, jn      ! Dummy loop indices 
    13211321      REAL(wp) ::   ztra, zflx 
    … …  
    13591359      ENDIF 
    13601360      ! 
     1361   END SUBROUTINE trc_kpp 
     1362 
     1363#else 
     1364   !!---------------------------------------------------------------------- 
     1365   !!   NO 'key_top'           DUMMY routine                  No TOP models 
     1366   !!---------------------------------------------------------------------- 
     1367   SUBROUTINE trc_kpp( kt )         ! Dummy routine 
     1368      INTEGER, INTENT(in) ::   kt   ! ocean time-step index 
     1369      WRITE(*,*) 'tra_kpp: You should not have seen this print! error?', kt 
    13611370   END SUBROUTINE trc_kpp 
    13621371#endif 

  • branches/dev_r2586_dynamic_mem/NEMOGCM/NEMO/OPA_SRC/nemogcm.F90

    r2617 r2618  
    467467     USE diawri,       ONLY: dia_wri_alloc 
    468468     USE dom_oce,      ONLY: dom_oce_alloc 
     469     USE ldfdyn_oce,   ONLY: ldfdyn_oce_alloc 
     470     USE ldftra_oce,   ONLY: ldftra_oce_alloc 
     471 
     472      
    469473     USE dynzdf_exp,   ONLY: dyn_zdf_exp_alloc 
    470 #if   defined key_floats   ||   defined key_esopa 
    471      USE flo_oce,      ONLY: flo_oce_alloc 
    472 #endif 
    473 #if   defined key_floats   ||   defined key_esopa 
    474      USE flowri,       ONLY: flo_wri_alloc 
    475 #endif 
    476474     USE geo2ocean,    ONLY: geo2oce_alloc 
    477      USE ldfdyn_oce,   ONLY: ldfdyn_oce_alloc 
    478 #if   defined key_ldfslp   ||   defined key_esopa 
    479      USE ldfslp,       ONLY: ldf_slp_alloc 
    480 #endif 
    481      USE ldftra_oce,   ONLY: ldftra_oce_alloc 
    482475#if   defined key_mpp_mpi   
    483476     USE lib_mpp,      ONLY: lib_mpp_alloc 
    484477#endif 
    485478#if defined key_obc 
    486      USE obcdta,      ONLY: obc_dta_alloc 
     479     USE obcdta ,      ONLY: obc_dta_alloc 
    487480     USE obc_oce,      ONLY: obc_oce_alloc 
    488481#endif 
    489      USE oce,          ONLY: oce_alloc 
    490482     USE sbcblk_clio,  ONLY: sbc_blk_clio_alloc 
    491483#if defined key_oasis3 || defined key_oasis4 
    … …  
    563555      !!---------------------------------------------------------------------- 
    564556 
    565       ierr = 0 
    566  
    567       ierr = ierr + dia_wri_alloc() 
    568       ierr = ierr + dom_oce_alloc()       ! ocean domain 
     557      ierr =        oce_alloc       ()    ! ocean  
     558      ierr = ierr + dia_wri_alloc   () 
     559      ierr = ierr + dom_oce_alloc   ()    ! ocean domain 
     560      ierr = ierr + ldfdyn_oce_alloc()    ! ocean lateral  physics : dynamics 
     561      ierr = ierr + ldftra_oce_alloc()    ! ocean lateral  physics : tracers 
    569562      ierr = ierr + zdf_oce_alloc()       ! ocean vertical physics 
    570563 
    … …  
    572565 
    573566      ierr = ierr + dyn_zdf_exp_alloc() 
    574 #if   defined key_floats   ||   defined key_esopa 
    575       ierr = ierr + flo_oce_alloc() 
    576       ierr = ierr + flo_wri_alloc() 
    577 #endif 
    578567      ierr = ierr + geo2oce_alloc() 
    579       ierr = ierr + ldfdyn_oce_alloc() 
    580 #if   defined key_ldfslp   ||   defined key_esopa 
    581      ierr = ierr + ldf_slp_alloc() 
    582 #endif 
    583       ierr = ierr + ldftra_oce_alloc() 
    584568#if defined key_mpp_mpi  
    585569      ierr = ierr + lib_mpp_alloc() 
    … …  
    589573      ierr = ierr + obc_oce_alloc() 
    590574#endif 
    591       ierr = ierr + oce_alloc() 
    592575      ierr = ierr + sbc_blk_clio_alloc() 
    593576#if defined key_oasis3 || defined key_oasis4 

  • branches/dev_r2586_dynamic_mem/NEMOGCM/NEMO/OPA_SRC/oce.F90

    r2590 r2618  
    88   !!            3.3  !  2010-09  (C. Ethe) TRA-TRC merge: add ts, gtsu, gtsv 4D arrays 
    99   !!---------------------------------------------------------------------- 
    10    USE par_oce      ! ocean parameters 
     10   USE par_oce        ! ocean parameters 
     11   USE in_out_manager ! I/O manager 
    1112 
    1213   IMPLICIT NONE 
    … …  
    1516   PUBLIC oce_alloc ! routine called by nemo_init in nemogcm.F90 
    1617 
    17    LOGICAL         , PUBLIC ::   l_traldf_rot = .FALSE.  !: rotated laplacian operator for lateral diffusion 
     18   LOGICAL, PUBLIC ::   l_traldf_rot = .FALSE.  !: rotated laplacian operator for lateral diffusion 
    1819 
    1920   !! dynamics and tracer fields                           ! before ! now    ! after   ! the after trends becomes the fields 
    … …  
    3839   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   sshv_b ,  sshv_n  ,  sshv_a  !: sea surface height at u-point [m] 
    3940   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::             sshf_n             !: sea surface height at f-point [m] 
     41   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   sshn_b                       !: before field without time-filter 
    4042   ! 
    4143   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   spgu, spgv                   !: horizontal surface pressure gradient 
    … …  
    4749 
    4850   !!---------------------------------------------------------------------- 
    49    !! NEMO/OPA 3.3 , NEMO Consortium (2010) 
     51   !! NEMO/OPA 4.0 , NEMO Consortium (2011) 
    5052   !! $Id$  
    51    !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 
    52    !!====================================================================== 
     53   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt) 
     54   !!---------------------------------------------------------------------- 
    5355CONTAINS 
    5456 
    55    FUNCTION oce_alloc() 
    56      IMPLICIT none 
    57      INTEGER :: oce_alloc 
    58      INTEGER :: ierr(2) 
    59  
    60      ! The Allocate statement is broken up to prevent excessive 
    61      ! line lengths 
    62      ALLOCATE(ub(jpi,jpj,jpk), un(jpi,jpj,jpk), ua(jpi,jpj,jpk), & 
    63               vb(jpi,jpj,jpk), vn(jpi,jpj,jpk), va(jpi,jpj,jpk), &       
    64               wn(jpi,jpj,jpk),                                   & 
    65               rotb(jpi,jpj,jpk),  rotn(jpi,jpj,jpk),             &    
    66               hdivb(jpi,jpj,jpk), hdivn(jpi,jpj,jpk),            & 
    67               tb(jpi,jpj,jpk), tn(jpi,jpj,jpk), ta(jpi,jpj,jpk), & 
    68               sb(jpi,jpj,jpk), sn(jpi,jpj,jpk), sa(jpi,jpj,jpk), &       
    69               tsb(jpi,jpj,jpk,jpts),tsn(jpi,jpj,jpk,jpts),tsa(jpi,jpj,jpk,jpts),& 
    70               rn2b(jpi,jpj,jpk), rn2(jpi,jpj,jpk),               & 
    71               ! 
    72               Stat=ierr(1)) 
    73  
    74      ALLOCATE(rhd(jpi,jpj,jpk),                                  & 
    75               rhop(jpi,jpj,jpk),                                 & 
    76               ! 
    77               sshb(jpi,jpj),   sshn(jpi,jpj),   ssha(jpi,jpj),   & 
    78               sshu_b(jpi,jpj), sshu_n(jpi,jpj), sshu_a(jpi,jpj), & 
    79               sshv_b(jpi,jpj), sshv_n(jpi,jpj), sshv_a(jpi,jpj), & 
    80                                sshf_n(jpi,jpj),                  & 
    81               ! 
    82               spgu(jpi,jpj),   spgv(jpi,jpj),                    & 
    83               ! 
    84               gtsu(jpi,jpj,jpts), gtsv(jpi,jpj,jpts),            & 
    85               gru(jpi,jpj), grv(jpi,jpj),                        & 
    86               ! 
    87               Stat=ierr(2)) 
    88  
    89      oce_alloc = maxval(ierr) 
    90  
     57   INTEGER FUNCTION oce_alloc() 
     58      !!---------------------------------------------------------------------- 
     59      INTEGER :: ierr(2) 
     60      !!---------------------------------------------------------------------- 
     61      ! 
     62      ALLOCATE( ub   (jpi,jpj,jpk)      , un   (jpi,jpj,jpk)      , ua(jpi,jpj,jpk)       ,     & 
     63         &      vb   (jpi,jpj,jpk)      , vn   (jpi,jpj,jpk)      , va(jpi,jpj,jpk)       ,     &       
     64         &      wn   (jpi,jpj,jpk)      ,                                                       & 
     65         &      rotb (jpi,jpj,jpk)      , rotn (jpi,jpj,jpk)      ,                             &    
     66         &      hdivb(jpi,jpj,jpk)      , hdivn(jpi,jpj,jpk)      ,                             & 
     67         &      tb   (jpi,jpj,jpk)      , tn   (jpi,jpj,jpk)      , ta(jpi,jpj,jpk)       ,     & 
     68         &      sb   (jpi,jpj,jpk)      , sn   (jpi,jpj,jpk)      , sa (jpi,jpj,jpk)      ,     &       
     69         &      tsb  (jpi,jpj,jpk,jpts) , tsn  (jpi,jpj,jpk,jpts) , tsa(jpi,jpj,jpk,jpts) ,     & 
     70         &      rn2b (jpi,jpj,jpk)      , rn2  (jpi,jpj,jpk)                              , STAT=ierr(1) ) 
     71         ! 
     72      ALLOCATE(rhd (jpi,jpj,jpk) ,                                         & 
     73         &     rhop(jpi,jpj,jpk) ,                                         & 
     74         &     sshb  (jpi,jpj)   , sshn  (jpi,jpj) , ssha  (jpi,jpj) ,     & 
     75         &     sshu_b(jpi,jpj)   , sshu_n(jpi,jpj) , sshu_a(jpi,jpj) ,     & 
     76         &     sshv_b(jpi,jpj)   , sshv_n(jpi,jpj) , sshv_a(jpi,jpj) ,     & 
     77         &                         sshf_n(jpi,jpj) ,                       & 
     78         &     sshn_b(jpi,jpj)   ,                                         & 
     79         &     spgu  (jpi,jpj)   , spgv(jpi,jpj)   ,                       & 
     80         &     gtsu(jpi,jpj,jpts), gtsv(jpi,jpj,jpts),                     & 
     81         &     gru(jpi,jpj)      , grv(jpi,jpj)                      , STAT=ierr(2) ) 
     82         ! 
     83      oce_alloc = maxval( ierr ) 
     84      IF( oce_alloc /= 0 )   CALL ctl_warn('oce_alloc: failed to allocate arrays') 
     85      ! 
    9186   END FUNCTION oce_alloc 
    9287 
     88   !!====================================================================== 
    9389END MODULE oce 
Note: See TracChangeset for help on using the changeset viewer.