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

First attempt to put dynamic allocation on the trunk

Location:
trunk/NEMOGCM/NEMO/OFF_SRC
Files:
4 edited
1 copied

Legend:

Unmodified
Added
Removed
  • trunk/NEMOGCM/NEMO/OFF_SRC/dommsk.F90

    r2528 r2715  
    1212   USE oce             ! ocean dynamics and tracers 
    1313   USE dom_oce         ! ocean space and time domain 
     14   USE lib_mpp         ! MPP library 
    1415   USE in_out_manager  ! I/O manager 
    1516 
     
    1920   PUBLIC   dom_msk    ! routine called by inidom.F90 
    2021 
    21 #if defined key_degrad 
    22    !! ------------------------------------------------ 
    23    !! Degradation method 
    24    !! -------------------------------------------------- 
    25    REAL(wp), PUBLIC, DIMENSION (jpi,jpj,jpk) ::   facvol  !! volume for degraded regions 
    26 #endif 
     22   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   facvol   !: volume for degraded regions 
    2723 
    2824   !! * Substitutions 
     
    3430   !!---------------------------------------------------------------------- 
    3531CONTAINS 
    36     
     32 
    3733   SUBROUTINE dom_msk 
    3834      !!--------------------------------------------------------------------- 
     
    4945      !!               tpol     : ??? 
    5046      !!---------------------------------------------------------------------- 
     47      USE wrk_nemo, ONLY:   iwrk_in_use, iwrk_not_released 
     48      USE wrk_nemo, ONLY:   imsk => iwrk_2d_1 
     49      ! 
    5150      INTEGER  ::   ji, jk                   ! dummy loop indices 
    5251      INTEGER  ::   iif, iil, ijf, ijl       ! local integers 
    53       INTEGER, DIMENSION(jpi,jpj) ::  imsk   ! 2D workspace 
    5452      !!--------------------------------------------------------------------- 
    5553      ! 
     54      IF( iwrk_in_use(2, 1) ) THEN 
     55         CALL ctl_stop('dom_msk: requested workspace arrays unavailable')   ;   RETURN 
     56      END IF 
     57      ! 
     58#if defined key_degrad 
     59      IF( dom_msk_alloc() /= 0 )   CALL ctl_stop('STOP','dom_msk: unable to allocate arrays') 
     60#endif 
     61 
    5662      ! Interior domain mask (used for global sum) 
    5763      ! -------------------- 
     
    95101      ENDIF 
    96102      ! 
     103      IF( iwrk_not_released(2, 1) )   CALL ctl_stop('dom_msk: failed to release workspace arrays') 
     104      ! 
    97105   END SUBROUTINE dom_msk 
     106 
     107 
     108   INTEGER FUNCTION dom_msk_alloc() 
     109      !!--------------------------------------------------------------------- 
     110      !!                 ***  FUNCTION dom_msk_alloc  *** 
     111      !!--------------------------------------------------------------------- 
     112      ALLOCATE( facvol(jpi,jpj,jpk) , STAT=dom_msk_alloc ) 
     113      IF( dom_msk_alloc /= 0 )   CALL ctl_warn('dom_msk_alloc : failed to allocate facvol array') 
     114      ! 
     115   END FUNCTION dom_msk_alloc 
    98116 
    99117   !!====================================================================== 
  • trunk/NEMOGCM/NEMO/OFF_SRC/domrea.F90

    r2528 r2715  
    1616   USE dommsk          ! domain: masks 
    1717   USE lbclnk          ! lateral boundary condition - MPP exchanges 
    18    USE in_out_manager  ! I/O manager 
     18   USE lib_mpp  
     19   USE in_out_manager 
     20   USE wrk_nemo, ONLY: wrk_in_use, wrk_not_released 
    1921 
    2022   IMPLICIT NONE 
     
    5355      !!---------------------------------------------------------------------- 
    5456      USE iom 
     57      USE wrk_nemo, ONLY: zmbk => wrk_2d_1, zprt => wrk_2d_2, zprw => wrk_2d_3 
    5558      !! 
    5659      INTEGER  ::   ji, jj, jk   ! dummy loop indices 
    5760      INTEGER  ::   ik, inum0 , inum1 , inum2 , inum3 , inum4   ! local integers 
    5861      REAL(wp) ::   zrefdep         ! local real 
    59       REAL(wp), DIMENSION(jpi,jpj) ::   zmbk, zprt, zprw   ! 2D workspace 
    6062      !!---------------------------------------------------------------------- 
    6163 
     
    6365      IF(lwp) WRITE(numout,*) 'dom_rea : read NetCDF mesh and mask information file(s)' 
    6466      IF(lwp) WRITE(numout,*) '~~~~~~~' 
     67 
     68      IF( wrk_in_use(2, 1,2,3)  ) THEN 
     69         CALL ctl_stop('dom_rea: ERROR: requested workspace arrays unavailable.') ; RETURN 
     70      END IF 
    6571 
    6672      zmbk(:,:) = 0._wp 
     
    141147         CALL iom_get( inum3, jpdom_data, 'e2u', e2u ) 
    142148         CALL iom_get( inum3, jpdom_data, 'e2v', e2v ) 
     149 
     150         e1e2t(:,:) = e1t(:,:) * e2t(:,:)                              ! surface at T-points 
    143151 
    144152         CALL iom_get( inum3, jpdom_data, 'ff', ff ) 
     
    314322      END SELECT 
    315323      ! 
     324      IF( wrk_not_released(2, 1,2,3)  ) CALL ctl_stop('dom_rea:failed to release workspace arrays.') 
     325      ! 
    316326   END SUBROUTINE dom_rea 
    317327 
     
    327337      !! ** Action  : - update mbathy: level bathymetry (in level index) 
    328338      !!---------------------------------------------------------------------- 
     339      USE wrk_nemo, ONLY: zmbk => wrk_2d_4 
     340      ! 
    329341      INTEGER ::   ji, jj   ! dummy loop indices 
    330       REAL(wp), DIMENSION(jpi,jpj) ::   zmbk   ! 2D workspace  
    331       !!---------------------------------------------------------------------- 
     342      !!---------------------------------------------------------------------- 
     343 
    332344      ! 
    333345      IF(lwp) WRITE(numout,*) 
    334346      IF(lwp) WRITE(numout,*) '    zgr_bot_level : ocean bottom k-index of T-, U-, V- and W-levels ' 
    335347      IF(lwp) WRITE(numout,*) '    ~~~~~~~~~~~~~' 
     348      ! 
     349      IF( wrk_in_use(2, 4) ) THEN 
     350         CALL ctl_stop('dom_rea: ERROR: requested workspace arrays unavailable.')  ;  RETURN 
     351      END IF 
    336352      ! 
    337353      mbkt(:,:) = MAX( mbathy(:,:) , 1 )    ! bottom k-index of T-level (=1 over land) 
     
    347363      zmbk(:,:) = REAL( mbkv(:,:), wp )   ;   CALL lbc_lnk(zmbk,'V',1.)   ;   mbkv  (:,:) = MAX( INT( zmbk(:,:) ), 1 ) 
    348364      ! 
     365      IF( wrk_not_released(2, 4) ) CALL ctl_stop('dom_rea:failed to release workspace arrays.') 
     366      ! 
    349367   END SUBROUTINE zgr_bot_level 
    350368 
  • trunk/NEMOGCM/NEMO/OFF_SRC/dtadyn.F90

    r2559 r2715  
    6363   INTEGER ::   numfl_t, numfl_u, numfl_v, numfl_w 
    6464 
    65    REAL(wp), DIMENSION(jpi,jpj,jpk,2) :: tdta       ! temperature at two consecutive times 
    66    REAL(wp), DIMENSION(jpi,jpj,jpk,2) :: sdta       ! salinity at two consecutive times 
    67    REAL(wp), DIMENSION(jpi,jpj,jpk,2) :: udta       ! zonal velocity at two consecutive times 
    68    REAL(wp), DIMENSION(jpi,jpj,jpk,2) :: vdta       ! meridional velocity at two consecutive times 
    69    REAL(wp), DIMENSION(jpi,jpj,jpk,2) :: wdta       ! vertical velocity at two consecutive times 
    70    REAL(wp), DIMENSION(jpi,jpj,jpk,2) :: avtdta     ! vertical diffusivity coefficient 
    71  
    72    REAL(wp), DIMENSION(jpi,jpj    ,2) :: hmlddta    ! mixed layer depth at two consecutive times 
    73    REAL(wp), DIMENSION(jpi,jpj    ,2) :: wspddta    ! wind speed at two consecutive times 
    74    REAL(wp), DIMENSION(jpi,jpj    ,2) :: frlddta    ! sea-ice fraction at two consecutive times 
    75    REAL(wp), DIMENSION(jpi,jpj    ,2) :: empdta     ! E-P at two consecutive times 
    76    REAL(wp), DIMENSION(jpi,jpj    ,2) :: qsrdta     ! short wave heat flux at two consecutive times 
    77    REAL(wp), DIMENSION(jpi,jpj    ,2) :: bblxdta    ! frequency of bbl in the x direction at 2 consecutive times  
    78    REAL(wp), DIMENSION(jpi,jpj    ,2) :: bblydta    ! frequency of bbl in the y direction at 2 consecutive times  
     65   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: tdta       ! temperature at two consecutive times 
     66   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: sdta       ! salinity at two consecutive times 
     67   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: udta       ! zonal velocity at two consecutive times 
     68   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: vdta       ! meridional velocity at two consecutive times 
     69   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: wdta       ! vertical velocity at two consecutive times 
     70   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: avtdta     ! vertical diffusivity coefficient 
     71 
     72   REAL(wp), ALLOCATABLE, SAVE,   DIMENSION(:,:,:) :: hmlddta    ! mixed layer depth at two consecutive times 
     73   REAL(wp), ALLOCATABLE, SAVE,   DIMENSION(:,:,:) :: wspddta    ! wind speed at two consecutive times 
     74   REAL(wp), ALLOCATABLE, SAVE,   DIMENSION(:,:,:) :: frlddta    ! sea-ice fraction at two consecutive times 
     75   REAL(wp), ALLOCATABLE, SAVE,   DIMENSION(:,:,:) :: empdta     ! E-P at two consecutive times 
     76   REAL(wp), ALLOCATABLE, SAVE,   DIMENSION(:,:,:) :: qsrdta     ! short wave heat flux at two consecutive times 
     77   REAL(wp), ALLOCATABLE, SAVE,   DIMENSION(:,:,:) :: bblxdta    ! frequency of bbl in the x direction at 2 consecutive times  
     78   REAL(wp), ALLOCATABLE, SAVE,   DIMENSION(:,:,:) :: bblydta    ! frequency of bbl in the y direction at 2 consecutive times  
    7979   LOGICAL :: l_offbbl 
    8080#if defined key_ldfslp 
    81    REAL(wp), DIMENSION(jpi,jpj,jpk,2) :: uslpdta    ! zonal isopycnal slopes 
    82    REAL(wp), DIMENSION(jpi,jpj,jpk,2) :: vslpdta    ! meridional isopycnal slopes 
    83    REAL(wp), DIMENSION(jpi,jpj,jpk,2) :: wslpidta   ! zonal diapycnal slopes 
    84    REAL(wp), DIMENSION(jpi,jpj,jpk,2) :: wslpjdta   ! meridional diapycnal slopes 
     81   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: uslpdta    ! zonal isopycnal slopes 
     82   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: vslpdta    ! meridional isopycnal slopes 
     83   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: wslpidta   ! zonal diapycnal slopes 
     84   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: wslpjdta   ! meridional diapycnal slopes 
    8585#endif 
    8686#if ! defined key_degrad &&  defined key_traldf_c2d && defined key_traldf_eiv  
    87    REAL(wp), DIMENSION(jpi,jpj    ,2) :: aeiwdta    ! G&M coefficient 
     87   REAL(wp), ALLOCATABLE, SAVE,   DIMENSION(:,:,:) :: aeiwdta    ! G&M coefficient 
    8888#endif 
    8989#if defined key_degrad 
    90    REAL(wp), DIMENSION(jpi,jpj,jpk,2) :: ahtudta, ahtvdta, ahtwdta   ! Lateral diffusivity 
     90   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: ahtudta, ahtvdta, ahtwdta   ! Lateral diffusivity 
    9191# if defined key_traldf_eiv 
    92    REAL(wp), DIMENSION(jpi,jpj,jpk,2) :: aeiudta, aeivdta, aeiwdta   ! G&M coefficient 
     92   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: aeiudta, aeivdta, aeiwdta   ! G&M coefficient 
    9393# endif 
    9494#endif 
     
    297297 
    298298 
     299   INTEGER FUNCTION dta_dyn_alloc() 
     300      !!--------------------------------------------------------------------- 
     301      !!                 ***  ROUTINE dta_dyn_alloc  *** 
     302      !!--------------------------------------------------------------------- 
     303 
     304      ALLOCATE( tdta    (jpi,jpj,jpk,2), sdta    (jpi,jpj,jpk,2),    & 
     305         &      udta    (jpi,jpj,jpk,2), vdta    (jpi,jpj,jpk,2),    & 
     306         &      wdta    (jpi,jpj,jpk,2), avtdta  (jpi,jpj,jpk,2),    & 
     307#if defined key_ldfslp  
     308         &      uslpdta (jpi,jpj,jpk,2), vslpdta (jpi,jpj,jpk,2),    & 
     309         &      wslpidta(jpi,jpj,jpk,2), wslpjdta(jpi,jpj,jpk,2),    & 
     310#endif 
     311#if defined key_degrad 
     312         &      ahtudta (jpi,jpj,jpk,2), ahtvdta (jpi,jpj,jpk,2),    & 
     313         &      ahtwdta (jpi,jpj,jpk,2),                             & 
     314# if defined key_traldf_eiv 
     315         &      aeiudta (jpi,jpj,jpk,2), aeivdta (jpi,jpj,jpk,2),    & 
     316         &      aeiwdta (jpi,jpj,jpk,2),                             & 
     317# endif 
     318#endif 
     319#if ! defined key_degrad &&  defined key_traldf_c2d && defined key_traldf_eiv 
     320         &      aeiwdta (jpi,jpj,    2),                             & 
     321#endif 
     322         &      hmlddta (jpi,jpj,    2), wspddta (jpi,jpj,    2),    & 
     323         &      frlddta (jpi,jpj,    2), qsrdta  (jpi,jpj,    2),    & 
     324         &      empdta  (jpi,jpj,    2),                         STAT=dta_dyn_alloc )  
     325         ! 
     326      IF( dta_dyn_alloc /= 0 )   CALL ctl_warn('dta_dyn_alloc: failed to allocate facvol array') 
     327      ! 
     328   END FUNCTION dta_dyn_alloc 
     329 
     330 
    299331   SUBROUTINE dynrea( kt, kenr ) 
    300332      !!---------------------------------------------------------------------- 
     
    305337      !! ** Method : READ the kenr records of DATA and store in udta(...,2), ....   
    306338      !!---------------------------------------------------------------------- 
     339      USE wrk_nemo, ONLY: wrk_in_use, wrk_not_released 
     340      USE wrk_nemo, ONLY: zu    => wrk_3d_1 , zv    => wrk_3d_2 , zw    => wrk_3d_3 
     341      USE wrk_nemo, ONLY: zt    => wrk_3d_4 , zs    => wrk_3d_5 
     342      USE wrk_nemo, ONLY: zavt  => wrk_3d_6 , zhdiv => wrk_3d_7 
     343      USE wrk_nemo, ONLY: zahtu => wrk_3d_8 , zahtv => wrk_3d_9 , zahtw => wrk_3d_10 
     344      USE wrk_nemo, ONLY: zaeiu => wrk_3d_11, zaeiv => wrk_3d_12, zaeiw => wrk_3d_13 
     345      ! 
     346      USE wrk_nemo, ONLY: zemp  => wrk_2d_1 , zqsr  => wrk_2d_2 , zmld  => wrk_2d_3 
     347      USE wrk_nemo, ONLY: zice  => wrk_2d_4 , zwspd => wrk_2d_5  
     348      USE wrk_nemo, ONLY: ztaux => wrk_2d_6 , ztauy => wrk_2d_7 
     349      USE wrk_nemo, ONLY: zbblx => wrk_2d_8 , zbbly => wrk_2d_9 
     350      USE wrk_nemo, ONLY: zaeiw2d => wrk_2d_10 
     351      ! 
    307352      INTEGER, INTENT(in) ::   kt, kenr   ! time index 
    308353      !! 
    309354      INTEGER ::  jkenr 
    310       REAL(wp), DIMENSION(jpi,jpj,jpk) ::  zu, zv, zw, zt, zs, zavt , zhdiv              ! 3D workspace 
    311       REAL(wp), DIMENSION(jpi,jpj)     ::  zemp, zqsr, zmld, zice, zwspd, ztaux, ztauy   ! 2D workspace 
    312       REAL(wp), DIMENSION(jpi,jpj)     ::  zbblx, zbbly 
    313  
    314 #if ! defined key_degrad && defined key_traldf_c2d && defined key_traldf_eiv 
    315       REAL(wp), DIMENSION(jpi,jpj) :: zaeiw  
    316 #endif 
    317 #if defined key_degrad 
    318    REAL(wp), DIMENSION(jpi,jpj,jpk) ::   zahtu, zahtv, zahtw  !  Lateral diffusivity 
    319 # if defined key_traldf_eiv 
    320    REAL(wp), DIMENSION(jpi,jpj,jpk) ::   zaeiu, zaeiv, zaeiw  ! G&M coefficient 
    321 # endif 
    322 #endif 
    323       !!---------------------------------------------------------------------- 
    324  
    325       ! 0. Initialization 
     355      !!---------------------------------------------------------------------- 
     356      !  
     357      IF( wrk_in_use(3, 1,2,3,4,5,6,7,8,9,10,11,12,13) .OR. & 
     358          wrk_in_use(2, 1,2,3,4,5,6,7,8,9,10)               ) THEN 
     359         CALL ctl_stop('domrea/dta_dyn: requested workspace arrays unavailable')   ;   RETURN 
     360      ENDIF 
    326361       
    327362      ! cas d'un fichier non periodique : on utilise deux fois le premier et 
     
    390425 
    391426#if ! defined key_degrad && defined key_traldf_c2d && defined key_traldf_eiv  
    392       CALL iom_get( numfl_w, jpdom_data, 'soleaeiw', zaeiw (:,: ), jkenr ) 
     427      CALL iom_get( numfl_w, jpdom_data, 'soleaeiw', zaeiw2d(:,: ), jkenr ) 
    393428#endif 
    394429 
     
    413448 
    414449#if ! defined key_degrad && defined key_traldf_c2d && defined key_traldf_eiv 
    415       aeiwdta(:,:,2)  = zaeiw(:,:) * tmask(:,:,1) 
     450      aeiwdta(:,:,2)  = zaeiw2d(:,:) * tmask(:,:,1) 
    416451#endif 
    417452 
     
    451486      ENDIF 
    452487      !       
     488      IF( wrk_not_released(3, 1,2,3,4,5,6,7,8,9,10,11,12,13) .OR. & 
     489          wrk_not_released(2, 1,2,3,4,5,6,7,8,9,10)               ) THEN 
     490         CALL ctl_stop('domrea/dta_dyn: failed to release workspace arrays') 
     491      END IF 
     492      ! 
    453493   END SUBROUTINE dynrea 
    454494 
     
    462502      !! ** Method : 
    463503      !!---------------------------------------------------------------------- 
    464       REAL(wp) ::   znspyr   !: number of time step per year 
    465       !! 
     504      REAL(wp) :: znspyr   !: number of time step per year 
     505      ! 
    466506      NAMELIST/namdyn/ ndtadyn, ndtatot, nsptint, lperdyn,  & 
    467       &                cfile_grid_T, cfile_grid_U, cfile_grid_V, cfile_grid_W 
    468       !!---------------------------------------------------------------------- 
    469  
    470       !  Define the dynamical input parameters 
    471       ! ====================================== 
    472  
     507         &             cfile_grid_T, cfile_grid_U, cfile_grid_V, cfile_grid_W 
     508      !!---------------------------------------------------------------------- 
     509      ! 
     510      IF( dta_dyn_alloc() /= 0 )  CALL ctl_stop( 'STOP', 'dta_dyn_alloc: unable to allocate standard ocean arrays' ) 
     511      ! 
    473512      REWIND( numnam )              ! Read Namelist namdyn : Lateral physics on tracers 
    474513      READ  ( numnam, namdyn ) 
    475  
     514      ! 
    476515      IF(lwp) THEN                  ! control print 
    477516         WRITE(numout,*) 
     
    493532      ! 
    494533      znspyr   = nyear_len(1) * rday / rdt   
    495       rnspdta  = znspyr / FLOAT( ndtadyn ) 
     534      rnspdta  = znspyr / REAL( ndtadyn, wp ) 
    496535      rnspdta2 = rnspdta * 0.5  
    497536      ! 
  • trunk/NEMOGCM/NEMO/OFF_SRC/nemogcm.F90

    r2574 r2715  
    55   !!====================================================================== 
    66   !! History :  3.3  ! 2010-05  (C. Ethe)  Full reorganization of the off-line: phasing with the on-line 
     7   !!            4.0  ! 2011-01  (C. Ethe, A. R. Porter, STFC Daresbury) dynamical allocation 
    78   !!---------------------------------------------------------------------- 
    89 
     
    2627   USE trabbl          ! bottom boundary layer          (tra_bbl_init routine) 
    2728   USE zdfini          ! vertical physics: initialization 
     29   USE sbcmod          ! surface boundary condition       (sbc_init     routine) 
    2830   USE phycst          ! physical constant                  (par_cst routine) 
    2931   USE dtadyn          ! Lecture and Interpolation of the dynamical fields 
     
    3941   USE lib_mpp         ! distributed memory computing 
    4042#if defined key_iomput 
    41    USE  mod_ioclient 
     43   USE mod_ioclient 
    4244#endif  
     45   USE prtctl           ! Print control                    (prt_ctl_init routine) 
    4346 
    4447   IMPLICIT NONE 
     
    122125      INTEGER ::   ji            ! dummy loop indices 
    123126      INTEGER ::   ilocal_comm   ! local integer 
    124       CHARACTER(len=80), DIMENSION(10) ::   cltxt = '' 
     127      CHARACTER(len=80), DIMENSION(16) ::   cltxt = '' 
    125128      !! 
    126129      NAMELIST/namctl/ ln_ctl  , nn_print, nn_ictls, nn_ictle,   & 
     
    137140      !                             !--------------------------------------------! 
    138141#if defined key_iomput 
    139       CALL init_ioclient( ilocal_comm )       ! nemo local communicator (used or not) given by the io_server 
    140       narea = mynode( cltxt, ilocal_comm )    ! Nodes selection 
     142      CALL  init_ioclient( ilocal_comm )                 ! exchange io_server nemo local communicator with the io_server 
     143      narea = mynode( cltxt, numnam, nstop, ilocal_comm )   ! Nodes selection 
    141144#else 
    142       narea = mynode( cltxt )                 ! Nodes selection (control print return in cltxt) 
     145      ilocal_comm = 0 
     146      narea = mynode( cltxt, numnam, nstop )                 ! Nodes selection (control print return in cltxt) 
    143147#endif 
     148 
    144149      narea = narea + 1                       ! mynode return the rank of proc (0 --> jpnij -1 ) 
    145150 
    146151      lwp = (narea == 1) .OR. ln_ctl          ! control of all listing output print 
     152 
     153      ! If dimensions of processor grid weren't specified in the namelist file  
     154      ! then we calculate them here now that we have our communicator size 
     155      IF( (jpni < 1) .OR. (jpnj < 1) )THEN 
     156#if   defined key_mpp_mpi   ||   defined key_mpp_shmem 
     157         CALL nemo_partition(mppsize) 
     158#else 
     159         jpni = 1 
     160         jpnj = 1 
     161         jpnij = jpni*jpnj 
     162#endif 
     163      END IF 
     164 
     165      ! Calculate domain dimensions given calculated jpni and jpnj 
     166      ! This used to be done in par_oce.F90 when they were parameters rather 
     167      ! than variables 
     168      jpi = ( jpiglo-2*jpreci + (jpni-1) ) / jpni + 2*jpreci   ! first  dim. 
     169      jpj = ( jpjglo-2*jprecj + (jpnj-1) ) / jpnj + 2*jprecj   ! second dim. 
     170      jpk = jpkdta                                             ! third dim 
     171      jpim1 = jpi-1                                            ! inner domain indices 
     172      jpjm1 = jpj-1                                            !   "           " 
     173      jpkm1 = jpk-1                                            !   "           " 
     174      jpij  = jpi*jpj                                          !  jpi x j 
     175 
    147176 
    148177      IF(lwp) THEN                            ! open listing units 
     
    163192         ! 
    164193      ENDIF 
     194 
     195      ! Now we know the dimensions of the grid and numout has been set we can  
     196      ! allocate arrays 
     197      CALL nemo_alloc() 
     198 
    165199      !                             !--------------------------------! 
    166200      !                             !  Model general initialization  ! 
     
    181215                            CALL  istate_init   ! ocean initial state (Dynamics and tracers) 
    182216 
     217 
     218      IF( ln_ctl        )   CALL prt_ctl_init   ! Print control 
     219 
    183220      !                                     ! Ocean physics 
     221                            CALL     sbc_init   ! Forcings : surface module 
    184222#if ! defined key_degrad 
    185223                            CALL ldf_tra_init   ! Lateral ocean tracer physics 
     
    307345   END SUBROUTINE nemo_closefile 
    308346 
     347 
     348   SUBROUTINE nemo_alloc 
     349      !!---------------------------------------------------------------------- 
     350      !!                     ***  ROUTINE nemo_alloc  *** 
     351      !! 
     352      !! ** Purpose :   Allocate all the dynamic arrays of the OPA modules 
     353      !! 
     354      !! ** Method  : 
     355      !!---------------------------------------------------------------------- 
     356      USE diawri,       ONLY: dia_wri_alloc 
     357      USE dom_oce,      ONLY: dom_oce_alloc 
     358      USE zdf_oce,      ONLY: zdf_oce_alloc 
     359      USE zdfmxl,       ONLY: zdf_mxl_alloc 
     360      USE ldftra_oce,   ONLY: ldftra_oce_alloc 
     361      USE trc_oce,      ONLY: trc_oce_alloc 
     362      USE wrk_nemo,    ONLY: wrk_alloc 
     363      ! 
     364      INTEGER :: ierr 
     365      !!---------------------------------------------------------------------- 
     366      ! 
     367      ierr =        oce_alloc       ()          ! ocean  
     368      ierr = ierr + dia_wri_alloc   () 
     369      ierr = ierr + dom_oce_alloc   ()          ! ocean domain 
     370      ierr = ierr + ldftra_oce_alloc()          ! ocean lateral  physics : tracers 
     371      ierr = ierr + zdf_oce_alloc   ()          ! ocean vertical physics 
     372      ierr = ierr + zdf_mxl_alloc   ()          ! ocean vertical physics 
     373      ! 
     374      ierr = ierr + lib_mpp_alloc   (numout)    ! mpp exchanges 
     375      ierr = ierr + trc_oce_alloc   ()          ! shared TRC / TRA arrays 
     376      ierr = ierr + wrk_alloc(numout, lwp) 
     377      ! 
     378      IF( lk_mpp    )   CALL mpp_sum( ierr ) 
     379      IF( ierr /= 0 )   CALL ctl_stop( 'STOP', 'nemo_alloc: unable to allocate standard ocean arrays' ) 
     380      ! 
     381   END SUBROUTINE nemo_alloc 
     382 
     383 
     384   SUBROUTINE nemo_partition( num_pes ) 
     385      !!---------------------------------------------------------------------- 
     386      !!                 ***  ROUTINE nemo_partition  *** 
     387      !! 
     388      !! ** Purpose :    
     389      !! 
     390      !! ** Method  : 
     391      !!---------------------------------------------------------------------- 
     392      INTEGER, INTENT(in) :: num_pes ! The number of MPI processes we have 
     393      ! 
     394      INTEGER, PARAMETER :: nfactmax = 20 
     395      INTEGER :: nfact ! The no. of factors returned 
     396      INTEGER :: ierr  ! Error flag 
     397      INTEGER :: ji 
     398      INTEGER :: idiff, mindiff, imin ! For choosing pair of factors that are closest in value 
     399      INTEGER, DIMENSION(nfactmax) :: ifact ! Array of factors 
     400      !!---------------------------------------------------------------------- 
     401 
     402      ierr = 0 
     403 
     404      CALL factorise( ifact, nfactmax, nfact, num_pes, ierr ) 
     405 
     406      IF( nfact <= 1 ) THEN 
     407         WRITE (numout, *) 'WARNING: factorisation of number of PEs failed' 
     408         WRITE (numout, *) '       : using grid of ',num_pes,' x 1' 
     409         jpnj = 1 
     410         jpni = num_pes 
     411      ELSE 
     412         ! Search through factors for the pair that are closest in value 
     413         mindiff = 1000000 
     414         imin    = 1 
     415         DO ji = 1, nfact-1, 2 
     416            idiff = ABS( ifact(ji) - ifact(ji+1) ) 
     417            IF( idiff < mindiff ) THEN 
     418               mindiff = idiff 
     419               imin = ji 
     420            ENDIF 
     421         END DO 
     422         jpnj = ifact(imin) 
     423         jpni = ifact(imin + 1) 
     424      ENDIF 
     425      ! 
     426      jpnij = jpni*jpnj 
     427      ! 
     428   END SUBROUTINE nemo_partition 
     429 
     430 
     431   SUBROUTINE factorise( kfax, kmaxfax, knfax, kn, kerr ) 
     432      !!---------------------------------------------------------------------- 
     433      !!                     ***  ROUTINE factorise  *** 
     434      !! 
     435      !! ** Purpose :   return the prime factors of n. 
     436      !!                knfax factors are returned in array kfax which is of  
     437      !!                maximum dimension kmaxfax. 
     438      !! ** Method  : 
     439      !!---------------------------------------------------------------------- 
     440      INTEGER                    , INTENT(in   ) ::   kn, kmaxfax 
     441      INTEGER                    , INTENT(  out) ::   kerr, knfax 
     442      INTEGER, DIMENSION(kmaxfax), INTENT(  out) ::   kfax 
     443      ! 
     444      INTEGER :: ifac, jl, inu 
     445      INTEGER, PARAMETER :: ntest = 14 
     446      INTEGER :: ilfax(ntest) 
     447      ! 
     448      ! lfax contains the set of allowed factors. 
     449      data (ilfax(jl),jl=1,ntest) / 16384, 8192, 4096, 2048, 1024, 512, 256,  & 
     450         &                            128,   64,   32,   16,    8,   4,   2  / 
     451      !!---------------------------------------------------------------------- 
     452 
     453      ! Clear the error flag and initialise output vars 
     454      kerr = 0 
     455      kfax = 1 
     456      knfax = 0 
     457 
     458      ! Find the factors of n. 
     459      IF( kn == 1 )   GOTO 20 
     460 
     461      ! nu holds the unfactorised part of the number. 
     462      ! knfax holds the number of factors found. 
     463      ! l points to the allowed factor list. 
     464      ! ifac holds the current factor. 
     465 
     466      inu   = kn 
     467      knfax = 0 
     468 
     469      DO jl = ntest, 1, -1 
     470         ! 
     471         ifac = ilfax(jl) 
     472         IF( ifac > inu )   CYCLE 
     473 
     474         ! Test whether the factor will divide. 
     475 
     476         IF( MOD(inu,ifac) == 0 ) THEN 
     477            ! 
     478            knfax = knfax + 1            ! Add the factor to the list 
     479            IF( knfax > kmaxfax ) THEN 
     480               kerr = 6 
     481               write (*,*) 'FACTOR: insufficient space in factor array ', knfax 
     482               return 
     483            ENDIF 
     484            kfax(knfax) = ifac 
     485            ! Store the other factor that goes with this one 
     486            knfax = knfax + 1 
     487            kfax(knfax) = inu / ifac 
     488            !WRITE (*,*) 'ARPDBG, factors ',knfax-1,' & ',knfax,' are ', kfax(knfax-1),' and ',kfax(knfax) 
     489         ENDIF 
     490         ! 
     491      END DO 
     492 
     493   20 CONTINUE      ! Label 20 is the exit point from the factor search loop. 
     494      ! 
     495   END SUBROUTINE factorise 
     496 
    309497   !!====================================================================== 
    310498END MODULE nemogcm 
Note: See TracChangeset for help on using the changeset viewer.