Changeset 2715 for trunk/NEMOGCM/NEMO/OFF_SRC
- Timestamp:
- 2011-03-30T17:58:35+02:00 (13 years ago)
- Location:
- trunk/NEMOGCM/NEMO/OFF_SRC
- Files:
-
- 4 edited
- 1 copied
-
dommsk.F90 (modified) (5 diffs)
-
domrea.F90 (modified) (7 diffs)
-
dtadyn.F90 (modified) (8 diffs)
-
nemogcm.F90 (modified) (8 diffs)
-
zdfmxl.F90 (copied) (copied from branches/dev_r2586_dynamic_mem/NEMOGCM/NEMO/OFF_SRC/zdfmxl.F90)
Legend:
- Unmodified
- Added
- Removed
-
trunk/NEMOGCM/NEMO/OFF_SRC/dommsk.F90
r2528 r2715 12 12 USE oce ! ocean dynamics and tracers 13 13 USE dom_oce ! ocean space and time domain 14 USE lib_mpp ! MPP library 14 15 USE in_out_manager ! I/O manager 15 16 … … 19 20 PUBLIC dom_msk ! routine called by inidom.F90 20 21 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 27 23 28 24 !! * Substitutions … … 34 30 !!---------------------------------------------------------------------- 35 31 CONTAINS 36 32 37 33 SUBROUTINE dom_msk 38 34 !!--------------------------------------------------------------------- … … 49 45 !! tpol : ??? 50 46 !!---------------------------------------------------------------------- 47 USE wrk_nemo, ONLY: iwrk_in_use, iwrk_not_released 48 USE wrk_nemo, ONLY: imsk => iwrk_2d_1 49 ! 51 50 INTEGER :: ji, jk ! dummy loop indices 52 51 INTEGER :: iif, iil, ijf, ijl ! local integers 53 INTEGER, DIMENSION(jpi,jpj) :: imsk ! 2D workspace54 52 !!--------------------------------------------------------------------- 55 53 ! 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 56 62 ! Interior domain mask (used for global sum) 57 63 ! -------------------- … … 95 101 ENDIF 96 102 ! 103 IF( iwrk_not_released(2, 1) ) CALL ctl_stop('dom_msk: failed to release workspace arrays') 104 ! 97 105 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 98 116 99 117 !!====================================================================== -
trunk/NEMOGCM/NEMO/OFF_SRC/domrea.F90
r2528 r2715 16 16 USE dommsk ! domain: masks 17 17 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 19 21 20 22 IMPLICIT NONE … … 53 55 !!---------------------------------------------------------------------- 54 56 USE iom 57 USE wrk_nemo, ONLY: zmbk => wrk_2d_1, zprt => wrk_2d_2, zprw => wrk_2d_3 55 58 !! 56 59 INTEGER :: ji, jj, jk ! dummy loop indices 57 60 INTEGER :: ik, inum0 , inum1 , inum2 , inum3 , inum4 ! local integers 58 61 REAL(wp) :: zrefdep ! local real 59 REAL(wp), DIMENSION(jpi,jpj) :: zmbk, zprt, zprw ! 2D workspace60 62 !!---------------------------------------------------------------------- 61 63 … … 63 65 IF(lwp) WRITE(numout,*) 'dom_rea : read NetCDF mesh and mask information file(s)' 64 66 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 65 71 66 72 zmbk(:,:) = 0._wp … … 141 147 CALL iom_get( inum3, jpdom_data, 'e2u', e2u ) 142 148 CALL iom_get( inum3, jpdom_data, 'e2v', e2v ) 149 150 e1e2t(:,:) = e1t(:,:) * e2t(:,:) ! surface at T-points 143 151 144 152 CALL iom_get( inum3, jpdom_data, 'ff', ff ) … … 314 322 END SELECT 315 323 ! 324 IF( wrk_not_released(2, 1,2,3) ) CALL ctl_stop('dom_rea:failed to release workspace arrays.') 325 ! 316 326 END SUBROUTINE dom_rea 317 327 … … 327 337 !! ** Action : - update mbathy: level bathymetry (in level index) 328 338 !!---------------------------------------------------------------------- 339 USE wrk_nemo, ONLY: zmbk => wrk_2d_4 340 ! 329 341 INTEGER :: ji, jj ! dummy loop indices 330 REAL(wp), DIMENSION(jpi,jpj) :: zmbk ! 2D workspace331 !!---------------------------------------------------------------------- 342 !!---------------------------------------------------------------------- 343 332 344 ! 333 345 IF(lwp) WRITE(numout,*) 334 346 IF(lwp) WRITE(numout,*) ' zgr_bot_level : ocean bottom k-index of T-, U-, V- and W-levels ' 335 347 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 336 352 ! 337 353 mbkt(:,:) = MAX( mbathy(:,:) , 1 ) ! bottom k-index of T-level (=1 over land) … … 347 363 zmbk(:,:) = REAL( mbkv(:,:), wp ) ; CALL lbc_lnk(zmbk,'V',1.) ; mbkv (:,:) = MAX( INT( zmbk(:,:) ), 1 ) 348 364 ! 365 IF( wrk_not_released(2, 4) ) CALL ctl_stop('dom_rea:failed to release workspace arrays.') 366 ! 349 367 END SUBROUTINE zgr_bot_level 350 368 -
trunk/NEMOGCM/NEMO/OFF_SRC/dtadyn.F90
r2559 r2715 63 63 INTEGER :: numfl_t, numfl_u, numfl_v, numfl_w 64 64 65 REAL(wp), DIMENSION(jpi,jpj,jpk,2) :: tdta ! temperature at two consecutive times66 REAL(wp), DIMENSION(jpi,jpj,jpk,2) :: sdta ! salinity at two consecutive times67 REAL(wp), DIMENSION(jpi,jpj,jpk,2) :: udta ! zonal velocity at two consecutive times68 REAL(wp), DIMENSION(jpi,jpj,jpk,2) :: vdta ! meridional velocity at two consecutive times69 REAL(wp), DIMENSION(jpi,jpj,jpk,2) :: wdta ! vertical velocity at two consecutive times70 REAL(wp), DIMENSION(jpi,jpj,jpk,2) :: avtdta ! vertical diffusivity coefficient71 72 REAL(wp), DIMENSION(jpi,jpj ,2) :: hmlddta ! mixed layer depth at two consecutive times73 REAL(wp), DIMENSION(jpi,jpj ,2) :: wspddta ! wind speed at two consecutive times74 REAL(wp), DIMENSION(jpi,jpj ,2) :: frlddta ! sea-ice fraction at two consecutive times75 REAL(wp), DIMENSION(jpi,jpj ,2) :: empdta ! E-P at two consecutive times76 REAL(wp), DIMENSION(jpi,jpj ,2) :: qsrdta ! short wave heat flux at two consecutive times77 REAL(wp), DIMENSION(jpi,jpj ,2) :: bblxdta ! frequency of bbl in the x direction at 2 consecutive times78 REAL(wp), DIMENSION(jpi,jpj ,2) :: bblydta ! frequency of bbl in the y direction at 2 consecutive times65 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 79 79 LOGICAL :: l_offbbl 80 80 #if defined key_ldfslp 81 REAL(wp), DIMENSION(jpi,jpj,jpk,2) :: uslpdta ! zonal isopycnal slopes82 REAL(wp), DIMENSION(jpi,jpj,jpk,2) :: vslpdta ! meridional isopycnal slopes83 REAL(wp), DIMENSION(jpi,jpj,jpk,2) :: wslpidta ! zonal diapycnal slopes84 REAL(wp), DIMENSION(jpi,jpj,jpk,2) :: wslpjdta ! meridional diapycnal slopes81 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 85 85 #endif 86 86 #if ! defined key_degrad && defined key_traldf_c2d && defined key_traldf_eiv 87 REAL(wp), DIMENSION(jpi,jpj ,2) :: aeiwdta ! G&M coefficient87 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: aeiwdta ! G&M coefficient 88 88 #endif 89 89 #if defined key_degrad 90 REAL(wp), DIMENSION(jpi,jpj,jpk,2) :: ahtudta, ahtvdta, ahtwdta ! Lateral diffusivity90 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: ahtudta, ahtvdta, ahtwdta ! Lateral diffusivity 91 91 # if defined key_traldf_eiv 92 REAL(wp), DIMENSION(jpi,jpj,jpk,2) :: aeiudta, aeivdta, aeiwdta ! G&M coefficient92 REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: aeiudta, aeivdta, aeiwdta ! G&M coefficient 93 93 # endif 94 94 #endif … … 297 297 298 298 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 299 331 SUBROUTINE dynrea( kt, kenr ) 300 332 !!---------------------------------------------------------------------- … … 305 337 !! ** Method : READ the kenr records of DATA and store in udta(...,2), .... 306 338 !!---------------------------------------------------------------------- 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 ! 307 352 INTEGER, INTENT(in) :: kt, kenr ! time index 308 353 !! 309 354 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 326 361 327 362 ! cas d'un fichier non periodique : on utilise deux fois le premier et … … 390 425 391 426 #if ! defined key_degrad && defined key_traldf_c2d && defined key_traldf_eiv 392 CALL iom_get( numfl_w, jpdom_data, 'soleaeiw', zaeiw 427 CALL iom_get( numfl_w, jpdom_data, 'soleaeiw', zaeiw2d(:,: ), jkenr ) 393 428 #endif 394 429 … … 413 448 414 449 #if ! defined key_degrad && defined key_traldf_c2d && defined key_traldf_eiv 415 aeiwdta(:,:,2) = zaeiw (:,:) * tmask(:,:,1)450 aeiwdta(:,:,2) = zaeiw2d(:,:) * tmask(:,:,1) 416 451 #endif 417 452 … … 451 486 ENDIF 452 487 ! 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 ! 453 493 END SUBROUTINE dynrea 454 494 … … 462 502 !! ** Method : 463 503 !!---------------------------------------------------------------------- 464 REAL(wp) :: 465 ! !504 REAL(wp) :: znspyr !: number of time step per year 505 ! 466 506 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 ! 473 512 REWIND( numnam ) ! Read Namelist namdyn : Lateral physics on tracers 474 513 READ ( numnam, namdyn ) 475 514 ! 476 515 IF(lwp) THEN ! control print 477 516 WRITE(numout,*) … … 493 532 ! 494 533 znspyr = nyear_len(1) * rday / rdt 495 rnspdta = znspyr / FLOAT( ndtadyn)534 rnspdta = znspyr / REAL( ndtadyn, wp ) 496 535 rnspdta2 = rnspdta * 0.5 497 536 ! -
trunk/NEMOGCM/NEMO/OFF_SRC/nemogcm.F90
r2574 r2715 5 5 !!====================================================================== 6 6 !! 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 7 8 !!---------------------------------------------------------------------- 8 9 … … 26 27 USE trabbl ! bottom boundary layer (tra_bbl_init routine) 27 28 USE zdfini ! vertical physics: initialization 29 USE sbcmod ! surface boundary condition (sbc_init routine) 28 30 USE phycst ! physical constant (par_cst routine) 29 31 USE dtadyn ! Lecture and Interpolation of the dynamical fields … … 39 41 USE lib_mpp ! distributed memory computing 40 42 #if defined key_iomput 41 USE 43 USE mod_ioclient 42 44 #endif 45 USE prtctl ! Print control (prt_ctl_init routine) 43 46 44 47 IMPLICIT NONE … … 122 125 INTEGER :: ji ! dummy loop indices 123 126 INTEGER :: ilocal_comm ! local integer 124 CHARACTER(len=80), DIMENSION(1 0) :: cltxt = ''127 CHARACTER(len=80), DIMENSION(16) :: cltxt = '' 125 128 !! 126 129 NAMELIST/namctl/ ln_ctl , nn_print, nn_ictls, nn_ictle, & … … 137 140 ! !--------------------------------------------! 138 141 #if defined key_iomput 139 CALL init_ioclient( ilocal_comm ) ! nemo local communicator (used or not) given bythe io_server140 narea = mynode( cltxt, ilocal_comm )! Nodes selection142 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 141 144 #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) 143 147 #endif 148 144 149 narea = narea + 1 ! mynode return the rank of proc (0 --> jpnij -1 ) 145 150 146 151 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 147 176 148 177 IF(lwp) THEN ! open listing units … … 163 192 ! 164 193 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 165 199 ! !--------------------------------! 166 200 ! ! Model general initialization ! … … 181 215 CALL istate_init ! ocean initial state (Dynamics and tracers) 182 216 217 218 IF( ln_ctl ) CALL prt_ctl_init ! Print control 219 183 220 ! ! Ocean physics 221 CALL sbc_init ! Forcings : surface module 184 222 #if ! defined key_degrad 185 223 CALL ldf_tra_init ! Lateral ocean tracer physics … … 307 345 END SUBROUTINE nemo_closefile 308 346 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 309 497 !!====================================================================== 310 498 END MODULE nemogcm
Note: See TracChangeset
for help on using the changeset viewer.
