- Timestamp:
- 2018-01-12T10:38:50+01:00 (6 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/2017/dev_merge_2017/NEMOGCM/NEMO/OFF_SRC/nemogcm.F90
r9169 r9213 10 10 11 11 !!---------------------------------------------------------------------- 12 !! nemo_gcm : off-line: solve ocean tracer only 13 !! nemo_init : initialization of the nemo model 14 !! nemo_ctl : initialisation of algorithm flag 15 !! nemo_closefile : close remaining files 12 !! nemo_gcm : off-line: solve ocean tracer only 13 !! nemo_gcm : solve ocean dynamics, tracer, biogeochemistry and/or sea-ice 14 !! nemo_init : initialization of the NEMO system 15 !! nemo_ctl : initialisation of the contol print 16 !! nemo_closefile: close remaining open files 17 !! nemo_alloc : dynamical allocation 18 !! nemo_partition: calculate MPP domain decomposition 19 !! factorise : calculate the factors of the no. of MPI processes 20 !! nemo_nfdcom : Setup for north fold exchanges with explicit point-to-point messaging 21 !! istate_init : simple initialization to zero of ocean fields 22 !! stp_ctl : reduced step control (no dynamics in off-line) 16 23 !!---------------------------------------------------------------------- 17 USE dom_oce ! ocean space domain variables 18 USE oce ! dynamics and tracers variables 19 USE trc_oce ! Shared ocean/passive tracers variables 20 USE c1d ! 1D configuration 21 USE domain ! domain initialization from coordinate & bathymetry (dom_init routine) 22 USE usrdef_nam ! user defined configuration 23 USE eosbn2 ! equation of state (eos bn2 routine) 24 USE dom_oce ! ocean space domain variables 25 USE oce ! dynamics and tracers variables 26 USE trc_oce ! Shared ocean/passive tracers variables 27 USE c1d ! 1D configuration 28 USE domain ! domain initialization from coordinate & bathymetry (dom_init routine) 29 USE closea ! treatment of closed seas (for ln_closea) 30 USE usrdef_nam ! user defined configuration 31 USE eosbn2 ! equation of state (eos bn2 routine) 24 32 ! ! ocean physics 25 USE ldftra 26 USE ldfslp 27 USE traqsr 28 USE trabbl 29 USE traldf 30 USE sbcmod 31 USE phycst 32 USE dtadyn 33 USE trcini 34 USE daymod 35 USE trcstp 36 USE dtadyn 33 USE ldftra ! lateral diffusivity setting (ldf_tra_init routine) 34 USE ldfslp ! slopes of neutral surfaces (ldf_slp_init routine) 35 USE traqsr ! solar radiation penetration (tra_qsr_init routine) 36 USE trabbl ! bottom boundary layer (tra_bbl_init routine) 37 USE traldf ! lateral physics (tra_ldf_init routine) 38 USE sbcmod ! surface boundary condition (sbc_init routine) 39 USE phycst ! physical constant (par_cst routine) 40 USE dtadyn ! Lecture and Interpolation of the dynamical fields 41 USE trcini ! Initilization of the passive tracers 42 USE daymod ! calendar (day routine) 43 USE trcstp ! passive tracer time-stepping (trc_stp routine) 44 USE dtadyn ! Lecture and interpolation of the dynamical fields 37 45 ! ! Passive tracers needs 38 USE trc 39 USE trcnam 40 USE trcrst 41 USE diaptr 42 USE sbc_oce 43 USE sbcrnf 46 USE trc ! passive tracer : variables 47 USE trcnam ! passive tracer : namelist 48 USE trcrst ! passive tracer restart 49 USE diaptr ! Need to initialise this as some variables are used in if statements later 50 USE sbc_oce , ONLY : ln_rnf 51 USE sbcrnf ! surface boundary condition : runoffs 44 52 ! ! I/O & MPP 45 USE iom 46 USE in_out_manager 47 USE mppini 48 USE lib_mpp 53 USE iom ! I/O library 54 USE in_out_manager ! I/O manager 55 USE mppini ! shared/distributed memory setting (mpp_init routine) 56 USE lib_mpp ! distributed memory computing 49 57 #if defined key_iomput 50 USE xios 58 USE xios ! xIOserver 51 59 #endif 52 USE prtctl ! Print control (prt_ctl_init routine) 53 USE timing ! Timing 54 USE lib_fortran ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) 55 USE lbcnfd, ONLY: isendto, nsndto, nfsloop, nfeloop ! Setup of north fold exchanges 56 57 60 USE prtctl ! Print control (prt_ctl_init routine) 61 USE timing ! Timing 62 USE lib_fortran ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) 63 USE lbcnfd , ONLY : isendto, nsndto, nfsloop, nfeloop ! Setup of north fold exchanges 58 64 59 65 IMPLICIT NONE … … 65 71 66 72 !!---------------------------------------------------------------------- 67 !! NEMO/OFF 3.3 , NEMO Consortium (2010)73 !! NEMO/OFF 4.0 , NEMO Consortium (2018) 68 74 !! $Id$ 69 75 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) … … 75 81 !! *** ROUTINE nemo_gcm *** 76 82 !! 77 !! ** Purpose : nemosolves the primitive equations on an orthogonal78 !! curvilinear mesh on the sphere.83 !! ** Purpose : NEMO solves the primitive equations on an orthogonal 84 !! curvilinear mesh on the sphere. 79 85 !! 80 86 !! ** Method : - model general initialization … … 99 105 istp = nit000 100 106 ! 101 ! Initialize arrays of runoffs structures and read data from the namelist 102 IF ( ln_rnf ) CALL sbc_rnf(istp) 107 IF( ln_rnf ) CALL sbc_rnf(istp) ! runoffs initialization 103 108 ! 104 CALL iom_init( cxios_context ) 109 CALL iom_init( cxios_context ) ! iom_put initialization (must be done after nemo_init for AGRIF+XIOS+OASIS) 105 110 ! 106 DO WHILE ( istp <= nitend .AND. nstop == 0 ) ! time stepping111 DO WHILE ( istp <= nitend .AND. nstop == 0 ) !== OFF time-stepping ==! 107 112 ! 108 113 IF( istp /= nit000 ) CALL day ( istp ) ! Calendar (day was already called at nit000 in day_init) … … 114 119 CALL stp_ctl ( istp, indic ) ! Time loop: control and print 115 120 istp = istp + 1 116 IF( lk_mpp ) CALL mpp_max( nstop )117 121 END DO 122 ! 118 123 #if defined key_iomput 119 124 CALL iom_context_finalize( cxios_context ) ! needed for XIOS+AGRIF … … 127 132 IF( nstop /= 0 .AND. lwp ) THEN ! error print 128 133 WRITE(numout,cform_err) 129 WRITE(numout,*) nstop, ' error have been found' 134 WRITE(numout,*) ' ==>>> nemo_gcm: a total of ', nstop, ' errors have been found' 135 WRITE(numout,*) 130 136 ENDIF 131 137 ! … … 134 140 CALL nemo_closefile 135 141 ! 136 # 137 CALL xios_finalize ! end mpp communications138 # 139 IF( lk_mpp ) CALL mppstop ! end mpp communications140 # 142 #if defined key_iomput 143 CALL xios_finalize ! end mpp communications with xios 144 #else 145 IF( lk_mpp ) CALL mppstop ! end mpp communications 146 #endif 141 147 ! 142 148 END SUBROUTINE nemo_gcm … … 145 151 SUBROUTINE nemo_init 146 152 !!---------------------------------------------------------------------- 147 !! *** ROUTINE nemo_init ***153 !! *** ROUTINE nemo_init *** 148 154 !! 149 155 !! ** Purpose : initialization of the nemo model in off-line mode 150 156 !!---------------------------------------------------------------------- 151 157 INTEGER :: ji ! dummy loop indices 152 INTEGER :: ilocal_comm ! local integer 153 INTEGER :: ios, inum ! local integers 154 INTEGER :: iiarea, ijarea ! local integers 155 INTEGER :: iirest, ijrest ! local integers 156 REAL(wp) :: ziglo, zjglo, zkglo, zperio ! local scalars 158 INTEGER :: ios, ilocal_comm ! local integers 159 INTEGER :: iiarea, ijarea ! - - 160 INTEGER :: iirest, ijrest ! - - 157 161 CHARACTER(len=120), DIMENSION(30) :: cltxt, cltxt2, clnam 158 162 !! 159 NAMELIST/namctl/ ln_ctl , nn_print, nn_ictls, nn_ictle, &160 & nn_isplt , nn_jsplt, nn_jctls, nn_jctle, &163 NAMELIST/namctl/ ln_ctl , nn_print, nn_ictls, nn_ictle, & 164 & nn_isplt , nn_jsplt, nn_jctls, nn_jctle, & 161 165 & ln_timing, ln_diacfl 162 163 NAMELIST/namcfg/ ln_read_cfg, cn_domcfg, ln_write_cfg, cn_domcfg_out, ln_use_jattr164 ! !----------------------------------------------------------------------166 NAMELIST/namcfg/ ln_read_cfg, cn_domcfg, ln_closea, ln_write_cfg, cn_domcfg_out, ln_use_jattr 167 !!---------------------------------------------------------------------- 168 ! 165 169 cltxt = '' 166 170 cltxt2 = '' … … 172 176 CALL ctl_opn( numnam_cfg, 'namelist_cfg', 'OLD', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. ) 173 177 ! 174 REWIND( numnam_ref ) ! Namelist namctl in reference namelist : Control prints & Benchmark178 REWIND( numnam_ref ) ! Namelist namctl in reference namelist 175 179 READ ( numnam_ref, namctl, IOSTAT = ios, ERR = 901 ) 176 180 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namctl in reference namelist', .TRUE. ) 177 REWIND( numnam_cfg ) ! Namelist namctl in confguration namelist : Control prints & Benchmark181 REWIND( numnam_cfg ) ! Namelist namctl in confguration namelist 178 182 READ ( numnam_cfg, namctl, IOSTAT = ios, ERR = 902 ) 179 183 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namctl in configuration namelist', .TRUE. ) 180 181 ! 182 REWIND( numnam_ref ) ! Namelist namcfg in reference namelist : Control prints & Benchmark 184 ! 185 REWIND( numnam_ref ) ! Namelist namcfg in reference namelist 183 186 READ ( numnam_ref, namcfg, IOSTAT = ios, ERR = 903 ) 184 187 903 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namcfg in reference namelist', .TRUE. ) 185 REWIND( numnam_cfg ) ! Namelist namcfg in confguration namelist : Control prints & Benchmark188 REWIND( numnam_cfg ) ! Namelist namcfg in confguration namelist 186 189 READ ( numnam_cfg, namcfg, IOSTAT = ios, ERR = 904 ) 187 190 904 IF( ios > 0 ) CALL ctl_nam ( ios , 'namcfg in configuration namelist', .TRUE. ) 188 191 189 190 192 ! !--------------------------! 191 193 ! ! Set global domain size ! (control print return in cltxt2) 192 ! 194 ! !--------------------------! 193 195 IF( ln_read_cfg ) THEN ! Read sizes in domain configuration file 194 196 CALL domain_cfg ( cltxt2, cn_cfg, nn_cfg, jpiglo, jpjglo, jpkglo, jperio ) … … 198 200 ENDIF 199 201 ! 200 ! 201 l_offline = .true. ! passive tracers are run offline 202 l_offline = .true. ! passive tracers are run offline 202 203 ! 203 204 ! !--------------------------------------------! … … 219 220 lwp = (narea == 1) .OR. ln_ctl ! control of all listing output print 220 221 221 IF(lwm) THEN 222 ! write merged namelists from earlier to output namelist now that the 223 ! file has been opened in call to mynode. nammpp has already been 224 ! written in mynode (if lk_mpp_mpi) 222 IF(lwm) THEN ! write merged namelists from earlier to output namelist 223 ! ! now that the file has been opened in call to mynode. 224 ! ! NB: nammpp has already been written in mynode (if lk_mpp_mpi) 225 225 WRITE( numond, namctl ) 226 226 WRITE( numond, namcfg ) 227 227 IF( .NOT.ln_read_cfg ) THEN 228 228 DO ji = 1, SIZE(clnam) 229 IF( TRIM(clnam (ji)) /= '' ) WRITE(numond, * ) clnam(ji)! namusr_def print229 IF( TRIM(clnam(ji)) /= '' ) WRITE(numond, * ) clnam(ji) ! namusr_def print 230 230 END DO 231 231 ENDIF … … 234 234 ! If dimensions of processor grid weren't specified in the namelist file 235 235 ! then we calculate them here now that we have our communicator size 236 IF( (jpni < 1) .OR. (jpnj < 1) )THEN236 IF( jpni < 1 .OR. jpnj < 1 ) THEN 237 237 #if defined key_mpp_mpi 238 CALL nemo_partition( mppsize)238 CALL nemo_partition( mppsize ) 239 239 #else 240 jpni = 1241 jpnj = 1240 jpni = 1 241 jpnj = 1 242 242 jpnij = jpni*jpnj 243 243 #endif 244 END 244 ENDIF 245 245 246 246 iiarea = 1 + MOD( narea - 1 , jpni ) … … 279 279 WRITE(numout,*) ' CNRS - NERC - Met OFFICE - MERCATOR-ocean - INGV - CMCC' 280 280 WRITE(numout,*) ' NEMO team' 281 WRITE(numout,*) ' Ocean General CirculationModel'282 WRITE(numout,*) ' version 3.6 (2015) '283 WRITE(numout,*) 284 WRITE(numout,*) 285 DO ji = 1, SIZE(cltxt) 286 IF( TRIM(cltxt (ji)) /= '' ) WRITE(numout,*) cltxt(ji)! control print of mynode281 WRITE(numout,*) ' Off-line TOP Model' 282 WRITE(numout,*) ' NEMO version 4.0 (2017) ' 283 WRITE(numout,*) 284 WRITE(numout,*) 285 DO ji = 1, SIZE(cltxt) 286 IF( TRIM(cltxt (ji)) /= '' ) WRITE(numout,*) cltxt(ji) ! control print of mynode 287 287 END DO 288 WRITE(numout,cform_aaa) ! Flag AAAAAAA 289 ! 290 ENDIF 291 292 ! Now we know the dimensions of the grid and numout has been set we can 293 ! allocate arrays 288 WRITE(numout,*) 289 WRITE(numout,*) 290 DO ji = 1, SIZE(cltxt2) 291 IF( TRIM(cltxt2(ji)) /= '' ) WRITE(numout,*) cltxt2(ji) ! control print of domain size 292 END DO 293 ! 294 WRITE(numout,cform_aaa) ! Flag AAAAAAA 295 ! 296 ENDIF 297 298 ! Now we know the dimensions of the grid and numout has been set: we can allocate arrays 294 299 CALL nemo_alloc() 295 300 296 ! !------------------------------- -!297 ! ! Modelgeneral initialization !298 ! !------------------------------- -!299 300 CALL nemo_ctl ! Control prints & Benchmark301 ! !-------------------------------! 302 ! ! NEMO general initialization ! 303 ! !-------------------------------! 304 305 CALL nemo_ctl ! Control prints 301 306 302 307 ! ! Domain decomposition 303 CALL mpp_init 304 ! 308 CALL mpp_init ! MPP 309 IF( ln_nnogather ) CALL nemo_nfdcom ! northfold neighbour lists 310 ! 311 ! ! General initialization 305 312 IF( ln_timing ) CALL timing_init 306 !307 308 ! ! General initialization309 313 IF( ln_timing ) CALL timing_start( 'nemo_init') 310 314 ! 311 CALL phy_cst ! Physical constants 312 CALL eos_init ! Equation of state 313 IF( lk_c1d ) CALL c1d_init ! 1D column configuration 314 315 CALL dom_init ! Domain 316 317 CALL istate_init ! ocean initial state (Dynamics and tracers) 318 319 IF( ln_nnogather ) CALL nemo_northcomms ! Initialise the northfold neighbour lists (must be done after the masks are defined) 320 321 IF( ln_ctl ) CALL prt_ctl_init ! Print control 322 323 CALL sbc_init ! Forcings : surface module 324 325 CALL ldf_tra_init ! Lateral ocean tracer physics 326 CALL ldf_eiv_init ! Eddy induced velocity param 327 CALL tra_ldf_init ! lateral mixing 328 IF( l_ldfslp ) CALL ldf_slp_init ! slope of lateral mixing 329 330 CALL tra_qsr_init ! penetrative solar radiation qsr 331 IF( ln_trabbl ) CALL tra_bbl_init ! advective (and/or diffusive) bottom boundary layer scheme 332 315 CALL phy_cst ! Physical constants 316 CALL eos_init ! Equation of state 317 IF( lk_c1d ) CALL c1d_init ! 1D column configuration 318 CALL dom_init ! Domain 319 IF( ln_ctl ) CALL prt_ctl_init ! Print control 320 321 CALL istate_init ! ocean initial state (Dynamics and tracers) 322 323 CALL sbc_init ! Forcings : surface module 324 325 ! ! Tracer physics 326 CALL ldf_tra_init ! Lateral ocean tracer physics 327 CALL ldf_eiv_init ! Eddy induced velocity param 328 CALL tra_ldf_init ! lateral mixing 329 IF( l_ldfslp ) CALL ldf_slp_init ! slope of lateral mixing 330 CALL tra_qsr_init ! penetrative solar radiation qsr 331 IF( ln_trabbl ) CALL tra_bbl_init ! advective (and/or diffusive) bottom boundary layer scheme 332 333 ! ! Passive tracers 333 334 CALL trc_nam_run ! Needed to get restart parameters for passive tracers 334 335 CALL trc_rst_cal( nit000, 'READ' ) ! calendar … … 336 337 337 338 CALL trc_init ! Passive tracers initialization 338 CALL dia_ptr_init ! Initialise diaptr as some variables are used339 ! ! in various advection and diffusion routines339 CALL dia_ptr_init ! Poleward TRansports initialization 340 340 341 IF(lwp) WRITE(numout,cform_aaa) ! Flag AAAAAAA 341 342 ! … … 357 358 WRITE(numout,*) 358 359 WRITE(numout,*) 'nemo_ctl: Control prints' 359 WRITE(numout,*) '~~~~~~~ 360 WRITE(numout,*) '~~~~~~~~' 360 361 WRITE(numout,*) ' Namelist namctl' 361 362 WRITE(numout,*) ' run control (for debugging) ln_ctl = ', ln_ctl … … 381 382 IF(lwp) THEN ! control print 382 383 WRITE(numout,*) 383 WRITE(numout,*) 'namcfg : configuration initialization through namelist read'384 WRITE(numout,*) '~~~~~~~ '385 384 WRITE(numout,*) ' Namelist namcfg' 386 WRITE(numout,*) ' read domain configuration file sln_read_cfg = ', ln_read_cfg385 WRITE(numout,*) ' read domain configuration file ln_read_cfg = ', ln_read_cfg 387 386 WRITE(numout,*) ' filename to be read cn_domcfg = ', TRIM(cn_domcfg) 388 WRITE(numout,*) ' write configuration definition files ln_write_cfg = ', ln_write_cfg 387 WRITE(numout,*) ' keep closed seas in the domain (if exist) ln_closea = ', TRIM(cn_domcfg) 388 WRITE(numout,*) ' create a configuration definition file ln_write_cfg = ', ln_write_cfg 389 389 WRITE(numout,*) ' filename to be written cn_domcfg_out = ', TRIM(cn_domcfg_out) 390 390 WRITE(numout,*) ' use file attribute if exists as i/p j-start ln_use_jattr = ', ln_use_jattr 391 391 ENDIF 392 392 IF( .NOT.ln_read_cfg ) ln_closea = .false. ! dealing possible only with a domcfg file 393 ! 393 394 ! ! Parameter control 394 395 ! … … 430 431 ENDIF 431 432 ! 432 IF( 1_wp /= SIGN(1._wp,-0._wp) ) CALL ctl_stop( 'nemo_ctl: The intrinsec SIGN function follows ', & 433 & 'f2003 standard. ' , & 434 & 'Compile with key_nosignedzero enabled' ) 433 IF( 1._wp /= SIGN(1._wp,-0._wp) ) CALL ctl_stop( 'nemo_ctl: The intrinsec SIGN function follows f2003 standard.', & 434 & 'Compile with key_nosignedzero enabled' ) 435 435 ! 436 436 END SUBROUTINE nemo_ctl … … 444 444 !!---------------------------------------------------------------------- 445 445 ! 446 IF ( lk_mpp )CALL mppsync446 IF( lk_mpp ) CALL mppsync 447 447 ! 448 448 CALL iom_close ! close all input/output files managed by iom_* … … 453 453 IF( numout /= 6 ) CLOSE( numout ) ! standard model output file 454 454 IF( lwm.AND.numond /= -1 ) CLOSE( numond ) ! oce output namelist 455 455 ! 456 456 numout = 6 ! redefine numout in case it is used after this point... 457 457 ! … … 467 467 !! ** Method : 468 468 !!---------------------------------------------------------------------- 469 USE diawri , ONLY: dia_wri_alloc470 USE dom_oce, ONLY: dom_oce_alloc471 USE zdf_oce, ONLY: zdf_oce_alloc472 USE trc_oce, ONLY: trc_oce_alloc469 USE diawri , ONLY : dia_wri_alloc 470 USE dom_oce, ONLY : dom_oce_alloc 471 USE zdf_oce, ONLY : zdf_oce_alloc 472 USE trc_oce, ONLY : trc_oce_alloc 473 473 ! 474 474 INTEGER :: ierr 475 475 !!---------------------------------------------------------------------- 476 476 ! 477 ierr = oce_alloc () ! ocean 478 ierr = ierr + dia_wri_alloc () 479 ierr = ierr + dom_oce_alloc () ! ocean domain 480 ierr = ierr + zdf_oce_alloc () ! ocean vertical physics 481 ! 482 ierr = ierr + trc_oce_alloc () ! shared TRC / TRA arrays 477 ierr = oce_alloc () ! ocean 478 ierr = ierr + dia_wri_alloc() 479 ierr = ierr + dom_oce_alloc() ! ocean domain 480 ierr = ierr + zdf_oce_alloc() ! ocean vertical physics 481 ierr = ierr + trc_oce_alloc() ! shared TRC / TRA arrays 483 482 ! 484 483 IF( lk_mpp ) CALL mpp_sum( ierr ) … … 496 495 !! ** Method : 497 496 !!---------------------------------------------------------------------- 498 INTEGER, INTENT(in) :: num_pes! The number of MPI processes we have497 INTEGER, INTENT(in) :: num_pes ! The number of MPI processes we have 499 498 ! 500 499 INTEGER, PARAMETER :: nfactmax = 20 … … 505 504 INTEGER, DIMENSION(nfactmax) :: ifact ! Array of factors 506 505 !!---------------------------------------------------------------------- 507 506 ! 508 507 ierr = 0 509 508 ! 510 509 CALL factorise( ifact, nfactmax, nfact, num_pes, ierr ) 511 510 ! 512 511 IF( nfact <= 1 ) THEN 513 512 WRITE (numout, *) 'WARNING: factorisation of number of PEs failed' … … 540 539 !! 541 540 !! ** Purpose : return the prime factors of n. 542 !! knfax factors are returned in array kfax which is of 541 !! knfax factors are returned in array kfax which is of 543 542 !! maximum dimension kmaxfax. 544 543 !! ** Method : … … 550 549 INTEGER :: ifac, jl, inu 551 550 INTEGER, PARAMETER :: ntest = 14 552 INTEGER :: ilfax(ntest) 551 INTEGER, DIMENSION(ntest) :: ilfax 552 !!---------------------------------------------------------------------- 553 553 ! 554 554 ! lfax contains the set of allowed factors. 555 555 ilfax(:) = (/(2**jl,jl=ntest,1,-1)/) 556 556 ! 557 557 ! Clear the error flag and initialise output vars 558 kerr = 0559 kfax = 1558 kerr = 0 559 kfax = 1 560 560 knfax = 0 561 562 ! Find the factors of n. 563 IF( kn .NE. 1 ) THEN 564 561 ! 562 IF( kn /= 1 ) THEN ! Find the factors of n 563 ! 565 564 ! nu holds the unfactorised part of the number. 566 565 ! knfax holds the number of factors found. 567 566 ! l points to the allowed factor list. 568 567 ! ifac holds the current factor. 569 568 ! 570 569 inu = kn 571 570 knfax = 0 572 571 ! 573 572 DO jl = ntest, 1, -1 574 573 ! 575 574 ifac = ilfax(jl) 576 575 IF( ifac > inu ) CYCLE 577 576 ! 578 577 ! Test whether the factor will divide. 579 578 ! 580 579 IF( MOD(inu,ifac) == 0 ) THEN 581 580 ! … … 594 593 ! 595 594 END DO 596 595 ! 597 596 ENDIF 598 597 ! … … 600 599 601 600 #if defined key_mpp_mpi 602 SUBROUTINE nemo_northcomms 603 !!====================================================================== 604 !! *** ROUTINE nemo_northcomms *** 605 !! nemo_northcomms : Setup for north fold exchanges with explicit 606 !! point-to-point messaging 607 !!===================================================================== 608 !!---------------------------------------------------------------------- 609 !! 610 !! ** Purpose : Initialization of the northern neighbours lists. 601 602 SUBROUTINE nemo_nfdcom 603 !!---------------------------------------------------------------------- 604 !! *** ROUTINE nemo_nfdcom *** 605 !! ** Purpose : Setup for north fold exchanges with explicit 606 !! point-to-point messaging 607 !! 608 !! ** Method : Initialization of the northern neighbours lists. 611 609 !!---------------------------------------------------------------------- 612 610 !! 1.0 ! 2011-10 (A. C. Coward, NOCS & J. Donners, PRACE) 613 !! 2.0 ! 2013-06 Setup avoiding MPI communication (I. Epicoco, S. 614 !Mocavero, CMCC) 615 !!---------------------------------------------------------------------- 616 611 !! 2.0 ! 2013-06 Setup avoiding MPI communication (I. Epicoco, S. Mocavero, CMCC) 612 !!---------------------------------------------------------------------- 617 613 INTEGER :: sxM, dxM, sxT, dxT, jn 618 614 INTEGER :: njmppmax 619 615 !!---------------------------------------------------------------------- 616 ! 620 617 njmppmax = MAXVAL( njmppt ) 621 618 ! 622 619 !initializes the north-fold communication variables 623 620 isendto(:) = 0 624 nsndto = 0 625 626 !if I am a process in the north 627 IF ( njmpp == njmppmax ) THEN 628 !sxM is the first point (in the global domain) needed to compute the 629 !north-fold for the current process 630 sxM = jpiglo - nimppt(narea) - nlcit(narea) + 1 631 !dxM is the last point (in the global domain) needed to compute the 632 !north-fold for the current process 633 dxM = jpiglo - nimppt(narea) + 2 634 635 !loop over the other north-fold processes to find the processes 636 !managing the points belonging to the sxT-dxT range 637 638 DO jn = 1, jpni 639 !sxT is the first point (in the global domain) of the jn 640 !process 641 sxT = nfiimpp(jn, jpnj) 642 !dxT is the last point (in the global domain) of the jn 643 !process 644 dxT = nfiimpp(jn, jpnj) + nfilcit(jn, jpnj) - 1 645 IF ((sxM .gt. sxT) .AND. (sxM .lt. dxT)) THEN 646 nsndto = nsndto + 1 647 isendto(nsndto) = jn 648 ELSEIF ((sxM .le. sxT) .AND. (dxM .ge. dxT)) THEN 649 nsndto = nsndto + 1 650 isendto(nsndto) = jn 651 ELSEIF ((dxM .lt. dxT) .AND. (sxT .lt. dxM)) THEN 652 nsndto = nsndto + 1 653 isendto(nsndto) = jn 654 END IF 655 END DO 656 nfsloop = 1 657 nfeloop = nlci 658 DO jn = 2,jpni-1 659 IF(nfipproc(jn,jpnj) .eq. (narea - 1)) THEN 660 IF (nfipproc(jn - 1 ,jpnj) .eq. -1) THEN 661 nfsloop = nldi 662 ENDIF 663 IF (nfipproc(jn + 1,jpnj) .eq. -1) THEN 664 nfeloop = nlei 665 ENDIF 666 ENDIF 667 END DO 668 621 nsndto = 0 622 ! 623 IF ( njmpp == njmppmax ) THEN ! if I am a process in the north 624 ! 625 !sxM is the first point (in the global domain) needed to compute the north-fold for the current process 626 sxM = jpiglo - nimppt(narea) - nlcit(narea) + 1 627 !dxM is the last point (in the global domain) needed to compute the north-fold for the current process 628 dxM = jpiglo - nimppt(narea) + 2 629 ! 630 ! loop over the other north-fold processes to find the processes 631 ! managing the points belonging to the sxT-dxT range 632 ! 633 DO jn = 1, jpni 634 ! 635 sxT = nfiimpp(jn, jpnj) ! sxT = 1st point (in the global domain) of the jn process 636 dxT = nfiimpp(jn, jpnj) + nfilcit(jn, jpnj) - 1 ! dxT = last point (in the global domain) of the jn process 637 ! 638 IF ( sxT < sxM .AND. sxM < dxT ) THEN 639 nsndto = nsndto + 1 640 isendto(nsndto) = jn 641 ELSEIF( sxM <= sxT .AND. dxM >= dxT ) THEN 642 nsndto = nsndto + 1 643 isendto(nsndto) = jn 644 ELSEIF( dxM < dxT .AND. sxT < dxM ) THEN 645 nsndto = nsndto + 1 646 isendto(nsndto) = jn 647 ENDIF 648 ! 649 END DO 650 nfsloop = 1 651 nfeloop = nlci 652 DO jn = 2,jpni-1 653 IF( nfipproc(jn,jpnj) == (narea - 1) ) THEN 654 IF( nfipproc(jn-1,jpnj) == -1 ) nfsloop = nldi 655 IF( nfipproc(jn+1,jpnj) == -1 ) nfeloop = nlei 656 ENDIF 657 END DO 658 ! 669 659 ENDIF 670 660 l_north_nogather = .TRUE. 671 END SUBROUTINE nemo_northcomms 661 ! 662 END SUBROUTINE nemo_nfdcom 663 672 664 #else 673 SUBROUTINE nemo_n orthcomms! Dummy routine674 WRITE(*,*) 'nemo_n orthcomms: You should not have seen this print! error?'675 END SUBROUTINE nemo_n orthcomms665 SUBROUTINE nemo_nfdcom ! Dummy routine 666 WRITE(*,*) 'nemo_nfdcom: You should not have seen this print! error?' 667 END SUBROUTINE nemo_nfdcom 676 668 #endif 677 669 … … 696 688 END SUBROUTINE istate_init 697 689 690 698 691 SUBROUTINE stp_ctl( kt, kindic ) 699 692 !!---------------------------------------------------------------------- … … 722 715 ! 723 716 END SUBROUTINE stp_ctl 717 724 718 !!====================================================================== 725 719 END MODULE nemogcm
Note: See TracChangeset
for help on using the changeset viewer.
