Ignore:
Timestamp:
2011-03-30T17:58:35+02:00 (10 years ago)
Author:
rblod
Message:

First attempt to put dynamic allocation on the trunk

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/NEMOGCM/NEMO/OPA_SRC/DOM/dommsk.F90

    r2528 r2715  
    3434   PRIVATE 
    3535 
    36    PUBLIC   dom_msk    ! routine called by inidom.F90 
     36   PUBLIC   dom_msk         ! routine called by inidom.F90 
     37   PUBLIC   dom_msk_alloc   ! routine called by nemogcm.F90 
    3738 
    3839   !                            !!* Namelist namlbc : lateral boundary condition * 
    3940   REAL(wp) ::   rn_shlat = 2.   ! type of lateral boundary condition on velocity 
    40     
     41 
     42   INTEGER, ALLOCATABLE, SAVE, DIMENSION(:,:) ::  icoord ! Workspace for dom_msk_nsa() 
     43 
    4144   !! * Substitutions 
    4245#  include "vectopt_loop_substitute.h90" 
     
    4851CONTAINS 
    4952    
     53   INTEGER FUNCTION dom_msk_alloc() 
     54      !!--------------------------------------------------------------------- 
     55      !!                 ***  FUNCTION dom_msk_alloc  *** 
     56      !!--------------------------------------------------------------------- 
     57      dom_msk_alloc = 0 
     58#if defined key_noslip_accurate 
     59      ALLOCATE(icoord(jpi*jpj*jpk,3), STAT=dom_msk_alloc) 
     60#endif 
     61      IF( dom_msk_alloc /= 0 )   CALL ctl_warn('dom_msk_alloc: failed to allocate icoord array') 
     62      ! 
     63   END FUNCTION dom_msk_alloc 
     64 
     65 
    5066   SUBROUTINE dom_msk 
    5167      !!--------------------------------------------------------------------- 
     
    109125      !!               tmask_i  : interior ocean mask 
    110126      !!---------------------------------------------------------------------- 
     127      USE wrk_nemo, ONLY:   wrk_in_use, wrk_not_released, iwrk_in_use, iwrk_not_released 
     128      USE wrk_nemo, ONLY:   zwf  =>  wrk_2d_1      ! 2D real    workspace 
     129      USE wrk_nemo, ONLY:   imsk => iwrk_2d_1      ! 2D integer workspace 
     130      ! 
    111131      INTEGER  ::   ji, jj, jk      ! dummy loop indices 
    112       INTEGER  ::   iif, iil, ii0, ii1, ii 
    113       INTEGER  ::   ijf, ijl, ij0, ij1 
    114       INTEGER , DIMENSION(jpi,jpj) ::  imsk 
    115       REAL(wp), DIMENSION(jpi,jpj) ::   zwf 
     132      INTEGER  ::   iif, iil, ii0, ii1, ii   ! local integers 
     133      INTEGER  ::   ijf, ijl, ij0, ij1       !   -       - 
    116134      !! 
    117135      NAMELIST/namlbc/ rn_shlat 
    118136      !!--------------------------------------------------------------------- 
    119137       
     138      IF( wrk_in_use(2, 1) .OR. iwrk_in_use(2, 1) ) THEN 
     139         CALL ctl_stop('dom_msk: requested workspace arrays unavailable')   ;   RETURN 
     140      ENDIF 
     141 
    120142      REWIND( numnam )              ! Namelist namlbc : lateral momentum boundary condition 
    121143      READ  ( numnam, namlbc ) 
     
    414436      ENDIF 
    415437      ! 
     438      IF( wrk_not_released(2, 1)  .OR.   & 
     439         iwrk_not_released(2, 1)  )   CALL ctl_stop('dom_msk: failed to release workspace arrays') 
     440      ! 
    416441   END SUBROUTINE dom_msk 
    417442 
     
    431456      !! ** Action : 
    432457      !!---------------------------------------------------------------------- 
    433       INTEGER  :: ji, jj, jk, jl      ! dummy loop indices 
     458      INTEGER  ::   ji, jj, jk, jl      ! dummy loop indices 
    434459      INTEGER  ::   ine, inw, ins, inn, itest, ierror, iind, ijnd 
    435460      REAL(wp) ::   zaa 
    436       INTEGER, DIMENSION(jpi*jpj*jpk,3) ::  icoord 
    437461      !!--------------------------------------------------------------------- 
    438        
    439  
    440       IF(lwp)WRITE(numout,*) 
    441       IF(lwp)WRITE(numout,*) 'dom_msk_nsa : noslip accurate boundary condition' 
    442       IF(lwp)WRITE(numout,*) '~~~~~~~~~~~   using Schchepetkin and O Brian scheme' 
    443       IF( lk_mpp ) CALL ctl_stop( ' mpp version is not yet implemented' ) 
     462 
     463      IF(lwp) WRITE(numout,*) 
     464      IF(lwp) WRITE(numout,*) 'dom_msk_nsa : noslip accurate boundary condition' 
     465      IF(lwp) WRITE(numout,*) '~~~~~~~~~~~   using Schchepetkin and O Brian scheme' 
     466      IF( lk_mpp )   CALL ctl_stop( ' mpp version is not yet implemented' ) 
    444467 
    445468      ! mask for second order calculation of vorticity 
     
    596619         CALL ctl_stop( 'We stop...' ) 
    597620      ENDIF 
    598  
     621      ! 
    599622   END SUBROUTINE dom_msk_nsa 
    600623 
Note: See TracChangeset for help on using the changeset viewer.