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

Changeset 2651


Ignore:
Timestamp:
2011-03-04T12:04:28+01:00 (12 years ago)
Author:
gm
Message:

dynamic mem: #785 ; minor changes, style mainly

Location:
branches/dev_r2586_dynamic_mem/NEMOGCM/NEMO
Files:
4 edited

Legend:

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

    r2633 r2651  
    3434   PRIVATE 
    3535 
    36    PUBLIC   dom_msk        ! routine called by inidom.F90 
    37    PUBLIC   dom_msk_alloc  ! routine called by nemogcm.F90 
     36   PUBLIC   dom_msk         ! routine called by inidom.F90 
     37   PUBLIC   dom_msk_alloc   ! routine called by nemogcm.F90 
    3838 
    3939   !                            !!* Namelist namlbc : lateral boundary condition * 
     
    5151CONTAINS 
    5252    
    53    FUNCTION dom_msk_alloc() 
     53   INTEGER FUNCTION dom_msk_alloc() 
    5454      !!--------------------------------------------------------------------- 
    55       !!                 ***  ROUTINE dom_msk_alloc  *** 
     55      !!                 ***  FUNCTION dom_msk_alloc  *** 
    5656      !!--------------------------------------------------------------------- 
    57       INTEGER :: dom_msk_alloc 
    58  
    5957      dom_msk_alloc = 0 
    60  
    6158#if defined key_noslip_accurate 
    62       ALLOCATE(icoord(jpi*jpj*jpk,3), Stat=dom_msk_alloc) 
     59      ALLOCATE(icoord(jpi*jpj*jpk,3), STAT=dom_msk_alloc) 
    6360#endif 
    64  
    65       IF(dom_msk_alloc /= 0)THEN 
    66          CALL ctl_warn('dom_msk_alloc: failed to allocate icoord array.') 
    67       END IF 
    68  
     61      IF( dom_msk_alloc /= 0 )   CALL ctl_warn('dom_msk_alloc: failed to allocate icoord array') 
     62      ! 
    6963   END FUNCTION dom_msk_alloc 
    7064 
     
    131125      !!               tmask_i  : interior ocean mask 
    132126      !!---------------------------------------------------------------------- 
    133       USE wrk_nemo, ONLY: wrk_in_use, wrk_not_released, iwrk_in_use, iwrk_not_released 
    134       USE wrk_nemo, ONLY: zwf => wrk_2d_1 
    135       USE wrk_nemo, ONLY: imsk => iwrk_2d_1 
     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 
     129      USE wrk_nemo, ONLY:   imsk => iwrk_2d_1 
    136130      !! 
    137131      INTEGER  ::   ji, jj, jk      ! dummy loop indices 
     
    142136      !!--------------------------------------------------------------------- 
    143137       
    144       IF( wrk_in_use(2,1) .OR. iwrk_in_use(2,1) )THEN 
    145          CALL ctl_stop('dom_msk: ERROR: requested workspace arrays unavailable.') 
    146          RETURN 
    147       END IF 
     138      IF( wrk_in_use(2, 1) .OR. iwrk_in_use(2, 1) )THEN 
     139         CALL ctl_stop('dom_msk: ERROR: requested workspace arrays unavailable')   ;   RETURN 
     140      ENDIF 
    148141 
    149142      REWIND( numnam )              ! Namelist namlbc : lateral momentum boundary condition 
     
    443436      ENDIF 
    444437      ! 
    445       IF( wrk_not_released(2,1) .OR. iwrk_not_released(2,1) )THEN 
    446          CALL ctl_stop('dom_msk: ERROR: failed to release workspace arrays.') 
    447       END IF 
     438      IF( wrk_not_released(2, 1) .OR.   & 
     439         iwrk_not_released(2, 1)   )   CALL ctl_stop('dom_msk: ERROR: failed to release workspace arrays') 
    448440      ! 
    449441   END SUBROUTINE dom_msk 
     
    464456      !! ** Action : 
    465457      !!---------------------------------------------------------------------- 
    466       INTEGER  :: ji, jj, jk, jl      ! dummy loop indices 
     458      INTEGER  ::   ji, jj, jk, jl      ! dummy loop indices 
    467459      INTEGER  ::   ine, inw, ins, inn, itest, ierror, iind, ijnd 
    468460      REAL(wp) ::   zaa 
    469461      !!--------------------------------------------------------------------- 
    470        
    471462 
    472463      IF(lwp)WRITE(numout,*) 
    473464      IF(lwp)WRITE(numout,*) 'dom_msk_nsa : noslip accurate boundary condition' 
    474465      IF(lwp)WRITE(numout,*) '~~~~~~~~~~~   using Schchepetkin and O Brian scheme' 
    475       IF( lk_mpp ) CALL ctl_stop( ' mpp version is not yet implemented' ) 
     466      IF( lk_mpp )   CALL ctl_stop( ' mpp version is not yet implemented' ) 
    476467 
    477468      ! mask for second order calculation of vorticity 
     
    628619         CALL ctl_stop( 'We stop...' ) 
    629620      ENDIF 
    630  
     621      ! 
    631622   END SUBROUTINE dom_msk_nsa 
    632623 
  • branches/dev_r2586_dynamic_mem/NEMOGCM/NEMO/OPA_SRC/OBS/obs_readmdt.F90

    r2638 r2651  
    44   !! Observation diagnostics: Read the MDT for SLA data (skeleton for now) 
    55   !!====================================================================== 
    6  
    7    !!---------------------------------------------------------------------- 
    8    !!   obs_rea_mdt : Driver for reading MDT 
    9    !!---------------------------------------------------------------------- 
    10  
    11    !! * Modules used    
    12    USE par_kind, ONLY : &       ! Precision variables 
    13       & wp, & 
    14       & dp, & 
    15       & sp 
    16    USE par_oce, ONLY : &        ! Domain parameters 
    17       & jpi, & 
    18       & jpj, & 
    19       & jpim1 
    20    USE in_out_manager, ONLY : & ! I/O manager 
    21       & lwp,    & 
    22       & numout  
    23    USE obs_surf_def             ! Surface observation definitions 
    24    USE dom_oce, ONLY : &        ! Domain variables 
    25       & tmask, & 
    26       & tmask_i, & 
    27       & e1t,   & 
    28       & e2t,   & 
    29       & gphit, & 
    30       & glamt 
    31    USE obs_const, ONLY : & 
    32       & obfillflt              ! Fillvalue 
    33    USE oce, ONLY : &           ! Model variables 
    34       & sshn 
    35    USE obs_inter_sup           ! Interpolation support routines 
    36    USE obs_inter_h2d           ! 2D interpolation 
    37    USE obs_utils               ! Various observation tools 
    38    USE lib_mpp, only: &        ! MPP routines 
    39       & lk_mpp, & 
    40       & mpp_sum 
    41    USE iom_nf90    
    42    USE netcdf                   ! NetCDF library 
    43    USE lib_mpp                  ! For ctl_warn/stop 
     6   !! History :      ! 2007-03 (K. Mogensen) Initial skeleton version 
     7   !!                ! 2007-04 (E. Remy) migration and improvement from OPAVAR 
     8   !!---------------------------------------------------------------------- 
     9 
     10   !!---------------------------------------------------------------------- 
     11   !!   obs_rea_mdt    : Driver for reading MDT 
     12   !!   obs_offset_mdt : Remove the offset between the model MDT and the used one 
     13   !!---------------------------------------------------------------------- 
     14   USE par_kind         ! Precision variables 
     15   USE par_oce          ! Domain parameters 
     16   USE in_out_manager   ! I/O manager 
     17   USE obs_surf_def     ! Surface observation definitions 
     18   USE obs_inter_sup    ! Interpolation support routines 
     19   USE obs_inter_h2d    ! 2D interpolation 
     20   USE obs_utils        ! Various observation tools 
     21   USE iom_nf90         ! IOM NetCDF 
     22   USE netcdf           ! NetCDF library 
     23   USE lib_mpp          ! MPP library 
     24   USE dom_oce, ONLY : &                  ! Domain variables 
     25      &                    tmask, tmask_i, e1t, e2t, gphit, glamt 
     26   USE obs_const, ONLY :   obfillflt      ! Fillvalue 
     27   USE oce      , ONLY :   sshn           ! Model variables 
    4428 
    4529   IMPLICIT NONE 
    46  
    47    !! * Routine accessibility 
    4830   PRIVATE 
    49  
    50    INTEGER, PUBLIC :: nmsshc = 1        ! MDT correction scheme 
    51    REAL(wp), PUBLIC :: mdtcorr = 1.61   ! User specified MDT correction 
    52    REAL(wp), PUBLIC :: mdtcutoff = 65.0  ! MDT cutoff for computed correction 
    53    PUBLIC obs_rea_mdt     ! Read the MDT 
    54    PUBLIC obs_offset_mdt  ! Remove the offset between the model MDT and the  
    55                           ! used one 
     31    
     32   PUBLIC   obs_rea_mdt     ! called by ? 
     33   PUBLIC   obs_offset_mdt  ! called by ? 
     34 
     35   INTEGER , PUBLIC ::   nmsshc    = 1         ! MDT correction scheme 
     36   REAL(wp), PUBLIC ::   mdtcorr   = 1.61_wp   ! User specified MDT correction 
     37   REAL(wp), PUBLIC ::   mdtcutoff = 65.0_wp   ! MDT cutoff for computed correction 
    5638 
    5739   !!---------------------------------------------------------------------- 
    5840   !! NEMO/OPA 3.3 , NEMO Consortium (2010) 
    5941   !! $Id$ 
    60    !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 
    61    !!---------------------------------------------------------------------- 
    62  
     42   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt) 
     43   !!---------------------------------------------------------------------- 
    6344CONTAINS 
    6445 
     
    7354      !! 
    7455      !! ** Action  :  
    75       !! 
    76       !! References : 
    77       !! 
    78       !! History :   
    79       !!      ! :  2007-03 (K. Mogensen) Initial skeleton version 
    80       !!      ! :  2007-04 (E. Remy) migration and improvement from OPAVAR 
    81       !!---------------------------------------------------------------------- 
    82       !! * Modules used 
     56      !!---------------------------------------------------------------------- 
    8357      USE iom 
    84       USE wrk_nemo, ONLY: wrk_in_use, wrk_not_released 
    85       USE wrk_nemo, ONLY: z_mdt => wrk_2d_1,  &  ! Array to store the MDT values 
    86                         mdtmask => wrk_2d_2    ! Array to store the mask for the MDT 
    87       !! 
    88       !! * Arguments 
    89       INTEGER, INTENT(IN) :: kslano          ! Number of SLA Products 
    90       TYPE(obs_surf), DIMENSION(kslano), INTENT(INOUT) :: & 
    91          & sladata       ! SLA data 
    92       INTEGER, INTENT(IN) :: k2dint 
    93  
    94       !! * Local declarations 
    95  
    96       CHARACTER(LEN=12), PARAMETER :: & 
    97          & cpname = 'obs_rea_mdt' 
    98       CHARACTER(LEN=20), PARAMETER :: & 
    99          & mdtname = 'slaReferenceLevel.nc' 
    100  
    101       INTEGER :: jslano      ! Data set loop variable 
    102       INTEGER :: jobs        ! Obs loop variable 
    103       INTEGER :: jpimdt      ! Number of grid point in latitude for the MDT 
    104       INTEGER :: jpjmdt      ! Number of grid point in longitude for the MDT 
    105       INTEGER :: iico        ! Grid point indicies 
    106       INTEGER :: ijco  
    107       INTEGER :: i_nx_id     ! Index to read the NetCDF file 
    108       INTEGER :: i_ny_id     !  
    109       INTEGER :: i_file_id   !  
    110       INTEGER :: i_var_id 
    111       INTEGER :: i_stat 
    112  
    113       REAL(wp), DIMENSION(1) :: & 
    114          & zext, & 
    115          & zobsmask 
    116       REAL(wp), DIMENSION(2,2,1) :: & 
    117          & zweig 
    118       REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: & 
    119          & zmask, & 
    120          & zmdtl, & 
    121          & zglam, & 
    122          & zgphi 
     58      USE wrk_nemo, ONLY:   wrk_in_use, wrk_not_released 
     59      USE wrk_nemo, ONLY:   z_mdt   => wrk_2d_1   ! Array to store the MDT values 
     60      USE wrk_nemo, ONLY:   mdtmask => wrk_2d_2   ! Array to store the mask for the MDT 
     61      ! 
     62      INTEGER                          , INTENT(IN)    ::   kslano    ! Number of SLA Products 
     63      TYPE(obs_surf), DIMENSION(kslano), INTENT(inout) ::   sladata   ! SLA data 
     64      INTEGER                          , INTENT(in)    ::   k2dint    ! ? 
     65      ! 
     66      CHARACTER(LEN=12), PARAMETER ::   cpname  = 'obs_rea_mdt' 
     67      CHARACTER(LEN=20), PARAMETER ::   mdtname = 'slaReferenceLevel.nc' 
     68 
     69      INTEGER ::   jslano              ! Data set loop variable 
     70      INTEGER ::   jobs                ! Obs loop variable 
     71      INTEGER ::   jpimdt, jpjmdt      ! Number of grid point in lat/lon for the MDT 
     72      INTEGER ::   iico, ijco          ! Grid point indicies 
     73      INTEGER ::   i_nx_id, i_ny_id, i_file_id, i_var_id, i_stat 
     74      INTEGER ::   nummdt 
     75      ! 
     76      REAL(wp), DIMENSION(1)     ::   zext, zobsmask 
     77      REAL(wp), DIMENSION(2,2,1) ::   zweig 
     78      ! 
     79      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::   zmask, zmdtl, zglam, zgphi 
     80      INTEGER , DIMENSION(:,:,:), ALLOCATABLE ::   igrdi, igrdj 
    12381          
    124       REAL(wp) :: zlam 
    125       REAL(wp) :: zphi 
    126       REAL(wp) :: zfill 
    127       REAL(sp) :: zinfill 
    128       INTEGER, DIMENSION(:,:,:), ALLOCATABLE :: & 
    129          & igrdi, & 
    130          & igrdj 
    131       INTEGER :: nummdt 
    132       !!---------------------------------------------------------------------- 
    133  
    134       IF(wrk_in_use(2, 1,2))THEN 
    135          CALL ctl_stop('obs_rea_mdt : requested workspace array unavailable.') 
    136          RETURN 
    137       END IF 
     82      REAL(wp) :: zlam, zphi, zfill, zinfill    ! local scalar 
     83      !!---------------------------------------------------------------------- 
     84 
     85      IF( wrk_in_use(2, 1,2) ) THEN 
     86         CALL ctl_stop('obs_rea_mdt : requested workspace array unavailable')   ;   RETURN 
     87      ENDIF 
    13888 
    13989      IF(lwp)WRITE(numout,*)  
    140       IF(lwp)WRITE(numout,*) ' obs_rea_mdt : ' 
     90      IF(lwp)WRITE(numout,*) ' obs_rea_mdt : Read MDT for referencing altimeter anomalies' 
    14191      IF(lwp)WRITE(numout,*) ' ------------- ' 
    142       IF(lwp)WRITE(numout,*) '   Read MDT for referencing altimeter', & 
    143          &                   '   anomalies' 
    144  
    145       ! Open the file 
    146        
    147       CALL iom_open( mdtname, nummdt ) 
    148        
    149       ! Get the MDT data 
    150  
    151       CALL iom_get( nummdt, jpdom_data, 'sossheig', z_mdt(:,:), 1 ) 
    152  
    153       ! Close the file 
    154  
    155       CALL iom_close(nummdt)      
     92 
     93      CALL iom_open( mdtname, nummdt )       ! Open the file 
     94      !                                      ! Get the MDT data 
     95      CALL iom_get ( nummdt, jpdom_data, 'sossheig', z_mdt(:,:), 1 ) 
     96      CALL iom_close(nummdt)                 ! Close the file 
    15697       
    15798      ! Read in the fill value 
     
    163104      i_stat = nf90_close( nummdt ) 
    164105 
    165 ! setup mask based on tmask and MDT mask 
    166 ! set mask to 0 where the MDT is set to fillvalue 
    167  
    168       WHERE(z_mdt(:,:) /= zfill) 
    169          mdtmask(:,:)=tmask(:,:,1) 
    170       ELSEWHERE 
    171          mdtmask(:,:)=0 
     106      ! setup mask based on tmask and MDT mask 
     107      ! set mask to 0 where the MDT is set to fillvalue 
     108      WHERE(z_mdt(:,:) /= zfill)   ;   mdtmask(:,:) = tmask(:,:,1) 
     109      ELSE WHERE                   ;   mdtmask(:,:) = 0 
    172110      END WHERE 
    173111 
    174112      ! Remove the offset between the MDT used with the sla and the model MDT 
    175  
    176       IF ( nmsshc == 1 .OR. nmsshc == 2 ) CALL obs_offset_mdt( z_mdt, zfill ) 
     113      IF( nmsshc == 1 .OR. nmsshc == 2 )   CALL obs_offset_mdt( z_mdt, zfill ) 
    177114 
    178115      ! Intepolate the MDT already on the model grid at the observation point 
    179116   
    180117      DO jslano = 1, kslano 
    181  
    182118         ALLOCATE( & 
    183119            & igrdi(2,2,sladata(jslano)%nsurf), & 
     
    202138         END DO 
    203139 
    204          CALL obs_int_comm_2d( 2, 2, sladata(jslano)%nsurf, & 
    205             &                  igrdi, igrdj, glamt, zglam ) 
    206          CALL obs_int_comm_2d( 2, 2, sladata(jslano)%nsurf, & 
    207             &                  igrdi, igrdj, gphit, zgphi ) 
    208          CALL obs_int_comm_2d( 2, 2, sladata(jslano)%nsurf, & 
    209             &                  igrdi, igrdj, mdtmask, zmask ) 
    210          CALL obs_int_comm_2d( 2, 2, sladata(jslano)%nsurf, & 
    211             &                  igrdi, igrdj, z_mdt, zmdtl ) 
     140         CALL obs_int_comm_2d( 2, 2, sladata(jslano)%nsurf, igrdi, igrdj, glamt  , zglam ) 
     141         CALL obs_int_comm_2d( 2, 2, sladata(jslano)%nsurf, igrdi, igrdj, gphit  , zgphi ) 
     142         CALL obs_int_comm_2d( 2, 2, sladata(jslano)%nsurf, igrdi, igrdj, mdtmask, zmask ) 
     143         CALL obs_int_comm_2d( 2, 2, sladata(jslano)%nsurf, igrdi, igrdj, z_mdt  , zmdtl ) 
    212144 
    213145         DO jobs = 1, sladata(jslano)%nsurf 
     
    220152               &                   zmask(:,:,jobs), zweig, zobsmask ) 
    221153             
    222             CALL obs_int_h2d( 1, 1,      & 
    223                    &              zweig, zmdtl(:,:,jobs),  zext ) 
     154            CALL obs_int_h2d( 1, 1, zweig, zmdtl(:,:,jobs),  zext ) 
    224155  
    225156            sladata(jslano)%rext(jobs,2) = zext(1) 
    226157 
    227158! mark any masked data with a QC flag 
    228             IF ( zobsmask(1) == 0 ) sladata(jslano)%nqc(jobs) = 11 
     159            IF( zobsmask(1) == 0 )  sladata(jslano)%nqc(jobs) = 11 
    229160 
    230161         END DO 
     
    241172      END DO 
    242173 
    243       IF(wrk_not_released(2, 1,2))THEN 
    244          CALL ctl_stop('obs_rea_mdt : failed to release workspace arrays.') 
    245       END IF 
    246  
     174      IF( wrk_not_released(2, 1,2) )   CALL ctl_stop('obs_rea_mdt: failed to release workspace arrays') 
     175      ! 
    247176   END SUBROUTINE obs_rea_mdt 
    248177 
     178 
    249179   SUBROUTINE obs_offset_mdt( mdt, zfill ) 
    250  
    251180      !!--------------------------------------------------------------------- 
    252181      !! 
     
    260189      !! 
    261190      !! ** Action  :  
    262       !! 
    263       !! References : 
    264       !! 
    265       !! History :   
    266       !!      ! :  2007-04 (E. Remy) migration from OPAVAR 
    267       !!---------------------------------------------------------------------- 
    268       !! * Modules used 
    269       USE wrk_nemo, ONLY: wrk_in_use, wrk_not_released 
    270       USE wrk_nemo, ONLY: zpromsk => wrk_2d_3 
    271       !! 
    272       !! * Arguments 
    273       REAL(wp), DIMENSION(jpi,jpj), INTENT(INOUT) :: & 
    274          & mdt           ! MDT used on the model grid 
    275       REAL(wp), INTENT(IN) :: zfill  
    276  
    277       !! * Local declarations  
    278       REAL(wp) :: zdxdy 
    279       REAL(wp) :: zarea 
    280       REAL(wp) :: zeta1 
    281       REAL(wp) :: zeta2 
    282       REAL(wp) :: zcorr_mdt   
    283       REAL(wp) :: zcorr_bcketa 
    284       REAL(wp) :: zcorr 
    285       INTEGER :: jj 
    286       INTEGER :: ji 
    287       CHARACTER(LEN=14), PARAMETER :: & 
    288          & cpname = 'obs_offset_mdt' 
    289       !!---------------------------------------------------------------------- 
    290  
    291       IF(wrk_in_use(2, 3))THEN 
    292          CALL ctl_stop('obs_offset_mdt : requested workspace array unavailable.') 
    293          RETURN 
    294       END IF 
     191      !!---------------------------------------------------------------------- 
     192      USE wrk_nemo, ONLY:   wrk_in_use, wrk_not_released 
     193      USE wrk_nemo, ONLY:   zpromsk => wrk_2d_3 
     194      ! 
     195      REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) ::   mdt     ! MDT used on the model grid 
     196      REAL(wp)                    , INTENT(in   ) ::   zfill  
     197      !  
     198      INTEGER  :: ji, jj 
     199      REAL(wp) :: zdxdy, zarea, zeta1, zeta2, zcorr_mdt, zcorr_bcketa, zcorr     ! local scalar 
     200      CHARACTER(LEN=14), PARAMETER ::   cpname = 'obs_offset_mdt' 
     201      !!---------------------------------------------------------------------- 
     202 
     203      IF( wrk_in_use(2, 3) ) THEN 
     204         CALL ctl_stop('obs_offset_mdt: requested workspace array unavailable')   ;   RETURN 
     205      ENDIF 
    295206 
    296207      !  Initialize the local mask, for domain projection  
     
    322233      END DO 
    323234 
    324       IF( lk_mpp) CALL mpp_sum( zeta1 ) 
    325       IF( lk_mpp) CALL mpp_sum( zeta2 ) 
    326       IF( lk_mpp) CALL mpp_sum( zarea ) 
     235      IF( lk_mpp)   CALL mpp_sum( zeta1 ) 
     236      IF( lk_mpp)   CALL mpp_sum( zeta2 ) 
     237      IF( lk_mpp)   CALL mpp_sum( zarea ) 
    327238       
    328       zcorr_mdt = zeta1 / zarea 
    329       zcorr_bcketa  = zeta2 / zarea 
     239      zcorr_mdt    = zeta1 / zarea 
     240      zcorr_bcketa = zeta2 / zarea 
    330241 
    331242      !  Define correction term 
     
    335246      !  Correct spatial mean of the MSSH 
    336247 
    337       IF ( nmsshc == 1 ) mdt(:,:) = mdt(:,:) - zcorr   
     248      IF( nmsshc == 1 )  mdt(:,:) = mdt(:,:) - zcorr   
    338249 
    339250      ! User defined value : 1.6 m for the Rio MDT compared to ORCA2 MDT 
    340251 
    341       IF ( nmsshc == 2 ) mdt(:,:) = mdt(:,:) - mdtcorr 
     252      IF( nmsshc == 2 )  mdt(:,:) = mdt(:,:) - mdtcorr 
    342253 
    343254      IF(lwp) THEN 
     
    348259         WRITE(numout,*) '               zcorr         = ', zcorr 
    349260         WRITE(numout,*) '               nmsshc        = ', nmsshc 
    350          WRITE(numout,*)  
    351261      ENDIF 
    352262 
    353       IF ( nmsshc == 0 ) WRITE(numout,*) & 
    354          &                 '           MSSH correction is not applied' 
    355       IF ( nmsshc == 1 ) WRITE(numout,*) & 
    356          &                 '           MSSH correction is applied' 
    357       IF ( nmsshc == 2 ) WRITE(numout,*) & 
    358          &                 '           User defined MSSH correction'  
    359  
    360  
    361       IF(wrk_not_released(2, 3))THEN 
    362          CALL ctl_stop('obs_offset_mdt : failed to release workspace array.') 
    363       END IF 
    364  
     263      IF ( nmsshc == 0 ) WRITE(numout,*) '           MSSH correction is not applied' 
     264      IF ( nmsshc == 1 ) WRITE(numout,*) '           MSSH correction is applied' 
     265      IF ( nmsshc == 2 ) WRITE(numout,*) '           User defined MSSH correction'  
     266 
     267      IF( wrk_not_released(2, 3) )   CALL ctl_stop('obs_offset_mdt: failed to release workspace array') 
     268      ! 
    365269   END SUBROUTINE obs_offset_mdt 
    366270  
     271   !!====================================================================== 
    367272END MODULE obs_readmdt 
  • branches/dev_r2586_dynamic_mem/NEMOGCM/NEMO/OPA_SRC/nemogcm.F90

    r2647 r2651  
    502502      !! ** Method  : 
    503503      !!---------------------------------------------------------------------- 
    504       USE par_oce 
    505504      INTEGER, INTENT(in) :: num_pes ! The number of MPI processes we have 
    506       ! Local variables 
     505      ! 
    507506      INTEGER, PARAMETER :: nfactmax = 20 
    508507      INTEGER :: nfact ! The no. of factors returned 
    509508      INTEGER :: ierr  ! Error flag 
    510       INTEGER :: i 
     509      INTEGER :: ji 
    511510      INTEGER :: idiff, mindiff, imin ! For choosing pair of factors that are closest in value 
    512511      INTEGER, DIMENSION(nfactmax) :: ifact ! Array of factors 
     
    526525         mindiff = 1000000 
    527526         imin    = 1 
    528          DO i=1,nfact-1,2 
    529             idiff = ABS(ifact(i) - ifact(i+1)) 
    530             IF(idiff < mindiff)THEN 
     527         DO ji = 1, nfact-1, 2 
     528            idiff = ABS( ifact(ji) - ifact(ji+1) ) 
     529            IF( idiff < mindiff ) THEN 
    531530               mindiff = idiff 
    532                imin = i 
    533             END IF 
     531               imin = ji 
     532            ENDIF 
    534533         END DO 
    535534         jpnj = ifact(imin) 
     
    543542 
    544543 
    545    SUBROUTINE factorise( ifax, maxfax, nfax, n, ierr ) 
     544   SUBROUTINE factorise( kfax, kmaxfax, knfax, kn, kerr ) 
    546545      !!---------------------------------------------------------------------- 
    547546      !!                     ***  ROUTINE factorise  *** 
    548547      !! 
    549548      !! ** Purpose :   return the prime factors of n. 
    550       !!                nfax factors are returned in array ifax which is of  
    551       !!                maximum dimension maxfax. 
     549      !!                knfax factors are returned in array kfax which is of  
     550      !!                maximum dimension kmaxfax. 
    552551      !! ** Method  : 
    553552      !!---------------------------------------------------------------------- 
    554       INTEGER, INTENT(in)  :: n, maxfax 
    555       INTEGER, INTENT(Out) :: ierr, nfax 
    556       INTEGER, INTENT(out) :: ifax(maxfax) 
    557       ! Local variables. 
    558       INTEGER :: i, ifac, l, nu 
     553      INTEGER                    , INTENT(in   ) ::   kn, kmaxfax 
     554      INTEGER                    , INTENT(  out) ::   kerr, knfax 
     555      INTEGER, DIMENSION(kmaxfax), INTENT(  out) ::   kfax 
     556      ! 
     557      INTEGER :: ifac, jl, inu 
    559558      INTEGER, PARAMETER :: ntest = 14 
    560       INTEGER :: lfax(ntest) 
     559      INTEGER :: ilfax(ntest) 
    561560 
    562561      ! lfax contains the set of allowed factors. 
    563       data (lfax(i),i=1,ntest) / 16384, 8192, 4096, 2048, 1024, 512, 256,  & 
    564          &                         128,   64,   32,   16,    8,   4,   2  / 
     562      data (ilfax(jl),jl=1,ntest) / 16384, 8192, 4096, 2048, 1024, 512, 256,  & 
     563         &                            128,   64,   32,   16,    8,   4,   2  / 
    565564      !!---------------------------------------------------------------------- 
    566565 
    567566      ! Clear the error flag and initialise output vars 
    568       ierr = 0 
    569       ifax = 1 
    570       nfax = 0 
     567      kerr = 0 
     568      kfax = 1 
     569      knfax = 0 
    571570 
    572571      ! Find the factors of n. 
    573       IF( n == 1 ) GOTO 20 
     572      IF( kn == 1 )  GOTO 20 
    574573 
    575574      ! nu holds the unfactorised part of the number. 
    576       ! nfax holds the number of factors found. 
     575      ! knfax holds the number of factors found. 
    577576      ! l points to the allowed factor list. 
    578577      ! ifac holds the current factor. 
    579578 
    580       nu   = n 
    581       nfax = 0 
    582  
    583       DO l = ntest, 1, -1 
     579      inu   = kn 
     580      knfax = 0 
     581 
     582      DO jl = ntest, 1, -1 
    584583         ! 
    585          ifac = lfax(l) 
    586          IF(ifac > nu)CYCLE 
     584         ifac = ilfax(jl) 
     585         IF( ifac > inu )   CYCLE 
    587586 
    588587         ! Test whether the factor will divide. 
    589588 
    590          IF( MOD(nu,ifac) == 0 ) THEN 
     589         IF( MOD(inu,ifac) == 0 ) THEN 
    591590            ! 
    592             nfax = nfax+1            ! Add the factor to the list 
    593             IF( nfax > maxfax ) THEN 
    594                ierr = 6 
    595                write (*,*) 'FACTOR: insufficient space in factor array ',nfax 
     591            knfax = knfax + 1            ! Add the factor to the list 
     592            IF( knfax > kmaxfax ) THEN 
     593               kerr = 6 
     594               write (*,*) 'FACTOR: insufficient space in factor array ', knfax 
    596595               return 
    597596            ENDIF 
    598             ifax(nfax) = ifac 
     597            kfax(knfax) = ifac 
    599598            ! Store the other factor that goes with this one 
    600             nfax = nfax + 1 
    601             ifax(nfax) = nu / ifac 
    602             !WRITE (*,*) 'ARPDBG, factors ',nfax-1,' & ',nfax,' are ', & 
    603             !            ifax(nfax-1),' and ',ifax(nfax) 
     599            knfax = knfax + 1 
     600            kfax(knfax) = inu / ifac 
     601            !WRITE (*,*) 'ARPDBG, factors ',knfax-1,' & ',knfax,' are ', kfax(knfax-1),' and ',kfax(knfax) 
    604602         ENDIF 
    605603         ! 
     
    608606   20 CONTINUE      ! Label 20 is the exit point from the factor search loop. 
    609607      ! 
    610       RETURN 
    611       ! 
    612608   END SUBROUTINE factorise 
    613609 
  • branches/dev_r2586_dynamic_mem/NEMOGCM/NEMO/TOP_SRC/TRP/trcsbc.F90

    r2643 r2651  
    5757      !! 
    5858      !!---------------------------------------------------------------------- 
    59       USE wrk_nemo, ONLY: wrk_in_use, wrk_not_released 
    60       USE wrk_nemo, zemps  => wrk_2d_1 
    61       USE wrk_nemo, ztrtrd => wrk_3d_1 
     59      USE wrk_nemo, ONLY:   wrk_in_use, wrk_not_released 
     60      USE wrk_nemo, ONLY:   zemps  => wrk_2d_1 
     61      USE wrk_nemo, ONLY:   ztrtrd => wrk_3d_1 
    6262      ! 
    6363      INTEGER, INTENT( in ) ::   kt          ! ocean time-step index 
Note: See TracChangeset for help on using the changeset viewer.